Path: utzoo!attcan!uunet!mcvax!hp4nl!dutrun!winfave
From: winfave@dutrun.UUCP (Alexander Verbraeck)
Newsgroups: comp.lang.pascal
Subject: Re: Reading a directory from Turbo.
Message-ID: <816@dutrun.UUCP>
Date: 25 Jul 89 23:11:29 GMT
References: <20336@adm.BRL.MIL>
Reply-To: winfave@dutrun.UUCP (A.Verbraeck)
Organization: Delft University of Technology, The Netherlands
Lines: 297

I got a number of e-mails asking for the sources for the directory
procedure. So: here it is!
Here are the Turbo Pascal version 3 and Turbo Pascal version 4 or 5 
sources for printing a directory.


TURBO 4 / 5 SOURCE
----------------------------------------------------------------------

procedure ViewDir(MatchPtrn : string[64]; FromLine : integer);

var
  DirInfo  : SearchRec;
  Line     ,
  Position : integer;

begin
  LowVideo;
  GotoXY(1,FromLine); ClrEos;
  Line:=FromLine; Position:=1;
  FindFirst(MatchPtrn,$37,DirInfo);
  if DosError<>0 then
    writeln('*** NO FILES FOUND ***')
  else
  while (DosError=0) and (Line<21) do
  begin
    GotoXY(Position,Line);
    if DirInfo.Attr=$10 then HighVideo;
    write(DirInfo.Name);
    LowVideo;
    Position:=Position+16;
    if Position>65 then
    begin
      Line:=Line+1;
      Position:=1;
    end;
    FindNext(DirInfo);
  end;
  NormVideo;
end;

----------------------------------------------------------------------


TURBO 3 SOURCE
----------------------------------------------------------------------

{ Source: TURBO Pascal Program Library
          Tom Rugg, Phil Feldman
          Que Corporation, 1986
          Indianapolis
          ISBN 0-88022-244-1
  Pages:  135 - 145
}

procedure ViewDir(MatchPtrn : string[64]; FromLine : integer);

type
  UserSpec   = string[64];
  Registers  = record
                 AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : integer;
               end;
  FileName   = string[13];
  DTAPointer = ^DTARecord;
  DTARecord  = record
                 DOSReserved : array[1..21] of byte;
                 Attribute   : byte;
                 FileTime    ,
                 FileDate    ,
                 SizeLow     ,
                 SizeHigh    : integer;
                 FoundName   : array[1..13] of char;
               end;

const
  NUL        = ^@;
  SeekAttrib = $16;

var
  TransferRec : DTAPointer;
  RetName     : FileName;
  FilSize     : Real;
  Count       : integer;
  NoFind      ,
  LastFile    ,
  SubDirec    : boolean;



procedure PointDTA(var DTARec : DTAPointer);

const
  GetDTA = $2F00;

var
  Regs : Registers;

begin
  Regs.AX := GetDTA;
  MsDos(Regs);
  DTARec := Ptr(Regs.ES,Regs.BX);
end;


function SizeOfFile(HiWord, LoWord : integer) : real;

var
  BigNo, Size : real;

begin
  BigNo := (MaxInt*2.0) + 2;
  if HiWord < 0 then
    Size := (BigNo+HiWord)*BigNo
  else
    Size := HiWord*BigNo;
  if LoWord >= 0 then
    Size := Size+LoWord
  else
    Size := Size+(BigNo+LoWord);
  SizeOfFile := Size;
end;



procedure FindFirst(Pattern:UserSpec; var Found:FileName; var Size:real;
                    var NoMatch:boolean; var LastOne:boolean;
                    var SubDir:boolean);

const
  FindFirst   = $4E00;

type
  ASCIIZ      = array[1..64] of char;

var
  FileSpec : ASCIIZ;
  Regs     : Registers;
  PosInStr ,
  Count    : integer;
  FoundLen : byte absolute Found;

