Chip 2002 March/Chip_2002-03_cd1.bin/zkuste/delphi/kompon/d5/cak/CAKDIR.ZIP/Utility.pas

Pascal/Delphi Source File | 2000-06-28 | 17KB | 708 lines

{++

u t i l i t y . p a s
Copyright (c) 1995-1997 by Alexander Staubo, all rights reserved.

Abstract:

  Utility functions.

  Additional notes:

  - The string functions are not optimized.

  - StreamReadLn is quite slow unless used on a buffered stream.

--}

{$WEAKPACKAGEUNIT ON}
{$I+}
{$IFNDEF Win32}
  !!  // 32-bit compilation only.
{$ENDIF}

unit Utility;

interface

uses
    SysUtils, Classes;

{ Types }

type
  TCharSet = set of Char;

{ Exception classes }

  EApiError =
    class(Exception)
    protected
      FErrorCode : Longint;
    public
      constructor Create (ErrorCode : Longint);
      constructor CreateMsg (ErrorCode : Longint; const Message : string);
      property ErrorCode : Longint read FErrorCode write FErrorCode;
    end;

{ System functions }

procedure ApiCheck (Result : Boolean);
  { If Error is True, this function raises an EApiError with the last error
    code and message }

procedure ApiError (ErrorCode : Longint);
  { Raises an EApiError with the specified system error code }

{ File utility functions }

function AddFileExt (const S, Ext : string) : string;
    { Add extension to file name if the file name does not already contain an
    extension. Ext must not contain period character }

function ForceFileExt (const S, Ext : string) : string;
    { Add extension to file name, deleting old extension. Equivalent to the
    ChangeFileExt procedure in SysUtils, except Ext must not contain period }

function AssurePath (const Path : string) : Boolean;
  { Assure that all directories in path exist. Equivalent to the
    ForceDirectories function in the Borland FileCtrl unit }

{ File string functions }

function AddBkSlash (const S : string) : string;
    { Returns S with backslash added}

function RemBkSlash (const S : string) : string;
    { Returns S with backslash removed}

{ Stream utilities }

procedure StreamWriteString (Stream : TStream; const Str : string);
  { Write string Str to stream }

function StreamReadString (Stream : TStream) : string;
  { Read string from stream }

function StreamReadLn (Stream : TStream) : string;
  { Read crlf-terminated line from stream }

procedure StreamWriteLn (Stream : TStream; Str : string);
  { Write crlf-terminated line to stream }

procedure StreamWrite (Stream : TStream; Str : string);
  { Write string to stream }

procedure StreamReadStrings (Stream : TStream; Strings : TStrings);
  { Read list of strings written with StreamWriteStrings from stream }

procedure StreamWriteStrings (Stream : TStream; Strings : TStrings);
  { Write list of strings to stream }

{ System functions }

function GetEnvironmentVarStr (const VarName : string) : string;
  { Read variable from environment block of the calling process }

function ExpandEnvironmentStr (const Str : string) : string;
  { Expands variables in Str to their equivalent environment variable values }

function GetUserNameStr : string;
  { Retrieve the user name of the current thread. This is the name of the user
    currently logged onto the system.  }

function GetComputerNameStr : string;
  { Retrieve the computer name of the current system. This name is established
    at system startup, when it is initialized from the registry }

function GetTempFileNameStr (const Path, Prefix : string;
  Unique : Longint) : string;
  { Generate a unique temporary file name. If successful, the file is also
    created with zero length. The resulting file name is the concatenation of
    specified path and prefix strings, a hexadecimal string formed from a
    specified integer, and the .TMP extension. If Unique is zero, a random
    number is used for the integer value; otherwise this value is used }

function GetTempPathStr : string;
  { Retrieve the path of the directory designated for temporary files }

function GetSystemDirectoryStr : string;
  { Retrieve system directory }

{ Miscellaneous low-level functions }

function LongSub (A, B : Longint) : Longint;
  { Evaluates the unsigned integer expression A-B, returning the result }

{ Timing functions. The tick routines avoid problems with 32-bit integers in
  Delphi, providing a separate type for storing the tick value }

type
  TTicks =
    record
      L, H : Word;
    end;

function NullTicks : TTicks;
  { Returns an empty tick value }

function GetTicks : TTicks; stdcall;
  { Get current tick count. Maps to GetTickCount }

function TicksSub (A, B : TTicks) : TTicks;
  { Subtract B ticks from A }

function TicksToInt (Ticks : TTicks) : Integer;
  { Convert ticks to integer }

function TicksToSec (Ticks : TTicks) : Integer;
  { Convert ticks to seconds }

