ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/PASTUT24.ZIP/PTUTRSRC.ZIP/OT4.PAS

Pascal/Delphi Source File | 1989-12-01 | 21.6 KB | 558 lines

                                     (* Chapter 14 - Program 13 *)
program Oak_Tree;         (* This version is for TURBO Pascal 4.0 *)

(*                 XXX     X    X   X  XXXXX  XXXX   XXXXX  XXXXX
  Oct 18, 1988    X   X   X X   X  X     X    X   X  X      X
                  X   X  X   X  X X      X    X   X  X      X
                  X   X  X   X  XX       X    XXXX   XXX    XXX
                  X   X  XXXXX  X X      X    X X    X      X
                  X   X  X   X  X  X     X    X  X   X      X
                   XXX   X   X  X   X    X    X   X  XXXXX  XXXXX
*)

uses Dos, Printer;

const  Page_Size = 66;
       Max_Lines = 55;

type   Command_String = string[127];

       Output_Type = (Directories,Files);

       Dir_Rec     = ^Dirtree;    (* Dynamic storage for dir names *)
       Dirtree     = record
         Next      : Dir_Rec;
         Dir_Name  : string[12];
      end;

       Filerec     = ^Filetree;         (* Dynamic storage for the *)
       Filetree    = record             (* filename sorting tree   *)
         Left      : Filerec;
         Right     : Filerec;
         FileData  : SearchRec;                 (* From Dos module *)
       end;

(*  Record definition from page 408 of the TURBO Pascal 4.0 manual *)
(*     type SearchRec = record                                     *)
(*                        Fill : array[1..21] of byte;             *)
(*                        Attr : byte;                             *)
(*                        Time : longint;                          *)
(*                        Size : longint;                          *)
(*                        Name : string[12];                       *)
(*                      end;                                       *)

var   File_Record    : SearchRec;      (* A working file record    *)
      File_Point     : Filerec;        (* Pointer to a file record *)
      Page_Number    : integer;
      Line_Number    : integer;
      Directory_Count : integer;
      Recpack        : Registers;               (* From Dos module *)
      File_Request   : string[25];
      Root_Mask      : Command_String;(* Used for vol-label search *)
      Starting_Path  : Command_String;

      Total_Clusters      : longint;
      Disk_Total_Bytes    : longint;
      Cluster_Size        : integer;
      Sectors_Per_Cluster : integer;
      Bytes_Per_Sector    : integer;
      Free_Clusters       : longint;
      Free_Bytes          : longint;
      Total_Cbytes        : longint;
      Total_Bytes         : longint;
      All_Files           : integer;    (* Number of files on disk *)
      Req_Files           : integer; (* Number of files in request *)

      Do_We_Print    : boolean;           (* Print or not          *)
      Do_All_Stats   : boolean;           (* List all disk stats?  *)
      No_Files_Out   : boolean;           (* List no files         *)
      Date_Time_Rec  : DateTime;          (* From Dos module       *)

(* **************************************************** Initialize *)
(* This procedure is used to initialize some variables and strings *)
(* prior to starting the disk search.                              *)
procedure Initialize;
begin
   Page_Number := 1;
   Line_Number := 1;
   Directory_Count := 0;
   Total_Cbytes := 0;
   Total_Bytes := 0;
   All_Files := 0;
   Req_Files := 0;
   Root_Mask := 'C:\*.*';
   Root_Mask[Length(Root_Mask) + 1] := Chr(0);
                           (* Get the current default drive letter *)
   Recpack.AX := $1900;
   Intr($21,Recpack);
   Root_Mask[1] := Chr(Recpack.AX and $F + Ord('A'));
end;

(* ****************************** Read And Parse Command Arguments *)
(* This procedure reads in the command line arguments, parses them,*)
(* and sets up the switches and defaults for the disk searches.    *)
procedure Read_And_Parse_Command_Arguments;
var    Parameters         : Command_String;
       Index              : byte;
