Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/LSTDIR.ZIP/LSTDIR.PAS

Pascal/Delphi Source File | 1987-10-22 | 16.7 KB | 552 lines

  { This Procedure performs a disk directory, searching for a given
    File Mask, displaying them alphabetically in a window (in multiple
    pages if necessary) and restoring the screen when you have either
    hit return or escape (return sets the filemask to the filename
    currently selected, escape returns a null string). The function
    restores the screen, so it can be called from any program without
    the trouble of redrawing the screen (unless you have already accessed
    the second display page in your program, then you will have to change
    the Screen2 variable below to point to the third or fourth screen).
    It doesn't save the screen colors, so you will have to reset those
    when the procedure returns. }

  { The core procedures were taken from a file I previously took down
    from Compuserve.  Unfortunately the contributor didn't include his
    name in the source so I cannot give full credit. }

  { I have included several routines I use frequently which others
    may also find useful.  They are a DrawBox procedure and
    EnableCursor and DisableCursor procedures.    DrawBox may be redundant
    with your favored box routine so replace it if you wish.  It is
    only called once.  The other two, I am told, can yield strange
    results so you may want to stub them out.  I have tested them on
    an EGA, a CGA, and an AT&T and have seen no adverse effects
    so I will leave that decision up to the users.  I think disabling
    the cursor makes the screen much neater.  }

TYPE  s80      = String[80];
      s14      = String[14];
      FilePtr     = ^FileRec;
      FileRec     = record
                Name : s14;
                Next,
                Prev : FilePtr;
               end;
      Registers   = Record Case Integer Of
                1: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer);
                2: (al,ah,bl,bh,cl,ch,dl,dh: Byte);
                 End;
      FCB_Layout  = record
                Drive            : byte;
                FileName    : Array[1..8] of char;
                FileExt     : Array[1..3] of char;
                CurBlock    : integer;
                RecSize     : integer;
                FSizeLow    : integer;
                FSizeHigh        : integer;
                CreateDate       : integer;
                CreateTime       : integer;
                Flags            : byte;
                DiskAddr1st      : integer;
                DiskAddrLst      : integer;
                LastAccess       : Array [1..3] of byte;
                NextRecord       : byte;
                RelRecLow        : integer;
                RelRecHigh       : integer;
               end;

VAR TestFileName : s14;   { For testing purposes }

