chfutils.pas

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

{$I LZDefine.inc}

unit ChfUtils;

{some miscellaneous routines for the ChiefLZ package}

interface
{$ifdef Delphi}
Uses SysUtils;
{$else}
{$ifndef Windows}
 Uses Dos;
{$endif Windows}
const
  fmOpenRead       = $00;
  fmOpenWrite      = $01;
  fmOpenReadWrite  = $02;
  fmShareCompat    = $00;
  fmShareExclusive = $10;
  fmShareDenyWrite = $20;
  fmShareDenyRead  = $30;
  fmShareDenyNone  = $40;
{$endif}

function AddBackSlash(Const DirName : string) : string;
function RemoveBackSlash(const S: string): string;
function Min(const I1, I2: LongInt): LongInt;

function FirstDirectoryBetween(const s1, s2: string): string;
Function DirectoryExists(const s:String): Boolean;
Function FSize(const S : String): LongInt;
Function sFTime(const s:string): LongInt;
Function lFTime(var f: file): LongInt;

{$ifdef Win32}

{$IFDEF Debug}
type
  EChiefLZDebug = class(Exception);
{
  AddrOfCaller ***MUST*** be called by a routine that has a stack frame!!
}
function AddrOfCaller: Pointer;
{$ENDIF}

procedure RaiseError(const EClass: ExceptClass; const Res: Integer);
procedure RaiseErrorStr(const EClass: ExceptClass;
                        const Res:    Integer;
                        const Mes:    string);
procedure RaiseIOError(const EMess, ECode: Integer);
function CreateIOError(const EMess, ECode: Integer): EInOutError;

function FileVersionInfo(const fName, StringToGet: string): string;

{$else Win32}

type
  PString = ^String;

function  Str2PChar(Var s:String):PChar;
function  NewString(const s: string): PString;
procedure DisposeString(var P: PString);
function  GetCurrentDir: string;

{$ifdef Win16}
{$ifndef DPMI}
Function FileVersionInfo(const Fname, StringToGet:PChar):String;
{$endif DPMI}
{$endif Win16}

{$IFDEF Debug}
procedure RunErrorMessage(const Mes: string);
procedure RunErrorMessageAt(const Mes: string; const ErrorLoc: Pointer);
{
  AddrOfCaller **MUST** be called by a FAR routine that has a stack frame!!
}
function AddrOfCaller: Pointer; inline($8B/$46/$02/   { mov ax, [bp+2] }
                                       $8B/$56/$04);  { mov dx, [bp+4] }
{$ENDIF}

{$endif Win32}

{$ifndef Delphi}
Function ExtractFilePath(const aName:String):String;
function ExtractFileName(const s:String):String;
Function ExtractFileExt(const aName:String):String;
Function ChangeFileExt(const aName, aExt:String):String;
Function FileExists(Const S : String) : Boolean;
Function Uppercase(S: String): String;
{$endif Delphi}

{$ifndef Windows}
Const
faDirectory=Directory;
faArchive=Archive;

{
faReadOnly=ReadOnly;
faSysFile=SysFile;
faHidden=Hidden;
faAnyFile=AnyFile;
}
{$endif Windows}

implementation
uses
{$ifdef Win32}
Windows
{$else Win32}
{$ifdef Windows}
{$ifndef Delphi}
WinDos, Strings,
{$endif Delphi}
{$ifdef DPMI}
WinAPI
{$else DPMI}
WinTypes,
WinProcs,
Ver
{$endif DPMI}
{$else Windows}
Strings
{$endif Windows}
{$endif Win32};

