chfutils.pas

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

      at AddrOfCaller
  {$else Win32}
    RunErrorMessageAt('FirstDirectoryBetween: ' + s1 +
                       ' not a substring of ' + s2,
                       AddrOfCaller)
  {$endif Win32};
{$ENDIF}
  i := Length(s1);
  repeat
    inc(i)
  until (i > Length(s2)) or (s2[i] = '\');
  FirstDirectoryBetween := Copy(s2,1,i)
end;
 
{$ifdef Win32}

procedure RaiseError(const EClass: ExceptClass; const Res: Integer);
begin
  raise EClass.CreateRes(Res)
end;

procedure RaiseErrorStr(const EClass: ExceptClass;
                        const Res:    Integer;
                        const Mes:    string);
begin
  raise EClass.CreateResFmt(Res,[Mes])
end;

{
  These functions enable IO-errors to be raised artificially ...
}
function CreateIOError(const EMess, ECode: Integer): EInOutError;
begin
  Result := EInOutError.CreateRes(EMess);
  Result.ErrorCode := ECode
end;

procedure RaiseIOError(const EMess, ECode: Integer);
begin
  raise CreateIOError(EMess,ECode)
end;

function Min(const I1, I2: LongInt): LongInt;
begin
  if I2 < I1 then
    Result := I2
  else
    Result := I1
end;

{$else Win32}

{
  These functions provide tools not required in Delphi 2 ...
}
type
  LongRec = record
              Lo, Hi: Word
            end;

function Min(const I1, I2: LongInt): LongInt; assembler;
asm
{$ifdef Delphi}
  DB $66; MOV AX, [BP+OFFSET I1]  (* mov eax, I1       *)
  DB $66; MOV DX, [BP+OFFSET I2]  (* mov edx, I2       *)
  DB $66; CMP AX, DX              (* cmp eax, edx      *)
  JLE @Exit
  DB $66; MOV AX, DX              (* mov eax, edx      *)
@Exit:
  DB $66, $0F, $A4, 11000010b, 16 (* shld edx, eax, 16 *)
{$else}
  MOV AX, LongRec[BP+OFFSET I1].Lo
  MOV DX, LongRec[BP+OFFSET I1].Hi
  MOV CX, LongRec[BP+OFFSET I2].Lo
  MOV BX, LongRec[BP+OFFSET I2].Hi
  CMP DX, BX
  JL @Exit
  JG @Swap
  CMP AX, CX
  JBE @Exit
@Swap:
  MOV AX, CX
  MOV DX, BX
@Exit:
{$endif}
end;

{/////////////////////////////////////////////////}
function Str2PChar(Var s: String): PChar;
{convert string to pChar type}
var
  i: integer;
Begin
{$ifdef Win32}
{ Str2PChar UNNECESSARY under Win32 }
  raise EChiefLZDebug.Create('Called Str2PChar in Win32 code')
    at AddrOfCaller;
{$endif Win32}
  i := Length(s);
  if i=0 then
    Str2PChar := @s
  else
    begin
      if s[i]<>#0 then
        s[i+1] := #0;  { Heap-strings have an extra byte allocated for #0 }
      Str2PChar := @s[1]
    end
End;

function NewString(const s: string): PString;
{$ifndef Delphi}
var
  Result: PString;
{$endif}
begin
{
 If Windows code, we must allow for the possibility that someone might
 try and place a #0 on the end of the string ... allocate an extra byte...
}
  GetMem(Result, 2*SizeOf(Char)+Length(s));
  if Result <> nil then
    Result^ := s;
{$ifndef Delphi}
  NewString := Result
{$endif}
end;

procedure DisposeString(var P: PString);
begin
  if P <> nil then
    begin
{
  We allocated an extra byte in case someone called Str2PChar()
  using this string ... This byte must be deallocated ...
}
      FreeMem(P, 2*SizeOf(Char)+Length(P^));
      P := nil
    end
end;

{/////////////////////////////////////////////////////////}
Function GetCurrentDir: String;
{return the current directory}
{$ifndef Delphi}
var
  Result: string;
{$endif Delphi}
begin
  GetDir(0,Result);
{$ifndef Delphi}
  GetCurrentDir := Result
{$endif Delphi}
end;
{$endif Win32}

{$ifndef Delphi}
{/////////////////////////////////////////////////}
{
  These functions provide string and file-handling services that
  Delphi offers in SysUtils ...
}
{/////////////////////////////////////////////////}
Function Uppercase(s: String): String;
{return uppercase of string}
var
i:Integer;
Begin
   for i:= 1 to Length(s) do s[i] := UpCase(s[i]);
   Uppercase := s;
end;

{/////////////////////////////////////////////////////////}
Function ChangeFileExt(const aName, aExt: String): String;
Var
i, j:Integer;
Begin
  i := Length(aName);
  j := i;
  while (i > 0) and (aName[i]<>'\') and (aName[i]<>':') do
    begin
      if aName[i] = '.' then
        begin
          j := i-1;
          break
        end;
      dec(i)
    end;
  ChangeFileExt := Copy(aName,1,j) + aExt
End;

{/////////////////////////////////////////////////////////}
function IsUNC(Const s:string):boolean;
{// look for UNC name in one string (at beginning only) //}
begin
  IsUNC := (Length(s) > 3) and (s[1]='\') and (s[2]='\');
end;

{/////////////////////////////////////////////////////////}
(*
Function ExtractFilePath(aName:String):String;
{return the path only - strip filename out}
{$ifdef TPW}
var
  P: array[0..79] of Char;
{$endif TPW}
Var
i:Integer;
begin
{$ifdef Delphi}
  aName := ExpandFileName(aName);
{$else Delphi}
  {$ifdef Windows}
  FileExpand(P, Str2PChar(aName));
  aName := StrPas(p);
  {$else Windows}
  aName := FExpand(aName);
  {$endif Windows}
{$endif Delphi}

  i := Length(aName);
  while aName[i] <> '\' do   { Expanded filenames must have '\' }
    dec(i);
  ExtractFilePath := Copy(aName,1,i)
end;
*)

Function ExtractFilePath(const aName: String): String;
{return the pathname only - strip filename out}
Var
i: Word;
Begin
  i := Length(aName);
  While not (aName[i] in ['\', ':']) and (i <> 0) do
     Dec(i);
  If i = 0 then
    ExtractFilePath := ''
  else if i = 1 then
    ExtractFilePath := aName[1]
  else
    ExtractFilePath := AddBackSlash(Copy(aName, 1, i))
End;

{////////////////////////////////////////}
Function ExtractFileExt(const aName: String): String;
{return the fileextension}
Var
  i: Word;
Begin
   i := Length(aName);
   while (i > 0) and (aName[i]<>'\') and (aName[i]<>':') do
     begin
       if aName[i] = '.' then
         begin
           ExtractFileExt := Copy(aName,i,Length(aName));
           Exit
         end;
       Dec(i)
     end;
   ExtractFileExt := ''
End;
{/////////////////////////////////////////////////////////}

Function ExtractFileName(const s: String): String;
{return the filename only - strip path out}
Var
i : Word;
begin
   for i:=Length(s) downto 1 do
     if s[i] in [':','\'] then
     begin
       ExtractFileName := Copy(s,i+1,Length(s));
       Exit
     end; {s[i] in [':','\']}
   ExtractFileName := s
end;
{/////////////////////////////////////////////////////////}

Function FileExists(Const S: String): Boolean;
{does filename "S" exist?}
var
  f:    file;
  Attr: word;
begin
  Assign(f, s);
  GetFAttr(f,Attr);
  FileExists := (DosError = 0)
end;
{$endif Delphi}

{$ifDef Windows}
{////////////////////////////////////////////////////////}
{$ifdef Win32}
function FileVersionInfo(const fName, StringToGet: string): string;
{get the version information from inside a Win32 binary}
var
  VSize           : LongInt;
  VHandle         : THandle;
  Buffer          : Pointer;
  TranslationInfo : Pointer;
  LangCharSetID   : LongRec;
  Length          : DWORD;
  StringFileInfo  : string;
  aResult         : PChar;
const
  DefaultLangInfo : LongRec = (Lo: $0409;  
                               Hi: $04E4); 
begin
  FileVersionInfo := '';
  { Get size of version info }
  VSize := GetFileVersionInfoSize(PChar(fName), VHandle);
  if VSize > 0 then
    begin
    {$IFDEF Debug}
      if VHandle <> 0 then
        raise EChiefLZDebug.Create('FileVersionInfo() has failed!');
    {$ENDIF}
  { Allocate version info buffer }
      GetMem(Buffer, VSize);
      try { finally }
  { Get version info }
        if GetFileVersionInfo(PChar(fName), VHandle, VSize, Buffer) then
          try { except }
  { Get translation info for Language / CharSet IDs }
            if not VerQueryValue(Buffer,
                                '\VarFileInfo\Translation',
                                 TranslationInfo,
                                 Length) then
              LangCharSetID := DefaultLangInfo {no translation info - use defaults}
            else
              LangCharSetID := LongRec(TranslationInfo^);
{
  N.B. If cannot get Translation info, (because there ISN'T any ...???)
       will the default values mean anything anyway ...?
}
            with LangCharSetID do
              StringFileInfo :=
                    Format( '\StringFileInfo\%4.4x%4.4x\'+StringToGet,
                            [ Lo, Hi ] );
            if VerQueryValue(Buffer, PChar(StringFileInfo),
                             Pointer(aResult), Length) then
              SetString(Result, aResult, Length)
          except
{
  WinNT does not support the version-information functions for 16 bit
  executable files (although Win95 seems to). Therefore we `handle'
  any EAccessViolation exceptions that VerQueryValue() might raise,
  ensuring that FileVersionInfo() returns an empty string-value ...
}
            on EAccessViolation do;
          end
      finally
        FreeMem(Buffer, VSize)
      end
    end
end;
{$else Win32}
{$ifndef DPMI}
Function FileVersionInfo(const Fname, StringToGet:PChar): String;
{get the version information from inside a Windows binary}
type
  TLangArray = array[1..2] of Word;
var
  VSize, VHandle: LongInt;
  Buffer: PChar;
  Length: Word;
  TranslationInfo, aResult: Pointer;
  StringFileInfo: array[0..255] of Char;
  LangCharSetIDArray: TLangArray;
const
  DefaultLangInfo: TLangArray = ($0409,$04E4);

begin
  FileVersionInfo:= '';
  StrCopy(StringFileInfo, '\StringFileInfo\%04x%04x\');
  { Get size of version info }
  VSize := GetFileVersionInfoSize(fName, VHandle);
  { Allocate version info buffer }
  GetMem(Buffer, VSize + 1);
  { Get version info }
  if Buffer <> nil then
  begin
    if GetFileVersionInfo(fName, VHandle, VSize, Buffer) then
    begin
      { Get translation info for Language / CharSet IDs }
      if not VerQueryValue(Buffer, '\VarFileInfo\Translation',
                                          TranslationInfo, Length) then
        LangCharSetIDArray := DefaultLangInfo {no translation info - use defaults}
      else
        begin
          LangCharSetIDArray[1] := LoWord(Longint(TranslationInfo^));
          LangCharSetIDArray[2] := HiWord(Longint(TranslationInfo^))
        end;

      wvsPrintf(StringFileInfo, StrCat(StringFileInfo,StringToGet),
                                                    LangCharSetIDArray);
      if VerQueryValue(Buffer, StringFileInfo, aResult, Length) then
        FileVersionInfo := StrPas(PChar(aResult))
    end;
    FreeMem(Buffer, VSize + 1)
  end
end;
{$endif DPMI}
{$endif Win32}
{///////////////////////////////////////////////}
{$endif Windows}

end.