home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DP Tool Club 31
/
CDASC_31_1996_juillet_aout.iso
/
vrac
/
fact127.zip
/
FACT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-05-23
|
32KB
|
1,083 lines
PROGRAM Freeware_Archive_Conversion_Tool;
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
| Program: FACT (Freeware Archive Conversion Tool)
| Version: 1.27 - May 23, 1996
| Author: David Daniel Anderson
| Copyright applies, but feel free to use "fair-use" size portions of code.
-----------------------------------------------------------------------------*)
{$M 20480,0,655360}
{$N-,E- no math support needed}
{$X- function calls may not be discarded}
{$I- disable I/O checking (trap errors by checking IOResult)}
USES DOS, HeapMan;
TYPE
STR128 = STRING[128];
FList = ^FNode;
FNode = RECORD
ArcFName: STRING[12]; { File names of archives to process. }
DelWhenDone: BOOLEAN; { Does FACT delete archive when done? }
Next: FList;
END;
ArcCommands = RECORD
ReCompress: STR128; { Command line for each ReCompressor. }
DeCompress: STR128; { Command line for each DeCompressor. }
DirsCompressed: BOOLEAN; { Does compressor compress dirs? }
END;
VAR
SavedExitProc: POINTER; { CustomExit proc inserted into normal exit. }
ComSpec: PATHSTR; { Used to execute commands. }
WATCH, { If TRUE, ReadLn executed after info messages. }
DelOriginal, { If TRUE, the original archive is deleted. }
QUIET, { If TRUE, most compressor output is suppressed. }
ONE: BOOLEAN; { If TRUE, convert only the primary archive. }
RecursionLevel: BYTE; { How deep the recursion is, affects ZIP archives. }
NewExt: EXTSTR; { New extension -- for recompressed archives. }
ArcString: STRING; { String of extensions of validated compressors. }
ArcArray: Array[1..244] of ArcCommands; { Commands for archive types. }
FileList: FList; { Singly linked list of archives to process. }
FUNCTION getFileName (fn: STR128): NAMESTR; FORWARD;
PROCEDURE NewLine; FORWARD;
PROCEDURE WriteStr (CONST s: STRING); FORWARD;
FUNCTION WordToHex (i: WORD): EXTSTR; FORWARD;
PROCEDURE CustomExit; FAR; {---- Always exit through here ----}
CONST
NL = #13#10;
VAR
message: STRING [79];
BEGIN
ExitProc := SavedExitProc;
IF (ExitCode > 0) THEN BEGIN
NewLine;
WriteStr ('FACT v1.27 - DOS utility: Freeware Archive Conversion Tool.');
WriteStr ('May 23, 1996. Copyright (c) 1996 by David Daniel Anderson - Reign Ware.'+NL);
WriteStr (' Usage : FACT archives .NewExt [-d] [-q] [-w] [-1]'+NL);
WriteStr (' Where : "archives" is specification of the archives to convert.');
WriteStr (' : ".NewExt" is the extension(s) you wish to convert them to.');
WriteStr (' : "-d"=del - forces the original archive to be deleted. [Optional]');
WriteStr (' : "-q"=quiet - hides most of the compressors'' messages. [Optional]');
WriteStr (' : "-w"=watch - causes FACT to pause after every action. [Optional]');
WriteStr (' : "-1"=1 level - only recompress the _primary_ archive. [Optional]'+NL);
WriteStr ('Examples : FACT c:\dls\*.zip .lzh');
WriteStr (' : FACT somefile.arc .arj .zip .uc2 -d');
WriteStr (' : FACT anyfiles.* .rar -d -q'+NL);
WriteStr (' Hints : DOS wildcards may be used when specifying the archives.');
WriteStr (' : Multiple ".NewExt" new extensions may be specified at one time.'+NL);
END;
IF ErrorAddr <> NIL THEN
BEGIN
WriteStr ('An unanticipated error occurred, please contact DDA with the following data:');
WriteLn ('Address = ', WordToHex (Seg (ErrorAddr^)), ':', WordToHex (Ofs (ErrorAddr^)));
WriteLn ('Code = ', ExitCode);
ErrorAddr := NIL;
END
ELSE
IF (ExitCode IN [1..254]) THEN BEGIN
CASE ExitCode OF
1 : message := 'No '+getFileName (ParamStr (0))+'.INI file found. It must be in same dir as '+ParamStr(0)+'.';
2 : message := 'No defined archives found matching "'+ParamStr(1)+'"!';
3 : message := 'None of the ".NewExt" compressors were validated.';
4 : message := 'User aborted while in "watch" mode. Working files may remain!';
6 : message := '"COMSPEC" not set! Type "COMSPEC=c:\dos\command.com" (or similar) to set it.';
7 : message := 'File handling error. There are likely files and directories to clean up now.';
ELSE message := 'Unknown error.';
END;
WriteLn ('Error encountered (#', ExitCode, '):'); WriteStr (message);
END;
END;
PROCEDURE CheckIO; { Check IOResult, exit on error. }
BEGIN
IF IOResult <> 0 THEN Halt (7);
END;
PROCEDURE NewLine;
BEGIN
WriteLn;
END;
PROCEDURE WriteStr (CONST s: STRING);
BEGIN
WriteLn (s);
END;
FUNCTION WordToHex (i: WORD): EXTSTR; {Convert a WORD variable to STRING[4]}
CONST
HexLetters : ARRAY [0..15] OF CHAR = '0123456789ABCDEF';
BEGIN
WordToHex := Concat (HexLetters [Hi (i) SHR 4], HexLetters [Hi (i) AND 15],
HexLetters [Lo (i) SHR 4], HexLetters [Lo (i) AND 15]);
END;
PROCEDURE ClrScr; ASSEMBLER;
(* Routine from SWAG *)
ASM
MOV AH, 0Fh
Int 10h
MOV AH, 0
Int 10h
END;
PROCEDURE Delay (ms : WORD); ASSEMBLER;
ASM {machine independent Delay Function}
mov AX, 1000;
mul ms;
mov CX, DX;
mov DX, AX;
mov AH, $86;
Int $15;
END;
PROCEDURE Pause; { Pauses for WATCH mode. }
FUNCTION ReadKey: CHAR;
VAR
r: REGISTERS;
BEGIN
r. AX := $0700;
Intr ($21, r);
ReadKey := Chr (r. AL);
END;
VAR
k: CHAR;
BEGIN
NewLine;
WriteStr ('Watch mode: press "N" to stop watching, or "A" to abort FACT.');
Write ('Otherwise, press any other normal key to continue ... ');
k := ReadKey;
Write (k);
IF k IN ['n', 'N'] THEN WATCH := FALSE;
IF k IN ['a', 'A'] THEN Halt (4);
NewLine;
NewLine;
END;
FUNCTION CommandProg (fn : STR128): STR128; {Separate prog name from switches.}
BEGIN
IF (Pos (#32, fn) > 0)
THEN CommandProg := Copy (fn, 1, (Pos (#32, fn) - 1))
ELSE CommandProg := fn;
END;
FUNCTION CommandTail (fn : STR128): STR128; {Separate prog switches from name.}
BEGIN
IF (Pos (#32, fn) > 0)
THEN CommandTail := Copy (fn, Pos (#32, fn), Length (fn))
ELSE CommandTail := '';
END;
FUNCTION RPad (bstr: STRING; len: BYTE): STRING;
BEGIN
WHILE (Length (bstr) < len) DO
bstr := bstr + #32;
RPad := bstr;
END;
FUNCTION RTrim (InStr: STRING): STRING;
BEGIN
WHILE (Length (InStr) > 0) AND (InStr [Length (InStr)] IN [#0, #9, #32]) DO
Dec (InStr [0]);
RTrim := InStr;
END;
FUNCTION LTrim (InStr: STRING): STRING;
BEGIN
WHILE (Length (InStr) > 0) AND (InStr [1] IN [#0, #9, #32]) DO
Delete (InStr, 1, 1);
LTrim := InStr;
END;
FUNCTION Trim (InStr: STRING): STRING;
BEGIN
Trim := RTrim (LTrim (InStr));
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 IsSwitch (sSwitch: STRING): BOOLEAN;
VAR
Return : BOOLEAN;
Param : STRING;
pc : BYTE;
BEGIN
Return := FALSE;
IF (ParamCount > 2) THEN
BEGIN
sSwitch := Upper (sSwitch);
FOR pc := 3 to ParamCount DO
IF (Return = FALSE) THEN
BEGIN
Param := Upper (ParamStr (pc));
IF (Pos ('/'+sSwitch, Param) > 0) OR (Pos ('-'+sSwitch, Param) > 0)
THEN Return := TRUE;
END;
END;
IsSwitch := Return;
END;
FUNCTION getFileExt (fn: STR128): 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: STR128): 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 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;
FUNCTION FilesExist: BOOLEAN;
VAR
FE: BOOLEAN;
NotVLabel: WORD;
DirInfo: SEARCHREC;
BEGIN
FE := FALSE;
NotVLabel := ReadOnly + Hidden + SysFile + Archive + Directory;
FindFirst ('*.*', NotVLabel, DirInfo);
WHILE (FE = FALSE) AND (DosError = 0) DO
BEGIN
IF (Copy (DirInfo.Name, 1, 1) <> '.') THEN
FE := TRUE;
FindNext (DirInfo);
END;
FilesExist := FE;
END;
FUNCTION GetFilePath (CONST PSTR: PATHSTR; VAR sDir: DIRSTR): PATHSTR;
VAR
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;
FUNCTION VerifyPath (tPath: STR128): STR128;
VAR
ArcPath, NewPath: STR128;
BEGIN
ArcPath := Trim (CommandProg (tPath)); { Verify tPath }
IF (Pos ('.', ArcPath) <= 0) THEN { if no extension, try COM/EXE }
BEGIN
NewPath := FSearch (ArcPath+'.com', GetEnv ('PATH'));
IF NewPath = '' THEN
NewPath := FSearch (ArcPath+'.exe', GetEnv ('PATH'));
END
ELSE
NewPath := FSearch (ArcPath, GetEnv ('PATH'));
IF (NewPath <> '')
THEN tPath := FExpand (NewPath) + CommandTail (tPath)
ELSE tPath := '';
VerifyPath := tPath;
END;
PROCEDURE EraseFile (CONST FileName : PATHSTR);
VAR
cFile : FILE;
BEGIN
IF IsFile (FileName) THEN BEGIN
Assign (cFile, FileName);
SetFAttr (cFile, 0);
Erase (cFile); CheckIO;
END;
END;
PROCEDURE EraseAllFiles;
VAR
JustFiles: WORD;
DirInfo : SEARCHREC;
BEGIN
JustFiles := ReadOnly + Hidden + SysFile + Archive;
FindFirst ('*.*', JustFiles, DirInfo);
WHILE DosError = 0 DO
BEGIN
EraseFile (DirInfo.Name);
FindNext (DirInfo);
END;
END;
PROCEDURE RemoveSubDirs; { Remove remnant subdirectories after processing. }
VAR
DirInfo: SEARCHREC;
BEGIN
FindFirst ('*.*', Directory, DirInfo);
WHILE DosError = 0 DO
BEGIN
IF IsDir (DirInfo.Name) AND (Copy (DirInfo.Name, 1, 1) <> '.') THEN
BEGIN
ChDir (DirInfo.Name); CheckIO;
RemoveSubDirs; { Continue recursion to any sub dirs. }
EraseAllFiles; { Now make sure current dir is empty. }
ChDir ('..'); { Step back to parent directory, } CheckIO;
RmDir (DirInfo.Name); { and remove the directory we were in.} CheckIO;
END;
FindNext (DirInfo);
END;
END;
PROCEDURE CheckExitCode (CONST eCommand: STR128);
BEGIN
IF (HeapMan.DosExitCode <> 0) THEN
BEGIN
NewLine;
WriteStr (#7+'*** WARNING! *** Compressor returned an error code!');
WriteStr ('FACT is setting QUIET mode OFF, and WATCH mode ON.');
NewLine;
WriteStr ('The command which preceded the compressor error was:');
NewLine;
WriteStr (eCommand);
NewLine;
WriteStr ('Advice: Unless you really need to fix something, let FACT continue. Wait for');
WriteStr ('FACT to finish and clean up after itself before you deal with this situation.');
NewLine;
QUIET := FALSE;
WATCH := TRUE;
Pause;
END;
END;
PROCEDURE StuffKeyBuffer (tKey: CHAR);
BEGIN
ASM
mov ah,05h
mov ch,1
mov cl, tKey
int 16h
END;
END;
PROCEDURE cRun (eCommand: STRING);
FUNCTION WhereX: BYTE; ASSEMBLER; {SWAG routine}
ASM
MOV AH, 3 {Ask For current cursor position}
MOV BH, 0 { On page 0 }
Int 10h { Return inFormation in DX }
Inc DL { Bios Assumes Zero-based. Crt.WhereX Uses 1 based }
MOV AL, DL { Return X position in AL For use in Byte Result }
END;
FUNCTION WhereY: BYTE; ASSEMBLER; {SWAG routine}
ASM
MOV AH, 3 {Ask For current cursor position}
MOV BH, 0 { On page 0 }
Int 10h { Return inFormation in DX }
Inc DH { Bios Assumes Zero-based. Crt.WhereY Uses 1 based }
MOV AL, DH { Return Y position in AL For use in Byte Result }
END;
PROCEDURE GotoXY (X, Y: BYTE); ASSEMBLER; {SWAG routine}
ASM
MOV DH, Y { DH = Row (Y) }
MOV DL, X { DL = Column (X) }
Dec DH { Adjust For Zero-based Bios routines }
Dec DL { Turbo Crt.GotoXY is 1-based }
MOV BH, 0 { Display page 0 }
MOV AH, 2 { Call For SET CURSOR POSITION }
Int 10h
END;
PROCEDURE WriteCharAtCursor (X: CHAR); {SWAG routine}
VAR
reg: REGISTERS;
BEGIN
reg. AH := $0A;
reg. AL := Ord (X);
reg. BH := $00; {* Display Page Number. * for Graphics Modes! *}
reg. CX := 1; {* Word for number of characters to write *}
Intr ($10, reg);
END;
PROCEDURE ClrEol; {DDA's routine}
VAR
NumCol: WORD ABSOLUTE $0040: $004A; { Number of CRT columns (1-based) }
X, Y, DistanceToRight: BYTE;
BEGIN
X := WhereX;
Y := WhereY;
DistanceToRight := NumCol - X;
Write ('': DistanceToRight);
WriteCharAtCursor (#32);
GotoXY (X, Y);
END;
VAR
X, Y: BYTE;
Prog: PATHSTR;
BEGIN
IF QUIET THEN
BEGIN
eCommand := eCommand + '>nul';
X := WhereX;
Y := WhereY;
Write ('Shelled out, running ', CommandProg (eCommand));
END;
Prog := Upper (getFileName (CommandProg (eCommand)));
IF Prog = 'AIN' THEN StuffKeyBuffer (#8);
{ If you change the following to Borland's DOS.Exec, }
{ don't forget to add "SwapVectors" before and after. }
DosError := Heapman.Execute (ComSpec, ' /c ' + eCommand);
IF QUIET THEN
BEGIN
GotoXY (X, Y);
ClrEol;
END;
END;
PROCEDURE Inform (info: STRING);
BEGIN
NewLine;
WriteLn ('Level ', RecursionLevel, '; executing following command line:');
WriteStr (info);
Pause;
END;
PROCEDURE RenameArchive (fName: PATHSTR; fExt: EXTSTR);
VAR
f: FILE;
BEGIN
Assign (f, fName + fExt);
Rename (f, fName + '.-' + Copy (fExt, 3, 2));
IF WATCH THEN
BEGIN
WriteStr ('Archive '+fName+fExt+' is being renamed to avoid destruction.');
WriteStr ('It has been renamed to '+fName + '.-' + Copy (fExt, 3, 2));
Pause;
END;
END;
(*
FUNCTION CheckAuthenticity (fName: PATHSTR; fExt: EXTSTR): BOOLEAN;
VAR
AV: BOOLEAN;
f: FILE;
c: CHAR;
BEGIN
AV := FALSE;
IF IsFile (fName+fExt) THEN
BEGIN
IF fExt = '.ARJ' THEN
BEGIN
cRun ('arj a -he1 '+fName+fExt+' nul');
IF (HeapMan.DosExitCode = 4) THEN
AV := TRUE;
END
ELSE
IF fExt = '.ZIP' THEN
BEGIN
Assign (f, fName);
Reset (f, 1);
Seek (f, 7); { Snarl... This isn't it, but I thought it was. }
BlockRead (f, c, 1);
Close (f);
IF ((Ord (c) SHR 1) AND 1) = 1 THEN
AV := TRUE;
END;
END;
CheckAuthenticity := AV;
END;
*)
PROCEDURE SetFileTime (fName: PATHSTR; ArcTime: LONGINT);
VAR
Arc: FILE;
BEGIN
IF IsFile (fName) THEN
BEGIN
Assign (Arc, fName);
Reset (Arc);
SetFTime (Arc, ArcTime);
Close (Arc);
END;
END;
PROCEDURE GetLatestFTime (VAR LatestFTime: LONGINT);
VAR
FileInfo: SEARCHREC;
BEGIN
FindFirst ('*.*', AnyFile, FileInfo);
WHILE DosError = 0 DO
BEGIN
IF IsDir (FileInfo.Name) AND (Copy (FileInfo.Name, 1, 1) <> '.')
THEN BEGIN
ChDir (FileInfo.Name);
GetLatestFTime (LatestFTime); { RECURSION! }
ChDir ('..');
END
ELSE
IF IsFile (FileInfo.Name) AND (FileInfo.Time > LatestFTime) THEN
LatestFTime := FileInfo.Time;
FindNext (FileInfo);
END;
END;
FUNCTION FindLatestFTime: LONGINT;
VAR
LatestFTime: LONGINT;
BEGIN
LatestFTime := 0;
GetLatestFTime (LatestFTime);
FindLatestFTime := LatestFTime;
END;
PROCEDURE RunCommandLine (fInfo: SEARCHREC; ReCompress: STR128);
VAR
ArcTime: LONGINT;
aPos: BYTE;
fn,
ReCompressT: STRING;
e: STRING[5];
f: FILE;
BEGIN
ArcTime := FindLatestFTime;
IF NewExt = '.ZIP' THEN
BEGIN
IF (RecursionLevel > 1)
THEN e := ' -e0 ' { STORING *nested* ZIP files }
ELSE e := ' -ex '; { yields smaller ZIPs overall }
END
ELSE e := #32;
fn := getFileName (fInfo.Name) + NewExt;
aPos := Pos ('%A', Upper (ReCompress));
IF (aPos > 0) THEN
BEGIN
ReCompressT := ReCompress;
Delete (ReCompressT, aPos, 2);
Insert (fn, ReCompressT, aPos);
END
ELSE
ReCompressT := ReCompress + e + fn + #32 + '*.*';
IF WATCH THEN Inform (ReCompressT);
cRun (ReCompressT);
SetFileTime (fn, ArcTime);
Assign (f, fn);
Rename (f, '..\' + fn); { Move new archive to parent directory }
IF NewExt <> '.JRC' THEN CheckExitCode (ReCompressT);
RemoveSubDirs;
EraseAllFiles;
ChDir ('..'); CheckIO;
IF IsDir (fInfo.Name) THEN RmDir (fInfo.Name); CheckIO;
END;
PROCEDURE CompressDirs (ReCompress: STR128);
{ "Preserve" subdirectories by archiving individually. }
VAR
FileInfo: SEARCHREC;
BEGIN
FindFirst ('*.*', Directory, FileInfo);
WHILE DosError = 0 DO
BEGIN
IF IsDir (FileInfo.Name) AND (Copy (FileInfo.Name, 1, 1) <> '.') THEN
BEGIN
ChDir (FileInfo.Name); CheckIO;
CompressDirs (ReCompress);
RunCommandLine (FileInfo, ReCompress);
END;
FindNext (FileInfo);
END;
END;
PROCEDURE ReCompressThem (DirName, ReCompress: STR128; DirsCompressed: BOOLEAN);
VAR
FileInfo: SEARCHREC;
ArcTime: LONGINT;
ReCompressT: STR128;
fn: STR128;
BEGIN
FindFirst (DirName, Directory, FileInfo);
WHILE DosError = 0 DO
BEGIN
IF IsDir (FileInfo.Name) AND (Copy (FileInfo.Name, 1, 1) <> '.') THEN
BEGIN
fn := FExpand (getFileName (FileInfo.Name));
ChDir (FileInfo.Name); CheckIO;
EraseFile (fn + NewExt); { Erase old version of this }
{ ┌───────────────────────────────────────────────────────────┐ }
{ │ Convert any extracted subdirs to individual archives. │ }
{ │ │ }
{ │ } IF NOT DirsCompressed THEN CompressDirs (ReCompress); { │ }
{ │ │ }
{ │ ONLY for compressors which don't preserve subdirectories! │ }
{ └───────────────────────────────────────────────────────────┘ }
RunCommandLine (FileInfo, ReCompress);
FindNext (FileInfo);
END;
END;
Dec (RecursionLevel);
END;
PROCEDURE DeCompressThem (ArcName, ReCompress: STR128; DirsCompressed: BOOLEAN);
CONST
DirExt = '.└┬┘';
VAR
FileInfo: SEARCHREC;
fn,
DeCompressT: STR128;
FileID: EXTSTR;
aPos,
ArcPos: BYTE;
ftc: STRING[30]; { Files To Compress }
Changed: BOOLEAN; { Have we changed the directory already? }
Y, M, D, W : WORD;
h1, h2, m1, m2, s1, s2, o1, o2: WORD;
aName: PATHSTR;
fExt: EXTSTR;
CmdLine: STR128;
BEGIN
Inc (RecursionLevel);
IF RecursionLevel = 1 THEN
BEGIN
ClrScr;
WriteStr ('~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~');
WriteStr ('Starting conversion of: ' + FExpand (ArcName));
WriteStr ('Converting to extension: ' + NewExt);
IF WATCH
THEN Pause
ELSE NewLine;
END;
FindFirst (ArcName, AnyFile, FileInfo);
WHILE DosError = 0 DO
BEGIN
IF (NOT ONE) AND IsDir (FileInfo.Name) THEN {Check for archives in subdirs}
BEGIN
IF (Copy (FileInfo.Name, 1, 1) <> '.') THEN
BEGIN
ChDir (FileInfo.Name); CheckIO;
DeCompressThem ('*.*', ReCompress, DirsCompressed);
{ Recursively cycle through subdirectories. }
ChDir ('..'); CheckIO;
END
END
ELSE BEGIN { If we have an actual file, continue. }
fn := FExpand (getFileName (FileInfo.Name));
FileID := Upper (getFileExt (FileInfo.Name));
ArcPos := Pos (FileID+'.', ArcString);
IF (FileID <> '') AND (ArcPos > 0) THEN { ELSE = Skip non-archives }
BEGIN
IF IsDir (fn + DirExt) THEN { Skip duplicates of archives. }
BEGIN
IF FileID = NewExt THEN
ReNameArchive (fn, FileID);
END
ELSE
BEGIN
aName := FExpand (FileInfo.Name);
DeCompressT := ArcArray[ArcPos].DeCompress;
aPos := Pos ('%A', Upper (DeCompressT));
IF (aPos > 0) THEN
BEGIN
Delete (DeCompressT, aPos, 2);
Insert (aName, DeCompressT, aPos);
END
ELSE
DeCompressT := DeCompressT + #32 + aName + ' *.*';
IF WATCH THEN Inform (DeCompressT);
GetDate (Y, M, D, W);
SetDate (1980, 1, 1); { Set all directory dates to Jan. 1st, 1980 }
MkDir (fn + DirExt); CheckIO;
ChDir (fn + DirExt); CheckIO;
GetTime (h1, m1, s1, o1);
cRun (DeCompressT);
SetDate (Y, M, D);
GetTime (h2, m2, s2, o2); { Adjust date if we just passed midnight. }
IF (h2 < h1) THEN
BEGIN
m2 := m2 + ((s2 + 1) div 60);
s2 := (s2 + 1) mod 60;
SetTime (23, 59, 59, 30);
IF NOT QUIET THEN
WriteStr ('Adjusting for midnight ...');
Delay (900);
SetTime (h2, m2, s2, o2);
END;
Changed := FALSE;
IF FilesExist THEN
BEGIN { Erase archives only if decompressed and not wanted. }
IF FileID <> '.JRC' THEN
CheckExitCode (DeCompressT);
IF (RecursionLevel > 1) THEN
EraseFile ('..\' + FileInfo.Name)
ELSE
IF (RecursionLevel = 1) AND DelOriginal THEN
BEGIN
CmdLine := Upper (STRING (Ptr (PrefixSeg, $0080)^));
fExt := Upper (getFileExt (ArcName));
IF (Length (fExt) > 0) AND (NOT (Pos (#32+fExt, CmdLine) > 0)) THEN
FileList^.DelWhenDone := TRUE;
END;
IF NOT ONE THEN
DeCompressThem ('*.*', ReCompress, DirsCompressed);
{ Check for nested archives }
END
ELSE BEGIN
Changed := TRUE;
ChDir ('..'); CheckIO;
RmDir (fn + DirExt); CheckIO;
END;
IF NOT Changed THEN
BEGIN
ChDir ('..'); CheckIO;
END;
END;
END;
END;
FindNext (FileInfo); { Continue for any more specified archives }
END;
ReCompressThem ('*' + DirExt, ReCompress, DirsCompressed);
{ Clean up decompressed files }
END;
PROCEDURE DisplayCompressorList;
VAR
number,
Index, I2: BYTE;
BEGIN
number := 0;
Index := 1;
WHILE (Index < (Length (ArcString) - 1)) AND WATCH DO
BEGIN
IF ArcString [Index] = '.' THEN
BEGIN
I2 := Index;
Inc (number);
Write ('#', number, ': extension is ');
REPEAT
Inc (Index);
Write (ArcString [Index]);
UNTIL ArcString [Index+1] = '.';
NewLine;
WriteStr ('ReCompression command line: ' + ArcArray [I2].ReCompress);
WriteStr ('DeCompression command line: ' + ArcArray [I2].DeCompress);
WriteLn ('Subdirectories compressed: ', ArcArray [I2].DirsCompressed);
Pause;
END;
Inc (Index);
END;
END;
PROCEDURE BuildCompressorList;
LABEL
NextArc;
VAR
IniPath : PATHSTR; {IniPath, etc fully qualified pathnames of *.Ini files}
IniDir : DIRSTR;
IniName : NAMESTR;
IniExt : EXTSTR;
IniFile: TEXT;
IniLine,
IniVar: PATHSTR;
ArcPos,
EqualPos: BYTE;
Prefix: STRING[2];
Command, DrComp,
DeComp, ReComp: STR128;
DONE: BOOLEAN;
BEGIN
FSplit (FExpand (ParamStr(0)), IniDir, IniName, IniExt); { break up path }
IniPath := IniDir + IniName + '.INI';
ArcString := '';
IF NOT IsFile (IniPath) THEN { MUST HAVE a .INI file, no defaults. }
Halt (1)
ELSE
BEGIN
NewLine;
WriteStr ('Validating compressors defined in FACT.INI: ');
Assign (IniFile, IniPath);
Reset (IniFile); CheckIO;
WHILE NOT SeekEoF (IniFile) DO { Find compressor definitions. }
BEGIN
ReadLn (IniFile, IniLine);
IF (Length (IniLine) > 4) AND (IniLine [1] <> ';')
AND (Upper (Copy (IniLine, 1, 4)) = 'EXT=') THEN
BEGIN
IniVar := Trim (Upper (Copy (IniLine, 5, Length (IniLine) - 4)));
DeComp := ''; ReComp := ''; DrComp := '';
DONE := SeekEof (IniFile);
WHILE NOT DONE DO { Compile extensions, plus compressor data. }
BEGIN
ReadLn (IniFile, IniLine);
IF SeekEoF (IniFile) THEN DONE := TRUE;
EqualPos := Pos ('=', IniLine);
IF (EqualPos > 0) THEN
Command := Copy (IniLine, EqualPos+1, Length (IniLine)-EqualPos);
Prefix := Upper (Copy (IniLine, 1, 2));
IF (Prefix = 'DE') THEN DeComp := Command ELSE
IF (Prefix = 'RE') THEN ReComp := Command ELSE
IF (Prefix = 'DC') THEN DrComp := Command ELSE
GOTO NextArc; { Abort definition if anything unexpected appears.}
IF (DeComp <> '') AND (ReComp <> '') AND (DrComp <> '')
THEN DONE := TRUE;
END;
IF (DeComp <> '') AND (ReComp <> '') THEN { Now validate definition. }
BEGIN
DeComp := VerifyPath (DeComp);
ReComp := VerifyPath (ReComp);
IF (DeComp <> '') AND (ReComp <> '') THEN
BEGIN {Add validated data to array.}
IF (IniVar = 'LZS') AND QUIET THEN
BEGIN
ReComp := ReComp + ' /m';
DeComp := DeComp + ' /m';
END;
IF (IniVar = 'LZH') AND QUIET THEN
BEGIN
IF NOT (Pos (ReComp, 'n2') > 0) THEN ReComp := ReComp + ' -n2';
IF NOT (Pos (DeComp, 'n2') > 0) THEN DeComp := DeComp + ' -n2';
END;
ArcPos := 1+Length (ArcString);
ArcArray [ArcPos].ReCompress := ReComp;
ArcArray [ArcPos].DeCompress := DeComp;
ArcArray [ArcPos].DirsCompressed :=
(Length (DrComp) > 0) AND (Upcase (DrComp[1]) = 'Y');
ArcString := ArcString + '.' + IniVar;
Write (' .' + RPad (IniVar, 3));
END;
END;
END;
NextArc:
END; { loop back to read another line }
Close (IniFile);
NewLine; NewLine;
END;
IF ArcString <> '' THEN ArcString := ArcString + '.';
IF WATCH THEN DisplayCompressorList;
END;
PROCEDURE BuildFileList (fPath: PATHSTR);
VAR
nFiles: WORD;
OneArc: SEARCHREC;
Anchor, TempNode: FList;
s: STRING[2];
BEGIN
nFiles := 0;
Anchor := NIL;
FileList := NIL;
FindFirst (fPath, Archive, OneArc);
WHILE DosError = 0 DO { Add to linked list }
BEGIN
IF (Pos (NewExt+'.', ArcString) > 0) THEN {If Arc type is defined properly}
BEGIN
Inc (nFiles);
New (TempNode);
TempNode^.ArcFName := OneArc.Name;
TempNode^.DelWhenDone := FALSE;
TempNode^.Next := NIL;
IF FileList <> NIL
THEN FileList^.Next := TempNode
ELSE Anchor := TempNode;
FileList := TempNode;
END;
FindNext (OneArc);
END;
FileList := Anchor;
IF (nFiles = 0) THEN Halt (2);
IF (nFiles <> 1) THEN s := 'es' ELSE s := 'e';
WriteLn ('Found ', nFiles, ' fil'+s+' which may be converted.');
NewLine;
IF WATCH THEN
BEGIN
WriteLn ('RAM leftover for compressors: ', MemAvail);
Pause;
END;
END;
PROCEDURE ProcessFiles;
{ Traverse linked list, processing each file. }
VAR
TempNode: FList;
pNum: BYTE;
ArcPos: BYTE;
ReCompress: STR128; { Command line being used to compress archives. }
DirsCompressed: BOOLEAN; { Does this compressor archive subdirectories? }
fExt: EXTSTR;
nArchives,
nFiles: WORD;
s1, s2: STRING[2];
BEGIN
nFiles := 0;
nArchives := 0;
WHILE FileList <> NIL DO BEGIN
Inc (nArchives);
FOR pNum := 2 TO ParamCount DO { Convert spec. archives to all others. }
BEGIN
fExt := getFileExt (FileList^.ArcFName);
IF (fExt <> '') AND (Pos (fExt+'.', ArcString) > 0) THEN
BEGIN
NewExt := Upper (ParamStr (pNum));
ArcPos := Pos (NewExt+'.', ArcString);
IF (NewExt <> '') AND (ArcPos > 0) THEN { Only convert TO those defined.}
WITH FileList^ DO BEGIN
Inc (nFiles);
ReCompress := ArcArray[ArcPos].ReCompress;
DirsCompressed := ArcArray[ArcPos].DirsCompressed;
RecursionLevel := 0;
DeCompressThem (ArcFName, ReCompress, DirsCompressed);
END;
END;
END;
IF FileList^.DelWhenDone THEN
EraseFile (FileList^.ArcFName);
TempNode := FileList;
FileList := FileList^. Next; { Clean up after ourselves. }
Dispose (TempNode);
END;
IF (nFiles = 0) THEN Halt (3);
IF nArchives <> 1 THEN s1 := 'es' ELSE s1 := 'e';
IF nFiles <> 1 THEN s2 := 'ns' ELSE s2 := 'n';
NewLine;
WriteLn ('Considered ', nArchives, ' fil'+s1+', and attempted ', nFiles, ' conversio'+s2+'.');
END;
PROCEDURE AnalyzeCommandLine;
BEGIN
IF (ParamCount < 2) THEN Halt (255);
ComSpec := GetEnv ('COMSPEC');
IF ComSpec = '' THEN Halt (6);
DelOriginal := IsSwitch ('d'); { Original archive deleted? }
QUIET := IsSwitch ('q'); { Compressor output suppressed? }
WATCH := IsSwitch ('w'); { Pause after info messages? }
ONE := IsSwitch ('1'); { Only convert primary archive? }
IF WATCH THEN BEGIN
NewLine;
WriteLn ('DEL=', DelOriginal, ' QUIET=', QUIET, ' WATCH=', WATCH, ' ONE=', ONE);
Pause;
END;
END;
VAR
StartDir, fDir: DIRSTR;
BEGIN
SavedExitProc := ExitProc;
ExitProc := @CustomExit; { Insert custom exit procedure. }
AnalyzeCommandLine; { Set global variables. }
BuildCompressorList; { Build compressor definition list. }
BuildFileList (GetFilePath (ParamStr (1), fDir)); { Build list of files. }
GetDir (0, StartDir); { Save starting directory. }
ChDir (Copy (fDir,1,Length(fDir)-1)); { Change to dir where files are. }
ProcessFiles; { Traverse linked list, processing each archive. }
ChDir (StartDir); { Restore starting directory. }
END.