Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB34.ZIP/DIR401.PAS

Pascal/Delphi Source File | 1986-03-15 | 46.6 KB | 1,616 lines

{
                  ╒═════════════════════════════════════════╕
                  │    DIR401.PAS      -         3/15/86    │
                  ╞═════════════════════════════════════════╡
                  │  Written by Wes Meier (76703,747) and   │
                  │  dedicated to the Public Domain.  The   │
                  │  directory read code was written by     │
                  │  Neil J. Rubenking.                     │
                  ╘═════════════════════════════════════════╛
}

{$V- }

Type

  Regtype     = Record
                  Ax,Bx,Cx,Dx,Bp,Si,Di,Ds,Es,Flags : integer
                End;
  HalfRegtype = Record
                  Al,Ah,Bl,Bh,Cl,Ch,Dl,Dh : byte
                End;
  filename_type = string[64];
  files_type = String[16];
  Str255 = String[255];
  Time = Record
           Hours,Min,Sec,Hundreths : Byte
         End;
  DOW = (Sun,Mon,Tue,Wed,Thu,Fri,Sat);
  Date = Record
           Month,Day : Byte;
           Year : Integer;
           DayOfWeek : DOW
         End;

Const

{regs is defined as a typed constant in order to get it in the code segment}

  Regs : regtype = (Ax:0;Bx:0;Cx:0;Dx:0;Bp:0;Si:0;Di:0;Ds:0;Es:0;Flags:0);
  Max_Entries = 3500;
  DayName : Array [DOW] Of String[9] = ('Sunday','Monday','Tuesday',
                                        'Wednesday','Thursday','Friday',
                                        'Saturday');
  CurStart = 0;
  CurEnd = 12;
  On = True;
  Off = False;

Var

  SaveRegs                    : regtype;
  HalfRegs                    : halfregtype absolute regs;
  x,y,entries,fore,back,bord,
  fore_hi,attrib              : integer;
  filepath                    : filename_type;
  files                       : Array [0..Max_Entries] of Files_Type;
  ok,Reading,Sort_Flag,
  List_Dta,List_Act           : boolean;
  ch,choice                   : char;
  cpi16                       : string[20];
  sx,sy,diskstr,disk          : Str255;
  ft                          : text;

Procedure Set_Cursor(start_line, End_line : integer);
  var
    result : regtype;

  Begin
    with result do
      Begin
        ax := $100;
        cx := start_line shl 8 + End_line;
        intr($10,result)
      End
  End; { Proc Set_Cursor }

 Procedure Cursor(On : boolean);
   Begin
     if On
       then
         Set_Cursor(CurStart,CurEnd)
       else
         Set_Cursor($20,$20)
   End; { Proc Cursor }

Procedure Pad_Left(var x       : Str255;
                       padchar : char;
                       num     : byte);

  var k : byte;

  Begin
    for k := 1 to num do x := padchar + x;
    x := copy(x,length(x) + 1 - num,num)
  End; { Proc Pad_Left }

Procedure Pad_Right(var x       : Str255;
                        padchar : char;
                        num     : byte);
  Begin
    while length(x) < num do x := x + padchar;
    x := copy(x,1,num)
  End; { Proc Pad_Right }

Procedure Check_Pos;
    Begin
      if WhereX > 70 then WriteLn;
      if WhereY > 23
        then
          Begin
            GotoXY(15,25);
            Write('Press any key to continue (* or Q to quit) ...');
            Repeat Until KeyPressed;
            Read(Kbd,choice);
            choice := UpCase(choice);
            if choice = 'Q' then choice := '*';
            ClrScr;
            GotoXY(1,1)
          End { if }
    End; { Proc Check_Pos }

Procedure AtEnd;
  var c : char;

  Begin
    GotoXY(20,25);
    Write('End of Directory. Press any key to continue ...');
    Repeat Until Keypressed
  End; { Proc AtEnd }

