home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / MISCPAS.ZIP / PCDISK.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-06-23  |  43.5 KB  |  1,444 lines
  1. {$C-,V- }
  2. program pcdisk3d; {adapted from John Friell's PC-DISK
  3.                   by G. Gallo April 17, 1985}
  4.  
  5. { types and vars req'd for disk space and dir procedures }
  6. Const
  7.   blink_yes    = true;
  8.   blink_no     = false;
  9.   yes_no       : set of char = ['Y','y','N','n'];
  10.   max_records  = 1000;
  11.  
  12. Type
  13.   str255     =   string[255];
  14.   str80      =   string[80];
  15.   str11      =   string[11];
  16.   str33      =   string[33];
  17.   regpack      = record
  18.                    ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  19.                  end;
  20.   mem_ptr      = ^pointer_type;
  21.   pointer_type = array [1..2] of integer;
  22.  
  23.   word         = array [1..2] of char;
  24.   cat_type     = record
  25.                    vol_record : integer;
  26.                    fil        : string[11];
  27.                    sizelo     : word;
  28.                    sizehi     : word;
  29.                    time       : word;
  30.                    date       : word;
  31.                    memo       : string[33];
  32.                  end;
  33.   temp_type    = record
  34.                    fil        : string[11];
  35.                    sizelo     : word;
  36.                    sizehi     : word;
  37.                    time       : word;
  38.                    date       : word;
  39.                    memo       : string[33];
  40.                  end;
  41.  
  42. Var
  43.   one_memo,
  44.   orig_path,
  45.   fullpathname,
  46.   catname                       : str33;
  47.   asciiz,filez                  : string[32];  {string input for dir scan}
  48.   template                      : str80;
  49.   Answer,S                      : str255;
  50.   id,volume,pathname            : str11;
  51.   R                             : regpack;
  52.   pointer,dta,fcb_addr          : mem_ptr;
  53.   bts                           : real;
  54.   c1,r1,c2,r2,
  55.   x, i, y, q, e, w, check_num,
  56.   drv, crt_reg,
  57.   z, t4, t1, t2, t3,
  58.   vol_min, vol_max,
  59.   cat_num, vol_num              : Integer;
  60.   ok, done, found, changed      : Boolean;
  61.   Ctype,GetType,ch,
  62.   orig_drive, default_drive     : Char;
  63.   catfile                       : file of cat_type;
  64.   cat_array                     : array [1..max_records] of cat_type;
  65.   vol_array                     : array [1..100] of str11;
  66.   temp_array                    : array [1..100] of temp_type;
  67.   dta_area                      : array [1..130] of byte;
  68.   fcb                           : array [-7..36] of char;
  69.   temp                          : string[11];
  70.   InsertOn,Exitt,
  71.   Escape,
  72.   F1,F10,
  73.   Use_Default                   : Boolean; {for input routine}
  74.  
  75. (* the following screen and input routines were written by Donald R. Ramsey
  76. and Larry Romero and are part of TURBO-UT - a public domain utility package*)
  77.  
  78. procedure Center(S: str255; Col,Row,L: integer);
  79.   { Center a string on a line of L length beginning at position Col,Row }
  80.   {** (Col,Row) is row and column to center on **}
  81.   {** L is the length of the line to center on **}
  82. var I: integer;
  83.  begin
  84.     gotoXY(Col,Row);
  85.     for I:= 1 to L do write(' ');
  86.     gotoXY(Col+(L-Length(S)) div 2,Row); write(S);
  87.  end;
  88.  
  89. procedure InvVideo( InvStr: str255);
  90.     { print a string in inverse video }
  91.  begin
  92.    textBackground(7);textcolor(0); write(InvStr);
  93.    textBackground(0) ;textcolor(15);
  94.  end;
  95.  
  96. procedure Color(BackGnd,Txt: integer);
  97.    { change the background & text color }
  98.  begin
  99.    textBackGround(BackGnd); textColor(Txt);
  100.  end;
  101.  
  102. function UpcaseStr(S : Str80) : Str80;
  103.    { convert a string to UpperCase }
  104. var
  105.   P : Integer;
  106. begin
  107.   for P := 1 to Length(S) do
  108.     S[P] := Upcase(S[P]);
  109.   UpcaseStr := S;
  110. end;
  111.  
  112. procedure StripSpaces(S: str33; var NewStr: str33);
  113.     {strip spaces from the end of a string}
  114.  begin
  115.    S:=S+'  '; NewStr := copy(S,1,pos('  ',S)-1);
  116.  end;
  117.  
  118. procedure Beep(Tone,Duration : integer);
  119.  begin
  120.    Sound(Tone); Delay(Duration); NoSound;
  121.  end;
  122.  
  123. procedure Say_Cap_Num;
  124.    { Display Caps, Num, Insert in inverse video on line 25 of Video }
  125.  var  Value  : integer;
  126.  begin
  127.  window(1,1,80,25);
  128.      Value := Mem[0000:1047];      { test for caps, numbers, & cursor cntrl }
  129.      gotoXY(65,25);
  130.      Case Value of
  131.        0   : begin LowVideo; write('               '); Inserton:= false; end;
  132.        32  : begin LowVideo; write('     '); InvVideo('NUM');
  133.                    Clreol; InsertOn:= false; end;
  134.        64  : begin InvVideo('CAPS'); Clreol;
  135.                    InsertOn:= false; end;
  136.        96  : begin InvVideo('CAPS'); write(' '); InvVideo('NUM');
  137.                    Clreol; InsertOn:=false; end;
  138.        128 : begin LowVideo; write('         ');
  139.                    InvVideo('Insert');InsertOn:=true; end;
  140.        160 : begin LowVideo; write('     '); InvVideo('NUM');write(' ');
  141.                    InvVideo('Insert'); InsertOn:=true; end;
  142.        192 : begin InvVideo('CAPS'); write('     ');
  143.                    InvVideo('Insert'); InsertOn:=true; end;
  144.        224 : begin InvVideo('CAPS'); write(' ');InvVideo('NUM'); write(' ');
  145.                    InvVideo('Insert'); InsertOn:= true; end;
  146.      end; { Case }
  147.      Window (c1,r1,c2,r2);
  148.   end;
  149.  
  150. procedure Set_Cap_Num(Caps,Num,Insert : Char);
  151.    { Set the Cap Lock, Number Lock, and Ins Keys as desired }
  152.  var J : integer;
  153.  begin
  154.   if Insert='I' then J:=128 else J:=0;
  155.   Case Caps of
  156.     'C': begin if Num='N' then  MemW[0000:1047]:= 96+J
  157.                 else            MemW[0000:1047]:= 64+J;
  158.          end;
  159.     ' ': begin if Num='N' then  MemW[0000:1047]:= 32+J
  160.                 else            MemW[0000:1047]:=  0+J;
  161.          end;
  162.   end; { Case }
  163.  end;
  164.  
  165. {.pa}
  166. procedure Ck_edit_key(var Ch: Char);
  167.    { test for an IBM Cursor control or Function key }
  168. begin
  169.   read(kbd,Ch);
  170.   begin {see if IBM specific key pressed}
  171.     case Ch of
  172.       'H': Ch:=^E    ;  { up-arrow  }
  173.       'P': Ch:=^X    ;  { dn-arrow  }
  174.       'M': Ch:=^D    ;  { rt-arrow  }
  175.       'K': Ch:=^S    ;  { left-arr  }
  176.       'S': Ch:=#127  ;  { Del       }
  177.       'R': Ch:=^V    ;  { insert    }
  178.       'G': Ch:=^G    ;  { Home      }
  179.       'O': Ch:=^O    ;  { End       }
  180.       'I': Ch:=^R    ;  { Pg-Up     }
  181.       'Q': Ch:=#00   ;  { Pg-Dn     }
  182.       ';': Ch:=^a    ;  { F1        }
  183.       '<': Ch:=^b    ;  { F2        }
  184.       '=': Ch:=^c    ;  { F3        }
  185.       '>': Ch:=^d    ;  { F4        }
  186.       '?': Ch:=^e    ;  { F5        }
  187.       '@': Ch:=^f    ;  { F6        }
  188.       'A': Ch:=^g    ;  { F7        }
  189.       'B': Ch:=^h    ;  { F8        }
  190.       'C': Ch:=^i    ;  { F9        }
  191.       'D': Ch:=^j    ;  { F10       }
  192.       'u': Ch:=#117  ;  {ctrl-end   }
  193.     end;   {Case Ch}
  194.   end;   {IBM check}
  195. end;  {Ck_edit_key}
  196.  
  197. procedure Get_Template(Template_num:integer; var template: str80);
  198.    { Templates are specified by the Programmer }
  199.  begin
  200.   Case Template_num of
  201.     1 : template := '';
  202.     2 : template := '';
  203.   end;
  204.  end;
  205.  
  206. procedure Input(Typ: Char          ;    { Type of input        }
  207.                 Default: str255    ;    { Default string       }
  208.                 Col,Row: integer   ;    { Where start line     }
  209.                 Mlen: integer      ;    { Max length           }
  210.                 UpperCase:Boolean  ;    { True if auto Upcase  }
  211.            var  F1,F10   : boolean);    { Returned true if F1 or F10 }
  212.  
  213.    {-- requires
  214.        Global procedures:
  215.          Say_Cap_Num, Set_Cap_Num, Color, Ck_edit_key, Beep, Get_template }
  216. var
  217.   X,J,LastValue: integer;
  218.   OkChars,temp : set of Char;
  219.   DF           : boolean;
  220.  
  221. {-------------------------- local procedures ---------------------------}
  222.   procedure GotoX;
  223.    begin
  224.      GotoXY(X+Col-1,Row);
  225.    end;
  226.  
  227.   procedure Ck_Cap_Num; { test for caps, numbers, & cursor cntrl }
  228.    var Value : integer;
  229.    begin
  230.       repeat
  231.         Value := Mem[0000:1047];
  232.         if LastValue<>value then
  233.           begin LastValue:=Value; Say_Cap_Num; GotoX; end;
  234.       until keypressed;
  235.    end;
  236.  
  237.   procedure PosX;
  238.     begin
  239.       while copy(template,X,1)<>#95 do
  240.        begin
  241.          Answer:=Answer + copy(template,X,1); X:=X+1; GotoX;
  242.        end;
  243.     end;
  244.  
  245.   procedure Del_Ans;
  246.     begin
  247.       Answer:=''; X:=1; GotoX;
  248.       write(template);  GotoX; PosX;
  249.     end;
  250.  
  251. {------------------------ end local procedures ------------------------}
  252.  
  253. begin
  254.   if Typ='A'then  OKChars:=[' '..'}']
  255.   else OKChars:=['0'..'9','+','-','.'];
  256.   Temp := OKChars;  color(7,0); DF:= false;
  257.   Case Typ of
  258.     'A','N','$': begin  fillchar(template,80,#95);
  259.                         template:=copy(template,1,Mlen);
  260.                         if Typ='$' then
  261.                          begin
  262.                            X:=0; GotoX; HighVideo; write('$');
  263.                          end;
  264.                  end;
  265.     'F':         begin
  266.                    Get_template(Mlen,template); Mlen := length(template);
  267.                    if copy(template,1,1)<>#95 then DF:= true;
  268.                  end;
  269.  
  270.   end;
  271.  
  272.   if Typ = 'A' then if uppercase then Set_Cap_Num('C',' ',' ')
  273.                     else Set_Cap_Num(' ',' ','I')
  274.   else Set_Cap_Num(' ','N',' ');
  275.   Color(7,0);
  276.   Answer := ''; F1:=false; F10:=false;
  277.   if Default<>'' then
  278.     begin
  279.       X:=1; GotoX; write(template); GotoX; write(default);
  280.       Answer:=Default;
  281.     end
  282.   else Del_Ans;
  283.   LastValue:=Mem[0000:1047]; Say_Cap_Num; GotoX;
  284.  
  285.   repeat
  286.     Ck_Cap_Num; read(kbd,Ch);  Color(7,0);
  287.     if (keypressed) and (Ch<>'p') and (Ch<>'q') then Ck_edit_key(Ch);
  288.     if (Typ='F') and (X=1) and (Default<>'') and (Ch<>^1) and (Ch<>#13)
  289.      then Del_Ans;
  290.     case Ch of
  291.        ^[: begin Del_Ans end;     { ESC pressed   }
  292.  
  293.        ^D: begin { Move cursor right : rt-arr }
  294.              X:=X+1;
  295.              if (X>length(Answer)+1) or (X>Mlen) then X:=X-1;
  296.              GotoX;
  297.            end;
  298.  
  299.        ^S: begin { Move cursor left : left-arr }
  300.              if Typ='F' then Del_Ans  else
  301.              begin
  302.                X:=X-1; if X<1 then X:=1;
  303.                GotoX;
  304.              end;
  305.            end;
  306.        ^O: begin { Move cursor to end of line }
  307.               X:=Length(Answer)+1; if X>Mlen then X:=Mlen; GotoX;
  308.            end;
  309.        ^G: begin { Move cursor to beginning of line }
  310.              X:=1; GotoX;
  311.            end;
  312.        ^H: begin { Delete left char: BS }
  313.              if Typ='F' then Del_Ans
  314.              else
  315.                begin
  316.                  X:=X-1;
  317.                  if (Length(Answer)>0) and (X>0)  then
  318.                    begin
  319.                      Delete(Answer,X,1); GotoX;
  320.                      Write(copy(Answer,X,(Length(Answer)-X+1)),#95);
  321.                      GotoX;
  322.                    end
  323.                  else X:=1;
  324.              end; { Typ <> 'F' }
  325.            end;
  326.  
  327.        #117: begin {delete end of line}
  328.               i := (mlen-x);
  329.               delete(answer,X,i);
  330.               for e := 0 to i do write(#95);
  331.               gotox;
  332.               end;
  333.        #127: begin { Delete }
  334.                Delete(Answer,X,1);
  335.                Write(copy(Answer,X,Length(Answer)-X+1),#95); GotoX;
  336.              end;
  337.         ^a : begin  { F1 pressed }
  338.                F1 := true; exitt := true; Answer:= default;
  339.              end;
  340.         ^M : exitt := true;
  341.         ^j : begin F10 := true; exitt := true; Answer := default; end;
  342.  
  343.     else
  344.     if (length(Answer)+1 <= Mlen) or (not InsertOn) then
  345.     begin   { non-IBM char }
  346.         if Ch in OkChars  then
  347.          begin
  348.           if InsertOn then
  349.           begin
  350.            if length(Answer) < Mlen then
  351.            begin             { OK to insert }
  352.              insert(Ch,Answer,X);
  353.                Case Typ of
  354.                 'A','N','$' : write(copy(Answer,X,Length(Answer)-X+1));
  355.                 'F'         : Write(Ch);
  356.                end; {Case}
  357.            end;        { OK to insert }
  358.           end else     { end InsertOn }
  359.           if X <= Mlen then
  360.           begin
  361.              write(Ch);
  362.              if X>length(Answer) then Answer:=Answer+Ch
  363.              else Answer[X]:=Ch;
  364.           end;  { processing this key }
  365.           if X+1 <= Mlen then X:=X+1;
  366.           if (X > Length(Answer)) and (template[X]<>#95) then PosX;
  367.          end { OkChars }
  368.          else if (Ch<> ^V) then Beep(300,150);
  369.              { beep if invalid char and ch is not Insert key }
  370.         GotoX;
  371.     end;   { non IBM key }
  372.     if (typ<>'F') and (length(Answer)+1 > Mlen) and (Ch <> ^V)
  373.      then  Beep(600,100);
  374.    end;    {   CASE!!!   }
  375.   until exitt = true;
  376.  Color(0,15); X:=1; gotoX; write(Answer);
  377.       { erase part of template that is left }
  378.  X:=length(Answer)+1; GotoX;
  379.  for J:= 1 to Mlen-x+1 do write(' ');
  380.  exitt := false; Color(0,15);
  381.  if (DF) and (length(Answer)=1) then
  382.   begin
  383.     gotoXY(col,row); write(' '); Answer:='';
  384.   end;
  385. end;          { end Input Procedure }
  386. {---------------------  Procedures  -----------------------------}
  387. {---- begin code from original PC-DISK---------}
  388.  
  389. procedure set_fcb; forward;
  390. procedure get_vol; forward;
  391. procedure save_catalog; forward;
  392. procedure keycontinue;
  393. begin
  394.   write(' Tap any key to continue');
  395.   read (kbd,ch);
  396.   CLRSCR;
  397. end;
  398.  
  399. procedure log_new_drive(ch:char);  {gg}
  400. begin
  401.      ch := upcase(ch);
  402.      CHDIR(ch+':');
  403.      default_drive := ch;
  404. end;
  405.  
  406. Procedure drawbox_ibm (x1,y1,x2,y2,FG,BG : Integer; boxname : str80; blnk : boolean);
  407. Begin
  408.   window (x1,y1,x2,y1+1);
  409.   textbackground(BG);
  410.   GotoXY(1,1);
  411.   x := x2-x1;
  412.   if length(boxname) > x then boxname[0] := chr(x-4);
  413.   textcolor(FG);
  414.   Write('U');
  415.   if blnk then textcolor(FG + blink) else textcolor(fg);
  416.   write (boxname);
  417.   textcolor(FG);
  418.   for q := x1+length(boxname)+1 to x2-1 do Write('M');
  419.   Write('8');
  420.   for q := 2 to y2-y1 do
  421.     Begin
  422.       window (x1,y1,x2,y1+q+1);
  423.       GotoXY(1,q); Write('3');
  424.       if blnk then clreol;
  425.       GotoXY(x2-x1+1,q); Write('3');
  426.     end;
  427.   Window(x1,y1,x2,y2+1);
  428.   gotoXY(1,y2-y1+1);
  429.   Write('T');
  430.   for q := x1+1 to x2-1 do Write('M');
  431.   Write('>');
  432. end;
  433.  
  434. function upcase11(strng : str11) : str11;
  435. var
  436.   temp : str11;
  437.   x : integer;
  438. begin
  439.   temp := '';
  440.   for x := 1 to length(strng) do
  441.     temp := temp + upcase(strng[x]);
  442.   upcase11 := temp;
  443. end;
  444.  
  445. procedure GetPath; {gg}
  446. begin
  447.      Getdir(0,fullpathname);
  448.      if length(fullpathname) = 3 then
  449.      pathname := 'ROOT       '
  450.      else
  451.      pathname := copy(fullpathname,4,11);
  452.      pathname := upcaseStr(pathname);
  453.      for x := 1 to (11-length(PATHNAME)) do pathname := pathname+' ';
  454. end;
  455.  
  456. Procedure drawbox (x1,y1,x2,y2,FG,BG : Integer; boxname : str80; blnk : boolean);
  457. Begin
  458.   Drawbox_IBM (x1,y1,x2,y2,FG,BG,boxname,blnk);
  459.   Window (x1+1,y1+1,x2-1,y2-1);
  460.   c1:=x1+1; r1:=y1+1; c2:=x2-1; r2:=y2-1;
  461.   Clrscr;
  462. end;
  463.  
  464. procedure load_catalog;
  465. begin
  466. drawbox (30,15,78,22,lightcyan,black,'[ Catalog Load ]',blink_no);
  467. volume := '';
  468. get_vol;
  469. if volume <> '' then
  470. begin
  471.   cat_num := 0;
  472.   writeln ('Loading from file ',catname);
  473.   set_fcb;
  474.   assign (catfile, catname);
  475.   {$I-}
  476.   reset (catfile);
  477.   {$I+}
  478.   ok := (ioresult=0);
  479.   if not ok then
  480.     begin
  481.       rewrite (catfile);
  482.       writeln ('File not found, Creating a new one. ');
  483.     end
  484.   else
  485.     begin
  486.       cat_num := 0;
  487.       vol_num := 0;
  488.       while (not eof(catfile)) and (cat_num < max_records + 1) do
  489.         begin
  490.           cat_num := cat_num + 1;
  491.           read (catfile, cat_array[cat_num]);
  492.           if cat_array[cat_num].vol_record > vol_num then
  493.             begin
  494.               writeln ('Invalid record found and discarded.');
  495.               cat_num := cat_num - 1;
  496.             end
  497.           else
  498.             if cat_array[cat_num].vol_record = -1 then   { vol label record }
  499.               begin
  500.                 vol_num := vol_num + 1;
  501.                 vol_array[vol_num] := cat_array[cat_num].fil;
  502.               end;
  503.         end;
  504.       writeln (cat_num,' file entries loaded, ',max_records - cat_num,' empty.');
  505.       writeln (vol_num,' volume entries loaded, ',100-vol_num,' empty.');
  506.     end;
  507.   close (catfile);
  508. end
  509.   else
  510.     begin
  511.       writeln('Cannot catalog a disk without a Volume Label.');
  512.       writeln('A)dd one from the Main Menu.');
  513.     end;
  514.     keycontinue;
  515. end;
  516.  
  517. procedure ChangeDir;    {gg}
  518. begin
  519.   drawbox (2,15,68,19,lightcyan,black,'[ Change Directory ]',blink_no);
  520.   GetPath;
  521.   writeln(' Current Directory is ',fullpathname);
  522.   Write(' Enter name of new directory: ');
  523.   input('A','',wherex,wherey,33,true,f1,f10);
  524.   IF LENGTH(ANSWER) = 0 THEN begin
  525.      writeln;
  526.      write(' No change.');
  527.      delay(900);
  528.      EXIT;
  529.      end;
  530.   {$I-}
  531.   ChDir(answer);
  532.   {$I+}
  533.        If IOResult<>0 Then
  534.        begin
  535.             Writeln;
  536.             Write(' *** Cannot access that path  - ');
  537.             keycontinue;
  538.             Exit;
  539.        end
  540.        else
  541.          writeln;
  542.          Write(' Done.');
  543.          GetPath;
  544.          delay( 900 );
  545.    end;
  546.  
  547. procedure ChangeDrive;      {gg}
  548. var
  549. ch : char;
  550. begin
  551.   drawbox (4,15,35,19,lightcyan,black,'[ Change Drive ]',blink_no);
  552.   writeln(' Current drive is: ', default_drive+':');
  553.   write(' Enter new drive: ');
  554.      repeat
  555.      read(KBD,ch);
  556.      ch := upcase(ch);
  557.        if not (ch in ['A'..'E',#13]) then write(^G)
  558.        else writeln(ch);
  559.      until ch in ['A'..'E',#13];
  560.      if ch = #13 then write(' No change.')
  561.       else begin
  562.        log_new_drive(ch);
  563.        write(' Done.');
  564.        end;
  565. delay(900);
  566. end;
  567.  
  568.  
  569. Procedure init;   {changed:  no longer calls Screen_on Screen_off, which
  570.                   seemed to hang some systems (I don't know what it did??)
  571.                   and is now called after every change of catalog. gg}
  572. Begin
  573.   done := False;
  574.   changed := false;
  575.   catname := '';
  576.   cat_num := 0;
  577.   vol_num := 0;
  578. end;
  579.  
  580. procedure save_catalog;
  581. begin
  582.   drawbox (40,15,78,23,lightcyan,black,'[ Save Catalog ]',blink_no);
  583.   writeln;
  584.   writeln ('Saving to file ',catname);
  585.   set_fcb;
  586.   close (catfile);
  587.   assign (catfile, catname);
  588.   rewrite (catfile);
  589.   x := 0;
  590.   if cat_num = 0 then
  591.     writeln ('No entries to save, aborted.')
  592.   else
  593.     begin
  594.       while x < cat_num do
  595.         begin
  596.           x := x + 1;
  597.           write (catfile, cat_array[x]);
  598.         end;
  599.     end;
  600.   close (catfile);
  601.   writeln;
  602.   writeln (x,' entries saved, ',max_records-x,' empty.');
  603.   KEYCONTINUE;
  604.   if Ctype = 'F' then log_new_drive(orig_drive);
  605.   init;
  606. end;
  607.  
  608.  
  609. Procedure big_exit;
  610. begin
  611.   if changed then
  612.       begin
  613.       drawbox (15,10,65,16,white,red,'[ Warning! ]',blink_yes);
  614.       writeln;
  615.       center ('  Catalog '+catname+' has been changed!',1,2,49);
  616.       center ('  Do you want to Save [Y/N] ? ',1,3,49);
  617.       repeat read (kbd,ch); until ch in yes_no;
  618.       if upcase(ch) = 'Y' then
  619.       save_catalog;
  620.      end;
  621.   done := true;
  622. end;
  623.  
  624. procedure set_dta;
  625. begin
  626. {-- Set DTA address --}
  627.   pointer := addr(dta_area);
  628.   r.ds := seg(pointer^);
  629.   r.dx := ofs(pointer^);
  630.   r.ax := $1A shl 8;
  631.   MsDos(R);
  632. end;
  633.  
  634. procedure get_dta;
  635. begin
  636. {-- Get DTA address in ES:BX --}
  637.   r.ax := 0;
  638.   r.es := 0;
  639.   r.bx := 0;
  640.   r.ax := $2F shl 8;
  641.   MsDos(R);
  642.   dta := ptr(r.es,r.bx);
  643. end;
  644.  
  645. procedure set_fcb;
  646. begin
  647. {-- Set up an unopened FCB --}
  648.   for x := -7 to 36 do fcb[x] := #0;
  649.   fcb[-7] := #255;
  650.   fcb[-1] := #0;
  651.   filez := '*.*' + #0;
  652.   pointer := addr(filez[1]);
  653.   r.ds := seg(pointer^);
  654.   r.si := ofs(pointer^);
  655.   pointer := addr(fcb[0]);
  656.   r.es := seg(pointer^);
  657.   r.di := ofs(pointer^);
  658.   r.ax := $29 shl 8;
  659.   msdos(R);
  660.   set_dta;
  661.   get_dta;
  662. end;
  663.  
  664.  
  665. procedure msdos12;
  666. begin
  667.   set_dta;
  668.   pointer := addr(fcb[-7]);
  669.   r.ds := seg(pointer^);
  670.   r.dx := ofs(pointer^);
  671.   r.ax := $12 shl 8;         { go after the next matching entry }
  672.   msdos(R);
  673. end;
  674.  
  675. procedure msdos11(x : integer);
  676. begin
  677.   set_fcb;
  678.   fcb[-7] := #255;
  679.   fcb[-1] := chr(x);
  680.   pointer := addr(fcb[-7]);
  681.   r.ds := seg(pointer^);
  682.   r.dx := ofs(pointer^);
  683.   r.ax := $11 shl 8;
  684.   msdos(R);
  685. end;
  686.  
  687.  
  688. procedure get_vol;
  689. begin
  690.   volume := '';
  691.   msdos11(8);
  692.   if (r.ax and 255) = 0 then
  693.     begin
  694.       for x := 8 to 18 do
  695.         volume := volume + chr(mem[seg(dta^):ofs(dta^)+x]);
  696.       writeln('Volume is ',volume);
  697.       writeln('Directory is ',fullpathname);
  698.     end
  699.   else
  700.     writeln ('Disk has no Volume Label!');
  701. end;
  702.  
  703. procedure delete_volume;
  704. var
  705.   vnum : integer;
  706. begin
  707.   drawbox (2,5,78,24,white,black,'[ Delete Volume ]',blink_yes);
  708.   writeln (' Select the volume to be deleted by entering the number');
  709.   writeln (' associated with the Volume Label.');
  710.   for x := 1 to vol_num do
  711.     write (' ',x:2,')',vol_array[x]:11);
  712.   writeln;
  713.   repeat
  714.     write ('Enter volume number (<0> quits):');
  715.     readln (vnum);
  716.   until (vnum >= 0) and (vnum <= vol_num);
  717.   if vnum = 0 then exit;
  718.   writeln;
  719.   write ('Delete volume ',vol_array[vnum],' [Y/N] ? ');
  720.   repeat read (kbd,ch); until ch in yes_no;
  721.   if upcase(ch) = 'Y' then
  722.     begin
  723.       writeln ('Deleting volume ',vol_array[vnum]);
  724.       vol_min := 0;
  725.       vol_max := 0;
  726.       t2 := 0;  { count files found on disk }
  727.       for x := 1 to cat_num  do
  728.         if (cat_array[x].vol_record = vnum) and (vol_min = 0) then
  729.           vol_min := x - 1
  730.         else
  731.           if (vol_min <> 0 ) and (vol_max = 0) and (cat_array[x].vol_record <> vnum) then
  732.             vol_max := x - 1 ;
  733.       if vol_max = 0 then vol_max := cat_num;
  734.       t1 := vol_max - vol_min + 1;
  735.       for x := (vol_max + t2-t1 + 1) to (cat_num + t2 - t1) do
  736.         cat_array[x] := cat_array[x -(t2-t1)];
  737.       if vnum = vol_num then
  738.         cat_num := vol_min - 1
  739.       else
  740.         cat_num := x;
  741.       { now renumber the cat_array }
  742.       vol_num := 0;
  743.       for x := 1 to cat_num do
  744.         begin
  745.           if cat_array[x].vol_record = -1 then
  746.             begin
  747.               vol_num := vol_num + 1;
  748.               vol_array[vol_num] := cat_array[x].fil;
  749.             end
  750.           else
  751.             cat_array[x].vol_record := vol_num;
  752.         end;
  753.     end
  754.   else
  755.     writeln ('Aborted.');
  756.   write (' Press any key to continue ');
  757.   read(kbd,ch);
  758. end;
  759.  
  760. procedure show_dta(x1,y1 : integer);
  761. var
  762.  t1,t2,d1,d2,hour,minutes,seconds,dd,mm,yy : integer;
  763.  bytes : real;
  764. begin
  765.   for x := 8 to 15 do
  766.     write(chr(mem[x1:y1+x]));
  767.   write (' ');
  768.   for x := 16 to 18 do
  769.     write(chr(mem[x1:y1+x]));
  770.   write (' ');
  771.   t1 := mem[x1:y1+30];
  772.   t2 := mem[x1:y1+31];
  773.   d1 := mem[x1:y1+32];
  774.   d2 := mem[x1:y1+33];
  775.   bytes := mem[x1:y1+37]*256.0;
  776.   bytes := bytes + mem[x1:y1+36];
  777.   bytes := bytes + mem[x1:y1+38] * 65536.0;
  778.   write (bytes:6:0,' ');
  779.   hour := (t2 and 249) shr 3;
  780.   if hour > 12 then hour := hour - 12;
  781.   minutes := ((t2 and 7) shl 3) + ((t1 and 224) shr 5);
  782.   write (hour:2,':');
  783.   if minutes < 10 then write ('0');
  784.   write (minutes);
  785.   mm := ((d2 and 1) shl 3) + ((d1 and 224) shr 5);
  786.   dd := (d1 and 31);
  787.   yy := 80 + ((d2 and 255) shr 1);
  788.   write ('  ');
  789.   if mm < 10 then write ('0'); write (mm,'-');
  790.   if dd < 10 then write ('0'); write (dd,'-');
  791.   write (yy:2);
  792. end;
  793.  
  794.  
  795. Function Free_Space( Drive_letter : Char) : Real;
  796. {changed to reflect the available space on a hard drive}
  797. var
  798.   Tracks,                              { number of available Tracks }
  799.   TotalTracks,                         { number of total Tracks }
  800.   Drive,                               { Drive number }
  801.   Bytes,                               { number of Bytes in one sector }
  802.   Sectors              : Integer;      { number of total Sectors }
  803.   Used                 : Real;
  804.  
  805. procedure DiskStatus( Drive : integer;  var Tracks, TotalTracks,
  806.                       Bytes, Sectors : integer );
  807.  var
  808.   Regs                 : RegPack;
  809. begin
  810.   Regs.AX := $3600;               { Get Disk free space }
  811.   Regs.DX := Drive;               { Store Drive number }
  812.   MSDos( Regs );                  { Call MSDos to get disk info }
  813.   Tracks := Regs.BX;              { Get number of Tracks Used }
  814.   TotalTracks := Regs.DX;         {  "    "    "  total Tracks }
  815.   Bytes := Regs.CX;               {  "    "    "  Bytes per sector }
  816.   Sectors := Regs.AX              {  "    "    "  Sectors per cluster }
  817. END; { of proc DiskStatus }
  818.  
  819. begin { main body of function Free_Space }
  820.   Drive := 0;                             { Initialize Drive }
  821.   drive_letter := upcase(drive_letter);
  822.   case drive_letter of
  823.     'A'..'E'  : drive := ord(drive_letter)-ord('A')+1;
  824.   else
  825.     drive := 0;
  826.   end;
  827.   DiskStatus( Drive, Tracks, TotalTracks, Bytes, Sectors );
  828.   Free_Space  := (( Sectors * Bytes * 1.0 ) * Tracks );
  829. end; { of function Free_Space }
  830.  
  831.  
  832. procedure dir2;
  833. var
  834.   x : integer;
  835.   bytes : real;
  836. begin
  837.   drawbox (1,5,39,24,white,black,'[ Dir ]',blink_yes);
  838.   x := 2;
  839.   GETPATH;
  840.   get_vol;
  841.   set_fcb;
  842.   msdos11(3);
  843.   if (r.ax and 255) = 0 then
  844.     begin
  845.       while (r.ax and 255) = 0 do
  846.         begin
  847.           x := x + 1;
  848.           write (' ');
  849.           show_dta (seg(dta^),ofs(dta^));
  850.           writeln;
  851.           if x/17 = int(x/17) then keycontinue;
  852.           msdos12;
  853.         end
  854.     end
  855.   else
  856.     writeln ('Disk is Empty!');
  857.   bytes := free_space(default_drive);
  858.   writeln ('    Free space = ',bytes:6:0,' bytes');
  859.   write   ('    Press any key to continue');
  860.   read (kbd,ch);
  861. end;
  862.  
  863.  
  864. procedure update_disk;
  865. begin
  866.   drawbox (10,7,70,24,white,black,'[ Update Disk ]',blink_no);
  867.   found := false;
  868.   writeln;
  869.   writeln ('Place disk in drive ',default_drive,' and press any key...');
  870.   read (kbd,ch);
  871.   id := '';
  872.   get_vol;
  873.   getpath; {gg}
  874.   if length(catname) = 0 then begin        {refuse update if no
  875.      writeln('No catalog loaded.');        catalog loaded gg.}
  876.      keycontinue;
  877.      exit;
  878.      end;
  879.   if volume <> '' then
  880.     begin
  881.      if (length(fullpathname) > 14) and (Ctype = 'T') then begin  {gg}
  882.      writeln;
  883.      writeln('Pathname longer than eleven characters.');
  884.      write('Enter an identifying label for this directory: ');
  885.      input('A','',wherex,wherey,11,true,f1,f10);
  886.      pathname := answer;
  887.      end;
  888.       {scan the catalog for volume}
  889.  if Ctype = 'T' then
  890.       id := pathname {if tree-structured or individual catalog use ID}
  891.  else
  892.       id := volume;  { use volume }
  893.  writeln;
  894.  changed := true;
  895.  for x := 1 to vol_num do
  896.         begin
  897.         if vol_array[x] = id then
  898.           begin
  899.             found := true;
  900.             t1 := x;
  901.             t4 := x;
  902.           end;
  903.         end;
  904.       if found then  { Do a selective update/delete function }
  905.         begin
  906.           writeln ('Disk is already cataloged, performing update.');
  907.           writeln;
  908.           vol_min := 0;
  909.           vol_max := 0;
  910.           t2 := 0;  { count files found on disk }
  911.           for x := 1 to cat_num  do
  912.             if (cat_array[x].vol_record = t1) and (vol_min = 0) then
  913.               vol_min := x
  914.             else
  915.               if (vol_min <> 0 ) and (vol_max = 0) and (cat_array[x].vol_record <> t1) then
  916.                 vol_max := x - 1 ;
  917.           if vol_max = 0 then vol_max := cat_num;
  918.           msdos11(3);
  919.           if (r.ax and 255) = 0 then
  920.             begin
  921.               while (r.ax and 255) = 0 do
  922.                 begin {q1}
  923.                   t2 := t2 + 1;
  924.                   temp := '';
  925.                   for x := 8 to 18 do
  926.                     temp := temp + chr(mem[seg(dta^):ofs(dta^)+x]);
  927.                   temp_array[t2].fil := temp;
  928.                   temp_array[t2].sizelo[1] := chr(mem[seg(dta^):ofs(dta^)+36]);
  929.                   temp_array[t2].sizelo[2] := chr(mem[seg(dta^):ofs(dta^)+37]);
  930.                   temp_array[t2].sizehi[1] := chr(mem[seg(dta^):ofs(dta^)+38]);
  931.                   temp_array[t2].sizehi[2] := chr(mem[seg(dta^):ofs(dta^)+39]);
  932.                   temp_array[t2].time[1] := chr(mem[seg(dta^):ofs(dta^)+30]);
  933.                   temp_array[t2].time[2] := chr(mem[seg(dta^):ofs(dta^)+31]);
  934.                   temp_array[t2].date[1] := chr(mem[seg(dta^):ofs(dta^)+32]);
  935.                   temp_array[t2].date[2] := chr(mem[seg(dta^):ofs(dta^)+33]);
  936.                   {-- now find old entry if any --}
  937.                   found := false;
  938.                   for x := vol_min to vol_max do
  939.                     begin
  940.                       if cat_array[x].fil = temp then
  941.                         begin
  942.                           found := true;
  943.                           t3 := x;
  944.                         end;
  945.                     end;
  946.  
  947.                   if not found then
  948.                     begin
  949.                       write (temp,'   Memo > ');
  950.                       Input('A','',wherex,wherey,33,true,F1,F10);
  951.  
  952.                       writeln;
  953.                       temp_array[t2].memo := answer;
  954.                     end
  955.                   else
  956.                     begin
  957.                       write (TEMP,'   Memo > ');
  958.                       input('A',cat_array[t3].memo,wherex,wherey,33,true,F1,F10);
  959.                       temp_array[t2].memo := answer;
  960.                       writeln;
  961.                     end;
  962.                   msdos12;
  963.                 end
  964.             end;
  965.           writeln ('Updating catalog..  One moment...');
  966.           t1 := vol_max - vol_min + 1;
  967.           if t1 < t2 then
  968.             begin
  969.               {check to see if we will overrun the array}
  970.               if (cat_num + (t2 - t1)) > max_records then
  971.                 begin
  972.                   writeln ('Maximum of ',max_records,' files exceeded by ',cat_num + t2 - t1 - max_records,'.');
  973.                   writeln ('Truncating to ',max_records);
  974.                 end;
  975.               {move the file up t2 - t1 records}
  976.               for x := (cat_num + t2 - t1) downto (vol_max + t2-t1 + 1) do
  977.                 cat_array[x] := cat_array[x - t2+t1];
  978.               cat_num := cat_num + t2 - t1;
  979.               {insert temp array}
  980.               for x := 1 to t2 do
  981.                 begin
  982.                   cat_array[x + vol_min - 1].fil := temp_array[x].fil;
  983.                   cat_array[x + vol_min - 1].sizelo := temp_array[x].sizelo;
  984.                   cat_array[x + vol_min - 1].sizehi := temp_array[x].sizehi;
  985.                   cat_array[x + vol_min - 1].time := temp_array[x].time;
  986.                   cat_array[x + vol_min - 1].date := temp_array[x].date;
  987.                   cat_array[x + vol_min - 1].memo := temp_array[x].memo;
  988.                   cat_array[x + vol_min - 1].vol_record := t4;
  989.                 end;
  990.             end
  991.           else  {the temp will fil in the old slot}
  992.             if t1 > t2 then
  993.               begin
  994.                 {insert temp array at vol_min}
  995.                 for x := 1 to t2 do
  996.                   begin
  997.                     cat_array[x + vol_min - 1].fil := temp_array[x].fil;
  998.                     cat_array[x + vol_min - 1].sizelo := temp_array[x].sizelo;
  999.                     cat_array[x + vol_min - 1].sizehi := temp_array[x].sizehi;
  1000.                     cat_array[x + vol_min - 1].time := temp_array[x].time;
  1001.                     cat_array[x + vol_min - 1].date := temp_array[x].date;
  1002.                     cat_array[x + vol_min - 1].memo := temp_array[x].memo;
  1003.                     cat_array[x + vol_min - 1].vol_record := t4;
  1004.                   end;
  1005.                 { move the array down to meet it }
  1006.                 for x := (vol_max + t2-t1 + 1) to (cat_num + t2 - t1) do
  1007.                   cat_array[x] := cat_array[x -(t2-t1)];
  1008.                 cat_num := x;
  1009.               end
  1010.             else  { the replacement array is an exact match !}
  1011.               for x := 1 to t2 do
  1012.                 begin
  1013.                   cat_array[x + vol_min - 1].fil := temp_array[x].fil;
  1014.                   cat_array[x + vol_min - 1].sizelo := temp_array[x].sizelo;
  1015.                   cat_array[x + vol_min - 1].sizehi := temp_array[x].sizehi;
  1016.                   cat_array[x + vol_min - 1].time := temp_array[x].time;
  1017.                   cat_array[x + vol_min - 1].date := temp_array[x].date;
  1018.                   cat_array[x + vol_min - 1].memo := temp_array[x].memo;
  1019.                   cat_array[x + vol_min - 1].vol_record := t4;
  1020.                 end;
  1021.         end
  1022.       else           { Do a Complete Add function }
  1023.         begin
  1024.           msdos11(3);
  1025.           if (r.ax and 255) = 0 then
  1026.             begin
  1027.               if Ctype = 'T' then
  1028.               id := pathname
  1029.               else
  1030.               id := volume;
  1031.               cat_num := cat_num + 1;
  1032.               vol_num := vol_num + 1;
  1033.               vol_array[vol_num] := id;
  1034.               cat_array[cat_num].vol_record := -1;  { -1 means this is a vol entry }
  1035.               cat_array[cat_num].fil := id;
  1036.               cat_array[cat_num].memo := 'Volume Label';
  1037.               while ((r.ax and 255) = 0) and (cat_num < max_records + 1) do
  1038.                 begin
  1039.                   cat_num := cat_num + 1;
  1040.                   temp := '';
  1041.                   for x := 8 to 18 do
  1042.                     temp := temp + chr(mem[seg(dta^):ofs(dta^)+x]);
  1043.                   write (temp,'  ');
  1044.                   write (' Memo > ');
  1045.                   Input('A','',wherex,wherey,33,true,F1,F10);
  1046.                   one_memo := answer;
  1047.                   writeln;
  1048.                   cat_array[cat_num].vol_record := vol_num;
  1049.                   cat_array[cat_num].fil := temp;
  1050.                   cat_array[cat_num].sizelo[1] := chr(mem[seg(dta^):ofs(dta^)+36]);
  1051.                   cat_array[cat_num].sizelo[2] := chr(mem[seg(dta^):ofs(dta^)+37]);
  1052.                   cat_array[cat_num].sizehi[1] := chr(mem[seg(dta^):ofs(dta^)+38]);
  1053.                   cat_array[cat_num].sizehi[2] := chr(mem[seg(dta^):ofs(dta^)+39]);
  1054.                   cat_array[cat_num].time[1] := chr(mem[seg(dta^):ofs(dta^)+30]);
  1055.                   cat_array[cat_num].time[2] := chr(mem[seg(dta^):ofs(dta^)+31]);
  1056.                   cat_array[cat_num].date[1] := chr(mem[seg(dta^):ofs(dta^)+32]);
  1057.                   cat_array[cat_num].date[2] := chr(mem[seg(dta^):ofs(dta^)+33]);
  1058.                   cat_array[cat_num].memo := one_memo;
  1059.                   msdos12;
  1060.                 end;
  1061.             end
  1062.           else
  1063.             writeln ('Disk has no files!');
  1064.         end;
  1065.       if cat_num = max_records then writeln ('The catalog is full.');
  1066.     end
  1067.   else
  1068.     begin
  1069.       writeln (' Cannot catalog a disk without a Volume Label.');
  1070.       writeln (' A)dd one from the Main Menu.');
  1071.     end;
  1072.     writeln;
  1073.   write (' Press any key to continue');
  1074.   read (kbd,ch);
  1075. end;
  1076.  
  1077. function upcase33(strng : str33) : str33;
  1078. var
  1079.   temp : str33;
  1080.   x : integer;
  1081. begin
  1082.   temp := '';
  1083.   for x := 1 to length(strng) do
  1084.     temp := temp + upcase(strng[x]);
  1085.   upcase33 := temp;
  1086. end;
  1087.  
  1088. procedure scan_comments;
  1089. var
  1090.   scanner : string[33];
  1091.   bytes : real;
  1092.   t1,t2,d1,d2,hour,minutes,mm,dd,yy,y : integer;
  1093. begin
  1094.   drawbox (7,6,70,10,lightcyan,black,'[ Scan Memos ]',blink_no);
  1095.   y := 0;
  1096.   write ('Enter string to scan for: ');
  1097.   input('A','',wherex,wherey,33,true,f1,f10);
  1098.   scanner := answer;
  1099.   drawbox (1,1,80,24,cyan,black,
  1100.   '[Volume   ] [Filename ] [Size] [Tm] [ Date ] [------------  Memo  -----------]',blink_no);
  1101.   scanner := upcase33(scanner);
  1102.   for x := 1 to cat_num do
  1103.       if cat_array[x].vol_record = -1 then
  1104.            ID :=  cat_array[x].fil
  1105.     else
  1106.       begin
  1107.       if pos(scanner, upcase33(cat_array[x].memo)) > 0 then
  1108.         begin
  1109.           y := y + 1;
  1110.           write (id:11);
  1111.           write (' ',cat_array[x].fil:11);
  1112.           bytes := ord(cat_array[x].sizelo[2]) * 256.0;
  1113.           bytes := bytes + ord(cat_array[x].sizelo[1]);
  1114.           bytes := bytes + ord(cat_array[x].sizehi[1]) * 65536.0;
  1115.           write (' ',bytes:6:0);
  1116.           t1 := ord(cat_array[x].time[1]);
  1117.           t2 := ord(cat_array[x].time[2]);
  1118.           d1 := ord(cat_array[x].date[1]);
  1119.           d2 := ord(cat_array[x].date[2]);
  1120.           hour := (t2 and 249) shr 3;
  1121.           if hour = 0 then
  1122.             write (' 00')
  1123.           else
  1124.             if hour < 10 then
  1125.               write (' 0',hour)
  1126.             else
  1127.               write (' ',hour);
  1128.           minutes := ((t2 and 7) shl 3) + ((t1 and 224) shr 5);
  1129.           if minutes < 10 then write ('0');
  1130.           write (minutes);
  1131.           mm := ((d2 and 1) shl 3) + ((d1 and 224) shr 5);
  1132.           dd := (d1 and 31);
  1133.           yy := 80 + ((d2 and 255) shr 1);
  1134.           write (' ');
  1135.           if mm < 10 then write ('0'); write (mm,'-');
  1136.           if dd < 10 then write ('0'); write (dd,'-');
  1137.           write (yy:2);
  1138.           write (' ',cat_array[x].memo);
  1139.           if length(cat_array[x].memo) < 33 then writeln;
  1140.           if y/21 = int(y/21) then keycontinue;
  1141.         end;
  1142.       end;
  1143.   writeln;
  1144.   write ('End of catalog. Press any key to continue');
  1145.   read (kbd,ch);
  1146. end;
  1147.  
  1148. procedure scan_files;
  1149. var
  1150.   scanner : string[11];
  1151.   bytes : real;
  1152.   t1,t2,d1,d2,hour,minutes,mm,dd,yy,y: integer;
  1153. begin
  1154.   drawbox (7,6,70,10,lightcyan,black,'[ Scan Filenames ]',blink_no);
  1155.   y := 0;
  1156.   write ('Enter string to scan for: ');
  1157.   input('A','',wherex,wherey,11,true,f1,f10);
  1158.   scanner := answer;
  1159.   drawbox (1,1,80,24,cyan,black,
  1160.   '[Volume   ] [Filename ] [Size] [Tm] [ Date ] [------------  Memo  -----------]',blink_no);
  1161.   scanner := upcase11(scanner);
  1162.   for x := 1 to cat_num do
  1163.     if cat_array[x].vol_record = -1 then
  1164.            ID :=  cat_array[x].fil
  1165.     else
  1166.       begin
  1167.       if pos(scanner, upcase11(cat_array[x].fil)) > 0 then
  1168.         begin
  1169.           y := y + 1;
  1170.           write (id:11);
  1171.           write (' ',cat_array[x].fil:11);
  1172.           bytes := ord(cat_array[x].sizelo[2]) * 256.0;
  1173.           bytes := bytes + ord(cat_array[x].sizelo[1]);
  1174.           bytes := bytes + ord(cat_array[x].sizehi[1]) * 65536.0;
  1175.           write (' ',bytes:6:0);
  1176.           t1 := ord(cat_array[x].time[1]);
  1177.           t2 := ord(cat_array[x].time[2]);
  1178.           d1 := ord(cat_array[x].date[1]);
  1179.           d2 := ord(cat_array[x].date[2]);
  1180.           hour := (t2 and 249) shr 3;
  1181.           if hour = 0 then
  1182.             write (' 00')
  1183.           else
  1184.             if hour < 10 then
  1185.               write (' 0',hour)
  1186.             else
  1187.               write (' ',hour);
  1188.           minutes := ((t2 and 7) shl 3) + ((t1 and 224) shr 5);
  1189.           if minutes < 10 then write ('0');
  1190.           write (minutes);
  1191.           mm := ((d2 and 1) shl 3) + ((d1 and 224) shr 5);
  1192.           dd := (d1 and 31);
  1193.           yy := 80 + ((d2 and 255) shr 1);
  1194.           write (' ');
  1195.           if mm < 10 then write ('0'); write (mm,'-');
  1196.           if dd < 10 then write ('0'); write (dd,'-');
  1197.           write (yy:2);
  1198.           write (' ',cat_array[x].memo);
  1199.           if length(cat_array[x].memo) < 33 then writeln;
  1200.           if y/21 = int(y/21) then keycontinue;
  1201.         end;
  1202.       end;
  1203.   writeln;
  1204.   write ('End of catalog. Press any key to continue');
  1205.   read (kbd,ch);
  1206. end;
  1207.  
  1208. procedure vol_disk;
  1209. var
  1210.   newvol : str11;
  1211. begin
  1212.   drawbox (3,15,55,20,lightgreen,black,'[ Volume Disk ]',blink_no);
  1213.   volume := '';
  1214.   msdos11(8);
  1215.   if (r.ax and 255) = 0 then
  1216.     begin
  1217.       for x := 8 to 18 do
  1218.         volume := volume + chr(mem[seg(dta^):ofs(dta^)+x]);
  1219.       writeln ('Current Volume is ',volume);
  1220.       write ('Are you sure you want to change ? ');
  1221.       repeat read (kbd,ch); until ch in yes_no;
  1222.       if upcase(ch) = 'Y' then
  1223.         begin
  1224.           writeln;
  1225.           write ('Enter new Volume Label >');
  1226.           input('A','',wherex,wherey,11,true,f1,f10);
  1227.           newvol := answer;
  1228.           for x := length(newvol) to 11 do newvol := newvol + ' ';
  1229.           for x := 17 to 28 do fcb[x] := newvol[x-16];
  1230.           pointer := addr(fcb[-7]);
  1231.           r.ds := seg(pointer^);
  1232.           r.dx := ofs(pointer^);
  1233.           r.ax := $17 shl 8;
  1234.           msdos(R);
  1235.         end
  1236.     end
  1237.   else
  1238.     begin
  1239.       write ('Enter new Volume Label >');
  1240.       input('A','',wherex,wherey,11,true,f1,f10);
  1241.       newvol := answer;
  1242.       for x := length(newvol) to 11 do newvol := newvol + ' ';
  1243.       for x := 1 to 11 do fcb[x] := newvol[x];
  1244.       pointer := addr(fcb[-7]);
  1245.       r.ds := seg(pointer^);
  1246.       r.dx := ofs(pointer^);
  1247.       r.ax := $16 shl 8;
  1248.       msdos(R);
  1249.     end;
  1250. end;
  1251.  
  1252. procedure scan_submenu;
  1253. begin
  1254.   drawbox(1,5,80,9,lightred,black,'[ Scan Sub-Menu ]',blink_no);
  1255.   writeln ;
  1256.   write ('  1) Filenames   2) Memos   3) Exit   Your choice?  ');
  1257.   repeat
  1258.     read (kbd,ch);
  1259.   until ch in ['1'..'3'];
  1260.   case ch of
  1261.     '1' : scan_files;
  1262.     '2' : scan_comments;
  1263.   end;
  1264. end;
  1265.  
  1266. Procedure Indtype; {gg}
  1267. begin
  1268. drawbox(20,15,78,22,lightcyan,black,'[ Catalog Load ]',blink_no);
  1269.    Ctype := 'T';
  1270.    GetPath;
  1271.    Get_Vol;
  1272.    if pathname = 'ROOT       ' then begin
  1273.     catname := copy(volume,1,11);
  1274.     stripspaces(catname,catname);
  1275.     catname := catname+'.CAT';
  1276.     end
  1277.     else begin
  1278.     stripspaces(pathname,catname);
  1279.     catname := catname+'.CAT';
  1280.     end;
  1281.     writeln;
  1282.      write('Enter name of catalog: ');
  1283.      input('A',catname,24,whereY,33,true,F1,F10);
  1284.      catname := answer;
  1285.      writeln;
  1286.     Load_Catalog;
  1287. end;
  1288.  
  1289. procedure TreeType; {gg}
  1290. begin
  1291.      Ctype := 'T';
  1292.      drawbox (20,15,78,22,lightcyan,black,'[ Catalog Load ]',blink_no);
  1293.      writeln;
  1294.      write('Enter name of catalog: ');
  1295.      input('A',default_drive+':\TREELIB.CAT',24,2,33,true,F1,F10);
  1296.      catname := answer;
  1297.      writeln;
  1298.      GetPath;
  1299.      Load_Catalog;
  1300. end;
  1301.  
  1302. procedure FlopType; {gg}
  1303. begin
  1304.      Ctype := 'F';
  1305.      drawbox (20,15,78,22,lightcyan,black,'[ Catalog Load ]',blink_no);
  1306.      writeln;
  1307.      write('Enter name of catalog: ');
  1308.      input('A',default_drive+':\FLOPLIB.CAT',24,2,33,true,F1,F10);
  1309.      catname := answer;
  1310.      orig_drive := default_drive;
  1311.      writeln;
  1312.      write('     Drive to catalog: ');
  1313.      repeat
  1314.      read(kbd,ch);
  1315.      ch := upcase(ch);
  1316.        if not (ch in ['A'..'E']) then beep(350,150);
  1317.      until ch in ['A'..'E'];
  1318.      write(ch+':');
  1319.      Log_New_Drive(Ch);
  1320.      GetPath;
  1321.      Load_Catalog;
  1322. end;
  1323.  
  1324. procedure Load_Type;    {gg}
  1325. begin
  1326.   if changed then
  1327.      begin
  1328.       drawbox (10,17,70,22,white,red,'[ Warning! ]',blink_yes);
  1329.       center('  Catalog '+catname+' has been changed!',1,2,59);
  1330.       center ('  Do you want to Save [Y/N] ? ',1,3,59);
  1331.       repeat read (kbd,ch); until ch in yes_no;
  1332.      if upcase(ch) = 'Y' then
  1333.      save_catalog
  1334.      end;
  1335.   INIT;
  1336.   getdir(0,fullpathname);
  1337.   default_drive := fullpathname[1];
  1338.   drawbox(2,17,78,22,lightred,black,'[ Load Catalog ]',blink_no);
  1339.   writeln ;
  1340.   writeln (' T)ree Structured Library   F)loppy Library   D)irectory Catalog  E)xit');
  1341.   writeln;
  1342.   write('                            Your choice ? ');
  1343.   repeat
  1344.     read (kbd,ch);
  1345.     ch := upcase(ch);
  1346.   until ch in ['T','F','D','E'];
  1347.   write(ch);
  1348.   case ch of
  1349.     'T' : TreeType;
  1350.     'F' : FlopType;
  1351.     'D' : IndType;
  1352.   end;
  1353. end;
  1354.  
  1355. procedure show_catalog;
  1356. begin
  1357.   drawbox (1,5,30,24,white,black,'[ show ]',blink_no);
  1358.   for x := 1 to cat_num do
  1359.    begin
  1360.     writeln (x,' ',cat_array[x].vol_record,' ',cat_array[x].fil);
  1361.     if x/17 = int(x/17) then keycontinue;
  1362.    end;
  1363.    keycontinue;
  1364. end;
  1365.  
  1366. procedure Help;
  1367. begin
  1368. drawbox(1,1,80,24,white,black,'[ Help Screen ]', blink_no);
  1369. writeln;
  1370. writeln(' PCDISK is adapted from John Friel IIIs Disk cataloger.  If you find it');
  1371. writeln(' of value please send your contribution to him at:   ');
  1372. writeln('    The Forbin Project, 715 Walnut Street, Cedar Falls, Iowa 50613.');
  1373. writeln;
  1374. writeln;
  1375. writeln(' COMMANDS:');
  1376. writeln;
  1377. writeln(' L)oad Catalog submenu:');
  1378. writeln('    T)ree  - useful for keeping track of a hard disk');
  1379. writeln('    F)loppy - useful for keeping track of up to 1000 files on 100 floppies');
  1380. writeln('    D)irectory - for a catalog of the current drive or directory');
  1381. writeln(' U)pdate - presents existing file descriptions for editing or addition');
  1382. writeln(' F)ilenames - Lists only the filenames in the catalog');
  1383. writeln(' R)eview - search for a string (in filenames or memos)');
  1384. writeln(' A)dd - create or change a volume label on the current drive');
  1385. writeln(' E)rase - removes the specified volume from memory');
  1386. writeln(' D)ir - shows directory of current drive/disk');
  1387. writeln;
  1388. writeln(' If you have questions about, or discover bugs in, this version of ');
  1389. writeln(' PCDISK, please address them to G. Gallo at PCSI - 1-212-924-6598');
  1390. keycontinue;
  1391. end;
  1392.  
  1393. procedure options;
  1394. begin
  1395.     Drawbox (1,1,80,4,brown,black,'',blink_yes);
  1396.     textcolor(lightgreen);
  1397.     Writeln ('                          PC-Disk  Version 3.0D ');
  1398.     Write   ('         (c) The Forbin Project  - revised by G.G. 23 May 1985    ');
  1399.     drawbox(1,5,80,15,yellow,black,'[ Main Menu ]',blink_no);
  1400.     writeln;
  1401.     writeln ('          L)oad Catalog                 R)eview Catalog in Memory');
  1402.     writeln ('          U)pdate Catalog in Memory     A)dd/Change Volume Label');
  1403.     writeln ('          S)ave Catalog to Disk         E)rase a Volume from Memory');
  1404.     writeln ('          D)isk Directory               H)elp Screen');
  1405.     writeln ('          C)hange Current Directory     F)ilenames in Catalog');
  1406.     writeln ('          N)ew Drive                    Q)uit PC-Disk');
  1407.     writeln;
  1408.     write   ('                           Your choice:  ');
  1409.     gotoxy (41,9);
  1410.     repeat
  1411.       read (kbd,ch);
  1412.       Ch := upcase(ch);
  1413.     until ch in ['L','C','D','U','S','N','R','A','H','F','E','O','I','Q'];
  1414.     write(ch);
  1415.     case ch of
  1416.       'L' :  load_type;
  1417.       'C' :  changedir;
  1418.       'D' :  dir2;
  1419.       'U' :  update_disk;
  1420.       'S' :  save_catalog;
  1421.       'R' :  scan_submenu;
  1422.       'A' :  vol_disk;
  1423.       'H' :  help;
  1424.       'E' :  delete_volume;
  1425.       'F' :  show_catalog;
  1426.       'N' :  changedrive;
  1427.       'Q' :  big_exit;
  1428.     end; { case }
  1429. end;
  1430.  
  1431. begin {main}
  1432.   clrscr;
  1433.   init;
  1434.   getdir(0,fullpathname);
  1435.   orig_path := fullpathname;
  1436.   default_drive := fullpathname[1];
  1437.   repeat
  1438.   options;
  1439.   until done;
  1440.   chdir(orig_path);
  1441.   window(1,1,80,25);
  1442.   clrscr;
  1443. end.
  1444.