begin
   Do_We_Print := FALSE;
   Do_All_Stats := FALSE;
   No_Files_Out := FALSE;
   File_Request := '*.*';

   for Index := 1 to ParamCount do begin
      Parameters := ParamStr(Index);
                                     (* Find command line switches *)
      if Parameters[1] = '/' then begin
         if Upcase(Parameters[2]) = 'P' then Do_We_Print := TRUE;
         if Upcase(Parameters[2]) = 'N' then No_Files_Out := TRUE;
         if Upcase(Parameters[2]) = 'S' then Do_All_Stats := TRUE;
      end
      else begin                   (* Find designated drive letter *)
         if Parameters[2] = ':' then begin
            Root_Mask[1] := Parameters[1];
            Delete(Parameters,1,2);
         end;

         if Parameters = '' then              (* No filename given *)
            File_Request := '*.*'
         else                                   (* Filename listed *)
            File_Request := Parameters;
      end;
   end;
                     (* get the current path on the selected drive *)
   Getdir(Ord(Root_Mask[1])-Ord('A') + 1,Starting_Path);
   if Length(Starting_Path) > 3 then
      Starting_Path := Starting_Path + '\';

end;

(* ********************************************* count print lines *)
procedure Count_Print_Lines(Line_Count : byte);
var Count : byte;
begin
   if Do_We_Print then begin
      if Line_Count > 250 then (* This signals the end of the tree *)
      begin                    (* Space up to a new page           *)
         Writeln(Lst,Char(12));
         Line_Number := 1;
         Line_Count := 0;
      end;
      Line_Number := Line_Number + Line_Count;
      if Line_Number > Max_Lines then begin
         Page_Number := Page_Number +1;
         Writeln(Lst,Char(12));                (* Go to a new page *)
         Writeln(Lst);                       (* Move down one line *)
         Writeln(Lst,'Page':60,
                                               Page_Number:4);
         Writeln(Lst);
         Line_Number := 1;
      end;
   end;
end;

(* ************************************************** Print Header *)
(* In this section of code, the volume label is found and displayed*)
(* and the present time and date are determined and displayed.     *)
procedure Print_Header;
var Year,Month,Day,DayOfWeek  : word;
    Hour,Minute,Second,Sec100 : word;
    Index                 : integer;
begin
   if Do_We_Print then begin
      Writeln(Lst);
      Write(Lst,'          Directory for ');
   end;
   Write('          Directory for ');
{  Recpack.AX := $1A00;                          (* Set up the DTA *)
   Recpack.DS := Seg(Dta);
   Recpack.DX := Ofs(Dta);
   Msdos(Recpack);                           (* DTA setup complete *)
   Error := Recpack.AX and $FF;
   if Error > 0 then Writeln('DTA setup error ',Error);
 }
   FindFirst(Root_Mask,$08,File_Record);      (* Get the volume ID *)
   if ((DosError > 0) or (File_Record.Attr <> 8)) then begin
      if Do_We_Print then
         Write(Lst,' <no vol label> ');
      Write(' <no vol label> ');
   end
   else begin                            (* Write out Volume Label *)
      if Do_we_Print then
         Write(Lst,File_Record.Name);
      Write(File_Record.Name);
   end;

   GetDate(Year,Month,Day,DayOfWeek);      (* Get the present date *)
   GetTime(Hour,Minute,Second,Sec100);     (* Get the present time *)
   Write('             ');
   Write(Month,'/',Day,'/',Year);
   Writeln('    ',Hour,':',Minute);
   Writeln;
   if Do_We_Print then begin
      Write(Lst,'             ');
      Write(Lst,Month,'/',Day,'/',Year);
      Writeln(Lst,'    ',Hour,':',Minute);
      Writeln(Lst);
      Count_Print_Lines(2);
   end;
                                  (* get all of the disk constants *)
   Recpack.AX := $3600;
   Recpack.DX := (Ord(Root_Mask[1]) - 64) and $F;
   Msdos(Recpack);
   Sectors_Per_Cluster := Recpack.AX;
   Free_Clusters := Recpack.BX;
   Bytes_Per_Sector := Recpack.CX;
   Total_Clusters := Recpack.DX;

   Cluster_Size := Bytes_Per_Sector * Sectors_Per_Cluster;

   if Do_All_Stats then begin (* Print out disk stats if asked for *)
      Write('             bytes/sector =',Bytes_Per_Sector:6);
      Disk_Total_Bytes := Total_Clusters * Cluster_Size;
      Writeln('       total disk space =',Disk_Total_Bytes:12);
      Write('            bytes/cluster =',Cluster_Size:6);
      Free_Bytes := Free_Clusters * Cluster_Size;
      Writeln('        free disk space =',Free_Bytes:12);
      Writeln;
      if Do_We_Print then begin
         Write(Lst,'             bytes/sector =',Bytes_Per_Sector:6);
         Writeln(Lst,'       total disk space =',
                                             Disk_Total_Bytes:12);
         Write(Lst,'            bytes/cluster =',Cluster_Size:6);
         Writeln(Lst,'        free disk space =',Free_Bytes:12);
         Writeln(Lst);
         Count_Print_Lines(3);
      end;
   end;
