chieflz.pas

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

  LZDone
{$endif}
End; { LZCompress }
{/////////////////////////////////////////////////////////}
{/////////////////////////////////////////////////////////}
{/////////////////////////////////////////////////////////}
Function LZDecompress({$ifdef Win32} Source, Dest:  string
                      {$else} const aSource, aDest: PChar
                      {$endif};
                      LZQuestion: TLZQuestionFunc;
                      aProc:      TLZReportProc):LongInt;
{$ifdef aDLL} {$ifdef Win32} stdcall
              {$else Win32}  export 
              {$endif Win32};
{$endif aDLL}

Var
f     : TLZHeader;
hT    : LongInt;
RepRec: TLZReportRec;
IsComp: Boolean;

{$ifndef Win32}
Source,
UpSource,
Dest    : TLZPathStr;
OldFMode: Byte;
LZReply : TLZReply;
{$endif}
p    : {$ifdef Win32} string;
       {$else}        array[0..79] of Char;
       {$endif}

Begin

{$ifDef aDLL}
  If IsLZInitialized then
  {$ifdef Win32}
    RaiseError(EChiefLZDLL,SBusyChief);
  {$else}
    begin
      LZDecompress := -20;  {already busy}
      Exit
    end
  {$endif};
{$endif aDLL}

  aRead := 0;
  aWrite:=0;

  if not LZInit then
  {$ifdef Win32}
    RaiseError(EChiefLZError,SInitFailed);
  {$else}
    begin
      LZDecompress := -10;  {unable to init}
      Exit
    end;
  {$endif}

{$ifdef Win32}
  try { finally }

  if (Length(Source)=0) or (Length(Dest)=0) then
    RaiseError(EChiefLZCompress,SInvalidParams);

  Source := ExpandFileName(Source);
  Dest   := ExpandFileName(Dest);
{
  Do case-insensitive comparison of full pathnames ...
}
  if AnsiCompareText(Source, Dest) = 0 then
    RaiseErrorStr(EChiefLZCompress,SSameFileName,Source);

{$else}

  Source   := StrPas(aSource);
  UpSource := Uppercase(Source);
  Dest     := StrPas(aDest);
  If (Length(Source)=0) or (Length(Dest)=0)
        or (UpSource=Uppercase(Dest))
  then
    LZDecompress := -11
  else begin

{$endif}

  {see if source file exists}
  {$ifdef Win32}
    p := '';
  {$else}
    p[0] := #0;
  {$endif}

    If Not FileExists(Source) then {look for name ending with MyLZMarker}
    begin
       Source := GetLZMarkedName(Source);
{
  Win32 will raise the correct exception automatically when
  GetChiefLZFileName() attempts to open Source ...
}
     {$ifdef Win32}

       p := GetChiefLZFileName(Source);
       if AnsiCompareText(ExtractFileName(p),
                          ExtractFileName(Source)) <> 0 then
         RaiseErrorStr(EChiefLZCompress,SWrongCompressedFile,p);

     {$else}

       If Not FileExists(Source) then {source file not found}
         begin
           LZDecompress := -12;
           LZDone;
           Exit
         end;

       GetChiefLZFileName(Str2PChar(Source), p); {read header}
       If (ExtractFileName(Uppercase(StrPas(p)))
            <> ExtractFileName(UpSource)) {wrong uncompressed file}
       then begin
          LZDecompress := -3; {wrong file}
          LZDone;
          Exit
        end;
     {$endif}
    end;

    {not FileExists}
  {||||||||}
  hT := sFTime(Source);

  {$ifdef Win32}

  AssignFile(InFile, Source);
  FileMode := fmOpenRead; { Win32 only allows 0 <= FileMode <= 2 }
  Reset(InFile, 1);       { However, share access is FILE_SHARE_READ }
  try { finally }

  {$else Win32}

  Assign(InFile, Source);
  OldFMode := FileMode;
  FileMode := (fmOpenRead or fmShareDenyWrite); {using these constants causes problems!}
  Reset(InFile, 1);                         { Only if file is already open for       }
  FileMode := OldFMode;                     { *writing* to by another process.       }
                                            { If a write happens during decomression }
  if IOResult <> 0 then                     { then the decompressed file is worthless}
    LZDecompress := -12 {can't open source}
  else begin

  {$endif Win32}

  IsComp := IsMyLZFile(InFile, f);

{||| does target file exist already? ||||}
  If FileExists(Dest) then begin
    with RepRec do
      If IsComp then
        begin {send details of Source(compressed) file}
          Names  := {AddBackSlash(ExtractFilePath(Source))+}f.fName{Source};
          Sizes  := f.cSize;
          uSizes := f.uSize;
          Times  := f.fTime;
          FileVersion := f.Version;
        end
      else begin
        Names  := Source;
        Sizes  := FileSize(InFile);
        uSizes := Sizes;
        Times  := hT;
        FileVersion := GetFileVersion(Source);
      end;

    if Assigned(LZQuestion) then    { and send name of existing target file}
    {$ifdef Win32}
      case LZQuestion(RepRec, Dest) of
        LZNo:   begin
                  LZDecompress := -100; {target exists - don't overwrite}
                  Exit
                end;
        LZQuit: Abort { Raises a silent-exception... Fast-track exit   }
      end             { out of entire application unless caught... :-) }
    {$else Win32}
      begin
        LZReply := LZQuestion(RepRec, Dest);
        if LZReply <> LZYes then
          begin
            if LZReply = LZNo then
              LZDecompress := -100   { Exit nicely ... }
            else
              LZDecompress := -150;  { ABORT!!!!!!!    }
            Close(InFile); { Reset() successful; Close() cannot fail }
            LZDone;
            Exit
          end
      end
    {$endif Win32}

  End;

  {report on target file}
  With RepRec do begin
     Names := Dest;
     If IsComp then begin
        Sizes  := f.cSize;
        uSizes := f.uSize;
        Times  := f.fTime;
        FileVersion := f.Version;
     end else begin
       Sizes  := fSize(Source);
       uSizes := Sizes;
       Times  := hT;
       FileVersion := '0';
     end;
  end;

  BlankRec := RepRec;

{$ifdef Win32}
    AssignFile(OutFile, Dest);
    Rewrite(OutFile, 1);
    try { finally }

      {//////////}
      if Assigned(aProc) then aProc(RepRec, -1);
      LZReportProc := aProc;
      {//////////}
      if not IsComp then
        begin {normal copy}
          f.fTime := hT{lFTime(InFile)};
          LZDecompress := MyFCopy(InFile,OutFile,
                                  LZ_UNKNOWN_LENGTH,doReportOnWrite)
        end
      else
        begin
          InBufPtr  := LZRWBufSize;
          InBufSize := LZRWBufSize;
          OutBufPtr := 0;
          FillChar(BinaryTree^.TextBuf, SizeOf(TLZTextBuf), 0);
          Seek(InFile, SizeOf(TLZHeader));
          Decompressing := True;
          LZDecode;
          LZDecompress := aWrite
        end

    finally
      { set date/time stamp }
      FileSetDate(TFileRec(OutFile).Handle, f.fTime);
      CloseFile(OutFile);
      if Assigned(aProc) then
        begin
          RepRec.Names := '';
          aProc(RepRec, -2)
        end
    end

  finally
    CloseFile(InFile)
  end
  finally
    LZDone
  end;
{$else}
  Assign(OutFile, Dest);
  Rewrite(OutFile, 1);
  if IOResult <> 0 then
    LZDecompress := -13  {can't open target}
  else begin

  {//////////}
  if Assigned(aProc) then aProc(RepRec, -1);
  LZReportProc := aProc;
  {//////////}
  if not IsComp{IsMyLZFile(InFile, f)} then
    begin {normal copy}
      f.fTime := hT{lFTime(InFile)};
      LZDecompress := MyFCopy(InFile,OutFile,
                              LZ_UNKNOWN_LENGTH,doReportOnWrite)
    end
  {//////////}
  else
    begin
      InBufPtr  := LZRWBufSize;
      InBufSize := LZRWBufSize;
      OutBufPtr := 0;
      FillChar(BinaryTree^.TextBuf, SizeOf(TLZTextBuf), 0);
      Seek(InFile, SizeOf(TLZHeader));
      Decompressing := True;
      LZDecode;
      LZDecompress := aWrite
    end;

{ set date/time stamp }
{$ifdef Delphi}
  FileSetDate(TFileRec(OutFile).Handle, f.fTime);
{$else}
  SetFTime(OutFile, f.fTime);
{$endif}
  Close(OutFile);if IOResult<>0 then;
  if Assigned(aProc) then
    begin
      RepRec.Names := '';
      aProc(RepRec, -2)
    end
  end; { IOResult = 0 }

  Close(InFile); if IOResult<>0 then;
  end { IOResult = 0 }

  end;
  LZDone
{$endif}
End; { LZDecompress }

{/////////////////////////////////////////////////////////}

Function IsChiefLZFile(const fName: {$ifdef Win32} string
                                    {$else}        PChar
                                    {$endif}):boolean;
{$ifdef aDLL} {$ifdef Win32} stdcall
              {$else Win32}  export
              {$endif Win32};
{$endif aDLL}

Var
h:TLZHeader;
f:file;
{$ifndef Win32}
OldFMode: byte;
{$endif}
Begin
  {$ifdef Win32}
    AssignFile(f, fName);
    FileMode := fmOpenRead; { Win32 only allows 0 <= FileMode <= 2     }
    Reset(f,1);             { However, share access is FILE_SHARE_READ }
    try
      Result := IsMyLZFile(f,h)
    finally
      CloseFile(f)
    end
  {$else}
    IsChiefLZFile := False;
    Assign(f, StrPas(fName));
    OldFMode := FileMode;
{
  Open file: we need Read-access, don't need Write-access and *INSIST*
  that no one else can write to it (i.e. corrupt it) 'til we're done ...
}
    FileMode := (fmOpenRead or fmShareDenyWrite);
    Reset(f,1);
    FileMode := OldFMode;
    if IOResult=0 then
      begin
        IsChiefLZFile := IsMyLZFile(f,h);
        Close(f) { ReadOnly Reset() succeeded; Close() MUST succeed }
      end
  {$endif}
end;
{/////////////////////////////////////////////////////////}
{/////////////////////////////////////////////////////////}
{/////////////////////////////////////////////////////////}
{/////////////////////////////////////////////////////////}
Function ArchiveSquash(Var InFile, OutFile: file;
                       Const aProc: TLZReportProc):LongInt;
Begin
  ArchiveSquash := -1;
  if IsLZInitialized then
  begin
    Seek(InFile, 0);{$ifndef Win32} if IOResult<>0 then; {$endif}

    LZReportProc := aProc;
    InBufPtr     := LZRWBufSize;
    InBufSize    := LZRWBufSize;
    OutBufPtr    := 0;
    Height       := 0;
    MatchPos     := 0;
    MatchLen     := 0;
    LastLen      := 0;
    aWrite       := 0;

    FillChar(BinaryTree^, SizeOf(TBinaryTree), 0);
    FillChar(CodeBuf, SizeOf(CodeBuf), 0);
    Decompressing := False;
    LZEncode;
    ArchiveSquash := aWrite
  end; {IsLZInitialized}
End; { ArchiveSquash }

{/////////////////////////////////////////////////////////}
Function IsFileInDir({$ifdef Delphi} const {$endif} fSpec:String):Boolean;
Var
{$ifdef Windows}
 Dir:TSearchRec;
{$else}
 Dir:SearchRec;
{$endif Windows}
Begin
   {$ifdef Delphi}
     Result := (FindFirst(fSpec, faAnyFile-faDirectory-faVolumeID, Dir)=0);
     if Result then
       SysUtils.FindClose(Dir);
   {$else Delphi}

   {$ifdef Windows}
     FindFirst(Str2PChar(fSpec), faAnyFile-faDirectory-faVolumeID, Dir);
   {$else Windows}
     FindFirst(fSpec,AnyFile-Directory-VolumeID, Dir);
   {$endif Windows}
     IsFileInDir := (DosError = 0)

    {$endif Delphi}
End;

{//////////////////////////////////////////}
Procedure InitReportRec(Var RepRec:TLZReportRec; Const X:TLZBigFileRec);
Begin
   With RepRec, X do
     begin
       Names := BigNames;
       Sizes := BigSizes;
       uSizes:= uBigSizes;
       Times := BigTimes;
       FileVersion := BigFileVersion;
       IsDir := IsBigDir
    end
End;

{/////////////////////////////////////////////////////////}
Function LZArchive(const fSpec, ArchName: {$ifdef Win32} string
                                          {$else}        PChar
                                          {$endif};
                   LZRecurseDirs: TLZRecurse;
                   aProc:         TLZReportProc):LongInt;
{$ifdef aDLL} {$ifdef Win32} stdcall
              {$else Win32}  export
              {$endif Win32};
{$endif aDLL}

type
  PDirTimes = ^TDirTimes;
  TDirTimes = array[1..MaxChiefLZDirectories] of LongInt;

Const