dpp_utils.pas

East make Tray Icon in delphi

{**************************************************************************************************}
{                                                                                                  }
{ Delphi language Preprocessor (dpp32)                                                             }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is dpp_Utils.pas                                                               }
{                                                                                                  }
{ The Initial Developer of the Original Code is Andreas Hausladen                                  }
{ Portions created by these individuals are Copyright (C) of these individuals.                    }
{                                                                                                  }
{**************************************************************************************************}
unit dpp_Utils;
{$define HASHTABLE}
interface
uses
{$ifdef MSWINDOWS}
  Windows, SysUtils, Classes, RTLConsts;
{$endif}
{$ifdef LINUX}  
  Libc, SysUtils, Classes, RTLConsts;
{$endif}

type
  TBooleanList = class(TObject)
  private
    FCount: Integer;
    FList: array of Boolean;
    FLast: Boolean;
    function GetItems(Index: Integer): Boolean;
    procedure SetItems(Index: Integer; const Value: Boolean);
  public
    constructor Create;
    function Add(Value: Boolean): Integer;
    procedure Delete(Index: Integer);
    procedure Clear;

    procedure DeleteLast;
    procedure ToggleLast;

    property Last: Boolean read FLast;
    property Count: Integer read FCount;
    property Items[Index: Integer]: Boolean read GetItems write SetItems;
  end;

  TRedirectTable = array of record
                              Text: string;
                              Index: Integer;
                            end;


procedure MakeStringHash(const Text: string; Index: Integer; var Table: TRedirectTable);
function FindStringHash(const Text: string; const Table: TRedirectTable; CaseSensitive: Boolean): Integer;
procedure DelStringHash(const Text: string; var Table: TRedirectTable; CaseSensitive: Boolean); overload;
procedure DelStringHash(Index: Integer; var Table: TRedirectTable); overload;

type
  TFilenameMapper = class(TStringList)
  private
    FHashTable: TRedirectTable;
  public
    procedure AddFilename(const Name, Filename: string);
    function FindFilename(const Name: string; var Filename: string): Boolean;

    procedure Clear; override;
  end;


// *****************************************************************************
// **************************** File handling **********************************
// *****************************************************************************

function CopyFile(const SourceFileName, DestFileName: String;
  NativeCopy: Boolean = True): Boolean;
// Copy Source to Dest using a native copy function or the built in.

function MoveFile(const SourceFilename, DestFilename: String): Boolean;
// Moves the file Source to Dest. If renaming is not possible the file is moved
// by copy and delete.

function FileExistsX(const Filename: string): Boolean;
// Like SysUtils.FileExists() but on Windows it is faster.

procedure FileToString(const Filename: string; out Content: string);
// Reads a file into the string Content.

procedure StringToFile(const Filename, Content: string);
// Writes a file from the string Content.

function GetPreProcessedFilename(const Filename: string; IncludeIndex: Integer = 0): string;
// Returns the corresponding preprocessed Filename.
// IncludeIndex = 0  -> *.i.*
// IncludeIndex > 0  -> *.iX.*   where X=IncludeIndex


type
  TExTestMethod = function(const Filename: string): Boolean of object;

function TestFilenames(const Paths, Filename: string; ExTestMethod: TExTestMethod = nil): string;
// Returns the file name of an existing file by seaching Paths.

function FollowRelativePath(BaseDir, Filename: string): string;
// Expands the relative file path Filename based on BaseDir.

function CompareFileNames(const FileName1, FileName2: string): Integer;
// Compares the two file names

// *****************************************************************************
// ************************** String handling **********************************
// *****************************************************************************

function CountCharsStop(Ch, StopCh: Char; P: PChar): Integer;
function CountChars(Ch: Char; const S: string): Integer;
// CountChars() gets the number of char Ch in P. It stops seeking on char StopCh.

function PosCharSet(CS: TSysCharSet; const S: string): Integer;
// Returns the index of the first char in S which is in CS.

function PosChar(Ch: Char; const S: string): Integer;
// Returns the index of the first char Ch in S.

function StartsText(const StartText, Text: string): Boolean;
// Returns TRUE if StartText is the beginning of Text

function RemoveQuotes(const Text: string): string;
// Removes the embracing quotes ( " and ' )

function IsStrEmpty(const Text: string): Boolean;
// Returns true if all chars in Text are in [#1..#32].

function IndexOfStrText(List: TStrings; const StrText: string;
  CaseSensitive: Boolean): Integer;
// Returns the index of StrText in List.

function IndexOfFilename(Files: TStrings; const Filename: string): Integer;
// Returns the index of the file name in Files (uses CompareFileNames).

procedure PathListToStrings(const Paths: string; List: TStrings);
// Converts Paths (path;path or path:path) to a string list.


implementation

{ TBooleanList }

constructor TBooleanList.Create;
begin
  inherited Create;
  FLast := True;
end;

function TBooleanList.Add(Value: Boolean): Integer;
begin
  if FCount >= Length(FList) then
    SetLength(FList, FCount + 10); // allocate more than 1 saves some memory with SysMemoryManger
  FList[FCount] := Value;
  Result := FCount;
  Inc(FCount);

  FLast := Value;
end;

procedure TBooleanList.Clear;
begin
  FCount := 0;
  SetLength(FList, 0);
  FLast := True;
end;

procedure TBooleanList.Delete(Index: Integer);
begin
  Dec(FCount);
  if FCount mod 10 = 0 then
    SetLength(FList, FCount);
  if FCount > 0 then
    FLast := FList[FCount - 1]
  else
    FLast := True;
end;