end;


(* *************************************** Position a new filename *)
(* When a new filename is found, this routine is used to locate it *)
(* in the B-TREE that will be used to sort the filenames alphabet- *)
(* ically.                                                         *)
procedure Position_A_New_Filename(Root, New : Filerec);
var    Index   : integer;
       Done    : boolean;
begin
   Index := 1;
   Done := FALSE;
   repeat
      if New^.FileData.Name < Root^.FileData.Name then begin
         Done := TRUE;
         if Root^.Left = nil then Root^.Left := New
         else
            Position_A_New_Filename(Root^.Left,New);
      end
      else if New^.FileData.Name > Root^.FileData.Name then
      begin
         Done := TRUE;
         if Root^.Right = nil then
            Root^.Right := New
         else
            Position_A_New_Filename(Root^.Right,New);
      end;
      Index := Index +1;
   until (Index = 13) or Done;
end;


(* ************************************************** Print a file *)
(* This is used to print the data for one complete file.  It is    *)
(* called with a pointer to the root and an attribute that is to be*)
(* printed.  Either the directories are printed (attribute = $10), *)
(* or the files are printed.                                       *)
procedure Print_A_File(Root : Filerec;
                       Which_List : Output_Type);
var Index,Temp  : byte;
begin
   Temp := Root^.FileData.Attr;
   if ((Temp =  $10) and (Which_List = Directories)) or
                 ((Temp <> $10) and (Which_List = Files)) then begin
      Write('                ');
      case Temp of
         $27 : Write('<HID>  ');
         $10 : Write('<DIR>  ');
         $20 : Write('       ')
         else  Write('<',Temp:3,'>  ');
      end;   (* of case *)
      if Do_We_Print then begin
         Write(Lst,'                ');
         case Temp of
            $27 : Write(Lst,'<HID>  ');
            $10 : Write(Lst,'<DIR>  ');
            $20 : Write(Lst,'       ')
            else  Write(Lst,'<',Temp:3,'>  ');
         end;   (* of case *)
      end;
                                         (* Write out the filename *)
      Write(Root^.FileData.Name);
      for Index := 1 to (15 - Length(Root^.FileData.Name)) do
         Write(' ');
      if Do_We_Print then begin
         Write(Lst,Root^.FileData.Name);
         for Index := 1 to (15 - Length(Root^.FileData.Name)) do
            Write(Lst,' ');
      end;
                                        (* Write out the file size *)
      Write(Root^.FileData.Size:9);
      if Do_We_Print then
         Write(Lst,Root^.FileData.Size:9);
                               (* Write out the file date and time *)
      UnpackTime(Root^.FileData.Time, Date_Time_Rec);
      Write('   ',Date_Time_Rec.Month:2,'/');
      Write(Date_Time_Rec.Day:2,'/');
      Write(Date_Time_Rec.Year,'   ');
      Write('  ',Date_Time_Rec.Hour:2,':');
      Writeln(Date_Time_Rec.Min:2);
      if Do_We_Print then begin
         Write(Lst,'   ',Date_Time_Rec.Month:2,'/');
         Write(Lst,Date_Time_Rec.Day:2,'/');
         Write(Lst,Date_Time_Rec.Year,'   ');
         Write(Lst,'  ',Date_Time_Rec.Hour:2,':');
         Writeln(Lst,Date_Time_Rec.Min:2);
         Count_Print_Lines(1);
      end;
   end;
end;

(* ********************************************* Print a directory *)
(* This is a recursive routine to print out the filenames in alpha-*)
(* betical order.  It uses a B-TREE with "infix" notation.  The    *)
(* actual printing logic was removed to another procedure so that  *)
(* the recursive part of the routine would not be too large and    *)
(* fill up the heap too fast.                                      *)
procedure Print_A_Directory(Root         : Filerec;
                            Which_List   : Output_Type);
begin
   if Root^.Left <> nil then
      Print_A_Directory(Root^.Left,Which_List);

   Print_A_File(Root,Which_List);        (* Write out the filename *)

   if Root^.Right <> nil then
      Print_A_Directory(Root^.Right,Which_List);
end;