PROCEDURE  DrawBox (LeftX, TopY, RightX, BottomY, LinesTop, LinesLeft,
              LinesRight, LinesBottom : Integer);

  TYPE     Segtype   = Array [0..1,1..2] of Char;
      Crnrtype  = Array [1..2,1..2,1..2,1..2] of Char;

  CONST  Horiz    = 0;
      Vert        = 1;
      Top    = 1;
      Left        = 1;
      Bottom    = 2;
      Right       = 2;
      Segment   : SegType  = ((#196,#205),(#179,#186));
      Corner    : CrnrType = ((((#218,#191),(#192,#217)),
                      ((#213,#184),(#212,#190))),
                     (((#214,#183),(#211,#189)),
                      ((#201,#187),(#200,#188))));

   VAR    I : Integer;

   BEGIN
     GotoXY(LeftX,TopY);
     Write(Corner[LinesLeft, LinesTop, Top, Left]);
     For I := (LeftX + 1) to (RightX - 1) do
     Write(Segment[Horiz, LinesTop]);
     Write(Corner[LinesRight, LinesTop, Top, Right]);
     For I := (TopY + 1) to (BottomY - 1) do
     Begin
       GotoXY(LeftX,I);  Write(Segment[Vert, Linesleft]);
       GotoXY(RightX,I); Write(Segment[Vert, LinesRight]);
     End;
     GotoXY(LeftX,BottomY);
     Write(Corner[LinesLeft, LinesBottom, Bottom, Left]);
     For I := (LeftX + 1) to (RightX - 1) do
     Write(Segment[Horiz, LinesBottom]);
     Write(Corner[LinesRight, LinesBottom, Bottom, Right]);
   END; {DrawBox}

PROCEDURE EnableCursor;    { Stub out these procedures if you do not     }
 var rb : registers;       { want the cursor to disappear.  This may     }
 Begin                     { be especially important if you are          }
  With rb do begin         { going to be distributing your program       }
    ax:=$0100;             { to machines with unknown display adapters,  }
    cx:=$0607;             { in which case you may have to either        }
  end;                     { provide multiple versions, or write         }
  Intr(16,rb);             { something to find out what kind of display  }
 End;                      { you've got attached, or use a flag in the   }
                           { environment.                                }

PROCEDURE DisableCursor;   { cx is set for the start and stop scan lines }
 var rb : registers;       { for the cursor: Enable starts at line 6 and }
 Begin                     { ends at line 7.  Disable puts both lines    }
  With rb do begin         { outside of the limits - unless you have     }
    ax:=$0100;             { something like an AT&T, which has more      }
    cx:=$0909;             { than 10 scan lines.  Be sure that each      }
  end;                     { byte is less than $10, however, or          }
  Intr(16,rb);             { unpredictable results will occur. ($0F max) }
 End;

PROCEDURE ListCatalog(var FileMask : s14);

Var   DirMask     : String[80];
      MarkFile,
      FirstFile,
      CurrFile    : FilePtr;
      PageOfs,
      Col,
      NamesInCol,
      FirstEntryInCol,
      TotFiles,
      Error,
      No,
      I        : integer;
      Screen1     : Array[1..80,1..25,1..2] of Integer absolute $B800:0000;
      Screen2     : Array[1..80,1..25,1..2] of Integer absolute $B900:0000;
      KeyStroke   : Char;
      X,Y,Z         : Integer;
      RegBlock    : Registers;

PROCEDURE SetDTA(MEMSeg,MEMOff:Integer;var Err:Integer );
   var
      DOSRegs  :   Registers;
   begin
      With DOSRegs do
       begin
      Err   := 0;           { Assume No Error }
      ah := $1A;            { Function used to set the DTA }
      DS := MEMSeg;         { store the parameter Segment in DS }
      DX := MEMOff;         {   "    "      "     Offset in DX }
      MSDos( DOSRegs );
      If (Flags And 1) = 1 then
        Err := al;
     end;
   end;

PROCEDURE GetDTA(var MEMSeg,MEMOff:Integer; var Err : Integer );
   var
      DOSRegs  :   Registers;
   begin
      With DOSRegs do
       begin
      ah := $2F;             { Function used to get current DTA address }
      MSDos( DOSRegs );
      MEMSeg := ES;          { Segment of DTA returned by DOS }
      MEMOff := BX;          { Offset of DTA returned }
      If (Flags and 1)=1 then
        Err := al;
       end;
   end;

PROCEDURE GetFirstFile( Mask : s80; var NamR : s80;
              MEMSeg, MEMOff : Integer; Option : Integer;
              var Err : Integer );
   var
      DOSRegs  :   Registers;
      I : Integer;
   begin
      With DOSRegs do
     begin
       Err := 0;
       ah := $4E;             { Get first directory entry }
       DS := Seg( Mask );     { Point to the file Mask }
       DX := Ofs( Mask )+1;
       CX := Option;          { Store the Option }
       MSDos( DOSRegs );
       If (Flags and 1)=1 then
         Err := al;
     end;
      I := 1;
      repeat
     NamR[I] := Chr(mem[MEMSeg:MEMOff+29+I]);
     I := I + 1;
      until ( not (NamR[I-1] in [' '..'~']));
      NamR[0] := Chr(I-1);
   end;

PROCEDURE GetNextFile( var NamR : s80; MEMSeg, MEMOff : Integer;
               Option : Integer; var Err : Integer );
   var
      DOSRegs  :   Registers;
      I : Integer;
   begin
     With DOSRegs do
      begin
     Err := 0;
     ah := $4F;            { Function used to get the next }
                           { directory entry }
     CX := Option;         { Set the file option }
     MSDos( DOSRegs );
     If (Flags and 1)=1 then
       Err := al;
      end;
     I := 1;
     repeat
       NamR[ I ] := Chr( mem[ MEMSeg : MEMOff + 29 + I ] );
       I := I + 1;
     until ( not ( NamR[ I - 1 ] in [ ' '..'~' ] ));
     NamR[ 0 ] := Chr( I - 1 );
   end;

FUNCTION WildStrComp(S,A:s80):boolean;
   { this function compares two strings, string A can contain '?' }
   { which match anything.                          }
   Var
      I,J    :  Integer;
      Done,
      Match  :  boolean;

   begin
      Match:=true;
      I:=1;
      J:=Length(A);
      Done:=false;
      If Length(A)<>Length(S) then
     Match:=false
      Else
     begin
        While Match and not Done do
          begin
            If ( I > J ) then Done:=true
            Else
            If A[I]<>'?' then
            If UpCase(A[I])<>UpCase(S[I]) then
              Match:=false;
            If Match then
           I:=I+1;
          end;
     end;
      WildStrComp:=Match;
   end;

FUNCTION FileNameScan(S:s14):s14;
   var
     T      : FCB_Layout;
     i      : integer;
     Regs : Registers;
   begin
      S:=S+Chr(0);
      with Regs do
     begin
       ah:=$29;
       al:=0;
       DS:=Seg(S);
       SI:=Ofs(S)+1;
       ES:=Seg(T);
       DI:=Ofs(T);
     end;
      with T do
     begin
       for i:=1 to 8 do
         FileName[i]:=' ';
       for i:=1 to 3 do
         FileExt[i]:=' ';
     end;
      MsDos(Regs);
      with T do
     begin
       for i:=1 to 8 do
         S[i]:=FileName[i];
       S[9]:='.';
       for i:=1 to 3 do
         S[9+i]:=FileExt[i];
       S[0]:=Chr(12);
     end;
      FileNameScan:=S;
   end;

PROCEDURE FileMaskScan(var S:s14);
   begin
      S:=FileNameScan(S);
   end;

PROCEDURE SearchDir(DirMask:s80; var FileMask:s14; var Option:Integer);
  Var
     SaveDTASeg,
     SaveDTAOfs,
     FileCount,
     Attr,
     Error     :   Integer;
     Dir       :   boolean;
     DirCur,
     DTABuffer,
     FileName  :   s80;
     FileSize,
     Total     :   Real;
     PrevFile,
     NewFile   :   FilePtr;
  begin
    DirCur:=DirMask+'*.*'+Chr(0);
    GetDTA(SaveDTASeg,SaveDTAOfs,Error);
    SetDTA(Seg(DTABuffer),Ofs(DTABuffer),Error);
    GetFirstFile(DirCur,FileName,Seg(DTABuffer),Ofs(DTABuffer),Option,Error);
    Total:=0.0;
    FileCount:=0;
    FirstFile := Nil;

    repeat
      If WildStrComp(FileNameScan(Copy(FileName,1,Length(FileName)-1)), FileMask)
     and (FileName[1] <> #229) and (FileName[1] <> '.') and (Error = 0) then
       begin
         FileCount:=FileCount+1;
         New(NewFile);
         NewFile^.Name := FileName;
         NewFile^.Next := Nil;
         NewFile^.Prev := Nil;
         If FirstFile = Nil then
           begin
          FirstFile := NewFile;
          MarkFile := NewFile;
           end
          else
           begin
          CurrFile := FirstFile;
          While (CurrFile^.Next <> Nil) and
                (CurrFile^.Name < NewFile^.Name) do
                 CurrFile := CurrFile^.Next;
          If CurrFile^.Name < NewFile^.Name then
            begin
              CurrFile^.Next := NewFile;
              NewFile^.Prev := CurrFile;
              NewFile^.Next := Nil;
            end
           else
            begin
              If CurrFile^.Prev <> Nil then
                begin
               PrevFile := CurrFile^.Prev;
               PrevFile^.Next := NewFile;
               NewFile^.Prev := PrevFile;
                end
               else
                begin
               NewFile^.Prev := Nil;
               FirstFile := NewFile;
                end;
              CurrFile^.Prev := NewFile;
              NewFile^.Next := CurrFile;
            end;
           end;
       end;
      GetNextFile(FileName,Seg(DTABuffer),Ofs(DTABuffer),Option,Error);
    Until Error <> 0;

    SetDTA(SaveDTASeg,SaveDTAOfs,Error);
    TotFiles := FileCount;
  end;

PROCEDURE SaveScreen;
  begin
    Move(Screen1,Screen2,4000);
  end;

PROCEDURE RestoreScreen;
  begin
    Move(Screen2,Screen1,4000);
  end;

PROCEDURE Beep;
  begin
    Sound(440);
    Delay(100);
    NoSound;
  end;

PROCEDURE DispFileNames(PgOffset : Integer);
  begin
    ClrScr;
    Write('  Files for directory ',DirMask);
    If TotFiles > 60+PgOffset then Write('    PgDn for More');
    X := 1+PgOffset;
    FirstEntryInCol := 1+PgOffset;
    Col := 2;
    CurrFile := FirstFile;
    For i := 1 to PgOffset do
      CurrFile := CurrFile^.Next;
    While (X <= TotFiles) and (X <= PgOffset+60) do
      begin
     While (X <= FirstEntryInCol+NamesInCol-1) and (X <= TotFiles) do
       begin
         GotoXY(Col, X-FirstEntryInCol+3);
         Write(' ',CurrFile^.Name);
         CurrFile := CurrFile^.Next;
         X := X + 1;
       end;
     FirstEntryInCol := FirstEntryInCol + NamesInCol;
     Col := Col + 15;
      end;
    X := 1+PgOffset;
    Col := 2;
    FirstEntryInCol := 1+PgOffset;
    CurrFile := FirstFile;
    For i := 1 to PgOffset do
      CurrFile := CurrFile^.Next;
  end;

BEGIN      { ListCatalog PROCEDURE }
  SaveScreen;
  GetDir(0,DirMask);
  If DirMask[Length(DirMask)] <> '\' then DirMask := DirMask + '\';
  I := 16;

  FileMaskScan(FileMask);
  SearchDir(DirMask,FileMask,I);

  If TotFiles <= 60 then
    begin
      NamesInCol := (TotFiles div 4);
      If NamesInCol*4 < TotFiles then
     NamesInCol := NamesInCol + 1;
    end
   else
    NamesInCol := 15;
  TextColor(White);
  TextBackground(Blue);
  DrawBox(8,5,71,9+NamesInCol,1,1,1,1);
  Window(9,6,70,8+NamesInCol);
  TextColor(Black);
  TextBackground(LightGray);

  PageOfs := 0;
  DispFileNames(PageOfs);
  DisableCursor;
  Repeat
    GotoXY(Col, X-FirstEntryInCol+3);
    TextColor(White);TextBackground(Blue);
    Write(' ',CurrFile^.Name,'':13-Length(CurrFile^.Name));
    Read(KBD,KeyStroke);
    If (KeyStroke = #27) and KeyPressed then
      begin
     Read(KBD,KeyStroke);
     GotoXY(Col, X-FirstEntryInCol+3);
     TextColor(Black);TextBackground(LightGray);
     Write(' ',CurrFile^.Name,'':13-Length(CurrFile^.Name));
     case KeyStroke of

       #72 : begin  { Up }
            If X = 1 then
              Beep
             else
              begin
                If X = FirstEntryInCol then
               begin
                 FirstEntryInCol := FirstEntryInCol - NamesInCol;
                 Col := Col - 15;
               end;
                X := X - 1;
                CurrFile := CurrFile^.Prev;
              end
          end;

       #80 : begin  { Down }
            If (X = TotFiles) or (X = PageOfs+60) then
              Beep
             else
              begin
                If X = FirstEntryInCol + NamesInCol-1 then
               begin
                 FirstEntryInCol := FirstEntryInCol + NamesInCol;
                 Col := Col + 15;
               end;
                X := X + 1;
                CurrFile := CurrFile^.Next;
              end;
          end;

       #73 : begin  { PgUp }
            If PageOfs > 0 then
               begin
                 PageOfs := PageOfs - 60;
                 DispFileNames(PageOfs);
               end
              else
               Beep;
          end;

       #81 : begin  { PgDown }
            If PageOfs < (TotFiles-60) then
               begin
                 PageOfs := PageOfs + 60;
                 DispFileNames(PageOfs);
               end
              else
               Beep;
          end;

       #75 : begin  { Left Arrow }
            If (X <= NamesInCol+PageOfs)     then
              Beep
             else
              begin
                FirstEntryInCol := FirstEntryInCol - NamesInCol;
                Col := Col - 15;
                X := X - NamesInCol;
                For i := 1 to NamesInCol do
               CurrFile := CurrFile^.Prev;
              end;
          end;

       #77 : begin  { Right Arrow }
            If (X + NamesInCol > TotFiles) or (X + NamesInCol > PageOfs+60) then
              Beep
             else
              begin
                FirstEntryInCol := FirstEntryInCol + NamesInCol;
                Col := Col + 15;
                X := X + NamesInCol;
                For i := 1 to NamesInCol do
               CurrFile := CurrFile^.Next;
              end;
          end;

        else Beep

      end; { case }
      end;
  Until KeyStroke in [#13,#27];
  EnableCursor;
  Window(1,1,80,25);
  RestoreScreen;
  If KeyStroke = #13 then FileMask := CurrFile^.Name
    else FileMask := ' ';
  Mark(MarkFile);
  Release(MarkFile);
END;

BEGIN   { for testing purposes }
  TestFileName := '*.*';
  ListCatalog(TestFileName);
  ClrScr;
  Writeln(TestFileName);
END.