Category : Pascal Source Code
Archive   : PASTUT.ZIP
Filename : OT3.PAS

(* Chapter 14 - Program 12 *)
program Oak_Tree; (* This version is for TURBO Pascal 3.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
*)

const Page_Size = 66;
Max_Lines = 55;

type Command_String = string[127];

Output_Type = (Directories,Files);

Regpack = record
AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS:integer;
end;

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

Filerec = ^Filetree; (* Dynamic storage for the *)
Filetree = record (* filename sorting tree *)
Left : Filerec;
Right : Filerec;
case boolean of
TRUE : (Attribute : byte;
File_Time : array[1..2] of byte;
File_Date : array[1..2] of byte;
File_Size : array[1..4] of byte;
File_Name : array[1..13] of char);
FALSE : (File_Rec : array[1..23] of char);
end;

var File_Point : Filerec; (* Pointer to a file record *)
Page_Number : integer;
Line_Number : integer;
Directory_Count : integer;
Recpack : Regpack;
Dta : array[1..43] of char; (* Disk xfer address *)
File_Request : string[25];
Root_Mask : Command_String;(* Used for vol-label search *)
Starting_Path : Command_String;
Cluster_Size : integer;
Sectors_Per_Cluster : integer;
Free_Clusters : integer;
Bytes_Per_Sector : integer;
Total_Clusters : integer;
Do_We_Print : boolean; (* Print or not *)
Do_All_Stats : boolean; (* List all disk stats? *)
No_Files_Out : boolean; (* List no files *)
Which_List : Output_Type;
Real_Size : real;
R1,R2,R3 : real;
Total_Cbytes : real;
Total_Bytes : real;
All_Files : integer;
Req_Files : integer;

(* **************************************************** 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_Input : Command_String absolute Cseg:$80;
Parameters : Command_String;
Index : byte;
Temp_Store : char;
begin
Do_We_Print := FALSE;
Do_All_Stats := FALSE;
No_Files_Out := FALSE;

(* First, preserve the input area to allow F3 to repeat *)
for Index := 0 to Length(Parameters_Input) do
Parameters[Index] := Parameters_Input[Index];
for Index := 1 to Length(Parameters) do begin
(* Find designated drive letter *)
if ((Parameters[Index] = ':') and (Index > 1)) then begin
Root_Mask[1] := Parameters[Index-1];
Parameters[Index-1] := ' ';
Parameters[Index] := ' ';
end;
(* Find command line switches *)
if (Parameters[Index] = '/') and (Index < Length(Parameters))
then begin
Temp_Store := Upcase(Parameters[Index + 1]);
if Temp_Store = 'P' then Do_We_Print := TRUE;
if Temp_Store = 'N' then No_Files_Out := TRUE;
if Temp_Store = 'S' then Do_All_Stats := TRUE;
Parameters[Index] := ' ';
Parameters[Index+1] := ' ';
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 + '\';

(* Finally, find the file name mask for searching *)
repeat (* Remove leading blanks *)
if Parameters[1] = ' ' then
Delete(Parameters,1,1);
until (Parameters[1] <> ' ') or (Length(Parameters) = 0);

Index := 0; (* Remove everything trailing the first entry *)
repeat
Index := Index + 1;
until (Parameters[Index] = ' ') or (Index=Length(Parameters) + 1);
Delete(Parameters,Index,127);
if Parameters = '' then
File_Request := '*.*'
else
File_Request := Parameters;
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 *)
for Count := Line_Number to (Page_Size - 3) do
Writeln(Lst);
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;
for Count := Line_Number to (Page_Size - 2) do
Writeln(Lst);
Writeln(Lst,' Page',
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 Month,Day,Hour,Minute : string[2];
Year : string[4];
Error : integer;
Attribute : byte;
Temp : byte;
Done : boolean;
Index : integer;
begin
if Do_We_Print then begin
Writeln(Lst);
Writeln(Lst);
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);

Recpack.AX := $4E00; (* Get the volume ID *)
Recpack.DS := Seg(Root_Mask[1]);
Recpack.DX := Ofs(Root_Mask[1]);
Recpack.CX := 8;
Intr($21,Recpack);
Error := Recpack.AX and $FF;
Attribute := $1F and Mem[Seg(Dta):Ofs(Dta) + 21];

if ((Error > 0) or (Attribute <> 8)) then begin
if Do_We_Print then
Write(Lst,' ');
Write(' ');
end
else begin (* Write out Volume Label *)
Done := FALSE;
for Index := 30 to 41 do begin
Temp := Mem[Seg(Dta):Ofs(Dta) + Index];
if Temp <> Ord('.') then begin (* Eliminate '.' in label *)
if Temp = 0 then Done := TRUE;
if Done = FALSE then begin
if Do_we_Print then
Write(Lst,Chr(Temp));
Write(Chr(Temp));
end;
end;
end;
end;

