chieflz.~pas

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

{$else Windows}
  INT $21
{$endif Windows}
  POP DS
  JC @Fail
{
  The file handle refers to an OPEN file; close it so we can open it
  the Pascal way ...
}
  MOV BX, AX
  MOV AH, $3E
{$ifdef Windows}
  CALL DOS3Call
{$else Windows}
  INT $21
{$endif Windows}
{
  Return True if successful, False otherwise ...
}
@Fail:
{$ifdef Delphi}
  DB $0F, $93, $C0  (* setnc al *)
{$else Delphi}
  MOV AL, False
  JC @End
  INC AX
@End:
{$endif Delphi}
end;

{$endif Win32}

{/////////////////////////////////////////////////////////}
{///// is this an LZ compressed file using this unit? ////}
Function IsMyLZFile(Var InFile:file; Var f:TLZHeader):boolean;
var
  OldPos:  LongInt;
  NumRead: Integer;
begin
  OldPos := FilePos(InFile);
  Seek(InFile,0);
  BlockRead(InFile, f, SizeOf(f), NumRead);
  IsMyLZFile := (NumRead = SizeOf(f))
                  and (Length(f.FName) <> 0)
                  and (f.Signature = ChiefLZSig);
  Seek(InFile,OldPos)
end;

{/////////////////////////////////////////////////////////}
{////: normal file copy if not LZ file}
const LZ_UNKNOWN_LENGTH = -1;

type TReporting = (doReportOnRead, doReportOnWrite);

Function MyFCopy(var InFile, OutFile: file;
                 const CopyLength: LongInt;
                 const doReport:   TReporting): LongInt;
{$ifndef Win32} far; {$endif}
Var
p: PBufType;
{
  Turn the enumerated type doReport into a Boolean:
    doReportOnRead  -> False
    doReportOnWrite -> True

  Decompression routines will call MyFCopy() using doReportOnWrite,
  whereas Compression routines will call using doReportOnRead
}
var
ReportingOnWrite: Boolean absolute doReport;

{$ifdef Win32}
NumRead:integer;
BRead:  integer;
{$else}
BRead:  word;
NumRead:word;
NumWrit:word;
{$endif}
{$ifndef Delphi}
Result: LongInt;
{$endif}

begin

{$IFDEF Debug}
   if CopyLength < LZ_UNKNOWN_LENGTH then
   {$ifdef Win32}
     raise EChiefLZDebug.Create('Negative copy-length passed to MyFCopy')
       at AddrOfCaller        
   {$else Win32}
     RunErrorMessageAt('Negative copy-length passed to MyFCopy',
                        AddrOfCaller)
   {$endif Win32};
{$ENDIF}
   Result := 0;
   New(p);
 {$ifdef Win32}
   try {finally}
 {$else Win32}
   if p = nil then
     begin
     {$ifndef Delphi}
       MyFCopy := 0;
     {$endif}
       Exit  { ERROR !!! Failed Memory Allocation! }
     end;
 {$endif Win32}

   repeat
     if CopyLength <> LZ_UNKNOWN_LENGTH then
       BRead := Min(CopyLength-Result, SizeOf(p^))
     else
       BRead := SizeOf(p^);
     BlockRead(InFile, p^, BRead, NumRead);

     {compressing - return number of bytes read}
     if Assigned(LZReportProc) and not ReportingOnWrite then
       LZReportProc(BlankRec, NumRead);
{
  If CopyLength <> LZ_UNKNOWN_LENGTH, we know how many bytes we EXPECT
  to be able to read from this file. If BRead <> NumRead, then the
  file must be corrupt ...
}
   {$ifdef Win32}
     if (CopyLength <> LZ_UNKNOWN_LENGTH) and (BRead <> NumRead) then
       RaiseIOError(SEndOfFile,100); { Will exit via `finally...end' }
   {$endif}
{
  This is the EOF condition for when we DON'T know how long the copy is ...
}
     if NumRead = 0 then
       break;
{
  Without the NumWrit parameter, BlockWrite will cause an IO-Error if the disc
  doesn't have room for SizeOf(p) bytes. This is good in Win32, as an exception
  will then be raised.
}
     BlockWrite(OutFile,p^,NumRead {$ifndef Win32}, NumWrit {$endif});
{
  If Win32 version gets this far, then all NumRead chars must have
  been written ...
}
     inc(Result, {$ifdef Win32} NumRead {$else} NumWrit {$endif});

     {de-compressing - return number of bytes written}
     if Assigned(LZReportProc) and ReportingOnWrite then
       LZReportProc(BlankRec, {$ifdef Win32} NumRead {$else} NumWrit {$endif})

   until {$ifndef Win32} (NumWrit<>NumRead) or {$endif}
         ( (CopyLength <> LZ_UNKNOWN_LENGTH) and
           (Result >= CopyLength) );
 {$ifndef Delphi}
   MyFCopy := Result;
 {$endif}
 {$ifdef Win32}
   finally
 {$endif}
     Dispose(p);
 {$ifdef Win32}
   end;
 {$endif}
end;

{/////////////////////////////////////////////////////////}
Function MyReadProc(var ReadBuf): TLZSSWord; {$ifndef Win32} far; {$endif}
{to read from files}
{$ifndef Delphi}
var
  Result: TLZSSWord;
{$endif}

Begin
  BlockRead(InFile, ReadBuf, LZRWBufSize, Result);
  Inc(aRead, Result);

 {compressing - return bytes read}
  if Assigned(LZReportProc) and not Decompressing then
    LZReportProc(BlankRec, Result);

{$ifndef Delphi}
  MyReadProc := Result
{$endif}
End; { MyReadProc }

{/////////////////////////////////////////////////////////}
Function MyWriteProc(var WriteBuf; Count: TLZSSWord): TLZSSWord;
{$ifndef Win32} far; {$endif Win32}
{$ifndef Delphi}
var
  Result: TLZSSWord;
{$endif}
{to write to files}
Begin
  BlockWrite(OutFile, WriteBuf, Count, Result);
  Inc(aWrite, Result);

 {de-compressing - return bytes written}
  if Assigned(LZReportProc) and Decompressing then
    LZReportProc(BlankRec, Result);

{$ifndef Delphi}
  MyWriteProc := Result
{$endif}
End; { MyWriteProc }

{/////////////////////////////////////////////////////////}
Function GetDirIndex(aDir: TLZPathStr; Const DirList: PLZDirArray;
                                       Const Max: TLZSSWord): LongInt;
{find the index of a directory within an array}
Var
  i: TLZSSWord;
begin
{$ifndef Win32}
  aDir := UpperCase(aDir);
{$endif Win32}
  for i := 0 to Max do
    if {$ifdef Win32} AnsiCompareText(aDir, DirList^[i]) = 0
       {$else Win32}  aDir = DirList^[i]^
       {$endif Win32} then
      begin
        GetDirIndex := i;
        Exit
      end;
  GetDirIndex := -1
end;

{/////////////////////////////////////////////////////////}
function CreatePath(Path: TLZPathStr): Integer;
{Iteratively create a directory path}
var
  i:      Integer;
  NewDir: TLZPathStr;
{$ifndef Delphi}
{$ifdef Windows}
  P:      array[0..79] of Char;
{$endif Windows}
  Result: Integer;
{$endif Delphi}
begin
{$ifdef Delphi}
  Path := ExpandFileName(Path);
{$else Delphi}
  {$ifdef Windows}
  FileExpand(P, Str2PChar(Path));
  Path := StrPas(p);
  {$else Windows}
  Path := FExpand(Path);
  {$endif Windows}
{$endif Delphi}

  i := 3;
  Result := 0;

  repeat
    repeat
      Inc(i)
    until (i > Length(Path)) or (Path[i] = '\');
    NewDir := Copy(Path,1,i-1);
    if not DirectoryExists(NewDir) then
      begin
        MkDir(NewDir);         { Win32 throws an exception and exits... }
        {$ifndef Win32}        { We shall catch and handle this     }
        If IOResult <> 0 then  { exception in the calling function. }
          begin
            CreatePath := -1;
            Exit
          end;
       {$endif Win32}
        Inc(Result)
      end
  until i > Length(Path);
{$ifndef Delphi}
  CreatePath := Result;
{$endif}
end;

{/////////////////////////////////////////////////////////}
function GetFullLZName(const     X: TChiefLZArchiveHeader;
                             Index: Integer): string;
{$ifdef aDLL} {$ifdef Win32} stdcall
              {$else Win32}  export
              {$endif Win32}; {$endif aDLL}
{$ifndef Delphi}
var
  Result: string;
{$endif}
begin
  Result := '';
  repeat
    with X.Files[Index] do
      begin
        Result := Names + '\' + Result;
        if not IsDir then
          Index := DirID
        else
          Index := ParentDir
      end
  until Index = 0;
{$ifdef Win32}
  SetLength(Result, Pred(Length(Result)));
{$else Win32}
  Dec(Result[0]);
{$endif Win32}
{$ifndef Delphi}
  GetFullLZName := Result;
{$endif Delphi}
end;

Function GetFileVersion({$ifdef Win32} Const
                        {$endif} fName: String): TLZVerStr;
{$ifndef DPMI}
{$ifdef TPW}
Var
Result: TLZVerStr;
{$endif TPW}
{$endif DPMI}
Begin
  {$ifdef DPMI}
    GetFileVersion := '0'
  {$else DPMI}
  {$ifdef Windows}
  {$ifdef Win32}
    Result := FileVersionInfo(fName, 'FileVersion');
  {$else Win32}
    Result := FileVersionInfo(Str2PChar(fName), 'FileVersion');
  {$endif Win32}
    if Length(Result) = 0 then
      GetFileVersion := '0'
  {$ifndef Delphi}
    else
      GetFileVersion := Result
  {$endif Delphi}
  {$else Windows}
    GetFileVersion := '0'
  {$endif Windows}
  {$endif DPMI}
End;

{/////////////////////////////////////////////////////////}
function GetLZMarkedName(const FName: string): string;
var
  i:   Integer;
  Ext: TLZExtStr;
begin
  Ext := ExtractFileExt(FName);
  i := Length(Ext);
  if i < 2 then             { Ext is either '' or '.' }
    Ext := '.' + MyLZMarker
  else
    Ext[i] := MyLZMarker;
  GetLZMarkedName := ChangeFileExt(FName, Ext)
end;

{/////////////////////////////////////////////////////////}
{/////////////////////////////////////////////////////////}
{
  These are the LZ functions exported from the unit
}
{/////////////////////////////////////////////////////////}
{/////////////////////////////////////////////////////////}
Function IsChiefLZArchive(const fName: {$ifdef Win32} string
                                       {$else}        PChar
                                       {$endif} ):boolean;
{$ifdef aDLL} {$ifdef Win32} stdcall
              {$else Win32}  export
              {$endif Win32};
{$endif aDLL}
Var
f:file;
NumRead: TLZSSWord;
{$ifndef Win32}
OldFMode: byte;
{$endif}

Hed : TLZArchiveHeader;

Begin
     IsChiefLZArchive := False;

     if {$ifdef Win32} Length(fName)
        {$else}        StrLen(fName)
        {$endif} = 0 then
       Exit;

  {$ifdef Win32}

    AssignFile(f, fName);
    FileMode := fmOpenRead; { Win32 only allows 0 <= FileMode <= 2 }
  {$I-}                     { However, share access is FILE_SHARE_READ }
    Reset(f, 1);
  {$I+}
    if IOResult = 0 then
      begin
        BlockRead(f, Hed, SizeOf(Hed), NumRead); // No IO-Error; uses NumRead
        CloseFile(f);
        IsChiefLZArchive := (NumRead = SizeOf(Hed)) and
                            (Hed.Signature = MyLZSignature) and
                            (Hed.Count <> 0)
                 // If haven't read SizeOf(Hed) bytes, CAN'T be LZ Archive
      end

   {$else}

    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
        BlockRead(f, Hed, SizeOf(Hed), NumRead);
        Close(f);
        IsChiefLZArchive := (NumRead = SizeOf(Hed)) and
                            (Hed.Signature = MyLZSignature) and
                            (Hed.Count <> 0)
      end
   {$endif}
end;

{/////////////////////////////////////////////////////////}
{$ifdef Win32}
Function GetChiefLZFileName(const fName: string): string;
{$ifdef aDLL} stdcall; {$endif aDLL}
var
f: file;
h: TLZHeader;
begin
  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
      SetString(Result, PChar(@h.fName[1]), Length(h.fName))
    else
      Result := fName
  finally
    CloseFile(f)
  end
end;
{$else}