procedure TBooleanList.DeleteLast;
begin
  if Count > 0 then
    Delete(Count - 1)
  else
    FLast := True;
end;

function TBooleanList.GetItems(Index: Integer): Boolean;
begin
{  if Cardinal(Index) >= Cardinal(Count) then
    TList.Error(@SListIndexError, Index);}
  Result := FList[Index];
end;

procedure TBooleanList.SetItems(Index: Integer; const Value: Boolean);
begin
{  if Cardinal(Index) >= Cardinal(Count) then
    TList.Error(@SListIndexError, Index);}
  FList[Index] := Value;
  if Index = Count - 1 then FLast := Value;
end;

procedure TBooleanList.ToggleLast;
begin
  if Count > 0 then
    Items[Count - 1] := not Items[Count - 1];
end;

{ TFilenameMapper }

procedure TFilenameMapper.AddFilename(const Name, Filename: string);
begin
  MakeStringHash(Name, Add(Name) + 1, FHashTable);
  Add(Filename);
end;

procedure TFilenameMapper.Clear;
begin
  SetLength(FHashTable, 0);
  inherited Clear;
end;

function TFilenameMapper.FindFilename(const Name: string; var Filename: string): Boolean;
{$ifdef HASHTABLE}
var Index: Integer;
begin
  Index := FindStringHash(Name, FHashTable, {$ifdef MSWINDOWS}False{$endif}{$ifdef LINUX}True{$endif});
  if Index > 0 then
  begin
    Result := True;
    Filename := Strings[Index];
  end
  else
    Result := False;
end;
{$else}
var
  i: Integer;
  cnt: Integer;
begin
  cnt := Count;
  i := 0;
  while i < cnt do
  begin
    if CompareFileNames(Name, Strings[i]) = 0 then
    begin
      Result := True;
      Filename := Strings[i + 1];
      Exit;
    end;
    Inc(i, 2);
  end;
  Result := False;
end;
{$endif}

// *****************************************************************************
// **************************** File handling **********************************
// *****************************************************************************

function CopyFile(const SourceFileName, DestFileName: String;
  NativeCopy: Boolean = True): Boolean;

 function BuiltInCopyFile: Boolean;
 var
   InFile, OutFile: TFileStream;
{$ifdef MSWINDOWS}
   CreationTime, LastWriteTime, LastAccessTime: TFileTime;
{$endif}
{$ifdef LINUX}
   st: TStatBuf;
{$endif}
 begin
   Result := True;
   try
     InFile := TFileStream.Create(SourceFileName, fmOpenRead or fmShareDenyWrite);
     try
       OutFile := TFileStream.Create(DestFileName, fmCreate or fmShareExclusive);
       try
         try
           OutFile.CopyFrom(InFile, 0);
         except
           Result := False;
         end;
{$ifdef MSWINDOWS}
         GetFileTime(InFile.Handle, @CreationTime, @LastAccessTime, @LastWriteTime);
         SetFileTime(OutFile.Handle, @CreationTime, @LastAccessTime, @LastWriteTime);
{$endif}
       finally
         OutFile.Free;
       end;
{$ifdef LINUX}
       FileSetDate(DestFileName, FileGetDate(InFile.Handle));
       if fstat(InFile.Handle, st) = 0 then
         Libc.chmod(PChar(DestFileName), st.st_mode);
{$endif}
     finally
       InFile.Free;
     end;
{$ifdef MSWINDOWS}
     SetFileAttributes(PChar(DestFileName), GetFileAttributes(PChar(SourceFileName)));
{$endif}
   except
     Result := False;
   end;
 end;

begin
{$ifdef MSWINDOWS}
  if NativeCopy then
    Result := Windows.CopyFile(PChar(SourceFileName), PChar(DestFileName), False)
  else
{$endif}
  Result := BuiltInCopyFile;
end;

// *****************************************************************************

function MoveFile(const SourceFilename, DestFilename: String): Boolean;
begin
  Result := False;
  if (SourceFilename = '') or (DestFilename = '') or
     (not FileExists(SourceFilename)) then Exit;

  ForceDirectories(ExtractFilePath(DestFilename)); // create directories

  if FileExists(DestFilename) then // delete destination file if exist
  begin
{$ifdef MSWINDOWS}
    SetFileAttributes(PChar(DestFilename), 0);
{$endif}
{$ifdef LINUX}
    FileSetReadOnly(DestFilename, False);
{$endif}
    DeleteFile(DestFilename);
  end;

  if not RenameFile(SourceFilename, DestFilename) then
  begin
    if CopyFile(SourceFilename, DestFilename, True) then
    begin
     // delete source file
{$ifdef MSWINDOWS}
      SetFileAttributes(PChar(SourceFilename), 0);
{$endif}
{$ifdef LINUX}
      FileSetReadOnly(SourceFilename, False);
{$endif LINUX}
      DeleteFile(SourceFilename);
      Result := True;
    end;
  end
  else
    Result := True;
end;

// *****************************************************************************

function FileExistsX(const Filename: string): Boolean;
{$ifdef MSWINDOWS}
var Attrib: Cardinal;
begin
  Attrib := GetFileAttributes(PChar(Filename));
  Result := (Attrib <> $FFFFFFFF) and (Attrib and FILE_ATTRIBUTE_DIRECTORY = 0);
end;
{$else}
asm
  JMP FileExists
end;
{$endif}

// *****************************************************************************

procedure FileToString(const Filename: string; out Content: string);
var
  Stream: TStream;
  Len: Integer;
begin
  Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyWrite);
  try
    Len := Stream.Size;