home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DP Tool Club 31
/
CDASC_31_1996_juillet_aout.iso
/
vrac
/
fact127.zip
/
SMALLEST.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1996-04-02
|
6KB
|
237 lines
{$N-,E- no math support needed}
{$X- function calls may not be discarded}
{$I- disable I/O checking (trap errors by checking IOResult)}
PROGRAM Save_Only_The_Smallest_File;
USES DOS;
VAR
TestExts: STRING;
PROCEDURE Help (problem: BYTE);
(* If any *foreseen* errors arise, we are sent here to
give a little help and exit (relatively) peacefully *)
CONST
lf = #13#10;
VAR
message: STRING [50];
BEGIN
WriteLn ('SMALLEST v1.00 - DOS utility: Save only the SMALLEST file. (Use with "FACT")');
WriteLn ('Copyright (c) April 2, 1996, by David Daniel Anderson - Reign Ware.' + lf);
WriteLn ('Usage : SMALLEST file_spec .ext .ex2 .ex3 .ex4 .etc ' + lf);
WriteLn ('Example : SMALLEST *.* .zip .arj .rar .uc2');
WriteLn (' : SMALLEST c:\dls\*.* .acb .ha .yc');
WriteLn (' : SMALLEST newgame.arj .arj .rar .zip' + lf);
IF problem > 0 THEN BEGIN
CASE problem OF
1 : message := 'No files matching specification found.';
ELSE message := 'Unanticipated error of unknown type.';
END;
WriteLn ('Error #', problem, ' - ', message);
END;
Halt (problem)
END;
FUNCTION Comma (num : LONGINT): STRING; {insert commas to break up number string}
VAR s : STRING [14];
l : SHORTINT;
BEGIN
Str (num, s);
l := (Length (s) - 2);
WHILE (l > 1) DO BEGIN
Insert (',', s, l);
Dec (l, 3);
END;
Comma := s;
END;
FUNCTION RPad (bstr: STRING; len: BYTE): STRING;
BEGIN
WHILE (Length (bstr) < len) DO
bstr := bstr + #32;
RPad := bstr;
END;
FUNCTION Upper (lstr : STRING): STRING;
PROCEDURE UpFast (VAR Str: STRING); {** from SWAG **}
INLINE($8C/$DA/$5E/$1F/$FC/$AC/$30/$E4/$89/$C1/$E3/$12/$BB/Ord('a')/Ord('z')/
$AC/$38/$D8/$72/$08/$38/$F8/$77/$04/$80/$6C/$FF/$20/$E2/$F1/$8E/$DA);
BEGIN
UpFast (lstr);
Upper := lstr;
END;
FUNCTION IsFile (CONST FileName: PATHSTR): BOOLEAN;
VAR
Attr : WORD;
cFile : FILE;
BEGIN
Assign (cFile, FileName);
GetFAttr (cFile, Attr);
IF (DosError = 0) AND ((Attr AND Directory) <> Directory)
THEN IsFile := TRUE
ELSE IsFile := FALSE;
END;
PROCEDURE EraseFile (CONST FileName : PATHSTR);
VAR
cFile : FILE;
BEGIN
IF IsFile (FileName) THEN BEGIN
Assign (cFile, FileName);
SetFAttr (cFile, 0);
Erase (cFile);
END;
END;
FUNCTION getFileExt (fn: PATHSTR): EXTSTR;
VAR
p: BYTE;
BEGIN
p := (Pos ('.', fn));
IF (p > 0)
THEN getFileExt := Copy (fn, p, 1 + Length (fn) - p)
ELSE getFileExt := '';
END;
FUNCTION getFileName (fn: PATHSTR): NAMESTR;
VAR
p: BYTE;
b: BOOLEAN;
BEGIN
b := TRUE;
WHILE b DO
BEGIN
p := Pos ('\', fn);
IF (p > 1)
THEN fn := Copy (fn, p+1, Length (fn) - p)
ELSE b := FALSE;
END;
IF (Pos ('.', fn) > 0)
THEN getFileName := Copy (fn, 1, (Pos ('.', fn) - 1))
ELSE getFileName := fn;
END;
FUNCTION IsDir (CONST FileName: PATHSTR): BOOLEAN;
VAR
Attr : WORD;
cFile : FILE;
BEGIN
Assign (cFile, FileName);
GetFAttr (cFile, Attr);
IF (DosError = 0) AND ((Attr AND Directory) = Directory)
THEN IsDir := TRUE
ELSE IsDir := FALSE;
END;
FUNCTION GetFilePath (CONST PSTR: STRING; VAR sDir: DIRSTR): PATHSTR;
VAR
dirinfo : SEARCHREC;
jPath : PATHSTR; { file path, }
jDir : DIRSTR; { directory, }
jName : NAMESTR; { name, }
jExt : EXTSTR; { extension. }
BEGIN
jPath := PSTR;
IF jPath = '' THEN jPath := '*.*';
IF (NOT (jPath [Length (jPath) ] IN [':', '\'])) AND IsDir (jPath) THEN
jPath := jPath + '\';
IF (jPath [Length (jPath) ] IN [':', '\']) THEN
jPath := jPath + '*.*';
FSplit (FExpand (jPath), jDir, jName, jExt);
jPath := jDir + jName+ jExt;
sDir := jDir;
GetFilePath := jPath;
END;
PROCEDURE Inform (Action, fName: STRING; fSize: LONGINT);
BEGIN
WriteLn (Action, ': ', RPad (fName, 40), Comma (fSize):9, ' bytes');
END;
PROCEDURE SaveSmallest (fDir: DIRSTR; fName: NAMESTR);
TYPE
FileInfo = RECORD
fName : PATHSTR;
fSize : LONGINT;
END;
VAR
DirInfo : SEARCHREC;
fLast,
fCurrent : FileInfo;
Deleted : WORD;
BEGIN
fLast.fName := '';
fCurrent.fName := '';
Deleted := 0;
FindFirst (fDir+fName+'.*', Archive, DirInfo);
WHILE DosError = 0 DO
BEGIN
IF (Pos (Upper (getFileExt (DirInfo.Name))+'.', TestExts) > 0) THEN
BEGIN
fCurrent.fName := fDir + DirInfo.Name;
fCurrent.fSize := DirInfo.Size;
IF fLast.fName = '' THEN
BEGIN
fLast.fName := fCurrent.fName;
fLast.fSize := fCurrent.fSize;
END
ELSE BEGIN
Inc (Deleted);
IF fCurrent.fSize < fLast.fSize THEN
BEGIN
Inform ('Erasing', fLast.fName, fLast.fSize);
EraseFile (fLast.fName);
fLast.fName := fCurrent.fName;
fLast.fSize := fCurrent.fSize;
END
ELSE BEGIN
Inform ('Erasing', fCurrent.fName, fCurrent.fSize);
EraseFile (fCurrent.fName);
END;
END;
END;
FindNext (DirInfo);
END;
IF Deleted > 0 THEN
BEGIN
Inform ('Keeping', fLast.fName, fLast.fSize);
WriteLn;
END;
END;
VAR
fPath : PATHSTR;
fDir : DIRSTR;
DirInfo : SEARCHREC;
i: BYTE;
p: STRING;
BEGIN
WriteLn;
TestExts := '';
IF ParamCount < 2 THEN Help (0);
FOR i := 2 to ParamCount DO
BEGIN
p := ParamStr (i);
IF (p[1] = '.') AND (Length (p) IN [2..4]) THEN
TestExts := TestExts + p;
END;
IF TestExts <> '' THEN
BEGIN
TestExts := Upper (TestExts) + '.';
fPath := GetFilePath (ParamStr(1), fDir);
FindFirst (fPath, Archive, DirInfo);
WHILE DosError = 0 DO
BEGIN
SaveSmallest (fDir, getFileName (DirInfo.Name));
FindNext (DirInfo);
END;
END
ELSE
Help (1);
END.