Procedure Get_File;

  type
    Dir_Entry   = Record
                    Reserved : array[1..21] of byte;
                    Attribute: byte;
                    Time, Date, FileSizeLo, FileSizeHi : integer;
                    Name : string[13]
                  End;

 var
   RetCode   : byte;
   Filename  : filename_type;
   Buffer    : Dir_Entry;
   Attribute : byte;

 Procedure CheckNulls;
   var v : integer;

   Begin
     for v := 1 to 12 do
       Begin
         if files[entries][v] = #0 then files[entries][v] := ' '
       End { for v }
   End; { Sub Proc CheckNulls }

 Procedure Disk_Trns_Addr(var Disk_Buf);
   var
     Registers : regtype;

  Begin
    with Registers do
      Begin
        Ax := $1A shl 8;                 { Set disk transfer address to  }
        Ds := seg(Disk_Buf);             { our disk buffer               }
        Dx := ofs(Disk_Buf);
        msdos(Registers)
      End
   End; { Proc Disk_Trns_Addr }

  Procedure Check_Max;
    Begin
      if entries > Max_Entries
        then
          Begin
            WriteLn;
            WriteLn;
            WriteLn(#7,'You have reached the Maximum number of entries!');
            WriteLn('Your DIR.DAT remains intact. You',#39,'ll have to create');
            WriteLn('another DIR.DAT file on a different data disk.');
            WriteLn;
            WriteLn('DIR Halted.');
            Halt
          End { if }
    End; { Proc Check_Max }

  Procedure Find_Next(var Att:byte;
                      var Filename : Filename_type;
                      var Next_RetCode : byte);
    var
      Registers  : regtype;
      Carry_flag : integer;
      N          : byte;

    Begin {Find_Next}
      Buffer.Name := '             ';      { Clear result buffer }
      with Registers do
        Begin
          Ax := $4F shl 8;                 { Dos Find next function }
          MsDos(Registers);
          Att := Buffer.Attribute;         { Set file attribute     }
          Carry_flag := 1 and Flags;       { Isolate the Error flag }
          Filename := '             ';
          if Carry_flag = 1
            then
              Next_RetCode := Ax and $00FF
            else
              Begin                         { Move file name         }
                Next_RetCode := 0;
                for N := 0 to 11 do FileName[N+1] := Buffer.Name[N]
              End { else }
        End  { with }
    End; { Proc Find_Next }

  Procedure Find_First (var Att: byte;
                        var Filename: Filename_type;
                        var RetCode_code : byte);

    var
      Registers  :regtype;
      Carry_flag :integer;
      Mask, N    :byte;

    Begin
     Disk_Trns_Addr(buffer);
     Filename := Filename + chr(0);
     Buffer.Name := '             ';
     with Registers do
       Begin
         Ax := $4E shl 8;                { Dos Find First Function }
         Cx := Att;                      { Attribute of file to fine }
         Ds := seg(Filename);            { Ds:Dx Asciiz string to find }
         Dx := ofs(Filename) + 1;
         MsDos(Registers);
         Att := Buffer.Attribute;        { set the file attribute byte  }

                                         { If error occured set, Return code. }

         Carry_flag := 1 and Flags;      { If Carry flag, error occured }
                                         { and Ax will contain Return code }
         if Carry_flag = 1
           then
             RetCode_code := Ax and $00FF
           else
             Begin
               RetCode_code := 0;
               Filename := '             ';
               for N := 0 to 11 do FileName[N+1] := Buffer.Name[N]
             End { else }
       End  {with}
    End; { Proc Find_First }

  var
    attribyte : byte;

  Begin { Primary block of Get_File }
    filename := filepath;
    attribyte := 0;
    Find_First(attribyte,filename,Retcode);
    If Retcode = 0
      then
        Begin
          if Reading
            then
              Begin
                entries := entries + 1;
                Check_Max;
                files[entries] :=Filename;
                Pad_Right(files[entries],#32,12);
                files[entries] := files[entries] + disk;
                CheckNulls;
              End { if Reading }
            else
              Begin
                Write(filename);
                Check_Pos;
                if choice = '*' then Retcode := 1;
                choice := ' '
              End { else }
        End; { if Retcode }

    { Now we Repeat Find_Next Until an error occurs }

    Repeat
      Find_Next(attribyte,filename,Retcode);
      if Retcode = 0
        then
          Begin
            if Reading
              then
                Begin
                  entries := entries + 1;
                  Check_Max;
                  files[entries] :=Filename;
                  Pad_Right(files[entries],' ',12);
                  files[entries] := files[entries] + disk;
                  CheckNulls;
                End { if Reading }
              else
                Begin
                  Write(filename);
                  Check_Pos;
                  if choice = '*' then Retcode := 1;
                  choice := ' '
                End { else }
          End { if Retcode }
    Until Retcode <> 0;
    if not Reading
      then
        if choice <> '*'
          then
            AtEnd
  End; { Proc Get_File }

Procedure TimDat(var timestr, datestr, daystr :Str255);
  Procedure GetTime(Var T:Time);
    var regs : HalfRegType;

    Begin
      With Regs,T Do
        Begin
          AH := $2C;
          MsDos(Regs);
          Hours := CH;
          Min := CL;
          Sec := DH;
          Hundreths := DL
       End { with }
    End; { Sub Proc GetTime }

  Procedure GetDate(Var D:Date);
    var
      Regs : HalfRegType;

    Begin
      With Regs,D Do
        Begin
          AH := $2A;
          MsDos(Regs);
          Month := DH;
          Day := DL;
          Year := 256 * CH + CL;
          DayOfWeek := DOW(AL)
        End { with }
    End; { Sub Proc GetDate }

  Var
    T1 : Time;
    D1 : Date;
    s1 : string[5];

  Begin { Proc TimDat Main }
    GetTime(T1);
    GetDate(D1);
    With T1 Do
      Begin
        timestr := '';
        str(hours,s1);
        Pad_Left(s1,'0',2);
        timestr := s1 + ':';
        str(min,s1);
        Pad_Left(s1,'0',2);
        timestr := timestr + s1 + ':';
        str(sec,s1);
        Pad_Left(s1,'0',2);
        timestr := timestr + s1
      End; { with T1 }
    With D1 Do
      Begin
        datestr := '';
        str(month,s1);
        Pad_Left(s1,'0',2);
        datestr := s1 + '/';
        str(day,s1);
        Pad_Left(s1,'0',2);
        datestr := datestr + s1 + '/';
        str(year,s1);
        datestr := datestr + s1;
        daystr := DayName[DayOfWeek]
      End  { with T1 }
  End; { Proc TimDat }

Procedure Color(fr,bk,bd : integer);
  Begin
    TextColor(fr);
    TextBackground(bk);
    Port[$03d9] := bd
  End; { Proc Color }

Procedure UpperCase(var x : Str255);
  var i : integer;

  Begin
    for i := 1 to length(x) do x[i] := UpCase(x[i])
  End; { Proc UpperCase }

Procedure Sort;
 label
   B, C, D;

 var
   i,j,k,l,m,n : integer;
   t           : files_type;

 Begin
   Cursor(Off);
   Write ('Sorting');
   n := entries;
   m := n div 2;
   While m > 0 do
     Begin
       Write ('.');   { Just to show that something's going on.... }
       j := 1;
       k := n - m;
B:     i := j;
C:     l := i + m;
       if files[i] >= files[l]
         then
           Begin
             t := files[i];
             files[i] := files[l];
             files[l] := t;
             i := i - m;
             if i >= 1 then goto C
           End; { if }
D:     j := j + 1;
       if j <= k then goto B;
       m := m div 2
     End; { while m }
   WriteLn;
   Cursor(On)
 End; { Proc Sort }

Procedure Sort_By_Num;
  var i : integer;

  Begin
    if Sort_Flag
      then
        Begin
          Sort_Flag := False;
          for i := 1 to entries do
            files[i] := copy(files[i],5,12) + copy(files[i],1,4)
        End { if }
      else
        Begin
          Sort_Flag := True;
          for i := 1 to entries do
            files[i] := copy(files[i],13,4) + copy(files[i],1,12)
        End; { else }
    Sort
  End; { Proc Sort_By_Num }

Function Exist(filenam : files_type) : Boolean;
  var
    f : file;

  Begin
    Assign(f, filenam);
    {$I- }
    Reset(f);
    {$I+ }
    Exist := (IOresult = 0);
    close(f)
  End; { Function Exist }

Procedure Init;
  var
    fil    : text;

  Begin
    if not Exist('dir4.cfg')
      then
        Begin
          Assign(fil,'dir4.cfg');
          ReWrite(fil);
          {
            Create the default parameters
          }
          fore := Green;
          back := Black;
          bord := Black;
          fore_hi := Yellow;
          cpi16 := #27 + 'P'; { Default to the Epson/IBM string }
          WriteLn(fil,fore);
          WriteLn(fil,back);
          WriteLn(fil,bord);
          WriteLn(fil,fore_hi);
          WriteLn(fil,cpi16)
        End { if }
      else
        Begin
          Assign(fil,'dir4.cfg');
          Reset(fil);
          ReadLn(fil,fore);
          ReadLn(fil,back);
          ReadLn(fil,bord);
          ReadLn(fil,fore_hi);
          ReadLn(fil,cpi16)
        End; { else }
    close(fil);
    Sort_Flag := False;
    color(fore,back,bord);
    ClrScr;
    window(27,9,60,21);
    gotoXY(1,1);
    WriteLn('╒════════════════════════╕');
    WriteLn('│                        │');
    WriteLn('│        DIR 4.01        │');
    WriteLn('│                        │');
    WriteLn('│      by Wes Meier      │');
    WriteLn('│                        │');
    WriteLn('│       March 1986       │');
    WriteLn('│                        │');
    WriteLn('╞════════════════════════╡');
    Write  ('│');
    TextColor(fore_hi);
    Write('FOR PUBLIC DOMAIN ONLY');
    TextColor(fore);
    WriteLn('│');
    Write  ('╘════════════════════════╛');
    window(1,1,80,25)
  End; { Proc Init }

Procedure Read_Data_From_Disk;
  var
    dir_dat : text;

  Begin
    if not Exist('DIR.DAT')
      then
        Begin
          Assign(dir_dat,'DIR.DAT');
          ReWrite(dir_dat);
          Close(dir_dat)
        End; { if }
    Assign(dir_dat,'DIR.DAT');
    Reset(dir_dat);
    entries := 0;
    while not EOF(dir_dat) do
      Begin
        entries := entries + 1;
        ReadLn(dir_dat,sx);

        {
         Are we Reading an old DIR3.n file?
        }

        if pos('"',sx) > 0
          then
            Begin
              sx := copy(sx,2,15);
              sy := copy(sx,1,8);
              while sy[length(sy)] = ' ' do
                Begin
                  delete(sy,length(sy),1)
                End; { While }
              sy := copy(sy + copy(sx,9,4) + '            ',1,12);
              sx := sy + copy(sx,13,3);
              insert('0',sx,13)
            End; { if }
        if copy(sx,13,4) = '0000'
          then
            entries := entries - 1  { don't allow files with '0000' in them }
          else
            files[entries] := sx
      End; { while }
    close(dir_dat)
  End; { Proc Read_Data_From_Disk }

Procedure Dump_Data_To_Disk; { Terminal routine...re-execs the program }
  var
    dir_dat : text;
    dir4    : file;
    i       : integer;

  Begin
    Cursor(Off);
    TextColor(fore + blink);
    ClrScr;
    GotoXY(20,12);
    Write('Dumping Data to Disk ....');
    Assign(dir_dat,'dir.dat');
    ReWrite(dir_dat);
    for i := 1 to entries do
      Begin
        if files[i][1] <> ' ' then WriteLn(dir_dat,files[i])
      End; { for }
    close(dir_dat);
    Assign(dir4,'DIR4.COM');
    Cursor(On);
    {$I- }
      Execute(dir4);
    {$I+ }
    if IOResult <> 0
      then
        Begin
          ClrScr;
          TextColor(fore);
          GotoXY(1,12);
          WriteLn(^G,'The file "DIR4.COM" was not found.');
          WriteLn('This program MUST be called "DIR4.COM" and be available in your default PATH.');
          WriteLn;
          WriteLn('Program Halted.');
          Halt
        End { if }
End; { Proc Dump_Data_To_Disk }

Procedure ShowMenu;
  Begin
    ClrScr;
    Window(19,8,62,22);
    GotoXY(1,1);
    WriteLn('╒═════════════════════════════════════════╕');
    Write  ('│     DIR 4.01 - ');
    Write  (entries:4);
    WriteLn(' Entries on File     │');
    WriteLn('├─────────────────────────────────────────┤');
    Write ('│ [');    TextColor(Fore_hi);
    Write ('F');      TextColor(Fore);
    WriteLn(']ind a File.                          │');
    Write ('│ [');    TextColor(Fore_hi);
    Write ('A');      TextColor(Fore);
    WriteLn(']dd File(s) to the Data Record.       │');
    Write ('│ [');    TextColor(Fore_hi);
    Write ('P');      TextColor(Fore);
    WriteLn(']rint or List the Data Record.        │');
    Write ('│ [');    TextColor(Fore_hi);
    Write ('D');      TextColor(Fore);
    WriteLn(']elete File(s) from the Data Record.  │');
    Write ('│ [');    TextColor(Fore_hi);
    Write ('L');      TextColor(Fore);
    WriteLn(']ist a Disk Directory (Data or Real). │');
    Write ('│ [');    TextColor(Fore_hi);
    Write ('W');      TextColor(Fore);
    WriteLn(']rite a Diskette Label.               │');
    Write ('│ [');    TextColor(Fore_hi);
    Write ('B');      TextColor(Fore);
    WriteLn(']ackup the Data Record File.          │');
    Write ('│ [');    TextColor(Fore_hi);
    Write ('C');      TextColor(Fore);
    WriteLn(']onfigure DIR4.                       │');
    Write ('│ [');    TextColor(Fore_hi);
    Write ('Q');      TextColor(Fore);
    WriteLn(']uit Back to DOS.                     │');
    Write ('╘═════════════════════════════════════════╛');
    Window(1,1,80,25);
  End; { Proc ShowMenu }

  Function Yes : boolean;
    var
      c   : char;
      yup : boolean;

    Begin
      Repeat
        Repeat Until KeyPressed;
        Read(kbd,c);
        c := UpCase(c)
      Until c in [#13,'Y','N','0','1','-','+'];
      yup := (c in [#13,'Y','+','1']);
      yes := yup;
      if yup
        then
          WriteLn('Yes')
        else
          WriteLn('No')
    End; { Function Yes }

  Procedure Fix_Path(var x : files_type);
    Begin
      if x[length(x)] <> '\' then x := x + '\';
      if x[2] <> ':' then insert(':',x,2);
      if pos(x,'*.*') = 0 then x := x + '*.*'
    End; { Proc Fix_Path }

  Procedure Add; { a file or files to the data Record }
    Procedure Disk_Read;
      var
        drive : filename_type;
        done,
        f     : boolean;
        i,j,w,z,
        count : integer;

      Begin{ Disk_Read }
        disk := '0000';
        done := False;
        Repeat { Until done }
          Repeat { Until Yes and disk <> '0000' }
            x := 0;
            ClrScr;
            GotoXY(20,3);
            val(disk,x,z);
            Write('Disk # to Read (1-9999). Default is ');
            Write(x + 1);
            Write(') ? ');
            z := WhereX;
            ReadLn(sx);
            if sx = ''
              then
                Begin
                  Str((x + 1),sx);
                  f := True
                End { if }
              else
                Begin
                  UpperCase(sx);
                  f := False
                End; { else }
            Pad_Left(sx,'0',4);
            disk := sx;
            if f
              then
                Begin
                  GotoXY(z,3);
                  Write(sx)
                End; { if }
            GotoXY(20,5);
            Write('Enter Drive or Path (Default is B:\) ? ');
            z := WhereX;
            ReadLn(filepath);
            if filepath = ''
              then
                Begin
                  filepath := 'B:\';
                  f := True
                End { if }
              else
                f := False;
            Fix_Path(filepath);
            if f
              then
                Begin
                  GotoXY(z,5);
                  Write(filepath)
                End; { if }
            GotoXY(20,7);
            Write('Is Disk #',disk,' on drive ',filepath,' correct ? ');
            if disk = '0000'
              then
                Begin
                  WriteLn;
                  WriteLn(^G,'"0000" is an illegal Disk value.');
                  WriteLn
                End { if }
          Until yes and (disk <> '0000');
          Reading := True;
          GotoXY(20,9);
          Write('Deleting all internal references to disk #',disk,'.');
          count := 0;
          for i := 1 to entries do
            Begin
              if disk = copy(files[i],13,4)
                then
                  Begin
                    files[i][1] := ' ';
                    count := count + 1
                  End { if }
            End; { for }
          GotoXY(20,11);
          if count = 0
            then
              Write('No entries found.')
            else
              Write(count,' entries deleted.');
          Get_File;
          GotoXY(20,13);
          Write('Done. More Disks to Read ? ');
          Done := not Yes
        Until done;
        WriteLn;
        GotoXY(20,15);
        Sort;
        Dump_Data_To_Disk
      End; { sub Proc Disk_Read }

    Procedure Manual_Entry;
      var
        done,
        new,
        k    : boolean;
        f,f1 : Str255;

      Begin{ Manual_Entry }
        new := False;
        done := False;
        k := False;
        ClrScr;
        GotoXY(1,12);
        Repeat { Until Done }
          Repeat { Until done or k, where k = Yes }
            Write('Enter File ("*" to Quit) ? ');
            ReadLn(f);
            if f = '*'
              then
                Begin
                  done := True;
                  k := False
                End { if }
              else
                Begin
                  UpperCase(f);
                  WriteLn;
                  Write('Enter Disk # (1-9999) ? ');
                  ReadLn(f1);
                  Pad_Left(f1,'0',4);
                  UpperCase(f1);
                  WriteLn;
                  Write('Is ',f,' on Disk #',f1,' Correct ? ');
                  k := yes;
                  if f1 = '0000'
                    then
                      Begin
                        k := False;
                        WriteLn(^G,'"0000" is an illegal Disk label!');
                      End { if }
                End; { else }
            WriteLn
          Until done or k; { k = Yes }
          if k
            then
              Begin
                new := True;
                entries := entries + 1;
                Pad_Right(f,' ',12);
                files[entries] := f + f1
              End { if k }
        Until done;
        if new
          then
            Begin
              Sort;
              Dump_Data_To_Disk
            End { if }
      End; { sub Proc Manual_Entry }

    var
      chc : char;

    Begin { Add }
      ClrScr;
      GotoXY(20,12);
      Write('Manually ');
      TextColor(fore_hi + blink);
      Write('A');
      TextColor(fore);
      Write('dd file(s), Read a ');
      TextColor(fore_hi + blink);
      Write('D');
      TextColor(fore);
      Write('isk, or ');
      TextColor(fore_hi + blink);
      Write('Q');
      TextColor(fore);
      Write('uit ? ');
      Repeat
        Repeat Until Keypressed;
        Read(kbd,chc);
        chc := UpCase(chc)
      Until pos(chc,'ADQ*') > 0;
      Case chc of
        'A' : manual_entry;
        'D' : disk_Read
      End { Case chc }
    End; { Proc Add }

Procedure Configure;
  var
    chc,c :  char;
    done  :  boolean;
    i     :  integer;

  Begin
    done := False;
    Repeat { Until done }
      ClrScr;
      Cursor(Off);
      Window(19,1,62,13);
      GotoXY(1,1);
      WriteLn('╒═════════════════════════════════════════╕');
      WriteLn('│      DIR 4.01 - Configuration Menu      │');
      WriteLn('├─────────────────────────────────────────┤');
      Write ('│ Change [');    TextColor(Fore_hi);
      Write ('F');      TextColor(Fore);
      WriteLn(']oreground Color.              │');
      Write ('│ Change [');    TextColor(Fore_hi);
      Write ('H');      TextColor(Fore);
      WriteLn(']ighlight Color.               │');
      Write ('│ Change [');    TextColor(Fore_hi);
      Write ('B');      TextColor(Fore);
      WriteLn(']ackground Color.              │');
      Write ('│ Change Bo[');    TextColor(Fore_hi);
      Write ('R');      TextColor(Fore);
      WriteLn(']der Color.                  │');
      Write ('│ Enter [');       TextColor(Fore_hi);
      Write ('P');      TextColor(Fore);
      WriteLn(']rinter 16 cpi Control String:  │');
      Write('│    Current String = ');
      TextColor(fore_hi);
      Write(copy(cpi16 + '                    ',1,20));
      TextColor(fore);
      WriteLn('│');
      Write ('│ [');    TextColor(Fore_hi);
      Write ('S');      TextColor(Fore);
      WriteLn(']ave Configuration.                   │');
      Write ('│ [');    TextColor(Fore_hi);
      Write ('Q');      TextColor(Fore);
      WriteLn(']uit Back to the Main Menu.           │');
      Write ('╘═════════════════════════════════════════╛');
      Repeat { Until valid choice selected }
        Repeat Until KeyPressed;
        Read(kbd,chc);
        chc := UpCase(chc)
      Until pos(chc,'FHBRSPQ*') > 0;
      Window(20,14,80,24);
      GotoXY(1,1);
      ClrScr;
      Cursor(On);
      Case chc of
        'F' : Begin
                for i:=0 to 15 do
                  Begin
                    TextColor(i);
                    Write('███')
                  End; { for }
                TextColor(fore);
                WriteLn;
                WriteLn(' 0  1  2  3  4  5  6  7  8  9  A  B  C  D  E  F');
                Write(' Select New Foreground Color (0-F) ');
                Repeat
                  Repeat Until KeyPressed;
                  Read(kbd,c);
                  c := UpCase(c);
                  i := pos(c,'0123456789ABCDEF')
                Until i > 0;
                fore := i - 1;
                TextColor(fore)
              End; { Case 'F' }
        'H' : Begin
                for i := 0 to 15 do
                  Begin
                    TextColor(i);
                    Write('███')
                  End; { for }
                TextColor(fore);
                WriteLn;
                WriteLn(' 0  1  2  3  4  5  6  7  8  9  A  B  C  D  E  F');
                Write(' Select New Highlight Color (0-F) ');
                Repeat
                  Repeat Until KeyPressed;
                  Read(kbd,c);
                  c := UpCase(c);
                  i := pos(c,'0123456789ABCDEF')
                Until i > 0;
                fore_hi := i - 1
              End; { Case 'H' }
        'B' : Begin
                for i := 0 to 7 do
                  Begin
                    TextColor(i);
                    Write('███')
                  End; { for }
                TextColor(fore);
                WriteLn;
                WriteLn(' 0  1  2  3  4  5  6  7');
                Write(' Select New Background Color (0-7) ');
                Repeat
                  Repeat Until KeyPressed;
                  Read(kbd,c);
                  c := UpCase(c);
                  i := pos(c,'01234567')
                Until i > 0;
                back := i - 1;
                TextBackground(back);
                window(1,1,80,25);
                color(fore,back,bord)
              End;  { Case 'B' }
        'R' : Begin
                for i := 0 to 7 do
                  Begin
                    TextColor(i);
                    Write('███')
                  End; { for }
                TextColor(fore);
                WriteLn;
                WriteLn(' 0  1  2  3  4  5  6  7');
                Write(' Select New Border Color (0-7) ');
                Repeat
                  Repeat Until KeyPressed;
                  Read(kbd,c);
                  c := UpCase(c);
                  i := pos(c,'01234567')
                Until i > 0;
                bord := i - 1;
                port[$03d9] := bord
              End;  { Case 'R' }
        'S' : Begin
                Cursor(Off);
                Assign(ft,'dir4.cfg');
                ReWrite(ft);
                WriteLn(ft,fore);
                WriteLn(ft,back);
                WriteLn(ft,bord);
                WriteLn(ft,fore_hi);
                WriteLn(ft,cpi16);
                close(ft);
                Cursor(On)
              End;  { Case 'S' }
        'P' : Begin
                WriteLn('Enter the command string that places your printer into');
                WriteLn('condensed (16 cpi) mode. Use "{" for the Esc character');
                Write('and "^" for Ctrl. String ? ');
                ReadLn(cpi16);
                if pos('{',cpi16)>0 then cpi16[pos('{',cpi16)] := #27;
                i := pos('^',cpi16);
                if i > 0
                  then
                    Begin
                      cpi16[i + 1] := UpCase(cpi16[i + 1]);
                      if (ord(cpi16[i + 1]) -64 >= 0) and
                         (ord(cpi16[i + 1]) -64 <= 31)
                        then
                          Begin
                            cpi16[i + 1] := chr(ord(cpi16[i + 1]) - 64);
                            delete(cpi16,i,1)
                          End { if (ord ... }
                    End { if i ... }
              End       { Case 'P' }
         else           { Cases Q and * }
           done := True
      End               { Case of chc }
    Until Done;
    window(1,1,80,25)
  End;                  { Proc Configure }

Procedure Backup;
  var
    dir_dat : text;
    ft      : Str255;
    i       : integer;
    no_err  : boolean;

  Begin
    ClrScr;
    Cursor(Off);
    GotoXY(1,12);
    Repeat { until no_err }
      Write('Backup "DIR.DAT" onto which drive ("*" to quit) ? ');
      ReadLn(ft);
      if ft = '*' then Exit;
      UpperCase(ft);
      if copy(ft,length(ft),1) <> ':' then ft := ft + ':';
      Assign(dir_dat,ft + 'dir.dat');
      {$I- }
        ReWrite(dir_dat);
      {$I+ }
      no_err := (IOResult = 0);
      if not no_err
        then
          Begin
            WriteLn;
            WriteLn(^G,'An I/O error occurred. Drive "',ft,'" is probably incorrect. Please try again.');
            WriteLn
          End { if }
    Until no_err;
    ClrScr;
    GotoXY(20,12);
    TextColor(fore + blink);
    Write('Backing "DIR.DAT" to drive ',ft);
    for i := 1 to entries do
      Begin
        if files[i][1] <> ' ' then WriteLn(dir_dat,files[i])
      End; { for }
    close(dir_dat);
    TextColor(fore)
  End; { Proc BackUp }

Procedure Zap; { Deletes one or more files or a complete diskette }
  var
    i,j,k  : integer;
    c      : char;
    sx     : Str255;
    mark,
    done,
    zapped : boolean;

  Begin
    zapped := False;
    ClrScr;
    GotoXY(1,12);
    Write('Delete a ');
    TextColor(fore_hi + blink);
    Write('F');
    TextColor(fore);
    Write('ile, a ');
    TextColor (fore_hi + blink);
    Write('D');
    TextColor(fore);
    Write('isk, or ');
    TextColor (fore_hi + blink);
    Write('Q');
    TextColor(fore);
    Write('uit back to the Main Menu ? ');
    Repeat
      Repeat Until KeyPressed;
      Read(kbd,c);
      c := UpCase(c)
    Until pos(c,'FDQ*') > 0;
    Case c of
      'F' : Begin
              ClrScr;
              GotoXY(1,12);
              done := False;
              Repeat { Until done }
                mark := False;
                Write('File to delete ("*" to quit) ? ');
                ReadLn(sx);
                UpperCase(sx);
                if sx = '*' then done := True;
                if not done
                  then
                    for i := 1 to entries do
                      Begin
                        if pos(sx,files[i]) > 0
                          then
                            Begin
                              files[i][1] := ' ';
                              mark := True;
                              zapped := True
                            End { if }
                      End; { for i }
                if not mark
                  then
                    Begin
                      WriteLn;
                      WriteLn('File "',sx,'" wasn',#39,'t found.');
                      WriteLn
                    End { if not mark }
                  else
                    WriteLn
              Until done
            End; { Case F }
      'D' : Begin
              j := 0;
              done := False;
              ClrScr;
              GotoXY(1,12);
              done := False;
              Repeat { Until done }
                Write('Enter Disk # (1-9999) to Delete ("*" to Quit) ? ');
                ReadLn(sx);
                UpperCase(sx);
                if sx = '*'
                  then
                    done := True
                  else
                    Begin
                      Pad_Left(sx,'0',4) ;
                      mark := False;
                      j := 0;
                      for i := 1 to entries do
                        Begin
                          if sx = copy(files[i],13,4)
                          then
                            Begin
                              mark := True;
                              zapped := True;
                              files[i] := ' ';
                              j := j + 1
                            End { if }
                        End; { for i }
                      if mark
                        then
                          Begin
                            WriteLn;
                            WriteLn('Done. ',j,' files were deleted.')
                          End { if }
                        else
                          Begin
                            WriteLn;
                            WriteLn('Disk #',sx,' wasn',#39,'t found.')
                          End; { else }
                      WriteLn
                  End { else not done }
              Until done
            End { Case D }
    End; { Case of c }
    if zapped then Dump_Data_To_Disk
  End; { Proc Zap }

Procedure Strip_Z(var x : Str255); { Strip leading zeros }
  Begin
    while x[1] = '0' do delete(x,1,1)
  End; { Proc Strip_Z }

Procedure Find;
  Procedure Strip_S(var x : Str255); { Strips trailing spaces from a string }
    Begin
      while x[length(x)] = ' ' do delete(x,length(x),1)
    End; { Sub Proc Strip_S }

  var
    i,j              : integer;
    st,stmp,s        : Str255;
    done,found,mark  : boolean;

  Begin
    ClrScr;
    GotoXY(1,10);
    done := False;
    Repeat { Until done }
      Write('Enter File (or Partial) to Find ("*" to Quit) ? ');
      ReadLn(st);
      WriteLn;
      if st = '*'
        then
          done := True
        else
          Begin
            found := False;
            Repeat { Until found }
              UpperCase(st);
              mark := False;
              i := 0;
              Repeat { Until i >= entries OR Found }
                i := i + 1;
                if pos(st,copy(files[i],1,12)) > 0
                  then
                    Begin
                      mark := True;
                      stmp := copy(files[i],1,12);
                      Strip_S(stmp);
                      WriteLn(stmp,' may be found on Disk(s):');
                      s := copy(files[i],13,4);
                      Strip_Z(s);
                      i := i + 1;
                      Write(s,', ');
                      for j := i to entries do
                        Begin
                          if pos(stmp,files[j]) > 0
                            then
                              Begin
                                s := copy(files[j],13,4);
                                Strip_Z(s);
                                Write(s,', ');
                                i := i + 1
                              End { if }
                        End; { for j }
                      WriteLn;
                      WriteLn;
                      Write('Is this the file you wanted ? ');
                      Found := Yes;
                      WriteLn
                    End { if }
              Until (i >= entries) or Found;
              if not mark
                then
                  Begin
                    WriteLn;
                    WriteLn('"',st,'" wasn',#39,'t found.');
                    WriteLn;
                    found := True
                  End { if }
                else
                  Begin
                    if i >= entries
                      then
                        Begin
                          found := True;
                          WriteLn('No further incidences of "',st,'" were found.');
                          WriteLn
                        End { if }
                      else
                        WriteLn
                  End { else }
            Until Found
          End { else }
    Until done
  End; { Proc Find }

Procedure Print_List;
  Procedure Print_Prt;
    var
      i,page,pages   : integer;
      linestr,
      headerstr      : string[126];
      s,s1,ds,dys,ts : Str255;

    Begin{ Print_Prt - Prints 7 columns of 50 entries each }
      WriteLn;
      WriteLn;
      WriteLn('Position your printer to about ',#171,'" below the top perforation and press any');
      Write('key to start the printout ("*" to quit) ? ');
      Repeat Until Keypressed;
      Read(Kbd,ch);
      if ch = '*' then Exit;
      WriteLn;
      WriteLn;
      Write('Printing Data Record. Press any key to abort ....');
      Write(Lst,cpi16);
      pages := entries div 350 + 1;
      linestr :='';
      for i := 1 to 124 do linestr := linestr + '-';
      headerstr := '';
      for i := 1 to 7 do headerstr := headerstr + 'File        Disk  ';
      for page := 1 to pages do
        Begin
          WriteLn(Lst);
          TimDat(ts,ds,dys);
          WriteLn(Lst,'      DIR.DAT Listing as of ',dys,', ',ds,' @ ',ts,'.');
          WriteLn(Lst,'      Page ',page,' of ',pages,' Pages.');
          WriteLn(Lst,'      ',headerstr);
          WriteLn(Lst,'      ',linestr);
          for x:= (page - 1) * 350 to (page - 1) * 350 + 49 do
            Begin
              Write(Lst,'      ');
              y := 1;
              While y <= 350 do
                Begin
                  if KeyPressed
                    then
                      Exit
                    else
                      Begin
                        if (x + y) <= entries
                          then
                            Begin
                              if Sort_Flag
                                then
                                  Begin
                                    s := copy(files[x + y],1,4);
                                    Strip_Z(s);
                                    s1 := copy(files[x + y],5,12);
                                    s1 := copy(s1 + '    ',1,12);
                                    Write(Lst,s1,s:4,'  ')
                                  End { if Sort_Flag }
                                else
                                  Begin
                                    s := copy(files[x + y],13,4);
                                    Strip_Z(s);
                                    s1 := copy(files[x + y],1,12) + '    ';
                                    s1 := copy(s1,1,12);
                                    Write(Lst,s1,s:4,'  ')
                                  End { else if Sort_Flag }
                            End { if }
                      End; { else if KeyPressed }
                  y := y + 50
                End; { while y }
              WriteLn(Lst)
            End; { for x }
          WriteLn(Lst,'      ',linestr);
          for i := 1 to 10 do WriteLn(Lst)
        End; { for page }
      if KeyPressed then Read(Kbd,ch)
    End; { Sub Proc Print_Prt }

  Procedure Print_Crt;
    var
      i    : integer;
      s    : Str255;

    Begin{ Proc Print_Crt }
      ClrScr;
      GotoXY(1,1);
      i := 1;
      Repeat { Until c = * OR i > entries }
        if Sort_Flag
          then
            s := copy(files[i],1,4)
          else
            s := copy(files[i],13,4);
        Strip_Z(s);
        s := copy('    ' + s,length(s) + 1,4);
        if Sort_Flag
          then
            Write(s,' ',copy(files[i],5,12),'  ')
          else
            Write(s,' ',copy(files[i],1,12),'  ');
        Check_Pos;
        i := i + 1;
      Until (choice = '*') or (i > entries);
      choice := ' ';
      if i > entries then AtEnd;
      WriteLn
    End; { Sub Proc Print_Crt }

  var
    c : char;

  Begin{ Print_List Main }
    ClrScr;
    GotoXY(1,12);
    Write('Do you want the Data Record Sorted by Disk Number ? ');
    if Yes
      then
        Begin
          WriteLn;
          Sort_By_Num
        End; { if }
    WriteLn;
    Write('Dump the Data Record to the ');
    TextColor(fore_hi + blink);
    Write('C');
    TextColor(Fore);
    Write('RT, the ');
    TextColor(fore_hi + blink);
    Write('P');
    TextColor(fore);
    Write('rinter, or ');
    TextColor(fore_hi + blink);
    Write('Q');
    TextColor(fore);
    Write('uit ? ');
    Repeat
      Repeat Until KeyPressed;
      Read(kbd,c);
      c := UpCase(c)
    Until pos(c,'CPQ*') > 0;
    Case c of
      'C' : Print_Crt;
      'P' : Print_Prt
    End { Case of c }
  End; { Proc Print_List }

Procedure List_Records;
  Procedure List_Actual;
    Var target : Str255;

    Begin
      ClrScr;
      GotoXY(1,12);
      Write('Enter drive or path to be listed ("*" to quit) ? ');
      ReadLn(target);
      ClrScr;
      GotoXY(1,1);
      if target <> '*'
        then
          Begin
            Fix_Path(target);
            filepath := target;
            Reading := False;
            ClrScr;
            Get_File
          End { if target <> * }
    End; { Sub Proc List_Actual }

  Procedure List_Data;
    var i    : integer;
    target,s : Str255;

    Begin
      ClrScr;
      GotoXY(1,12);
      Write('Enter disk # (1-9999) to be listed ("*" to quit) ? ');
      ReadLn(target);
      UpperCase(target);
      ClrScr;
      GotoXY(1,1);
      if target <> '*'
        then
          Begin
            i := 1;
            Pad_Left(target,'0',4);
            Repeat { until i > entries or choice = * }
              if target = copy(files[i],13,4)
                then
                  Begin
                    s := copy(files[i],13,4);
                    Strip_Z(s);
                    Pad_Left(s,' ',4);
                    Write(s,' ',copy(files[i],1,12),'  ');
                    Check_Pos
                  End; { if target = }
              i := i + 1
            Until (i > entries) or (choice = '*');
            choice := ' ';
            if i > entries then AtEnd
          End { if target <> '*' }
    End; { Sub Proc List_Data }

  Begin{ Proc List_Records Main }
    ClrScr;
    GotoXY(1,12);
    Write('List an ');
    TextColor(fore_hi + blink);
    Write('A');
    TextColor(Fore);
    Write('ctual Disk Directory, the ');
    TextColor(fore_hi + blink);
    Write('D');
    TextColor(fore);
    Write('ata Record, or ');
    TextColor(fore_hi + blink);
    Write('Q');
    TextColor(fore);
    Write('uit ? ');
    Repeat
      Repeat Until KeyPressed;
      Read(kbd,ch);
      ch := UpCase(ch)
    Until pos(ch,'ADQ*') > 0;
    Case ch of
      'A' : List_Actual;
      'D' : List_Data
    End { Case of ch }
  End; { Proc List_Records }

Procedure Write_Label;
  var
    i,count    : integer;
    horiz_line,
    tmp_line,
    t_line     : string[74];
    target,
    tm,dt,dy   : Str255;

  Begin
    horiz_line := '+';
    for i := 1 to 72 do horiz_line := horiz_line + '-';
    horiz_line := horiz_line + '+';
    t_line := '|' + copy(horiz_line,2,72) + '|';
    ClrScr;
    GotoXY(1,12);
    Write('Write a Label for which disk (1-9999) - ("*" to quit) ? ');
    ReadLn(target);
    UpperCase(target);
    ClrScr;
    GotoXY(1,12);
    Write('Printing Label .....');
    if target <> '*'
      then
        Begin
          i := 1;
          Pad_Left(target,'0',4);
          TimDat(tm,dt,dy);
          WriteLn(Lst,cpi16,horiz_line);
          WriteLn(Lst,'| Disk #',target,'. ',dt,'                                                 |');
          WriteLn(Lst,t_line);
          count := 2;
          tmp_line := '| ';
          Repeat { until i > entries }
            if target = copy(files[i],13,4)
              then
                Begin
                  tmp_line := tmp_line + copy(files[i],1,12) + '  ';
                  if length(tmp_line) > 70
                    then
                      Begin
                        tmp_line := tmp_line + ' |';
                        WriteLn(Lst,tmp_line);
                        tmp_line := '| ';
                        count :=  count + 1
                      End { if length(tmp_line) }
                End; { if target }
            i := i + 1
          Until i > entries;
          while count < 26 do
            Begin
              while (length(tmp_line) < 72) do
                Begin
                  tmp_line := tmp_line + ' ';
                End; { while length }
              tmp_line := tmp_line + ' |';
              WriteLn(Lst,tmp_line);
              count := count + 1;
              tmp_line := '| '
            End; { while count }
          WriteLn(Lst,horiz_line);
          for i := 1 to 5 do WriteLn(Lst)
        End { if target }
  End; { Proc Write_Label }

Procedure Do_It; { Essentially the main loop }
  Begin
    Cursor(Off);
    Init;
    Read_Data_From_Disk;
    Repeat { Until Choice = Q or * }
      if Sort_Flag then Sort_By_Num;
      ClrScr;
      Cursor(Off);
      ShowMenu;
      Repeat { Until a valid choice is selected }
        Repeat Until KeyPressed;
        Read(kbd,choice);
        choice := UpCase(choice)
      Until pos(choice,'ABCDFLPQW*') > 0;
      Cursor(On);
      Case choice of
        'A' : Add;
        'B' : Backup;
        'C' : Configure;
        'D' : Zap;
        'F' : Find;
        'L' : List_Records;
        'P' : Print_List;
        'W' : Write_Label
      End { Case of Choice }
    Until (choice = 'Q') or (choice = '*');
    Set_Cursor(5,6)
  End; { Proc Do_It }

Begin       {     ╒═════════════════════════════════════════╕     }
  Do_It     {     │                  Main                   │     }
End.        {     ╘═════════════════════════════════════════╛     }