{ String utilities }

type
  TWordOptions = set of
    (
      woNoSkipQuotes,
      woNoConsecutiveDelims
    );

function StrGetWord (const S : string; N : Integer;
  const Delims : TCharSet; const Options : TWordOptions) : string;
  { Extracts word number N from string S. Delims specify the characters used to
    delimit words }

function StrWordCount (const S : string; const Delims : TCharSet;
  const Options : TWordOptions) : Integer;
  { Returns number of words in S }

function StrWordPos (const S : string; N : Integer;
  const Delims : TCharSet; const Options : TWordOptions) : Integer;
  { Returns the character position of a word in S }

function UnquoteStr (const Str : string) : string;
  { Removes double quotes ("") from string Str }

function StrCompareWildCards (const A, B : string) : Boolean;
  { Compares two strings using Unix-like wild cards. Both A and B may contain
    the wild cards * and ? }

function ReplaceString (const Str, SubStr, NewStr : string) : string;
  { Replace occurences of SubStr in Str with NewStr }

implementation

uses
    Windows;

{ Resource strings }

{$I strconst.inc}

{ EApiError }

constructor EApiError.Create (ErrorCode : Longint);
begin
  inherited CreateFmt(strApiError, [ErrorCode, SysErrorMessage(ErrorCode)]);
end;

constructor EApiError.CreateMsg (ErrorCode : Longint; const Message : string);
begin
  inherited CreateFmt(Message, [ErrorCode]);
end;

{ Functions }

procedure ApiCheck (Result : Boolean);
begin
  if not Result then
    ApiError(GetLastError);
end;

procedure ApiError (ErrorCode : Longint);
begin
  raise EApiError.Create(ErrorCode);
end;

function AddFileExt (const S, Ext : string) : string;
begin
    if Pos('.', S) > 0 then
        Result:=S
    else
        Result:=S + '.' + Ext;
end;

function ForceFileExt (const S, Ext : string) : string;
begin
  if S <> '' then
    Result:=ChangeFileExt(S, '') + '.' + Ext
  else
    Result:='';
end;

function AssurePath (const Path : string) : Boolean;
begin
    if (Path = '') or ((Length(Path) = 2) and (Path[2] = ':') and
    (UpCase(Path[1]) in ['A'..'Z'])) then
        Result:=True
    else
    begin
      Result:=False;
      if AssurePath(RemBkSlash(ExtractFilePath(RemBkSlash(Path)))) then
        begin
          try
            MkDir(RemBkSlash(Path));
          except
            on E : EInOutError do
              if (E.ErrorCode <> 0) and
                 (E.ErrorCode <> ERROR_ACCESS_DENIED) and
                 (E.ErrorCode <> ERROR_ALREADY_EXISTS) then
                Exit;
            end;
          Result:=True;
        end
    end;
end;

