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

Pascal/Delphi Source File | 1989-03-20 | 13.4 KB | 342 lines

program TreeList;

(* The following program performs a systematic location of all sub-     *)
(* directories, and displays a Tree-like relationship between the files *)
(* and the subdirectories.                                              *)
(*                                                                      *)
(* A few things are assumed, but may be changed, such as: The maximum   *)
(* number of files in a directory is 128, the deepest level of nested   *)
(* subdirectories is 8, and the maximum number of subdirectories in a   *)
(* single directory is 24.  All of these may be moved up or down, as    *)
(* may be required.                                                     *)
(*                                                                      *)
(* The program as it is written requires the usage of Turbo Pascal 3.0  *)
(* and the SORT.BOX file in the Turbo Toolbox.  The main reasons for    *)
(* using these two are the inclusion of Directory routines and Command  *)
(* line parameter routines in version 3.0 of Turbo Pascal.  Also, the   *)
(* Sort routine in the Turbo Toolbox is indeed a gem.                   *)
(*                                                                      *)
(* The program Syntax is as follows:                                    *)
(*                                                                      *)
(*    TreeList [/P][/F][/L]  where P will print the output              *)
(*                                 F will list Files with the SubDir's  *)
(*                                 L will list Files in long form       *)
(*                                                                      *)
(* As the author of this program and many others, I would like to thank *)
(* Borland International for a truly great Pascal Compiler and for the  *)
(* guts to buck the tide of high price ripoffs.                         *)
(*                                                                      *)
(* This program is hereby donated to the Public Domain, it may be       *)
(* copied, and distributed as you wish, as long as this section of the  *)
(* code is not removed or changed.                                      *)
(*                                                                      *)
(* If you use this program and feel that it has in some way made your   *)
(* time more valuable, a small donation may be made to:                 *)
(*                                                                      *)
(*        David W. Terry                                                *)
(*        3036 Putnam Ct.                                               *)
(*        West Valley City, UT 84120                                    *)
(*                                                                      *)
(*  Copyright (C) 1985  David W. Terry                                  *)

{$C-}
type
  str2  = string[2];
  str6  = string[6];
  str9  = string[9];
  str12 = string[12];
  str15 = string[15];
  pathtype = string[62];
  FileType = record
               Name: str12;
               Attrib: byte;
               Size: real;
               Date,Time: str9;
               end;
  ListType = array[1..128] of FileType;
  Dirtype  = array[1..8] of record
               Total: byte;
               Name: array[1..24] of PathType;
               end;
  regpack  = record
               ax,bx,cx,dx,bp,si,di,ds,es,flags:integer
               end;
var
  List,SortedList: ListType;
  DirList: DirType;
  DirPos,DirTotal: array[1..10] of byte;
  Path: pathtype;
  Total,Counter,DirLevel: byte;
  recpack: regpack;
  Dircty,DiskLabel,PrnLabel,Prt,Long,ShowFiles: boolean;
  Spacer,Tail,LongStr: string[80];

(*-------  Sort procedures for sorting the directories  ----------------*)

{$I sort.box}

procedure InP;  { Forward Declared in SORT.BOX }
begin
  for Counter:=1 to Total do
    SortRelease(List[Counter]);
  end;  { inp }

function Less;  { Forward Declared in SORT.BOX }
var
  FirstFile:  FileType absolute X;
  SecondFile: FileType absolute Y;

begin
  Less:=FirstFile.Name<SecondFile.Name;
  end;  { less }

procedure OutP;  { Forward Declared in SORT.BOX }
begin
  for Counter:=1 to Total do
    SortReturn(SortedList[Counter]);
  end;  { outp }

(*----------------------------------------------------------------------*)

(*----------  Procedure to Read the Directory  -------------------------*)

procedure Directory(FileMask: str15; var List: ListType; var Total: byte);
var Dta: string[44];

function FileSize: real;           { decypher the File's Size in Bytes }
var Size: real;
    Byte1,Byte2,Byte3,Byte4: byte;
begin
  Byte1:=ord(copy(DTA,28,1));
  Byte2:=ord(copy(DTA,27,1));
  Byte3:=ord(copy(DTA,29,1));
  Byte4:=ord(copy(DTA,30,1));
  Size:=Byte1 shl 8+Byte2;
  if Size<0 then Size:=Size+65536.0;   { adjust for negative values }
  Size:=(Byte3 shl 8+Byte4)*256.0+Size;
  FileSize:=Size;
  end;  { filesize }

function FileDate: str9;         { decypher the File's Date Stamp }
var Day,Month,Year: str2;
    Temp: integer;
    Byte1,Byte2: byte;
begin
  Byte1:=ord(copy(DTA,25,1));
  Byte2:=ord(copy(DTA,26,1));
  str(Byte1 and 31:2,Day);
  Temp:=(Byte1 shr 5) and 7+(Byte2 and 1) shl 3;
  str(Temp:2,Month);
  str((Byte2 shr 1)+80:2,Year);
  if Day[1]=' ' then Day[1]:='0';
  if Year[1]=' ' then Year[1]:='0';
  FileDate:=Month+'-'+Day+'-'+Year;
  end;  { filedate }

function FileTime: str6;            { decypher the File's Time Stamp }
var Hour,Min: str2;
    Temp: integer;
    AmPm: char;
    Byte1,Byte2: byte;
begin
  Byte1:=ord(copy(DTA,23,1));
  Byte2:=ord(copy(DTA,24,1));
  Temp:=(Byte1 shr 5) and 7+(Byte2 and 7) shl 3;
  str(Temp:2,Min);
  Temp:=Byte2 shr 3;
  if Temp<13 then AmPm:='a' else begin
    Temp:=Temp-12;
    AmPm:='p';
    end;
  str(Temp:2,Hour);
  if Min[1]=' ' then Min[1]:='0';
  FileTime:=Hour+':'+Min+AmPm;
  end;  { filetime }

procedure FillRecord(RecNo: byte);        { fill List.[RecNo] with file info }
begin
  with List[RecNo] do begin
    Name:=copy(DTA,31,13);
    Attrib:=ord(copy(DTA,22,1));
    Size:=FileSize;                       { Fill names shorter than 8 chars }
    Date:=FileDate;                       { with spaces }
    Time:=FileTime;
    if (Name[1]<>'.') and (pos('.',Name)<>0) then begin
      while pos('.',Name)<9 do insert(' ',Name,pos('.',Name));
      end;
    end;
  fillchar(Dta[31],12,' ');      { clear name to prepare for next call $4F }
  end;  { fillrecord }

procedure FillDirList;
begin
  Total:=1;
  FillRecord(Total);
  repeat                         { Dos call $4F is used to find the next }
    recpack.Ax:=$4f shl 8;       { matching file, in this case all files }
    MsDos(recpack);
    if (recpack.Ax<>18) and (recpack.Ax<>2) then begin
      Total:=Total+1;
      FillRecord(Total);
      end;                              { repeat filling until no more files }
    until (recpack.flags and 1)<>0;
  end;  { filldirlist }

begin  { Directory }
  Total:=0;
  FileMask:=FileMask+#0;
  fillchar(DTA[1],44,' '); DTA[0]:=#44;
  with recpack do begin                        { First, Set aside the DTA    }
    Ax:=$1a shl 8;                             { or Data Transfer Area,      }
    Ds:=Seg(Dta); Dx:=Ofs(Dta)+1;              { call $1A then call $4E to   }
    MsDos(recpack);                            { find the First Match. Set   }
    Ax:=$4e shl 8;                             { set Cx to 31 to include all }
    Ds:=Seg(FileMask); Dx:=Ofs(FileMask)+1;    { hidden files. Then up above }
    Cx:=31;                                    { call $4F to find subsequent }
    MsDos(recpack);                            { matches, filling List.      }
    if (flags and 1)=0 then FillDirList;
    end;
  end;  { directory }

(*----------------------------------------------------------------------*)

(*---------------  MsDos functions that Borland left out  --------------*)

function CurrentDrive: byte;     { returns the number of the current drive }
begin                            { default as follows:  1=A, 2=B, 3=C      }
  with Recpack do begin
    Ax:=$19 shl 8;
    MsDos(Recpack);
    CurrentDrive:=lo(Ax)+1;
    end;
  end;  { currentpath }

function CurrentPath: pathtype;  { returns the current Default Path }
var DirStr: pathtype;
begin
  GetDir(CurrentDrive,DirStr);
  CurrentPath:=DirStr;
  end;  { currentpath }

(*----------------------------------------------------------------------*)

(*--------  The main routines for finding and reading directories  -----*)

procedure FindDirs;
var P: pathtype;
begin
  P:=CurrentPath; if length(P)>3 then P:=P+'\';
  DirTotal[DirLevel]:=0;
  for Counter:=1 to Total do                { this routine mostly does the   }
    with SortedList[Counter] do begin       { work of picking out DIR's from }
      DiskLabel:=((Attrib and  8)= 8);      { the main list and storing them }
      Dircty:=   ((Attrib and 16)=16);      { in the DIRLIST array along     }
      if DiskLabel and PrnLabel then begin  { with Total # of SubDIR's       }
        TextColor(LightRed);
        if pos('.',Name)<>0 then delete(Name,pos('.',Name),1);
        writeln('Label for the Disk in Drive ',chr(CurrentDrive+64),': is ',Name);
        if prt then writeln(lst,'Label for the Disk in Drive ',chr(CurrentDrive+64),': is ',Name);
        end;
      if Dircty and (Name[1]<>'.') then begin
        DirTotal[DirLevel]:=DirTotal[DirLevel]+1;
        DirList[DirLevel].Name[DirTotal[DirLevel]]:=P+Name;
        end;
      end;
   end;  { finddirs }

procedure FillerUp;
begin
  Directory('*.*',List,Total);                 { This routine calls Directory }
  if TurboSort(Sizeof(FileType))<>0 then begin { to fill LIST with a list of  }
    writeln('Internal Error, Aborting!');      { files in the Directory. Then }
    halt                                       { then FindDirs picks out the  }
    end;                                       { subdirectories.              }
  FindDirs;
  end;  { fillerup }

procedure Progress;
begin
  if DirPos[DirLevel]<=DirTotal[DirLevel] then begin
    ChDir(DirList[DirLevel].Name[DirPos[DirLevel]]);
    DirPos[DirLevel]:=DirPos[DirLevel]+1;
    DirLevel:=DirLevel+1; DirPos[DirLevel]:=1;
    FillerUp;
  end else begin                     { This routine is Recursive, and looks }
    DirLevel:=DirLevel-1;            { a little complicated, but it simply  }
    if DirLevel>0 then Progress;     { keeps track of the current DIR level }
    end;                             { and Position in the Directory.       }
  end;  { progress }

(*----------------------------------------------------------------------*)

(*----------------------  The Main Program  ----------------------------*)

begin
  ClrScr; TextColor(White);
  writeln('Tree Listing of Subdirectories and Files');
  writeln;
  if ParamCount=0 then begin
      TextColor(LightCyan);
      writeln('Copyright (C) 1985 by David W. Terry');
      writeln;
      writeln('Program Syntax is as follows:  TREELIST [/P][/F][/L]');
      writeln;
      writeln('   where P = Print Output on Printer');
      writeln('         F = List Files along with Subdirectories');
      writeln('         L = Show Long Form list of Files');
      writeln;
      writeln('NOTE: Subdirectories are indented from their parents.');
      writeln('      Also, the Long form indicates file attributes of');
      writeln('      Normal, Hidden, System, Read Only, and Archive by');
      writeln('      marking them with  N,H,S,R,A  respectively');
      writeln;
      Prt:=False; Long:=False; ShowFiles:=False;
    end else begin
      Prt:=      (pos('/P',ParamStr(1))<>0) or (pos('/p',ParamStr(1))<>0);
      ShowFiles:=(pos('/F',ParamStr(1))<>0) or (pos('/f',ParamStr(1))<>0);
      Long:=     (pos('/L',ParamStr(1))<>0) or (pos('/l',ParamStr(1))<>0);
      if Long then ShowFiles:=True;
      end;
  Path:=CurrentPath; ChDir('\');
  TextColor(White); fillchar(Spacer[1],80,32);
  DirLevel:=1; DirTotal[DirLevel]:=1; DirPos[DirLevel]:=1;
  DirList[1].Name[1]:='\';
  PrnLabel:=True; FillerUp; PrnLabel:=False;
  repeat
    TextColor(LightGreen);
    Spacer[0]:=chr((DirLevel-1)*4);
    writeln;
    writeln(Spacer,'[',CurrentPath,']',' Files in Directory are:');
    TextColor(Yellow);
    if prt then begin
      writeln(lst);
      writeln(lst,Spacer,'[',CurrentPath,']',' Files in Directory are:'); TextColor(Yellow);
      end;
    if ShowFiles then for Counter:=1 to total do
      with SortedList[Counter] do begin
        Spacer[0]:=chr(DirLevel*4);
        Tail:='-----';
        if (Attrib=0)         then Tail[1]:='N';   { Normal   }
        if (Attrib and  1)= 1 then Tail[2]:='R';   { ReadOnly }
        if (Attrib and  2)= 2 then Tail[3]:='H';   { Hidden   }
        if (Attrib and  4)= 4 then Tail[4]:='S';   { System   }
        if (Attrib and 32)=32 then Tail[5]:='A';   { Archive  }
        DiskLabel:=(Attrib and  8)= 8;
        Dircty:=   (Attrib and 16)=16;
        if (not Long) then LongStr:='' else
          LongStr:=' '+Date+' '+Time+' '+Tail;
        if (not DiskLabel) and (not Dircty) then begin
          writeln(Spacer,'--> ',Name,Size:7:0,LongStr);
          if prt then writeln(lst,Spacer,'--> ',Name,Size:7:0,LongStr);
          end;
        end;
    Progress;
    until (DirLevel=0);
  ChDir(Path);
  end.
,'--> ',Name,Size:7:0,LongStr);
          end;
        end;
    Progress;
    until (DirLevel=0);
  C