lz.pas

delhpi下lzss加密算法源码及例子

{
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 <InSpec> [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,}
                   '<DIR>':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.