Write(' ');
if Do_We_Print then
Write(Lst,' ');
Recpack.AX := $2A00; (* Get the present date *)
Msdos(Recpack);
Str(Recpack.CX:4,Year);
Str((Recpack.DX mod 256):2,Day);
Str((Recpack.DX shr 8):2,Month);
if Day[1] = ' ' then Day[1] := '0';
Write(Month,'/',Day,'/',Year);
if Do_We_Print then
Write(Lst,Month,'/',Day,'/',Year);
Recpack.AX := $2C00; (* Get the present time *)
Msdos(Recpack);
Str((Recpack.CX shr 8):2,Hour);
Str((Recpack.CX mod 256):2,Minute);
if Minute[1] = ' ' then Minute[1] := '0';
Writeln(' ',Hour,':',Minute);
Writeln;
if Do_We_Print then begin
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);
R1 := Total_Clusters;
R2 := Cluster_Size;
R1 := R1 * R2;
Writeln(' total disk space =',R1:12:0);
Write(' bytes/cluster =',Cluster_Size:6);
R3 := Free_Clusters;
R2 := R3 * R2;
Writeln(' free disk space =',R2:12:0);
Writeln;
if Do_We_Print then begin
Write(Lst,' bytes/sector =',Bytes_Per_Sector:6);
Writeln(Lst,' total disk space =',R1:12:0);
Write(Lst,' bytes/cluster =',Cluster_Size:6);
Writeln(Lst,' free disk space =',R2:12:0);
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^.File_Name[Index] < Root^.File_Name[Index] then begin
Done := TRUE;
if Root^.Left = nil then Root^.Left := New
else
Position_A_New_Filename(Root^.Left,New);
end
else if New^.File_Name[Index] > Root^.File_Name[Index] 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;
Temp_String : string[25];
Day : string[2];
begin
Temp := Root^.Attribute;
if ((Temp = $10) and (Which_List = Directories)) or
((Temp <> $10) and (Which_List = Files)) then begin
Write(' ');
case Temp of
$27 : Write(' ');
$10 : Write(' ');
$20 : Write(' ')
else Write('<',Temp:3,'> ');
end; (* of case *)
if Do_We_Print then begin
Write(Lst,' ');
case Temp of
$27 : Write(Lst,' ');
$10 : Write(Lst,' ');
$20 : Write(Lst,' ')
else Write(Lst,'<',Temp:3,'> ');
end; (* of case *)
end;
Temp_String := ' ';
Index := 1;
repeat
Temp := Ord(Root^.File_Name[Index]);
if Temp > 0 then
Temp_String[Index] := Root^.File_Name[Index];
Index := Index + 1;
until (Temp = 0) or (Index = 14);
Temp_String[0] := Chr(15);
Write(Temp_String);
if Do_We_Print then
Write(Lst,Temp_String);

(* Write out the file size *)
R1 := Root^.File_Size[1];
R2 := Root^.File_Size[2];
R3 := Root^.File_Size[3];
Real_Size := R3*65536.0 + R2 * 256.0 + R1;
Write(Real_Size:9:0);
if Do_We_Print then
Write(Lst,Real_Size:9:0);
(* Write out the file date *)
Temp := ((Root^.File_Date[1] shr 5) and $7);
Write(' ',(Temp + ((Root^.File_Date[2] and 1) shl 3)):2,'/');
if Do_We_Print then
Write(Lst,' ',
(Temp+((Root^.File_Date[2] and 1) shl 3)):2,'/');
Str((Root^.File_Date[1] and $1F):2,Day);
if Day[1] = ' ' then Day[1] := '0';
Write(Day,'/');
Write(80 + ((Root^.File_Date[2] shr 1) and $7F),' ');
if Do_We_Print then begin
Write(Lst,day,'/');
Write(Lst,80 + ((Root^.File_Date[2] shr 1) and $7F),' ');
end;

(* Write out the file time *)
Write(' ',((Root^.File_Time[2] shr 3) and $1F):2,':');
if Do_We_Print then
Write(Lst,' ',((Root^.File_Time[2] shr 3) and $1F):2,':');
Temp := ((Root^.File_Time[2]) and $7) shl 3;
Str((Temp + ((Root^.File_Time[1] shr 5) and $7)):2,Day);
if Day[1] = ' ' then Day[1] := '0';
Writeln(Day);
if Do_We_Print then begin
Writeln(Lst,Day);
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;
Error : byte;
Cluster_Count : integer;
Byte_Count : real;
Tree_Root : Filerec; (* Root of file tree *)
Dir_Root : Dir_Rec;
Dir_Point : Dir_Rec;
Dir_Last : Dir_Rec;