(* **************************************************** Erase tree *)
(* After the directory is printed and counted, it must be erased or*)
(* the "heap" may overflow for a large disk with a lot of files.   *)
procedure Erase_Tree(Root : Filerec);
begin
   if Root^.Left  <> nil then Erase_Tree(Root^.Left);
   if Root^.Right <> nil then Erase_Tree(Root^.Right);
   Dispose(Root);
end;

(* ************************************************ Do A Directory *)
(* This procedure reads all entries in any directory and sorts the *)
(* filenames alphabetically.  Then it prints out the complete stat-*)
(* istics, and calls itself to do all of the same things for each  *)
(* of its own subdirectories.  Since each subdirectory also calls  *)
(* each of its subdirectories, the recursion continues until there *)
(* are no more subdirectories.                                     *)
procedure Do_A_Directory(Input_Mask : Command_String);
var   Mask          : Command_String;
      Count,Index   : integer;
      Cluster_Count : longint;
      Cluster_Bytes : longint;
      Byte_Count    : longint;
      Tree_Root     : Filerec;                (* Root of file tree *)
      Dir_Root      : Dir_Rec;
      Dir_Point     : Dir_Rec;
      Dir_Last      : Dir_Rec;
      File_Record   : SearchRec;

    (* This embedded procedure is called upon to store all of the  *)
    (* directory names in a linear linked list rather than a       *)
    (* B-TREE since it should be rather short and efficiency of    *)
    (* sorting is not an issue.  A bubble sort will be used on it. *)
    procedure Store_Dir_Name;
    begin
       if File_Record.Attr = $10 then begin (* Pick out directories*)
                    (* Directory name found, ignore if it is a '.' *)
          if File_Record.Name[1] <> '.' then begin
             New(Dir_Point);
             Dir_Point^.Dir_Name := File_Record.Name;
             Dir_Point^.Next := nil;
             if Dir_Root = nil then
                Dir_Root := Dir_Point
             else
                Dir_Last^.Next := Dir_Point;
             Dir_Last := Dir_Point;
          end;
       end;
    end;

     (* This is the procedure that sorts the directory names after *)
     (* they are all accumulated.  It uses a bubble sort technique *)
     (* which is probably the most inefficient sort available.  It *)
     (* is perfectly acceptable for what is expected to be a very  *)
     (* short list each time it is called.  More than 30 or 40     *)
     (* subdirectories in one directory would not be good practice *)
     (* but this routine would sort any number given to it.        *)
     procedure Sort_Dir_Names;
     var Change      : byte;
         Save_String : string[15];
         Dir_Next    : Dir_Rec;
     begin
        repeat
           Change := 0;
           Dir_Point := Dir_Root;
           while Dir_Point^.Next <> nil do
              begin
              Dir_Next := Dir_Point^.Next;
              Save_String := Dir_Next^.Dir_Name;
              if Save_String < Dir_Point^.Dir_Name then begin
                 Dir_Next^.Dir_Name := Dir_Point^.Dir_Name;
                 Dir_Point^.Dir_Name := Save_String;
                 Change := 1;
              end;
              Dir_Point := Dir_Point^.Next;
           end;
        until Change = 0;    (* No swaps in this pass, we are done *)
     end;