begin
  for PosInStr:=1 to length(Pattern) do
    FileSpec[PosInStr] := Pattern[PosInStr];
  FileSpec[length(Pattern)+1] := NUL;
  with Regs do
  begin
    DS := Seg(FileSpec);
    DX := Ofs(FileSpec);
    CX := SeekAttrib;
    AX := FindFirst;
    MsDos(Regs);
    if (Flags and 1) > 0 then
    begin
      case AX of
        2 : begin  { No match }
              NoMatch := true;
              LastOne := true;
            end;
       18 : begin  { No more files }
              NoMatch := false;
              LastOne := true;
            end;
      else
        Fout('Can''t interpret error return code');
        Exit
      end;  { case }
    end
    else
    begin  { No error return code }
      NoMatch := false;
      LastOne := false;
    end;
  end;  { with Regs }

  if (not NoMatch) then
  with TransferRec^ do
  begin
    Found := FoundName;
    Count := 0;
    while Found[Count] <> NUL do Count := Count+1;
    FoundLen := Count;
    for Count := Length(Found)+1 to 13 do Found := Found+' ';
    if (Attribute and SeekAttrib) <> 0 then
      SubDir := true
    else
      SubDir := false;
    if not SubDir then
      Size := SizeOfFile(SizeHigh,SizeLow)
    else
      Size := 0.0;
  end;  { with TransferRec }
end;



procedure FindNext(var Found:FileName; var Size:real;
                   var LastOne:boolean; var SubDir:boolean);

const
  FindNext   = $4F00;

var
  Regs     : Registers;
  Count    : integer;
  FoundLen : byte absolute Found;

begin
  with Regs do
  begin
    AX := FindNext;
    MsDos(Regs);
    if (Flags and 1) > 0 then
    begin
      if AX=18 then LastOne := true
      else
      begin
        writeln(^G'Can''t interpret error return code');
        Halt;
      end;
    end
    else LastOne:=false;
  end;  { with Regs }

  with TransferRec^ do
  begin
    Found := FoundName;
    Count := 0;
    while Found[Count] <> NUL do Count := Count+1;
    FoundLen := Count;
    for Count := Length(Found)+1 to 13 do Found := Found+' ';
    if (Attribute and SeekAttrib) <> 0 then
      SubDir := true
    else
      SubDir := false;
    if not SubDir then
      Size := SizeOfFile(SizeHigh,SizeLow)
    else
      Size := 0.0;
  end;  { with TransferRec }
end;


{ Start of ViewDir }

begin
  GotoXY(1,FromLine); ClrEos;
  NormVideo;
  Count:=0;
  PointDTA(TransferRec);
  FindFirst(MatchPtrn,RetName,FilSize,NoFind,LastFile,SubDirec);
  if NoFind or LastFile then
    writeln('*** NO FILES FOUND ***')
  else
  begin
    while not LastFile do
    begin
      if SubDirec then LowVideo;
      if Pos('.',RetName)=0 then write(RetName,'  ') else
        write(copy(copy(RetName,1,Pos('.',RetName)-1)+'        ',1,8),
              copy(RetName,Pos('.',RetName),4),'  ');
      Count:=Count+1;
      NormVideo;
      if (Count mod 5) = 0 then writeln;
      FindNext(RetName,FilSize,LastFile,SubDirec);
    end;
  end;
  LowVideo;
end;

----------------------------------------------------------------------


Call of procedure ViewDir :

----------------------------------------------------------------------

begin
  { ... }
  GotoXY(1,7);
  writeln('PRN FILES IN DIRECTORY \TMP: : ');
  ViewDir('\TMP\*.PRN',9);
  { ... }
end;

----------------------------------------------------------------------


If you have any questions, please ask.
Sincerely,

---------------------------------------------------------------------
Alexander Verbraeck                            e-mail:
Delft University of Technology                 winfave@hdetud1.bitnet
Department of Information Systems              winfave@dutrun.uucp
PO Box 356, 2600 AJ  The Netherlands
---------------------------------------------------------------------