Collection of Hack-Phreak Scene Programs/cleanhpvac.zip/cleanhpvac/CHFLZ100.ZIP/CHFUTILS.PAS

Pascal/Delphi Source File | 1996-09-05 | 21KB | 818 lines

{$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)
      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.