Category : Pascal Source Code
Archive   : ADD10.ZIP
Filename : ADD.PAS

{ FreeWare - Just don't modify and re-distribute.

Randy Crawford
12 Taft Ct., Suite.110
Rockville, MD 20850
301-424-6892

ADD - Alphabetized Double-wide Directory utility.
Requires Turbo Pascal 4.0.
Sort help displayed using '/' on command line }

Program ADD;

Uses CRT, DOS;

Const
Numfiles = 300;

Type
Filename = array [1..numfiles] of string [60];
Filesize = string [40];
Strng2 = string [2];

VAR
Page: integer;
FileCount: integer; { total # of files }
Count2: integer;
Srec: SEARCHREC;
Path: STRING[40];
FirstDir: String[40];
Drive1: Strng2;
Pfile1: string[60];
Pfile2: string[60];
ATTR: BYTE;
YEAR: string[4];
MONTH: strng2;
DAY: strng2;
dt: datetime;
hour: strng2;
min: strng2;
name: filesize;
size: filesize;
files: filename;
decpos: integer;
tsize: longint;
tot: boolean;
ext: boolean;
dat: boolean;
siz: boolean;
help: boolean;
Reverse: boolean;
REGS: REGISTERS;
diff: integer;
left: integer;
Lines: integer;
pivot: integer;
group: integer;
scan1: integer;
scan2: integer;
extend: string[3];
parmstr: string;
letter: char;
ScrollNum: integer;
DiskLeft: longint;
DLeft: filesize;
DiskSpace: longint;
DSpace: filesize;
RetKey: char;
Colour: word;

Procedure Flip; { reverse order of array }
Var
Count: integer;
Pivot: integer;
Offset: integer;
Hold : string[60];
LastFile: integer;
Begin
Pivot := FileCount DIV 2;
LastFile := FileCount + 1;
if (Pivot * 2) > FileCount then { if Filecount=7, Pivot=3 }
Pivot := Pivot - 1;

For Count := 1 to Pivot DO
BEGIN
Hold := Files [Count];
Offset := LastFile - Count;
Files [Count] := Files [Offset];
Files [Offset] := Hold;
END;
End;

Procedure GetChar (VAR Key: char);
BEGIN
gotoxy (80, 25);
key := CHR(0);
repeat
Key := ReadKey;
until key <> chr(0);
END;

Procedure Caps (VAR CAPS: STRING); { set string to all caps }
VAR
count: integer;
long: integer;
begin
long := length (caps);
for count := 1 to long do
IF (ord (caps [count]) > 96) and (ord (caps [count]) < 123) then
caps [count] := chr (ord (caps [count]) - 32);
end;

Procedure Comma (VAR numstr: filesize);
VAR
dot : integer;
plc : integer;
tens : real;
number: real;
begin
val (numstr, number, dot);
dot := pos ('.', numstr);
if dot = 0 then
dot := length (numstr) + 1;
plc := 3;
tens := 1000;
While (copy (numstr, 1, 1) = ' ') and (number >= tens) DO
begin
insert (',', numstr, dot - plc);
delete (numstr, 1, 1);
tens := tens * 1000;
plc := plc + 4;
end;
end;

Procedure Fpad (VAR strng : filesize);
VAR
plc: integer;
BEGIN
plc := pos ('.', strng);
While (plc > 0) and (plc < 9) DO
Begin
insert (' ', strng, plc);
plc := pos ('.', strng);
End;
plc := length (strng);
While (plc < 12) DO
Begin
strng := strng + ' ';
plc := length (strng);
End;
strng[9] := ' ';
END;

Procedure Npad (VAR strng : strng2);
BEGIN
if copy (strng, 1, 1) = ' ' then
begin
strng := copy (strng, 2, 1);
insert ('0', strng, 1)
end;
END;

Procedure Attributes; { check for DIR / set size }
BEGIN
if ((srec.attr and 16) = 16) then
size := chr(178)+chr(177)+' DIR '+chr(177)+chr(178)
else
BEGIN
str (srec.SIZE:8, size);
comma (size);
size := ' ' + size;
END;
END; { attributes }

Procedure CheckParams;
Var
spc : integer;
count: integer;
chekpath: string [12];
BEGIN
path := '*.*';
tot := false;
ext := false;
dat := false;
siz := false;
help:= false;
Reverse:= False;

if (paramcount > 0) then
BEGIN
{ set path }
chekpath := paramstr(1);

if pos (':', chekpath) = 2 then
drive1 := copy(chekpath,1,2)
else
drive1 := '';

if pos('/',ChekPath) <> 0 then
ChekPath := '*.*';

if (paramstr (1) = '.') then
chekpath := '*.*';

if (paramstr (1) = '..') then
chekpath := '..\*.*';

if (paramstr (1) = '...') then
chekpath := '...\*.*';

if (pos (':', chekpath) <> 0) and (length (chekpath) = 2) then
chekpath := chekpath + '*.*'; { A: to A:*.*}

if (pos ('*',chekpath) <> 0) and (pos ('.', chekpath) = 0) then
chekpath := paramstr(1) + '.*';

FindFirst (chekpath, attr, srec); { file or subdirectory? }

if (doserror = 0) then { TRADE is file, \TRADE is DIR }
BEGIN
count := 2;
if (pos ('.', chekpath) = 0) and ((srec.attr and 16) = 16) then
path := chekpath + '\*.*' { entire directory }
else
path := chekpath { a file mask found }
END
else
begin
if copy (paramstr (1), 1, 1) = '/' then
count := 1 { not a file mask }
else
begin
count := paramcount + 1; { a file mask not found }
path := paramstr (1);
end
end;

{ parse sort order sub string }
parmstr := ''; { concat sub-string }
Count := 1;
while (count <= paramcount) do
begin
parmstr := parmstr + paramstr (count);
count := count + 1;
end;

caps (parmstr);

if (POS ('/T', PARMSTR) <> 0) then
TOT := TRUE;
if (POS ('/S', PARMSTR) <> 0) then
SIZ := TRUE;
IF (POS ('/E', PARMSTR) <> 0) THEN
EXT := TRUE;
IF (POS ('/D', PARMSTR) <> 0) THEN
DAT := TRUE;
IF (POS ('/R', PARMSTR) <> 0) THEN
Reverse := TRUE;

if (pos ('/', PARMSTR) <> 0) AND (DAT = FALSE) AND
(TOT = FALSE) AND (EXT = FALSE) AND (SIZ = FALSE)
AND (REVERSE = FALSE) THEN
HELP := TRUE;

END;
END; { path }

Procedure Quicksort (Lo, Hi: integer);
Procedure Sort (L, R: integer);
var
I, J: integer;
X, Y: STRING [50];
begin
I := L;
J := R;
X := files [(L+R) DIV 2];
repeat
while files [I] < X do
I := I + 1;
while X < files [J] do
J := J - 1;
if I <= J then
begin
Y := files [I];
files [I] := files [J];
files [J] := Y;
I := I+1;
J := J-1;
end;
until I > J;
if L < J then sort (L, J);
if I < R then sort (I, R);
end;
BEGIN { quicksort }
Sort (Lo, Hi);
END; { quicksort }

Procedure SetCurs (CURSCN : LONGINT);
Var
regs : registers;
begin
REGS.AX := $100;
REGS.CX := CURSCN; { $2020 elims cursor, $0607 restores for EGA amd mono }
INTR ($10, REGS);
end;

Procedure Truncate;
VAR
DelAmt: integer;
Begin
Pfile1 := files [count2 + group];
Pfile2 := files [count2 + group + diff];
DelAmt := 1;
if (SIZ = true) then
DelAmt := DelAmt + 9;

if (DAT = true) then
DelAmt := DelAmt + 5;

if (EXT = true) then
DelAmt := DelAmt + 3;

delete (pfile1, 1, DelAmt);
delete (pfile2, 1, DelAmt);
End;

Procedure ScrollUp (ScLines: integer);
Begin
If Page > 0 then
ScLines := ScLines + 1;

if ScLines >= 25 then
ScLines := 25
else
ScLines := ScLines + 1;

REGS.AX := $600 + ScLines;
REGS.BX := Colour * 256; { BH is scroll attribute - prob 7 gray }
REGS.CX := $0000; { top row , left col }
REGS.DX := $184F; { bot row, right col }

INTR ($10, REGS);

If (Page > 0) and (ScLines > 1) then
ScLines := ScLines - 1;

ScLines := MEM [$0:$451] + 1 - ScLines;

if Sclines < 1 then
ScLines := 1;

gotoxy (1, ScLines);

If (Page > 0) and (ScLines > 1) then
Writeln ('ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ');
End;

Procedure ShowFiles; { prints list of files }
BEGIN
Lines := FileCount div 2;
if Lines <> (FileCount / 2) then
Lines := Lines + 1;
diff := lines;

if (diff > 25) then diff := 25;
count2 := 1;
left := Lines;
group := 0;
pivot := count2 + 25;

ScrollNum := (MEM [$0:$451] + Left) - 24;

if (ScrollNum >= 0) then
ScrollUp (ScrollNum);

while (count2 <= Lines) and (RetKey <> Chr(27)) DO
begin
truncate;

write (pfile1 + ' ³ ' + pfile2);
count2 := count2 + 1;

if (count2 = pivot) then
begin
GETCHAR (RetKey);
if (RetKey <> chr(27)) then
begin
Page := Page + 1;
left := left - 25;
diff := left;

if (left < 25) then
left := left + 1;
ScrollUp (Left);

if diff > 25 then diff := 25;
group := group + 25;
pivot := count2 + 25;
end;
end
else
Writeln;
end;
end;

Procedure Getfiles;
BEGIN
for FileCount := 1 to numfiles do
files [FileCount] := '';
TSIZE := 0;

FindFirst (path, attr, srec);
FileCount := 0;

while (DosError = 0) and (FileCount < numfiles) do
begin
if (copy (srec.name, 1, 1) <> '.') then
BEGIN
FileCount := FileCount + 1;
if (srec.attr and 16) <> 16 then
tsize := tsize + srec.size;

if (TOT = False) then { 17 long }
Begin
UNPACKTIME (srec.TIME, dt);
str (DT.YEAR:4, year);
year := copy (year, 3, 2);
str (DT.MONTH:2, month);
str (DT.DAY:2, day);
npad (day);
str (dt.min:2, min);
npad (min);
str (dt.hour:2, hour);
name := srec.name;
fpad (name);
attributes;

if (EXT = true) then { +3 }
begin
extend := copy (name, 10, 3);
if (srec.attr and 16) = 16 then
extend := chr(0)+chr(0)+chr(0); { directory }
name := extend + name;
end;

if (DAT = true) then { +5 }
name := chr(255 xor (dt.year-1900)) + chr(255 xor dt.month)
+ chr(255 xor dt.day) + chr(255 xor dt.hour)
+ chr(255 xor dt.min) + name;

if (SIZ = true) then { +9 }
begin
if (srec.attr and 16) = 16 then
name := ' ' + name
else
name := size + name;
end;

if (srec.attr and 16) = 16 then { +1 }
name := chr(0) + name { directory }
else
name := chr(32) + name;

Files [FileCount] := name+size+' '+MONTH+'.'+DAY+'.'+YEAR+' '+hour+':'+min;
End;
END;
FindNext (srec);
end;
END;

Function Cut (letters: string): string;
begin
while copy (letters,1,1) = ' ' DO
letters := copy (letters, 2, 80);
while copy (letters, length (letters), 1) = ' ' DO
letters := copy (letters, 1, length (letters) - 1);
Cut := letters;
end;

BEGIN { main }
RetKey := ' ';
Page := 0;
attr := $37;
Drive1 := '';

GetDir (0,FirstDir); { set current directory }
CheckParams; { look for sort specs, file mask, drive and directory }

if (help = true) then
begin
writeln;
writeln (' Flags are:');
writeln;
writeln (' /D Sort by date and time.');
writeln (' /E Sort by extension.');
writeln (' /S Sort by size.');
Writeln (' /R Reverse sort order.');
writeln;
writeln (' /T No sort: Total bytes on disk for matching files.');
end
else
begin
if Drive1 <> '' then
Chdir (Drive1);

DiskLeft := DiskFree (0);
DiskSpace := DiskSize (0);

GetFiles;

IF (TOT = False) and (FileCount <> 0) THEN
BEGIN { set color for scroll }
Colour := MEM [0:$449];
If (Colour <> 7) then
Colour := MEM [$B800:3841]; { FROM BOTTOM LINE ON SCREEN }

QuickSort (1, FileCount);
If (Reverse = True) then { reverse sorted order }
Flip;
ShowFiles;
END;

if (RetKey <> Chr(27)) then
begin
if (FileCount <> 0) then
begin
str (tsize:11, size);
comma (size);
str (diskleft:12, dleft);
comma (dleft);
str (diskspace:12, dspace);
comma (dspace);
WRITE (' ',SIZE,' bytes in ',FileCount,' files ... ',Cut(DLeft),' free of ',Cut(DSpace),'.');
{ volume label ? }
end
else
WRITE (' No files found using '+path+' mask.');

if (count2 = (pivot - 1)) then
GETCHAR (RetKey);

Chdir (FirstDir);
end;
end;
END.