www.pudn.com > lzss.rar > LZ.~DPR
{
SAMPLE PROGRAM TO DEMONSTRATE THE USE OF THE CHIEFLZ v1.00 PACKAGE.
THIS PROGRAM WILL COMPILE FOR THE FOLLOWING PLATFORMS;
Dos Real mode - TP7, BP7
Dos DPMI - BP7, BPW
Win16 - BPW, TPW, Delphi 1.x
Win32 - Delphi 2.0x
}
Program LZ;
{$I LZDefine.inc}
{this (aDLL) is now defined (or not) in LZDEFINE.INC}
{$ifdef aDLL}
{$define ExplicitLink} {use explicit linking of DLL}
{$endif aDLL}
{$ifdef Windows}
{$ifdef Win32}
{$MINSTACKSIZE $00004000}
{$MAXSTACKSIZE $00100000}
{$IMAGEBASE $00400000}
{$APPTYPE Console}
{$else Win32}
{$M 20000, 1024}
{$F+} { Force Far-Calls }
{$K+} { Use smart call-backs for LZReport, etc. }
{$endif Win32}
{$endif Windows}
{$ifdef Delphi}
{
Link in the Delphi-generated resource file ...
}
{$R *.RES}
{$endif Delphi}
Uses
{$ifdef Win32}
{$ifdef aDLL}
ShareMem, { ChiefLZ.DLL exports long-strings ...!!! }
{$ifdef ExplicitLink}
LZExplic in 'LZExplic.pas',
{$else ExplicitLink}
LZImplic in 'LZImplic.pas',
{$endif ExplicitLink}
{$else aDLL}
ChiefLZ in 'ChiefLZ.pas',
{$endif aDLL}
{$else Win32}
{$ifdef aDLL}
{$ifdef ExplicitLink}
LZExplic,
{$else ExplicitLink}
LZImplic,
{$endif ExplicitLink}
{$else aDLL}
ChiefLZ,
{$endif aDLL}
{$endif Win32}
{$ifdef Delphi}
SysUtils,
{$endif Delphi}
{$ifdef Win32}
Windows,
{$else Win32}
{$ifdef Windows}
{$ifndef DPMI}
WinCRT,
{$endif DPMI}
{$ifndef Delphi}
WinDOS, Strings,
{$endif Delphi}
{$else Windows}
Dos, Strings,
{$endif Windows}
{$endif Win32}
ChfTypes,
ChfUtils;
VAR
AutoReplaceAll: boolean;
{$ifdef Win32}
procedure FlushInputBuffer;
begin
FlushConsoleInputBuffer(GetStdHandle(STD_INPUT_HANDLE))
end;
function ReadKey32: Char;
var
NumRead: Integer;
HConsoleInput: THandle;
InputRec: TInputRecord;
begin
HConsoleInput := GetStdHandle(STD_INPUT_HANDLE);
while not ReadConsoleInput(HConsoleInput,
InputRec,
1,
NumRead) or
(InputRec.EventType <> KEY_EVENT) do;
Result := InputRec.KeyEvent.AsciiChar
end;
{$endif Win32}
{$ifdef Delphi}
function TimeToStr(const l: LongInt): string;
begin
Result := FormatDateTime('dd/mm/yy hh:nna/p',FileDateToDateTime(l))
end;
{$else}
Function TimeToStr(Const L : Longint):String;
Type
ElementStr = String[10];
procedure FormatElement(Num: word; var EStr: ElementStr);
begin
Str(Num:2, EStr);
if Num < 10 then
EStr[1] := '0'
end;
Var
Result : String[25];
{$ifdef Windows}
Var
T : TDateTime;
{$else}
Var
T : DateTime;
{$endif Windows}
Var
Dd,Mm,Yy,
Hr,Min : ElementStr;
Begin
UnpackTime(L, T);
FormatElement(T.Day, Dd);
FormatElement(T.Month, Mm);
Str(T.Year:4, Yy);
FormatElement(T.Hour, Hr);
FormatElement(T.Min, Min);
Result := Dd+'/'+Mm+'/'+Yy+' '+Hr+':'+Min{+':'+Sec};
TimeToStr := Result;
End;
{$endif Delphi}
{------------------------------------------------------------}
{///////////////////////////////////////////}
Function Confirm(const fRec: TLZReportRec; Const aDest:String):TLZReply;
{$IFDEF Win16} {$ifdef aDLL} export {$else} far {$endif}; {$ENDIF}
{procedure to ask question if target file exists already}
Var
Ch:Char;
Begin
if AutoReplaceAll then
begin
Confirm := LZYes;
Exit
end;
With fRec
do begin
Writeln('Target File Exists!!!');
Writeln('File Name : ',Names);
Writeln('File Date : ',TimeToStr(Times));
Writeln('Compressed: ',Sizes);
Writeln('Real Size : ',uSizes);
Writeln('Version : ',FileVersion);
End;
Repeat
Write('OVERWRITE FILE : ', aDest, ' ? (Yes/No/All/Quit) [Y/N/A/Q] : ');
Readln(Ch);
Until Upcase(Ch) in ['Y','N','A','Q'];
Case UpCase(Ch) of
'A' : begin
Confirm := LZYes;
AutoReplaceAll := True {overwrite all others}
end;
'N' : begin
Confirm := LZNo;
Writeln('Skipping file : ',aDest)
end;
'Q' : Confirm := LZQuit { stop all processing and Exit }
else
Confirm := LZYes { Ch = 'Y' }
End; {Case}
End;
{///////////////////////////////////////////}
Procedure DeMyRep(Const aName: TLZReportRec{String}; Const aSize: Longint);
{$IFDEF Win16} {$ifdef aDLL} export {$else} far {$endif}; {$ENDIF}
{procedure to show progress}
Begin
if (Length(aName.Names) > 0) and (aSize=-1) then
Write('Processing file: ',aName.Names,' ')
else if (asize=-2) then
Writeln
else if aSize > 0 then
Write('.')
End;
{-----------------------------------------------}
function MyRename(var FName: string): boolean;
{$ifdef Win16} {$ifdef aDLL} export {$else} far {$endif}; {$endif}
var
Ch: Char;
{$ifndef Delphi}
var Result: boolean;
{$endif}
begin
Write( 'Cannot overwrite ', FName, ' - Rename? [Y/N]' );
Readln(Ch);
Result := UpCase(Ch) = 'Y';
if Result then
begin
Write( 'New name: ' );
Readln(FName)
end;
{$ifndef Delphi}
MyRename := Result
{$endif}
end;
{-----------------------------------------------}
Procedure Syntax;
Begin
Writeln('LZSS Compressor: by Dr A Olowofoyeku (the African Chief), and Chris Rankin.');
writeln;
WriteLn('Usage: LZ [OutSpec] [[/U /A[/R[1]] /X /V]]');
Writeln;
Writeln('no switch = compress a single file (InSpec) to OutSpec');
Writeln('e.g. LZ BIG.EXE SMALL.LZZ');
Writeln;
Writeln(' /U = decompress a single file (InSpec) to OutSpec');
Writeln(' e.g. LZ SMALL.LZZ BIG.EXE /U');
Writeln('');
Writeln(' /A = compress and archive the files (InSpec) into archive (OutSpec)');
Writeln('e.g. LZ C:\TEMP\*.* TEMP.LZZ /A');
Writeln(' Max = ' + {$ifdef Win32} '2048'
{$else} '600'
{$endif} + ' files in archive');
Writeln;
Writeln(' /R = recurse through directory structure (for archives)');
Writeln(' /R1 = recurse into 1st level directories (for archives)');
Writeln('e.g. LZ C:\TEMP\*.* TEMP.LZZ /A /R');
Writeln;
Writeln(' /X = decompress an LZ archive (InSpec) into directory (OutSpec)');
Writeln('e.g. LZ TEMP.LZZ C:\TEMP /X');
Writeln;
Writeln(' /V = show contents of an LZ archive (InSpec)');
Writeln('e.g. LZ TEMP.LZZ /V');
{$ifdef Windows}
{$ifdef Win32}
{
FlushInputBuffer; // Use these if running within IDE to
ReadKey32; // prevent console window from disappearing
}
{$else}
{$ifndef DPMI}
ReadKey;
DoneWincrt;
{$endif DPMI}
{$endif Win32}
{$endif Windows}
Halt(1);
End;
{-----------------------------------------------}
{$ifNdef aDLL}
{example of using the LZ object}
Procedure UseObj;
Var
o:LZObj;
l:longint;
Param:string;
Begin
o {$ifdef Delphi} := LZObj.Create
{$else} .Init
{$endif}(ParamStr(1),ParamStr(2));
{$ifdef Delphi}
try
o.QuestionProc := Confirm;
o.ReportProc := DeMyRep;
{$else}
o.SetQuestionProc(Confirm);
o.SetReportProc(DeMyRep);
{$endif}
Param := Uppercase(ParamStr(3));
if (Param='/U') or (Param='-U') then
l:=o.Decompress
else
l:=o.Compress;
{$ifdef Delphi}
finally
o.Free
end;
{$else}
o.Done;
{$endif}
Writeln(l);
Halt;
End;
{$Endif aDLL}
{///////////////////////////////////////////}
function GetCompressionRatio(const Comp, Orig: LongInt): LongInt;
begin
if Orig = 0 then
GetCompressionRatio := 0 { 0%, on the grounds that the file }
else { is still its original size ... }
GetCompressionRatio := 100 - ( (100*Comp) div Orig )
end;
{///////////////////////////////////////////}
{///////////////////////////////////////////}
{///////////////////////////////////////////}
{///////////////////////////////////////////}
var
ReadProc,WriteProc,UserParam: TLZPathStr;
p: {$ifdef Win32} string;
{$else} array[0..79] of Char;
{$endif}
i:integer;
j,k:longint;
X:PChiefLZArchiveHeader;
LZRecurseDirs: TLZRecurse;
Begin
{$ifdef Windows}
{$ifndef Win32}
{$ifndef DPMI}
StrPCopy(WindowTitle, 'Sample ChiefLZ program ');
ScreenSize.x:=80;
ScreenSize.y:=250;
WindowOrg.x := 1;
WindowOrg.y := 1;
{$endif DPMI}
{$endif Win32}
{$endif Windows}
if ParamCount < 2 then
begin
Syntax;
end;
{$ifdef ExplicitLink}
{$ifdef Win32}
if not LoadChiefLZDLL('') then
begin
Writeln('ChiefLZ Error : cannot load ChiefLZ.DLL');
Halt
end;
{$else Win32}
i := LoadChiefLZDLL(''{'MYDLL.DLL'});
if i <> 0 then begin
Writeln('ChiefLZ Error : cannot load ChiefLZ.DLL');
Writeln('Error Code : ',i);
Halt;
end;
{$endif Win32}
Writeln('ChiefLZ DLL loaded successfully. Its DLL handle is: ',GetChiefLZDLLHandle);
Writeln('Working now ... ');
{$endif ExplicitLink}
{
UseObj;
Halt;
}
ReadProc := ParamStr(1);
WriteProc := ParamStr(2);
UserParam := Uppercase(ParamStr(3));
AutoReplaceAll := False; {confirm for each file}
if (Uppercase(ParamStr(2))='-V') or
(Uppercase(ParamStr(2))='/V') then begin
if not IsChiefLZArchive({$ifdef Win32} ReadProc
{$else} @ReadProc[1]
{$endif})
then begin
Writeln(ReadProc,' is not a ChiefLZ archive!');
{$ifdef ExplicitLink}
If UnloadChiefLZDLL
then Writeln('I have unloaded the ChiefLZ.DLL');
{$endif ExplicitLink}
Halt;
end;
New(X);
{$ifdef Win32}
try
{$endif}
GetChiefLZArchiveInfo({$ifdef Win32} ReadProc
{$else Win32} Str2PChar(ReadProc)
{$endif Win32}, X^);
j:=0;k:=0;
Writeln('ChiefLZ archive file: ',ReadProc);
Writeln('ChiefLZ archive size: ',
GetChiefLZArchiveSize({$ifdef Win32} ReadProc
{$else Win32} Str2PChar(ReadProc)
{$endif Win32}),
' bytes');
Writeln(' Real Size LZ Size Ratio Date Time Version FileName');
Writeln('------------------------------------------------------------------');
for i := 1 to X^.Count do
with X^.Files[i] do
begin
inc(j, Sizes);
inc(k, uSizes);
If IsDir then
Write({ Names:13,}
'':10,
0:10,
0:6 )
else
Write( {Names:13,}
uSizes:10,
Sizes:10,
GetCompressionRatio(Sizes,uSizes):6 );
Write( '% ',
TimeToStr(Times),
' ', FileVersion:8,
' ',GetFullLZName(X^,i) );
if IsDir then
Writeln('\')
else
Writeln
end {for i};
Writeln;
Writeln('Number of Files = ',X^.Count);
Writeln('Compressed Size = ',j,' bytes');
Writeln('Expanded Size = ',k,' bytes');
Writeln('Compression Ratio = ', GetCompressionRatio(j,k),'%');
{$ifdef Win32}
finally
{$endif}
Dispose(X);
{$ifdef Win32}
end
{$endif}
end
else
if (UserParam = '/X') or (UserParam = '-X') then begin
writeln(LZDearchive({$ifdef Win32} ReadProc, WriteProc,
{$else} Str2PChar(ReadProc), Str2PChar(WriteProc),
{$endif} Confirm, DeMyRep, MyRename))
end else
if (UserParam = '/A') or (UserParam = '-A') then begin
UserParam := Uppercase(ParamStr(ParamCount));
if (UserParam = '-R') or (UserParam = '/R') then
LZRecurseDirs := LZFullRecurse
else if (UserParam = '-R1') or (UserParam = '/R1') then
LZRecurseDirs := LZRecurseOnce
else
LZRecurseDirs := LZNoRecurse;
writeln(LZArchive({$ifdef Win32} ReadProc, WriteProc
{$else} Str2PChar(ReadProc), Str2PChar(WriteProc)
{$endif}, LZRecurseDirs, DeMyRep))
end else
if (UserParam = '/U') or (UserParam = '-U') then
begin
writeln(LZDecompress({$ifdef Win32} ReadProc, WriteProc,
{$else} Str2PChar(ReadProc), Str2PChar(WriteProc),
{$endif} Confirm, DemyRep));
{$ifdef Win32} p := GetChiefLZFileName(ReadProc);
{$else} GetChiefLZFileName(Str2PChar(ReadProc), p);
{$endif}
Writeln('Filename in header: ',p);
writeln('FileSize in header: ',
GetChiefLZFileSize({$ifdef Win32} ReadProc
{$else} Str2PChar(ReadProc)
{$endif}) );
end
else
if ParamStr(2)= '/1' then begin
LZCompressEx({$ifdef Win32} ReadProc,
{$else} Str2PChar(ReadProc),
{$endif} Confirm,DeMyRep);
end else
if ParamStr(2)= '/2' then begin
LZDecompressEx({$ifdef Win32} ReadProc,
{$else} Str2PChar(ReadProc),
{$endif} Confirm,DeMyRep);
end
else begin
writeln(LZCompress({$ifdef Win32} ReadProc, WriteProc,
{$else} Str2PChar(ReadProc), Str2PChar(WriteProc),
{$endif} Confirm, DeMyRep));
end;
{$ifdef ExplicitLink}
Writeln;
If UnloadChiefLZDLL then
Writeln('I have successfully unloaded the ChiefLZ DLL')
else
Writeln('Error trying to unloaded the ChiefLZ DLL');
Writeln('Its DLL handle is: ',GetChiefLZDLLHandle);
{$endif ExplicitLink}
{$ifdef Windows}
{$ifdef Win32}
{
FlushInputBuffer; // Use these if running within the IDE
ReadKey32; // to prevent console window disappearing
}
{$else}
{$ifndef DPMI}
ReadKey;
DoneWincrt;
{$endif DPMI}
{$endif Win32}
{$endif Windows}
End.