chieflz.~pas

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

Function GetChiefLZFileName(fName, Dest:PChar):boolean;
{$ifdef aDLL} export; {$endif aDLL}
Var
h:TLZHeader;
f:file;
{$ifndef Delphi}
Result:boolean;
{$endif}
OldFMode:byte;
Begin
    GetChiefLZFileName := false;
    StrCopy(Dest, fName); {return filename}
    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) until we're done.
}
    FileMode := (fmOpenRead or fmShareDenyWrite);
    Reset(f,1);
    FileMode := OldFMode;
    if IOResult=0 then
      begin
        Result := IsMyLZfile(f,h);
        Close(f);  { Reset() OK, so Close() must succeed }
      {$ifndef Delphi}
        GetChiefLZFileName := Result;
      {$endif Delphi}
        if Result then
          StrPCopy(Dest, h.fName);
      end
end;
{$endif}
{/////////////////////////////////////////////////////////}
{/////////////////////////////////////////////////////////}
Function GetChiefLZFileSize(fName: {$ifdef Win32} string
                                   {$else}        PChar
                                   {$endif}):LongInt;
{$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
      if IsMyLZFile(f,h) then
        Result := h.uSize
      else
        Result := FileSize(f)
    finally
      CloseFile(f)
    end;
  {$else}
    GetChiefLZFileSize := -1{error};
    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) until we're done.
}
    FileMode := (fmOpenRead or fmShareDenyWrite);
    Reset(f,1);
    FileMode := OldFMode;
    if IOResult=0 then
      begin

        if IsMyLZFile(f,h) then
          GetChiefLZFileSize := h.uSize      {uncompressed size}
        else
          GetChiefLZFileSize := FileSize(f); {actual size}
        Close(f);         { Reset() OK, so Close() cannot fail }

      end;
  {$endif}
end;
{/////////////////////////////////////////////////////////}

function GetChiefLZArchiveInfo(const ArchName: {$ifdef Win32} string
                                               {$else Win32}  PChar
                                               {$endif Win32};
                               var   Header: TChiefLZArchiveHeader): boolean;
{$ifdef aDLL} {$ifdef Win32} stdcall
              {$else Win32}  export
              {$endif Win32};
{$endif aDLL}
var
  f       : file;
  Hed     : TLZArchiveHeader;
{$ifndef Win32}
  OldFMode: byte;
{$endif Win32}
begin
{$ifdef Win32}

  Result := IsChiefLZArchive(ArchName);
  if Result then
    begin
      AssignFile(f,ArchName);
      FileMode := fmOpenRead; { Win32 only allows 0 <= FileMode <= 2 }
      Reset(f,1);             { However, share access is FILE_SHARE_READ }
      try
        BlockRead(f, Hed, SizeOf(Hed)); {read archive header}
        Header.Count := Hed.Count;
        BlockRead(f, Header.Files[1], SizeOf(TLZFileRec)*Hed.Count)
      finally
        CloseFile(f)
      end
    end

{$else Win32}

    GetChiefLZArchiveInfo := False;
    If IsChiefLZArchive(ArchName) then
      begin
        Assign(f, StrPas(ArchName));
        OldFMode := FileMode;
{
  Open file: we need Read-access, don't need Write-access and *INSIST*
  that no one can write to it (i.e. corrupt it) until we're done ...
}
        FileMode := (fmOpenRead or fmShareDenyWrite);
        Reset(f, 1);
        FileMode := OldFMode;
        if IOResult=0 then
          begin
            BlockRead(f, Hed, SizeOf(Hed)); {read archive header}
            If IOResult=0 then
            begin
              Header.Count := Hed.Count;
              BlockRead(f, Header.Files[1], SizeOf(TLZFileRec)*Hed.Count);
              if IOResult=0 then
                GetChiefLZArchiveInfo := True;
              Close(f) { If successful open, Close() MUST succeed here }
            end
          end
      end

{$endif Win32}
End;

{/////////////////////////////////////////////////////////}
Function GetChiefLZArchiveSize(const ArchName: {$ifdef Win32} string
                                               {$else Win32}  PChar
                                               {$endif Win32}): LongInt;
{$ifdef aDLL} {$ifdef Win32} stdcall
              {$else Win32}  export
              {$endif Win32};
{$endif aDLL}
{get uncompressed size of archive}
Var
X: PChiefLZArchiveHeader;
i: Longint;
{$ifndef Delphi}
Result: LongInt;
{$endif Delphi}
Begin
  New(X);
{$ifdef Win32}
  try { finally }
{$endif Win32}
  if not GetChiefLZArchiveInfo(ArchName, X^) then
    GetChiefLZArchiveSize := FSize({$ifdef Win32} ArchName
                                   {$else Win32}  StrPas(ArchName)
                                   {$endif Win32})
  else
    begin
      Result := 0;
      with X^ do
        for i := 1 to Count do
          Inc(Result, Files[i].uSizes);
    {$ifndef Delphi}
      GetChiefLZArchiveSize := Result
    {$endif Delphi}
    end;
{$ifdef Win32}
  finally
{$endif Win32}
  Dispose(X)
{$ifdef Win32}
  end
{$endif Win32}
End;

{/////////////////////////////////////////////////////////}
Function LZCompress(const {$ifdef Win32} Source, Dest:   string
                          {$else}        aSource, aDest: pChar
                          {$endif};
                    LZQuestion  :TLZQuestionFunc;
                    aProc:TLZReportProc):LongInt;
{$ifdef aDLL} {$ifdef Win32} stdcall
              {$else Win32}  export
              {$endif Win32};
{$endif aDLL}
Var
{$ifndef Win32}
OldFMode : byte;
Source,
Dest     : String;
{$endif}
f     : TLZHeader;
RepRec: TLZReportRec;
hT    : LongInt;

Begin

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

  aRead := 0;
  aWrite:= 0;

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

{$ifdef Win32}
  try { finally }
{$endif}

  {$ifdef Win32}
  if (Length(Source)=0) or (Length(Dest)=0) then
    RaiseError(EChiefLZCompress,SInvalidParams);
  if AnsiCompareText(Source, Dest) = 0 then
    RaiseErrorStr(EChiefLZCompress,SSameFileName,Source);
  {$else}
  Source := StrPas(aSource);
  Dest   := StrPas(aDest);
  If (Length(Source)=0) or (Length(Dest)=0) or
                                  (Uppercase(Source)=Uppercase(Dest))
  then
  begin
    LZCompress := -11;  {same source and target}
    LZDone;
    Exit
  end
  {$endif};

  hT := sFTime(Source);

{||| does target file exist already? ||||}
  If FileExists(Dest) then
    begin
      With RepRec do
        begin   {details of Source}
          Names  := Source;
          Sizes  := fSize(Source);
          uSizes := Sizes;
          Times  := hT;
          FileVersion := GetFileVersion(Source);
        end;

      if Assigned(LZQuestion) then
        if LZQuestion(RepRec, Dest) <> LZYes then
          begin
            LZCompress := -100; {target exists - don't overwrite}
          {$ifndef Win32}
            LZDone;
          {$endif}
            Exit
          end
    end
  else
    With RepRec do
      begin
        Names  := Source;
        Times  := ht;
        uSizes := FSize(Source);
        Sizes  := -1;
        FileVersion := GetFileVersion(Source);
      end;
  BlankRec := RepRec;

{$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 }
    AssignFile(OutFile, Dest);
    Rewrite(OutFile,1);
    try { finally }

      If Assigned(aProc) then aProc(RepRec, -1);
      LZReportProc := aProc;

      if IsMyLZFile(InFile, f) then
        LZCompress := MyFCopy(InFile,OutFile,
                               LZ_UNKNOWN_LENGTH,doReportOnRead)
      else                               {already compressed: just copy}
        begin
          FillChar(f, SizeOf(f), 0);
          with f do
            begin
              fName := ExtractFileName(Source);
              fTime := hT;
              Signature := ChiefLZSig;
              uSize := RepRec.USizes{FileSize(InFile)};
              Version := RepRec.FileVersion;
            end;
          BlockWrite(OutFile, f, SizeOf(f)); {write header}

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

          FillChar(BinaryTree^, SizeOf(TBinaryTree), 0);
          FillChar(CodeBuf, SizeOf(CodeBuf), 0);
          Decompressing := False;
          LZEncode;

          {go back and rewrite header}
          f.cSize := aWrite;
          Seek(OutFile,0);
          BlockWrite(OutFile, f, SizeOf(f)); {write header}

          LZCompress := aWrite+SizeOf(TLZHeader)
        end

    finally
      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(InFile, Source);
  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(InFile, 1);
  FileMode := OldFMode;
  if IOResult<>0 then
    LZCompress := -2
  else begin

  Assign(OutFile, Dest);
  Rewrite(OutFile, 1);
  if IOResult<>0 then
    LZCompress := -3
  else begin

  If Assigned(aProc) then aProc(RepRec, -1);
  LZReportProc := aProc;

  If IsMyLZFile(InFile, f) then
    LZCompress := MyFCopy(InFile,OutFile,LZ_UNKNOWN_LENGTH,doReportOnRead)
  else                                   {already compressed: just copy}
    begin
     FillChar(f, SizeOf(f), 0);
     With f do
       begin
         fName := ExtractFileName(Source);
         fTime := hT;
         uSize := FileSize(InFile);
         Signature  := ChiefLZSig;
         Version := RepRec.FileVersion;
       end;
     BlockWrite(OutFile, f, SizeOf(f)); {write header}

     if IOResult <> 0 then
       LZCompress := -4
     else
       begin
         InBufPtr := LZRWBufSize;
         InBufSize := LZRWBufSize;
         OutBufPtr := 0;
         Height := 0;
         MatchPos := 0;
         MatchLen := 0;
         LastLen := 0;

         FillChar(BinaryTree^, SizeOf(TBinaryTree), 0);
         FillChar(CodeBuf, SizeOf(CodeBuf), 0);
         Decompressing := False;
         LZEncode;

         {go back and rewrite header}
         f.cSize := aWrite;
         Seek(Outfile, 0);if IOResult<>0 then;
         BlockWrite(OutFile, f, SizeOf(f)); {write header}

         LZCompress := aWrite+SizeOf(TLZHeader)
       end
    end;

  if Assigned(aProc) then
    begin
      RepRec.Names := '';
      aProc(RepRec, -2)
    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;
  end; { IOResult = 0 }

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