begin (* Do_A_Directory procedure *)
   Count := 0;
   Cluster_Count := 0;
   Dir_Root := nil;
   Mask := Input_Mask + '*.*';
   Mask[Length(Mask) + 1] := Chr(0);    (* A trailing zero for DOS *)
                                   (* Count all files and clusters *)
   repeat
      if Count = 0 then               (* Get first directory entry *)
         FindFirst(Mask,$17,File_Record)
      else                     (* Get additional directory entries *)
         FindNext(File_Record);
      if DosError = 0 then begin       (* A good filename is found *)
         Count := Count +1;            (* Add one for a good entry *)

                           (* Count up the number of clusters used *)
         Index := File_Record.Size div Cluster_size;
         if File_Record.Size mod Cluster_Size > 0 then
            Index := Index + 1;            (* If a fractional part *)
         Cluster_Count := Cluster_Count + Index;
         if Index = 0 then     (* This is a directory, one cluster *)
            Cluster_Count := Cluster_Count + 1;
         Store_Dir_Name;
      end;
   until DosError > 0;
   Cluster_Bytes := Cluster_Count * Cluster_Size;
   Directory_Count := Directory_Count + 1;
   Write('    ',Directory_Count:3,'. ');
   Write(Input_Mask);
   for Index := 1 to (32 - Length(Input_Mask)) do Write(' ');
   Writeln(Count:4,' Files  Cbytes =',Cluster_Bytes:9);
   if Do_We_Print then begin
      Write(Lst,'    ',Directory_Count:3,'. ');
      Write(Lst,Input_Mask);
      for Index := 1 to (32 - Length(Input_Mask)) do Write(Lst,' ');
      Writeln(Lst,Count:4,' Files  Cbytes =',Cluster_Bytes:9);
      Count_Print_Lines(1);
   end;
   Total_Cbytes := Total_Cbytes + Cluster_Bytes;
   All_Files := All_Files + Count;

                           (* files counted and clusters counted   *)
                           (* Now read in only the requested files *)

   Count := 0;
   Byte_Count := 0;
   Tree_Root := nil;
   if No_Files_Out <> TRUE then begin
      Mask := Input_Mask + File_Request;
      Mask[Length(Mask) + 1] := Chr(0); (* A trailing zero for DOS *)
      repeat
         New(File_Point);
         if Count = 0 then            (* Get first directory entry *)
            FindFirst(Mask,$17,File_Record)
         else                  (* Get additional directory entries *)
            FindNext(File_Record);
         if DosError = 0 then begin    (* A good filename is found *)
            Count := Count +1;         (* Add one for a good entry *)
            File_Point^.Left := nil;
            File_Point^.Right := nil;
            File_Point^.FileData := File_Record;
            if Tree_Root = nil then begin (* Pt to 1st elem in tree*)
               Tree_Root := File_Point;
            end
            else begin     (* Point to additional elements in tree *)
               Position_A_New_Filename(Tree_Root,File_Point);
            end;

            Byte_Count := Byte_Count + File_Record.Size;
         end;
      until DosError > 0;
   end;

   if Tree_Root <> nil then
      Print_A_Directory(Tree_Root,Directories);
   if Tree_Root <> nil then
      Print_A_Directory(Tree_Root,Files);
   if Count > 0 then begin
      Writeln('                  ',Count:5,' Files ',
                                 Byte_Count:17,' Bytes');
      Writeln;
      if Do_We_Print then begin
         Writeln(Lst,'                  ',Count:5,' Files ',
                                    Byte_Count:17,' Bytes');
         Writeln(Lst);
         Count_Print_Lines(2);
      end;
      Total_Bytes := Total_Bytes + Byte_Count;
      Req_Files := Req_Files + Count;
   end;
                            (* Now go do all of the subdirectories *)
   if Dir_Root <> nil then Sort_Dir_Names;
   Dir_Point := Dir_Root;
   while Dir_Point <> nil do begin
      Mask := Input_Mask + Dir_Point^.Dir_Name + '\';
      Do_A_Directory(Mask);
      Dir_Point := Dir_Point^.Next;
   end;
                           (* Finally, erase the tree and the list *)
   if Tree_Root <> nil then
      Erase_Tree(Tree_Root);

   while Dir_Root <> nil do begin
      Dir_Point := Dir_Root^.Next;
      Dispose(Dir_Root);
      Dir_Root := Dir_Point;
   end;
end;

(* ******************************************* Output Summary Data *)
procedure Output_Summary_Data;

begin
   Writeln;
   Write('                     ',Req_Files:5,' Files');
   Writeln(Total_Bytes:15,' Bytes in request');
   Write('                     ',All_Files:5,' Files');
   Writeln(Total_Cbytes:15,' Cbytes in tree');
   Write('                                   ');
   Free_Bytes := Free_Clusters * Cluster_Size;
   Writeln(Free_Bytes:12,' Bytes free on disk');
   if Do_We_Print then begin
      Writeln(Lst);
      Write(Lst,'                     ',Req_Files:5,' Files');
      Writeln(Lst,Total_Bytes:15,' Bytes in request');
      Write(Lst,'                     ',All_Files:5,' Files');
      Writeln(Lst,Total_Cbytes:15,' Cbytes in tree');
      Write(Lst,'                                   ');
      Writeln(Lst,Free_Bytes:12,' Bytes free on disk');
      Count_Print_Lines(4);      (* Signal the end, space paper up *)
   end;
end;

begin  (* Main program - Oak Tree ******************************** *)
   Initialize;
   Read_And_Parse_Command_Arguments;
   Print_Header;
   Do_A_Directory(Starting_Path);
   Output_Summary_Data;
   Count_Print_Lines(255);
end.  (* Main Program *)