(* 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;
var Temp_String : string[15];
Temp : byte;
Index : byte;
begin
Temp := Mem[Seg(Dta):Ofs(Dta) + 21]; (* Attribute *)
if Temp = $10 then begin (* Pick out directories *)
Index := 1;
repeat
Temp := Mem[Seg(Dta):Ofs(Dta) + 29 + Index];
if Temp > 0 then
Temp_String[Index] := Chr(Temp);
Index := Index + 1;
until (Temp = 0) or (Index = 14);
Temp_String[0] := Chr(Index - 2);
(* Directory name found, ignore if it is a '.' *)
if Temp_String[1] <> '.' then begin
New(Dir_Point);
Dir_Point^.Dir_Name := Temp_String;
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
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 begin (* Get first directory entry *)
Recpack.AX := $4E00;
Recpack.DS := Seg(Mask[1]);
Recpack.DX := Ofs(Mask[1]);
Recpack.CX := $17; (* Attribute for all files *)
Intr($21,Recpack);
end
else begin (* Get additional directory entries *)
Recpack.AX := $4F00;
Intr($21,Recpack);
end;
Error := Recpack.AX and $FF;
if Error = 0 then begin (* A good filename is found *)
Count := Count +1; (* Add one for a good entry *)

(* Count up the number of clusters used *)
R1 := Mem[Seg(Dta):Ofs(Dta) + 26];
R2 := Mem[Seg(Dta):Ofs(Dta) + 27];
R3 := Mem[Seg(Dta):Ofs(Dta) + 28];
Real_Size := R3*65536.0 + R2 * 256.0 + R1; (*Nmbr of bytes*)
R1 := Cluster_Size;
R1 := Real_Size/R1; (* Number of clusters *)
Index := Trunc(R1);
R2 := Index;
if (R1 - R2) > 0.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 Error > 0;
R1 := Cluster_Count;
R2 := Cluster_Size;
R1 := R1 * R2;
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 =',R1:9:0);
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 =',R1:9:0);
Count_Print_Lines(1);
end;
Total_Cbytes := Total_Cbytes + R1;
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 begin (* Get first directory entry *)
Recpack.AX := $4E00;
Recpack.DS := Seg(Mask[1]);
Recpack.DX := Ofs(Mask[1]);
Recpack.CX := $17; (* Attribute for all files *)
Intr($21,Recpack);
end
else begin (* Get additional directory entries *)
Recpack.AX := $4F00;
Intr($21,Recpack);
end;
Error := Recpack.AX and $FF;
if Error = 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;
for Index := 1 to 23 do
File_Point^.File_Rec[Index] :=
Char(Mem[Seg(Dta):Ofs(Dta) + 20 + Index]);
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;

(* Count up the number of bytes used *)
R1 := File_Point^.File_Size[1];
R2 := File_Point^.File_Size[2];
R3 := File_Point^.File_Size[3];
Real_Size := R3*65536.0 + R2 * 256.0 + R1; (*Number of *)
(* bytes used. *)
Byte_Count := Byte_Count + Real_Size;
end;
until Error > 0;
end;

Which_List := Directories;
if Tree_Root <> nil then
Print_A_Directory(Tree_Root,Which_List);
if Tree_Root <> nil then
Print_A_Directory(Tree_Root,Succ(Which_List));
if Count > 0 then begin
Writeln(' ',Count:5,' Files ',
Byte_Count:17:0,' Bytes');
Writeln;
if Do_We_Print then begin
Writeln(Lst,' ',Count:5,' Files ',
Byte_Count:17:0,' 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:0,' Bytes in request');
Write(' ',All_Files:5,' Files');
Writeln(Total_Cbytes:15:0,' Cbytes in tree');
Write(' ');
R1 := Free_Clusters;
R2 := Cluster_Size;
R1 := R1 * R2;
Writeln(R1:12:0,' Bytes free on disk');
if Do_We_Print then begin
Writeln(Lst);
Write(Lst,' ',Req_Files:5,' Files');
Writeln(Lst,Total_Bytes:15:0,' Bytes in request');
Write(Lst,' ',All_Files:5,' Files');
Writeln(Lst,Total_Cbytes:15:0,' Cbytes in tree');
Write(Lst,' ');
Writeln(Lst,R1:12:0,' 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 *)