function AddBkSlash (const S : string) : string;
begin
    if (S = '') or (S[Length(S)] = '\') then
      Result:=S
  else
      Result:=S + '\';
end;

function RemBkSlash (const S : string) : string;
begin
    if (S <> '') and (S[Length(S)] = '\') then
      Result:=Copy(S, 1, Length(S) - 1)
  else
      Result:=S;
end;

procedure StreamWriteString (Stream : TStream; const Str : string);
var
    Len : Longint;
begin
    Len:=Length(Str);
    Stream.Write(Len, SizeOf(Len));
    Stream.Write(Str[1], Len);
end;

function StreamReadString (Stream : TStream) : string;
var
    Len : Longint;
begin
    Stream.Read(Len, SizeOf(Len));
    SetLength(Result, Len);
    Stream.Read(Result[1], Len);
end;

function StreamReadLn (Stream : TStream) : string;
var
    C : Char;
begin
    Result:='';
    while True do
        begin
            if Stream.Read(C, SizeOf(C)) = 0 then
                Break;

            if C <> #13 then
                if C = #10 then
                    Break
                else
                    Result:=Result + C;
        end;
end;

procedure StreamWriteLn (Stream : TStream; Str : string);
begin
    Str:=Str + ^M^J;
    Stream.Write(Str[1], Length(Str));
end;

procedure StreamWrite (Stream : TStream; Str : string);
begin
    Stream.Write(Str[1], Length(Str));
end;

procedure StreamReadStrings (Stream : TStream; Strings : TStrings);
var
  I, N : Integer;
begin
  I:=0;
  Stream.Read(I, SizeOf(I));
  Strings.Clear;
  for N:=0 to I - 1 do
    Strings.Add(StreamReadString(Stream));
end;

procedure StreamWriteStrings (Stream : TStream; Strings : TStrings);
var
  I, N : Integer;
begin
  if Strings <> nil then
    I:=Strings.Count
  else
    I:=0;
  Stream.Write(I, SizeOf(I));
  for N:=0 to I - 1 do
    StreamWriteString(Stream, Strings.Strings[N]);
end;

function GetEnvironmentVarStr (const VarName : string) : string;
var
    Buf : array[0..128] of Char;
    Len : Integer;
begin
    Len:=GetEnvironmentVariable(PChar(VarName), @Buf, SizeOf(Buf));
    if Len > 0 then
        Result:=string(Buf)
    else
        Result:='';
end;

function ExpandEnvironmentStr (const Str : string) : string;
var
  Len : Integer;
  Buffer : array[Byte] of Char;
begin
  Len:=ExpandEnvironmentStrings(PChar(Str), Buffer, SizeOf(Buffer));
  if Len = 0 then
    raise EConvertError.CreateFmt(
      'Error %d calling ExpandEnvironmentStrings', [GetLastError]);
  Result:=string(Buffer);
end;

function GetUserNameStr : string;
var
  Buffer : array[0..127] of Char;
  Len : Integer;
begin
  Len:=SizeOf(Buffer);
{
  if GetUserName(@Buffer, Len) then
    Result:=string(Buffer)
  else
}
    Result:='';
end;

function GetComputerNameStr : string;
var
  Buffer : array[0..MAX_COMPUTERNAME_LENGTH - 1] of Char;
  Len : Integer;
begin
  Len:=SizeOf(Buffer);
{
  if GetComputerName(@Buffer, Len) then
    Result:=string(Buffer)
  else
}
    Result:='';
end;

function GetTempFileNameStr (const Path, Prefix : string;
  Unique : Longint) : string;
var
  Buffer : array[0..MAX_PATH - 1] of Char;
begin
  if GetTempFileName(PChar(Path), PChar(Prefix), Unique, @Buffer) <> 0 then
    Result:=string(Buffer)
  else
    Result:=''
end;

function GetTempPathStr : string;
var
  Buffer : array[0..MAX_PATH - 1] of Char;
begin
  if GetTempPath(SizeOf(Buffer) - 1, @Buffer) <> 0 then
    Result:=string(Buffer)
  else
    Result:=''
end;

function GetSystemDirectoryStr : string;
var
  Buffer : array[0..MAX_PATH - 1] of Char;
begin
  if GetSystemDirectory(@Buffer, SizeOf(Buffer) - 1) <> 0 then
    Result:=string(Buffer)
  else
    Result:=''
end;

function LongSub (A, B : Longint) : Longint;
asm
  mov eax, A
  mov ebx, B
  sub eax, ebx
end;

function NullTicks : TTicks;
asm
  mov eax, 0
end;

function GetTicks; external 'kernel32.dll' name 'GetTickCount';

function TicksSub (A, B : TTicks) : TTicks;
asm
  mov eax, A
  mov ebx, B
  sub eax, ebx
end;

function TicksToInt (Ticks : TTicks) : Integer;
asm
  mov eax, Ticks
end;

function TicksToSec (Ticks : TTicks) : Integer;
begin
  Result:=TicksToInt(Ticks) div 1000;
end;

function StrGetWord (const S : string; N : Integer;
  const Delims : TCharSet; const Options : TWordOptions) : string;
var
  I, I0 : Integer;
  QuoteChar : string;
begin
  I0:=1;
  I:=1;
  if woNoSkipQuotes in Options then
    QuoteChar:=''
  else
    QuoteChar:='"';
  if S <> '' then
    while I <= Length(S) + 1 do
      begin
        if (I > Length(S)) or (S[I] in Delims) then
          begin
            if N > 0 then
              Dec(N);
            if N = 0 then
              begin
                Result:=Copy(S, I0, I - I0);
                if Result <> '' then
                  Exit;
              end;
            if woNoConsecutiveDelims in Options then
              I0:=I + 1
            else
              begin
                while (I <= Length(S)) and (S[I] in Delims) do
                  Inc(I);
                I0:=I;
              end;
          end;
        if S[I] = QuoteChar then
          begin
            Inc(I);
            while (I <= Length(S)) and (S[I] <> QuoteChar) do
              Inc(I);
          end;
        Inc(I);
      end;
  Result:='';
end;

function StrWordCount (const S : string; const Delims : TCharSet;
  const Options : TWordOptions) : Integer;
var
  I : Integer;
  QuoteChar : string;
begin
  Result:=0;
  I:=1;
  if woNoSkipQuotes in Options then
    QuoteChar:=''
  else
    QuoteChar:='"';
  if S <> '' then
    while I <= Length(S) + 1 do
      begin
        if (I > Length(S)) or (S[I] in Delims) then
          begin
            Inc(Result);
            if not (woNoConsecutiveDelims in Options) then
              while (I <= Length(S)) and (S[I] in Delims) do
                Inc(I);
          end;
        if S[I] = QuoteChar then
          begin
            Inc(I);
            while (I <= Length(S)) and (S[I] <> QuoteChar) do
              Inc(I);
          end;
        Inc(I);
      end;
end;

function StrWordPos (const S : string; N : Integer;
  const Delims : TCharSet; const Options : TWordOptions) : Integer;
var
  I : Integer;
  QuoteChar : string;
begin
  Result:=1;
  I:=1;
  if woNoSkipQuotes in Options then
    QuoteChar:=''
  else
    QuoteChar:='"';
  if S <> '' then
    while (N > 0) and (I <= Length(S)) do
      begin
        if S[I] in Delims then
          begin
            Dec(N);
            if N = 0 then
              Exit;
            if not (woNoConsecutiveDelims in Options) then
              while (I <= Length(S)) and (S[I] in Delims) do
                Inc(I);
            Result:=I;
          end
        else if S[I] = QuoteChar then
          begin
            Inc(I);
            while (I <= Length(S)) and (S[I] <> '"') do
              Inc(I);
          end;
        Inc(I);
      end;
end;

function UnquoteStr (const Str : string) : string;
begin
  if (Length(Str) >= 2) and (Str[1] = '"') and (Str[Length(Str)] = '"') then
    Result:=Copy(Str, 2, Length(Str) - 2)
  else
    Result:=Str;
end;

function StrCompareWildCards (const A, B : string) : Boolean;
var
    PosA, PosB : Integer;
begin
    PosA:=1;
    PosB:=1;
    Result:=True;

    if (Length(A) = 0) and (Length(B) = 0) then
        Result:=True
    else
        if Length(A) = 0 then
            begin
        if B[1] = '*' then
                  Result:=True
              else
                  Result:=False
      end
        else if Length(B) = 0 then
            begin
        if A[1] = '*' then
                  Result:=True
              else
                  Result:=False;
      end;

    while (Result = True) and (PosA <= Length(A)) and (PosB <= Length(B)) do
        if (A[PosA] = '?') or (B[PosB] = '?') then
            begin
                Inc(PosA);
                Inc(PosB);
            end
        else if A[PosA] = '*' then
            begin
                Inc(PosA);
                if PosA <= Length(A) then
                    begin
                        while (PosB <= Length(B)) and not StrCompareWildCards(
              Copy(A, PosA, Length(A) - PosA + 1),
              Copy(B, PosB, Length(B) - PosB + 1)) do
                            Inc(PosB);

                        if PosB > Length(B) then
                            Result:=False
                        else
                            begin
                                PosA:=Succ(Length(A));
                                PosB:=Succ(Length(B));
                            end
                    end
                else
                    PosB:=Succ(Length(B));
            end
        else if B[PosB] = '*' then
            begin
                Inc(PosB);
                if PosB <= Length(B) then
                    begin
                        while (PosA <= Length(A)) and not StrCompareWildCards(
              Copy(A, PosA, Length(A) - PosA + 1),
              Copy(B, PosB, Length(B) - PosB + 1)) do
                            Inc(PosA);

                        if PosA > Length(A) then
                            Result:=False
                        else
                            begin
                                PosA:=Succ(Length(A));
                                PosB:=Succ(Length(B));
                            end
                    end
                else
                    PosA:=Succ(Length(A));
            end
        else if UpCase(A[PosA]) = UpCase(B[PosB]) then
            begin
                Inc(PosA);
                Inc(PosB);
            end
        else
            Result:=False;

    if PosA > Length(A) then
        begin
            while (PosB <= Length(B)) and (B[PosB] = '*') do
                Inc(PosB);

            if PosB <= Length(B) then
                Result:=False;
        end;

    if PosB > Length(B) then
        begin
            while (PosA <= Length(A)) and (A[PosA] = '*') do
                Inc(PosA);
            if PosA <= Length(A) then
                Result:=False;
        end;
end;

function ReplaceString (const Str, SubStr, NewStr : string) : string;
var
  I : Integer;
begin
  Result:=Str;
  while True do
    begin
      I:=Pos(SubStr, Result);
      if I > 0 then
        begin
          Delete(Result, I, Length(SubStr));
          Insert(NewStr, Result, I);
        end
      else
        Break;
    end;
end;

end.