{$IFDEF Debug}
{$ifdef Win32}
{
  This function has no stack frame of its own, hence EBP is its caller's
  stack frame. This means that EAX is loaded with the RETurn address of
  the calling function ...
}
{$W-}
function AddrOfCaller: Pointer; assembler;
asm
  MOV EAX, [EBP+4]  // DWord at [EBP] is old EBP
{
  Quick and dirty fix to overcome a *BUG* in ShowException()...
  Add an `anti-correction' to the address so that Delphi will return
  the absolute address of the exception, rather than a relative one.

  Remove this once ShowException() has been fixed ...
}
  ADD EAX, OFFSET TextStart
end;
{$W+}

{$else Win32}

type
  THexStr = string[4];

function Hex4(X: Word): THexStr;
var
  i, j: byte;
begin
  Hex4[0] := chr(4);
  for i := 4 downto 1 do
    begin
      j := lo(X) and $F;
      if j > 9 then
        inc(j,ord('A')-$A)
      else
        inc(j,ord('0'));
      X := X shr 4;
      Hex4[i] := chr(j)
    end
end;

procedure RunErrorMessageAt(const Mes: string; const ErrorLoc: Pointer);
type
  PtrRec = record
             Ofs, Seg: word
           end;
{$ifdef Windows}
var
  NewMes: array[0..255] of Char;
  HexNum: array[0..4] of Char;
{$endif}
begin
{$ifdef Windows}
{
  This is untested: I have no idea whether the address here will function
  correctly in the IDE. This address is the undoctored location of the
  error ...
}
  with PtrRec(ErrorLoc) do
    StrCat(StrCat(StrCat(StrCat(
               StrPCopy(NewMes, Mes),
               #13#10'Address for "Search|Find Error" is ' ),
               StrPCopy(HexNum, Hex4(Seg)) ),
               ':' ),
               StrPCopy(HexNum, Hex4(Ofs)) );
  {$ifndef DPMI}WinProcs.{$endif}MessageBox(HInstance, NewMes,
                                             'ChiefLZ Error', MB_OK);
{$else Windows}
{
  Perform Real-Mode segment-arithmetic to calculate logical address for
  IDE. The IDE expects the segment number to be relative to the main
  program's code segment. This is located immediately after the PSP,
  and the PSP is 16 paragraphs long.
}
  Writeln;
  Writeln( 'ChiefLZ Error: ', Mes );
  with PtrRec(ErrorLoc) do
    Writeln( 'Address for "Search|Find Error" is ',
                                  Hex4(Seg-PrefixSeg-16),':',Hex4(Ofs) );
{$endif Windows}
  Halt
end;

procedure RunErrorMessage(const Mes: string);
begin
  RunErrorMessageAt(Mes, AddrOfCaller)
end;

{$endif Win32}
{$ENDIF}

{/////////////////////////////////////////////////}
{
  These are general-purpose functions used by all versions ...
}
{/////////////////////////////////////////////////}

function AddBackSlash(Const DirName: string) : string;
{-Add a default backslash to a directory name}
begin
{$ifdef Win32}
{
  Win32 version uses ExpandFileName() ... ':' ***shouldn't*** appear ...
}
  if (Length(DirName)=0) or (DirName[Length(DirName)]='\') then
    AddBackSlash := DirName
  else
    begin
    {$IFDEF Debug}
      if DirName[Length(DirName)] = ':' then
        raise EChiefLZDebug.Create('Directory name "' + DirName +
                                   '" terminated by '':'' character')
          at AddrOfCaller;  // Error will not be reported at THIS address,
    {$ENDIF}                // but where AddBackSlash() was called.
      AddBackSlash := DirName + '\'
    end;
{$else}
  if DirName[Length(DirName)] in ['\',':',#0] then
    AddBackSlash := DirName
  else
    AddBackSlash := DirName + '\'
{$endif}
end;

function RemoveBackSlash(const S: string): string;
{$ifdef Win32}
var
  i: Integer;
{$endif}
{$ifndef Delphi}
var
  Result: string;
{$endif}                       
begin
  Result := s;
{$ifdef Win32}
  i := Length(s);
  if s[i] = '\' then
    SetLength(Result, i-1);
{$else Win32}
  if s[Length(s)] = '\' then
    dec(Result[0]);
{$ifndef Delphi}
  RemoveBackSlash := Result;
{$endif Delphi}
{$endif Win32}
{$IFDEF Debug}
  if Pos('\',Result) = 0 then
  {$ifdef Win32}
    raise EChiefLZDebug.Create('Removed ''\'' from root directory!')
      at AddrOfCaller
  {$else Win32}
    RunErrorMessageAt('Removed ''\'' from root directory!', AddrOfCaller)
  {$endif Win32};
{$ENDIF}
end;

{/////////////////////////////////////////////////////////}
Function FSize(Const S: String): LongInt;
{return the file size of filename "S"}
var
f: file;
{$ifndef Win32}
OldFMode: byte;
{$endif}

begin
  {$ifdef Win32}
    AssignFile(f,s);
    FileMode := fmOpenRead; { Win32 only allows 0 <= FileMode <= 2 }
    Reset(f,1);             { However, share access is FILE_SHARE_READ }
    try
      Result := FileSize(f)
    finally
      CloseFile(f)
    end
  {$else}
    FSize:=0;
    Assign(f, s);
    OldFMode := FileMode;
    FileMode:= (fmOpenRead or fmShareDenyWrite);
    Reset(f, 1);
    FileMode := OldFMode;
    if IOResult=0 then begin
        FSize:=FileSize(f);
        Close(f);  { Reset() successful and ReadOnly - Close() cannot fail }
    end
  {$endif}
end;

{/////////////////////////////////////////////////////////}
Function sFTime(Const s: string): LongInt;
{get the date/time stamp of a file}
var
{$ifdef Delphi}
Handle  : LongInt;
{$else}
f       : file;
OldFMode: byte;
Result  : LongInt;
{$endif}

begin
   sFtime := 0;
   {$ifdef Delphi}
    Handle := FileOpen(s, fmOpenRead or fmShareDenyNone);
    If Handle <> -1 then begin
     sFTime := FileGetDate(Handle);
     FileClose(Handle);
    end;
   {$else}
   OldFMode := FileMode;
   FileMode:= (fmOpenRead or fmShareDenyNone);
   Assign(f, s);
   Reset(f, 1);
   FileMode := OldFMode;
   if IOResult=0 then begin
      GetFTime(f, Result);
      sfTime:=Result;
      Close(f)
   end;
   {$endif}
end;

{/////////////////////////////////////////////////////////}
Function lFTime(var f:file) : LongInt;
{get the date/time stamp of a file}
{$ifndef Delphi}
var
Result:LongInt;
{$endif}
begin
{$ifdef Delphi}
  Result := FileGetDate(TFileRec(f).Handle);
{$else}
  GetFTime(f, Result);
  lfTime:=Result;
{$endif}
end;

{/////////////////////////////////////////////////////////}
Function DirectoryExists(Const s: String): Boolean;
{does a directory exist?}
var
{$ifdef Win32}
Attr: DWORD;
{$else Win32}
{$ifdef Delphi}
Attr: Integer;
{$else Delphi}
f   : file;
Attr: word;
{$endif Delphi}
{$endif Win32}
Begin
{$ifdef Win32}
  Attr := Windows.GetFileAttributes(PChar(s));
  Result := (Attr <> $FFFFFFFF) and                  // Success ...
            (Attr and FILE_ATTRIBUTE_DIRECTORY <> 0) // Directory...
{$else Win32}
 {$ifdef Delphi}
   Attr := FileGetAttr(s);
   Result := (Attr>=0) and (Attr and faDirectory<>0)
 {$else Delphi}
  Assign(f,s);
  GetFAttr(f,Attr);
  DirectoryExists := (DosError = 0) and (Attr and faDirectory <> 0)
 {$endif Delphi}
{$endif Win32}
End;

function FirstDirectoryBetween(const s1, s2: string): string;
var
  i: Integer;
begin
{$IFDEF Debug}
  if Pos(s1,s2) = 0 then
  {$ifdef Win32}
    raise EChiefLZDebug.Create('FirstDirectoryBetween: ' + s1 +
                               ' not a substring of ' + s2)