Componentes.Terceros.jcl/official/2.1.1/source/common/JclSysUtils.pas

{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ 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 JclSysUtils.pas.                                                            }
{                                                                                                  }
{ The Initial Developer of the Original Code is Marcel van Brakel.                                 }
{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved.  }
{                                                                                                  }
{ Contributors:                                                                                    }
{   Alexander Radchenko,                                                                           }
{   Andreas Hausladen (ahuser)                                                                     }
{   Anthony Steele                                                                                 }
{   Bernhard Berger                                                                                }
{   Heri Bender                                                                                    }
{   Jean-Fabien Connault (cycocrew)                                                                }
{   Jeroen Speldekamp                                                                              }
{   Marcel van Brakel                                                                              }
{   Peter Friese                                                                                   }
{   Petr Vones (pvones)                                                                            }
{   Python                                                                                         }
{   Robert Marquardt (marquardt)                                                                   }
{   Robert R. Marsh                                                                                }
{   Robert Rossmair (rrossmair)                                                                    }
{   Rudy Velthuis                                                                                  }
{   Uwe Schuster (uschuster)                                                                       }
{   Wayne Sherman                                                                                  }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Description: Various pointer and class related routines.                                         }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Last modified: $Date:: 2009-10-03 11:34:58 +0200 (sam., 03 oct. 2009)                          $ }
{ Revision:      $Rev:: 3034                                                                     $ }
{ Author:        $Author:: outchy                                                                $ }
{                                                                                                  }
{**************************************************************************************************}

unit JclSysUtils;

{$I jcl.inc}

interface

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF MSWINDOWS}
  SysUtils, Classes, TypInfo, SyncObjs,
  JclBase;

// memory initialization
// first parameter is "out" to make FPC happy with uninitialized values
procedure ResetMemory(out P; Size: Longint);

// Pointer manipulation
procedure GetAndFillMem(var P: Pointer; const Size: Integer; const Value: Byte);
procedure FreeMemAndNil(var P: Pointer);
function PCharOrNil(const S: string): PChar;
function PAnsiCharOrNil(const S: AnsiString): PAnsiChar;
{$IFDEF SUPPORTS_WIDESTRING}
function PWideCharOrNil(const W: WideString): PWideChar;
{$ENDIF SUPPORTS_WIDESTRING}

function SizeOfMem(const APointer: Pointer): Integer;

function WriteProtectedMemory(BaseAddress, Buffer: Pointer; Size: Cardinal;
  out WrittenBytes: Cardinal): Boolean;

// Guards
type
  ISafeGuard = interface
    function ReleaseItem: Pointer;
    function GetItem: Pointer;
    procedure FreeItem;
    property Item: Pointer read GetItem;
  end;

  IMultiSafeGuard = interface (IInterface)
    function AddItem(Item: Pointer): Pointer;
    procedure FreeItem(Index: Integer);
    function GetCount: Integer;
    function GetItem(Index: Integer): Pointer;
    function ReleaseItem(Index: Integer): Pointer;
    property Count: Integer read GetCount;
    property Items[Index: Integer]: Pointer read GetItem;
  end;

    TJclSafeGuard = class(TInterfacedObject, ISafeGuard)
  private
    FItem: Pointer;
  public
    constructor Create(Mem: Pointer);
    destructor Destroy; override;
    { ISafeGuard }
    function ReleaseItem: Pointer;
    function GetItem: Pointer;
    procedure FreeItem; virtual;
    property Item: Pointer read GetItem;
  end;

  TJclObjSafeGuard = class(TJclSafeGuard, ISafeGuard)
  public
    constructor Create(Obj: TObject);
    { ISafeGuard }
    procedure FreeItem; override;
  end;

  TJclMultiSafeGuard = class(TInterfacedObject, IMultiSafeGuard)
  private
    FItems: TList;
  public
    constructor Create;
    destructor Destroy; override;
    { IMultiSafeGuard }
    function AddItem(Item: Pointer): Pointer;
    procedure FreeItem(Index: Integer); virtual;
    function GetCount: Integer;
    function GetItem(Index: Integer): Pointer;
    function ReleaseItem(Index: Integer): Pointer;
    property Count: Integer read GetCount;
    property Items[Index: Integer]: Pointer read GetItem;
  end;

  TJclObjMultiSafeGuard = class(TJclMultiSafeGuard, IMultiSafeGuard)
  public
    { IMultiSafeGuard }
    procedure FreeItem(Index: Integer); override;
  end;

function Guard(Mem: Pointer; out SafeGuard: ISafeGuard): Pointer; overload;
function Guard(Obj: TObject; out SafeGuard: ISafeGuard): TObject; overload;

function Guard(Mem: Pointer; var SafeGuard: IMultiSafeGuard): Pointer; overload;
function Guard(Obj: TObject; var SafeGuard: IMultiSafeGuard): TObject; overload;

function GuardGetMem(Size: Cardinal; out SafeGuard: ISafeGuard): Pointer;
function GuardAllocMem(Size: Cardinal; out SafeGuard: ISafeGuard): Pointer;

(*
{$IFDEF SUPPORTS_GENERICS}
type
  ISafeGuard<T: class> = interface
    function ReleaseItem: T;
    function GetItem: T;
    procedure FreeItem;
    property Item: T read GetItem;
  end;

  TSafeGuard<T: class> = class(TObject, ISafeGuard<T>)
  private
    FItem: T;
    function ReleaseItem: T;
    function GetItem: T;
    procedure FreeItem;

	constructor Create(Instance: T);
	destructor Destroy; override;
  public
    class function New(Instance: T): ISafeGuard<T>; static;
  end;
{$ENDIF SUPPORTS_GENERICS}
*)

{ Shared memory between processes functions }

// Functions for the shared memory owner
type
  ESharedMemError = class(EJclError);

{$IFDEF MSWINDOWS}

{ SharedGetMem return ERROR_ALREADY_EXISTS if the shared memory is already
  allocated, otherwise it returns 0.
  Throws ESharedMemError if the Name is invalid. }
function SharedGetMem(var P{: Pointer}; const Name: string; Size: Cardinal;
  DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Integer;

{ SharedAllocMem calls SharedGetMem and then fills the memory with zero if
  it was not already allocated.
  Throws ESharedMemError if the Name is invalid. }
function SharedAllocMem(const Name: string; Size: Cardinal;
  DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Pointer;

{ SharedFreeMem releases the shared memory if it was the last reference. }
function SharedFreeMem(var P{: Pointer}): Boolean;

// Functions for the shared memory user

{ SharedOpenMem returns True if the shared memory was already allocated by
  SharedGetMem or SharedAllocMem. Otherwise it returns False.
  Throws ESharedMemError if the Name is invalid. }

function SharedOpenMem(var P{: Pointer}; const Name: string;
  DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Boolean; overload;

{ SharedOpenMem return nil if the shared memory was not already allocated
  by SharedGetMem or SharedAllocMem.
  Throws ESharedMemError if the Name is invalid. }
function SharedOpenMem(const Name: string;
  DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Pointer; overload;

{ SharedCloseMem releases the shared memory if it was the last reference. }
function SharedCloseMem(var P{: Pointer}): Boolean;

{$ENDIF MSWINDOWS}

// Binary search
function SearchSortedList(List: TList; SortFunc: TListSortCompare; Item: Pointer;
  Nearest: Boolean = False): Integer;

type
  TUntypedSearchCompare = function(Param: Pointer; ItemIndex: Integer; const Value): Integer;

function SearchSortedUntyped(Param: Pointer; ItemCount: Integer; SearchFunc: TUntypedSearchCompare;
  const Value; Nearest: Boolean = False): Integer;

// Dynamic array sort and search routines
type
  TDynArraySortCompare = function (Item1, Item2: Pointer): Integer;

procedure SortDynArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortCompare);
// Usage: SortDynArray(Array, SizeOf(Array[0]), SortFunction);
function SearchDynArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortCompare;
  ValuePtr: Pointer; Nearest: Boolean = False): Integer;
// Usage: SearchDynArray(Array, SizeOf(Array[0]), SortFunction, @SearchedValue);

{ Various compare functions for basic types }

function DynArrayCompareByte(Item1, Item2: Pointer): Integer;
function DynArrayCompareShortInt(Item1, Item2: Pointer): Integer;
function DynArrayCompareWord(Item1, Item2: Pointer): Integer;
function DynArrayCompareSmallInt(Item1, Item2: Pointer): Integer;
function DynArrayCompareInteger(Item1, Item2: Pointer): Integer;
function DynArrayCompareCardinal(Item1, Item2: Pointer): Integer;
function DynArrayCompareInt64(Item1, Item2: Pointer): Integer;

function DynArrayCompareSingle(Item1, Item2: Pointer): Integer;
function DynArrayCompareDouble(Item1, Item2: Pointer): Integer;
function DynArrayCompareExtended(Item1, Item2: Pointer): Integer;
function DynArrayCompareFloat(Item1, Item2: Pointer): Integer;

function DynArrayCompareAnsiString(Item1, Item2: Pointer): Integer;
function DynArrayCompareAnsiText(Item1, Item2: Pointer): Integer;
function DynArrayCompareWideString(Item1, Item2: Pointer): Integer;
function DynArrayCompareWideText(Item1, Item2: Pointer): Integer;
function DynArrayCompareString(Item1, Item2: Pointer): Integer;
function DynArrayCompareText(Item1, Item2: Pointer): Integer;

// Object lists
procedure ClearObjectList(List: TList);
procedure FreeObjectList(var List: TList);

// Reference memory stream
type
  TJclReferenceMemoryStream = class(TCustomMemoryStream)
  public
    constructor Create(const Ptr: Pointer; Size: Longint);
    function Write(const Buffer; Count: Longint): Longint; override;
  end;

// AutoPtr
type
  IAutoPtr = interface
    { Returns the object as pointer, so it is easier to assign it to a variable }
    function AsPointer: Pointer;
    { Returns the AutoPtr handled object }
    function AsObject: TObject;
    { Releases the object from the AutoPtr. The AutoPtr looses the control over
      the object. }
    function ReleaseObject: TObject;
  end;

  TJclAutoPtr = class(TInterfacedObject, IAutoPtr)
  private
    FValue: TObject;
  public
    constructor Create(AValue: TObject);
    destructor Destroy; override;
    { IAutoPtr }
    function AsPointer: Pointer;
    function AsObject: TObject;
    function ReleaseObject: TObject;
  end;

function CreateAutoPtr(Value: TObject): IAutoPtr;

// Replacement for the C ternary conditional operator ? :
function Iff(const Condition: Boolean; const TruePart, FalsePart: string): string; overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart: Char): Char; overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart: Byte): Byte; overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart: Integer): Integer; overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart: Cardinal): Cardinal; overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart: Float): Float; overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart: Boolean): Boolean; overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart: Pointer): Pointer; overload;
function Iff(const Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overload;
{$IFDEF SUPPORTS_VARIANT}
function Iff(const Condition: Boolean; const TruePart, FalsePart: Variant): Variant; overload;
{$ENDIF SUPPORTS_VARIANT}

// Classes information and manipulation
type
  EJclVMTError = class(EJclError);

// Virtual Methods
{$IFNDEF FPC}
function GetVirtualMethodCount(AClass: TClass): Integer;
{$ENDIF ~FPC}
function GetVirtualMethod(AClass: TClass; const Index: Integer): Pointer;
procedure SetVirtualMethod(AClass: TClass; const Index: Integer; const Method: Pointer);

// Dynamic Methods
type
  TDynamicIndexList = array [0..MaxInt div 16] of Word;
  PDynamicIndexList = ^TDynamicIndexList;
  TDynamicAddressList = array [0..MaxInt div 16] of Pointer;
  PDynamicAddressList = ^TDynamicAddressList;

function GetDynamicMethodCount(AClass: TClass): Integer;
function GetDynamicIndexList(AClass: TClass): PDynamicIndexList;
function GetDynamicAddressList(AClass: TClass): PDynamicAddressList;
function HasDynamicMethod(AClass: TClass; Index: Integer): Boolean;
{$IFNDEF FPC}
function GetDynamicMethod(AClass: TClass; Index: Integer): Pointer;
{$ENDIF ~FPC}

{ init table methods }

function GetInitTable(AClass: TClass): PTypeInfo;

{ field table methods }

type
  PFieldEntry = ^TFieldEntry;
  TFieldEntry = packed record
    OffSet: Integer;
    IDX: Word;
    Name: ShortString;
  end;

  PFieldClassTable = ^TFieldClassTable;
  TFieldClassTable = packed record
    Count: Smallint;
    Classes: array [0..8191] of ^TPersistentClass;
  end;

  PFieldTable = ^TFieldTable;
  TFieldTable = packed record
    EntryCount: Word;
    FieldClassTable: PFieldClassTable;
    FirstEntry: TFieldEntry;
   {Entries: array [1..65534] of TFieldEntry;}
  end;

function GetFieldTable(AClass: TClass): PFieldTable;

{ method table }

type
  PMethodEntry = ^TMethodEntry;
  TMethodEntry = packed record
    EntrySize: Word;
    Address: Pointer;
    Name: ShortString;
  end;

  PMethodTable = ^TMethodTable;
  TMethodTable = packed record
    Count: Word;
    FirstEntry: TMethodEntry;
   {Entries: array [1..65534] of TMethodEntry;}
  end;

function GetMethodTable(AClass: TClass): PMethodTable;
function GetMethodEntry(MethodTable: PMethodTable; Index: Integer): PMethodEntry;

// Class Parent
procedure SetClassParent(AClass: TClass; NewClassParent: TClass);
function GetClassParent(AClass: TClass): TClass;

{$IFNDEF FPC}
function IsClass(Address: Pointer): Boolean;
function IsObject(Address: Pointer): Boolean;
{$ENDIF ~FPC}

function InheritsFromByName(AClass: TClass; const AClassName: string): Boolean;

// Interface information
function GetImplementorOfInterface(const I: IInterface): TObject;

// Numeric formatting routines
type
  TDigitCount = 0..255;
  TDigitValue = -1..35;  // invalid, '0'..'9', 'A'..'Z'
  TNumericSystemBase = 2..Succ(High(TDigitValue));

  TJclNumericFormat = class(TObject)
  private
    FWantedPrecision: TDigitCount;
    FPrecision: TDigitCount;
    FNumberOfFractionalDigits: TDigitCount;
    FExpDivision: Integer;
    FDigitBlockSize: TDigitCount;
    FWidth: TDigitCount;
    FSignChars: array [Boolean] of Char;
    FBase: TNumericSystemBase;
    FFractionalPartSeparator: Char;
    FDigitBlockSeparator: Char;
    FShowPositiveSign: Boolean;
    FPaddingChar: Char;
    FMultiplier: string;
    function GetDigitValue(Digit: Char): Integer;
    function GetNegativeSign: Char;
    function GetPositiveSign: Char;
    procedure InvalidDigit(Digit: Char);
    procedure SetPrecision(const Value: TDigitCount);
    procedure SetBase(const Value: TNumericSystemBase);
    procedure SetNegativeSign(const Value: Char);
    procedure SetPositiveSign(const Value: Char);
    procedure SetExpDivision(const Value: Integer);
  protected
    function IntToStr(const Value: Int64; out FirstDigitPos: Integer): string; overload;
    function ShowSign(const Value: Float): Boolean; overload;
    function ShowSign(const Value: Int64): Boolean; overload;
    function SignChar(const Value: Float): Char; overload;
    function SignChar(const Value: Int64): Char; overload;
    property WantedPrecision: TDigitCount read FWantedPrecision;
  public
    constructor Create;
    function Digit(DigitValue: TDigitValue): Char;
    function DigitValue(Digit: Char): TDigitValue;
    function IsDigit(Value: Char): Boolean;
    function Sign(Value: Char): Integer;
    procedure GetMantissaExp(const Value: Float; out Mantissa: string; out Exponent: Integer);
    function FloatToHTML(const Value: Float): string;
    function IntToStr(const Value: Int64): string; overload;
    function FloatToStr(const Value: Float): string; overload;
    function StrToInt(const Value: string): Int64;
    property Base: TNumericSystemBase read FBase write SetBase;
    property Precision: TDigitCount read FPrecision write SetPrecision;
    property NumberOfFractionalDigits: TDigitCount read FNumberOfFractionalDigits write FNumberOfFractionalDigits;
    property ExponentDivision: Integer read FExpDivision write SetExpDivision;
    property DigitBlockSize: TDigitCount read FDigitBlockSize write FDigitBlockSize;
    property DigitBlockSeparator: Char read FDigitBlockSeparator write FDigitBlockSeparator;
    property FractionalPartSeparator: Char read FFractionalPartSeparator write FFractionalPartSeparator;
    property Multiplier: string read FMultiplier write FMultiplier;
    property PaddingChar: Char read FPaddingChar write FPaddingChar;
    property ShowPositiveSign: Boolean read FShowPositiveSign write FShowPositiveSign;
    property Width: TDigitCount read FWidth write FWidth;
    property NegativeSign: Char read GetNegativeSign write SetNegativeSign;
    property PositiveSign: Char read GetPositiveSign write SetPositiveSign;
  end;

function IntToStrZeroPad(Value, Count: Integer): string;

// Child processes
type
  // e.g. TStrings.Append
  TTextHandler = procedure(const Text: string) of object;

const
  ABORT_EXIT_CODE = {$IFDEF MSWINDOWS} ERROR_CANCELLED {$ELSE} 1223 {$ENDIF};

function Execute(const CommandLine: string; OutputLineCallback: TTextHandler; RawOutput: Boolean = False;
  AbortPtr: PBoolean = nil): Cardinal; overload;
function Execute(const CommandLine: string; var Output: string; RawOutput: Boolean = False;
  AbortPtr: PBoolean = nil): Cardinal; overload;

type
{$HPPEMIT 'namespace Jclsysutils'}
{$HPPEMIT '{'}
{$HPPEMIT '  // For some reason, the generator puts this interface after its first'}
{$HPPEMIT '  // usage, resulting in an unusable header file. We fix this by forward'}
{$HPPEMIT '  // declaring the interface.'}
{$HPPEMIT '  __interface IJclCommandLineTool;'}
(*$HPPEMIT '}'*)

  IJclCommandLineTool = interface
    ['{A0034B09-A074-D811-847D-0030849E4592}']
    function GetExeName: string;
    function GetOptions: TStrings;
    function GetOutput: string;
    function GetOutputCallback: TTextHandler;
    procedure AddPathOption(const Option, Path: string);
    function Execute(const CommandLine: string): Boolean;
    procedure SetOutputCallback(const CallbackMethod: TTextHandler);
    property ExeName: string read GetExeName;
    property Options: TStrings read GetOptions;
    property OutputCallback: TTextHandler read GetOutputCallback write SetOutputCallback;
    property Output: string read GetOutput;
  end;

  EJclCommandLineToolError = class(EJclError);

  TJclCommandLineTool = class(TInterfacedObject, IJclCommandLineTool)
  private
    FExeName: string;
    FOptions: TStringList;
    FOutput: string;
    FOutputCallback: TTextHandler;
  public
    constructor Create(const AExeName: string);
    destructor Destroy; override;
    { IJclCommandLineTool }
    function GetExeName: string;
    function GetOptions: TStrings;
    function GetOutput: string;
    function GetOutputCallback: TTextHandler;
    procedure AddPathOption(const Option, Path: string);
    function Execute(const CommandLine: string): Boolean;
    procedure SetOutputCallback(const CallbackMethod: TTextHandler);
    property ExeName: string read GetExeName;
    property Options: TStrings read GetOptions;
    property OutputCallback: TTextHandler read GetOutputCallback write SetOutputCallback;
    property Output: string read GetOutput;
  end;

// Console Utilities
function ReadKey: Char;

// Loading of modules (DLLs)
type
{$IFDEF MSWINDOWS}
  TModuleHandle = HINST;
{$ENDIF MSWINDOWS}
{$IFDEF LINUX}
  TModuleHandle = Pointer;
{$ENDIF LINUX}

const
  INVALID_MODULEHANDLE_VALUE = TModuleHandle(0);

function LoadModule(var Module: TModuleHandle; FileName: string): Boolean;
function LoadModuleEx(var Module: TModuleHandle; FileName: string; Flags: Cardinal): Boolean;
procedure UnloadModule(var Module: TModuleHandle);
function GetModuleSymbol(Module: TModuleHandle; SymbolName: string): Pointer;
function GetModuleSymbolEx(Module: TModuleHandle; SymbolName: string; var Accu: Boolean): Pointer;
function ReadModuleData(Module: TModuleHandle; SymbolName: string; var Buffer; Size: Cardinal): Boolean;
function WriteModuleData(Module: TModuleHandle; SymbolName: string; var Buffer; Size: Cardinal): Boolean;

// Conversion Utilities
type
  EJclConversionError = class(EJclError);

function StrToBoolean(const S: string): Boolean;
function BooleanToStr(B: Boolean): string;
function IntToBool(I: Integer): Boolean;
function BoolToInt(B: Boolean): Integer;

const
  {$IFDEF MSWINDOWS}
  ListSeparator = ';';
  {$ENDIF MSWINDOWS}
  {$IFDEF LINUX}
  ListSeparator = ':';
  {$ENDIF LINUX}

// functions to handle items in a separated list of items
// add items at the end
procedure ListAddItems(var List: string; const Separator, Items: string);
// add items at the end if they are not present
procedure ListIncludeItems(var List: string; const Separator, Items: string);
// delete multiple items
procedure ListRemoveItems(var List: string; const Separator, Items: string);
// delete one item
procedure ListDelItem(var List: string; const Separator: string;
  const Index: Integer);
// return the number of item
function ListItemCount(const List, Separator: string): Integer;
// return the Nth item
function ListGetItem(const List, Separator: string;
  const Index: Integer): string;
// set the Nth item
procedure ListSetItem(var List: string; const Separator: string;
  const Index: Integer; const Value: string);
// return the index of an item
function ListItemIndex(const List, Separator, Item: string): Integer;

// RTL package information
function SystemTObjectInstance: TJclAddr;
function IsCompiledWithPackages: Boolean;

// GUID
function JclGUIDToString(const GUID: TGUID): string;
function JclStringToGUID(const S: string): TGUID;

// thread safe support

type
  TJclIntfCriticalSection = class(TObject, IInterface)
  private
    FCriticalSection: TCriticalSection;
  public
    constructor Create;
    destructor Destroy; override;
    { IInterface }
    function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  end;

type
  TJclSimpleLog = class (TObject)
  private
    FDateTimeFormatStr: String;
    FLogFileHandle: {$IFDEF BORLAND}Integer{$ELSE}THandle{$ENDIF};
    FLogFileName: string;
    FLoggingActive: Boolean;
    FLogWasEmpty: Boolean;
    function GetLogOpen: Boolean;
  protected
    function CreateDefaultFileName: string;
  public
    constructor Create(const ALogFileName: string = '');
    destructor Destroy; override;
    procedure ClearLog;
    procedure CloseLog;
    procedure OpenLog;
    procedure Write(const Text: string; Indent: Integer = 0; KeepOpen: Boolean = true); overload;
    procedure Write(Strings: TStrings; Indent: Integer = 0; KeepOpen: Boolean = true); overload;
    //Writes a line to the log file. The current timestamp is written before the line.
    procedure TimeWrite(const Text: string; Indent: Integer = 0; KeepOpen: Boolean = true); overload;
    procedure TimeWrite(Strings: TStrings; Indent: Integer = 0; KeepOpen: Boolean = true); overload;
    procedure WriteStamp(SeparatorLen: Integer = 0; KeepOpen: Boolean = true);
    // DateTimeFormatStr property assumes the values described in "FormatDateTime Function" in Delphi Help
    property DateTimeFormatStr: String read FDateTimeFormatStr write FDateTimeFormatStr;
    property LogFileName: string read FLogFileName;
    //1 Property to activate / deactivate the logging
    property LoggingActive: Boolean read FLoggingActive write FLoggingActive default True;
    property LogOpen: Boolean read GetLogOpen;
  end;

// Procedure to initialize the SimpleLog Variable
procedure InitSimpleLog(const ALogFileName: string = ''; AOpenLog: Boolean = true);

// Global Variable to make it easier for an application wide log handling.
// Must be initialized with InitSimpleLog before using
var
  SimpleLog : TJclSimpleLog;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.1-Build3536/jcl/source/common/JclSysUtils.pas $';
    Revision: '$Revision: 3034 $';
    Date: '$Date: 2009-10-03 11:34:58 +0200 (sam., 03 oct. 2009) $';
    LogPath: 'JCL\source\common';
    Extra: '';
    Data: nil
    );
{$ENDIF UNITVERSIONING}

implementation

uses
  {$IFDEF HAS_UNIT_TYPES}
  Types,
  {$ENDIF HAS_UNIT_TYPES}
  {$IFDEF UNIX}
  {$IFDEF HAS_UNIT_LIBC}
  Libc,
  {$ELSE ~HAS_UNIT_LIBC}
  dl,
  {$ENDIF ~HAS_UNIT_LIBC}
  {$ENDIF UNIX}
  {$IFDEF MSWINDOWS}
  JclConsole,
  {$ENDIF MSWINDOWS}
  Contnrs,
  {$IFDEF HAS_UNIT_ANSISTRINGS}
  AnsiStrings,
  {$ENDIF HAS_UNIT_ANSISTRINGS}
  JclFileUtils, JclMath, JclResources, JclStrings, JclStringConversions, JclSysInfo;

// memory initialization
procedure ResetMemory(out P; Size: Longint);
begin
  if Size > 0 then
  begin
    Byte(P) := 0;
    FillChar(P, Size, 0);
  end;
end;

// Pointer manipulation
procedure GetAndFillMem(var P: Pointer; const Size: Integer; const Value: Byte);
begin
  GetMem(P, Size);
  FillChar(P^, Size, Value);
end;

procedure FreeMemAndNil(var P: Pointer);
var
  Q: Pointer;
begin
  Q := P;
  P := nil;
  FreeMem(Q);
end;

function PCharOrNil(const S: string): PChar;
begin
  Result := Pointer(S);
end;

function PAnsiCharOrNil(const S: AnsiString): PAnsiChar;
begin
  Result := Pointer(S);
end;

{$IFDEF SUPPORTS_WIDESTRING}

function PWideCharOrNil(const W: WideString): PWideChar;
begin
  Result := Pointer(W);
end;

{$ENDIF SUPPORTS_WIDESTRING}

{$IFDEF MSWINDOWS}
type
  PUsed = ^TUsed;
  TUsed = record
    SizeFlags: Integer;
  end;

const
  cThisUsedFlag = 2;
  cPrevFreeFlag = 1;
  cFillerFlag   = Integer($80000000);
  cFlags        = cThisUsedFlag or cPrevFreeFlag or cFillerFlag;

function SizeOfMem(const APointer: Pointer): Integer;
var
  U: PUsed;
begin
  if IsMemoryManagerSet then
    Result:= -1
  else
  begin
    Result := 0;
    if APointer <> nil then
    begin
      U := APointer;
      U := PUsed(TJclAddr(U) - SizeOf(TUsed));
      if (U.SizeFlags and cThisUsedFlag) <> 0 then
        Result := (U.SizeFlags) and (not cFlags - SizeOf(TUsed));
    end;
  end;
end;
{$ENDIF MSWINDOWS}

{$IFDEF LINUX}
function SizeOfMem(const APointer: Pointer): Integer;
begin
  if IsMemoryManagerSet then
    Result:= -1
  else
  begin
    if APointer <> nil then
      Result := malloc_usable_size(APointer)
    else
      Result := 0;
  end;
end;
{$ENDIF LINUX}

function WriteProtectedMemory(BaseAddress, Buffer: Pointer;
  Size: Cardinal; out WrittenBytes: Cardinal): Boolean;
{$IFDEF MSWINDOWS}
var
  OldProtect, Dummy: Cardinal;
begin
  WrittenBytes := 0;
  if Size > 0 then
  begin
    // (outchy) VirtualProtect for DEP issues
    OldProtect := 0;
    Result := VirtualProtect(BaseAddress, Size, PAGE_EXECUTE_READWRITE, OldProtect);
    if Result then
    try
      Move(Buffer^, BaseAddress^, Size);
      WrittenBytes := Size;
      if OldProtect in [PAGE_EXECUTE, PAGE_EXECUTE_READ, PAGE_EXECUTE_READWRITE, PAGE_EXECUTE_WRITECOPY] then
        FlushInstructionCache(GetCurrentProcess, BaseAddress, Size);
    finally
      Dummy := 0;
      VirtualProtect(BaseAddress, Size, OldProtect, Dummy);
    end;
  end;
  Result := WrittenBytes = Size;
end;
{$ENDIF MSWINDOWS}
{$IFDEF LINUX}
{ TODO -cHelp : Author: Andreas Hausladen }
{ TODO : Works so far, but causes app to hang on termination }
var
  AlignedAddress: Cardinal;
  PageSize, ProtectSize: Cardinal;
begin
  Result := False;
  WrittenBytes := 0;

  PageSize := Cardinal(getpagesize);
  AlignedAddress := Cardinal(BaseAddress) and not (PageSize - 1); // start memory page
  // get the number of needed memory pages
  ProtectSize := PageSize;
  while Cardinal(BaseAddress) + Size > AlignedAddress + ProtectSize do
    Inc(ProtectSize, PageSize);

  if mprotect(Pointer(AlignedAddress), ProtectSize,
    PROT_READ or PROT_WRITE or PROT_EXEC) = 0 then // obtain write access
  begin
    try
      Move(Buffer^, BaseAddress^, Size); // replace code
      Result := True;
      WrittenBytes := Size;
    finally
      // Is there any function that returns the current page protection?
//    mprotect(p, ProtectSize, PROT_READ or PROT_EXEC); // lock memory page
    end;
  end;
end;

procedure FlushInstructionCache;
{ TODO -cHelp : Author: Andreas Hausladen }
begin
  // do nothing
end;

{$ENDIF LINUX}

// Guards

//=== { TJclSafeGuard } ======================================================

constructor TJclSafeGuard.Create(Mem: Pointer);
begin
  inherited Create;
  FItem := Mem;
end;

destructor TJclSafeGuard.Destroy;
begin
  FreeItem;
  inherited Destroy;
end;

function TJclSafeGuard.ReleaseItem: Pointer;
begin
  Result := FItem;
  FItem := nil;
end;

function TJclSafeGuard.GetItem: Pointer;
begin
  Result := FItem;
end;

procedure TJclSafeGuard.FreeItem;
begin
  if FItem <> nil then
    FreeMem(FItem);
  FItem := nil;
end;

//=== { TJclObjSafeGuard } ===================================================

constructor TJclObjSafeGuard.Create(Obj: TObject);
begin
  inherited Create(Pointer(Obj));
end;

procedure TJclObjSafeGuard.FreeItem;
begin
  if FItem <> nil then
  begin
    TObject(FItem).Free;
    FItem := nil;
  end;
end;

//=== { TJclMultiSafeGuard } =================================================

constructor TJclMultiSafeGuard.Create;
begin
  inherited Create;
  FItems := TList.Create;
end;

destructor TJclMultiSafeGuard.Destroy;
var
  I: Integer;
begin
  for I := FItems.Count - 1 downto 0 do
    FreeItem(I);
  FItems.Free;
  inherited Destroy;
end;

function TJclMultiSafeGuard.AddItem(Item: Pointer): Pointer;
begin
  Result := Item;
  FItems.Add(Item);
end;

procedure TJclMultiSafeGuard.FreeItem(Index: Integer);
begin
  FreeMem(FItems[Index]);
  FItems.Delete(Index);
end;

function TJclMultiSafeGuard.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TJclMultiSafeGuard.GetItem(Index: Integer): Pointer;
begin
  Result := FItems[Index];
end;

function TJclMultiSafeGuard.ReleaseItem(Index: Integer): Pointer;
begin
  Result := FItems[Index];
  FItems.Delete(Index);
end;

function Guard(Mem: Pointer; var SafeGuard: IMultiSafeGuard): Pointer; overload;
begin
  if SafeGuard = nil then
    SafeGuard := TJclMultiSafeGuard.Create;
  Result := SafeGuard.AddItem(Mem);
end;

//=== { TJclObjMultiSafeGuard } ==============================================

procedure TJclObjMultiSafeGuard.FreeItem(Index: Integer);
begin
  TObject(FItems[Index]).Free;
  FItems.Delete(Index);
end;

function Guard(Obj: TObject; var SafeGuard: IMultiSafeGuard): TObject; overload;
begin
  if SafeGuard = nil then
    SafeGuard := TJclObjMultiSafeGuard.Create;
  Result := SafeGuard.AddItem(Obj);
end;

function Guard(Mem: Pointer; out SafeGuard: ISafeGuard): Pointer; overload;
begin
  Result := Mem;
  SafeGuard := TJclSafeGuard.Create(Mem);
end;

function Guard(Obj: TObject; out SafeGuard: ISafeGuard): TObject; overload;
begin
  Result := Obj;
  SafeGuard := TJclObjSafeGuard.Create(Obj);
end;

function GuardGetMem(Size: Cardinal; out SafeGuard: ISafeGuard): Pointer;
begin
  GetMem(Result, Size);
  Guard(Result, SafeGuard);
end;

function GuardAllocMem(Size: Cardinal; out SafeGuard: ISafeGuard): Pointer;
begin
  Result := AllocMem(Size);
  Guard(Result, SafeGuard);
end;

{$IFDEF SUPPORTS_GENERICS_}
//=== { TSafeGuard<T> } ======================================================

constructor TSafeGuard<T>.Create(Instance: T);
begin
  inherited Create;
  FItem := Instance;
end;

destructor TSafeGuard<T>.Destroy;
begin
  FreeItem;
  inherited Destroy;
end;

function TSafeGuard<T>.ReleaseItem: T;
begin
  Result := FItem;
  FItem := nil;
end;

function TSafeGuard<T>.GetItem: T;
begin
  Result := FItem;
end;

procedure TSafeGuard<T>.FreeItem;
begin
  if FItem <> nil then
    FItem.Free;
  FItem := nil;
end;
{$ENDIF SUPPORTS_GENERICS_}

//=== Shared memory functions ================================================

type
  PMMFHandleListItem = ^TMMFHandleListItem;
  TMMFHandleListItem = record
    Next: PMMFHandleListItem;
    Memory: Pointer;
    Handle: THandle;
    Name: string;
    References: Integer;
  end;

  PMMFHandleList = PMMFHandleListItem;

var
  MMFHandleList: PMMFHandleList = nil;
  {$IFDEF THREADSAFE}
  MMFFinalized: Boolean = False;
  GlobalMMFHandleListCS: TJclIntfCriticalSection = nil;
  {$ENDIF THREADSAFE}

{$IFDEF THREADSAFE}
function GetAccessToHandleList: IInterface;
var
  OldValue: Pointer;
  CS: TJclIntfCriticalSection;
begin
  if not Assigned(GlobalMMFHandleListCS) and not MMFFinalized then
  begin
    CS := TJclIntfCriticalSection.Create;
    {$IFDEF RTL200_UP} // Delphi 2009+
    OldValue := InterlockedCompareExchangePointer(Pointer(GlobalMMFHandleListCS), Pointer(CS), nil);
    {$ELSE}
      {$IFDEF RTL160_UP} // Delphi 7-2007
    OldValue := Pointer(InterlockedCompareExchange(Longint(GlobalMMFHandleListCS), Longint(CS), 0));
      {$ELSE} // Delphi 5, 6
    OldValue := InterlockedCompareExchange(Pointer(GlobalMMFHandleListCS), Pointer(CS), nil);
      {$ENDIF RTL180_UP}
    {$ENDIF RTL185_UP}
    if OldValue <> nil then
      CS.Free;
  end;
  Result := GlobalMMFHandleListCS;
end;
{$ENDIF THREADSAFE}

{$IFDEF MSWINDOWS}

function SharedGetMem(var P{: Pointer}; const Name: string; Size: Cardinal;
  DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Integer;
var
  FileMappingHandle: THandle;
  Iterate, NewListItem: PMMFHandleListItem;
  Protect: Cardinal;
  {$IFDEF THREADSAFE}
  HandleListAccess: IInterface;
  {$ENDIF THREADSAFE}
begin
  Result := 0;
  Pointer(P) := nil;

  if (GetWindowsVersion in [wvUnknown..wvWinNT4]) and ((Name = '') or (Pos('\', Name) > 0)) then
    raise ESharedMemError.CreateResFmt(@RsInvalidMMFName, [Name]);

  {$IFDEF THREADSAFE}
  HandleListAccess := GetAccessToHandleList;
  {$ENDIF THREADSAFE}

  // search for same name
  Iterate := MMFHandleList;
  while Iterate <> nil do
  begin
    if CompareText(Iterate^.Name, Name) = 0 then
    begin
      Inc(Iterate^.References);
      Pointer(P) := Iterate^.Memory;
      Result := ERROR_ALREADY_EXISTS;
      Exit;
    end;
    Iterate := Iterate^.Next;
  end;

  // open file mapping
  FileMappingHandle := OpenFileMapping(DesiredAccess, False, PChar(Name));
  if FileMappingHandle = 0 then
  begin
    if Size = 0 then
      raise ESharedMemError.CreateResFmt(@RsInvalidMMFEmpty, [Name]);

    Protect := PAGE_READWRITE;
    if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and (DesiredAccess = FILE_MAP_COPY) then
      Protect := PAGE_WRITECOPY;

    FileMappingHandle := CreateFileMapping(INVALID_HANDLE_VALUE, nil, Protect,
      0, Size, PChar(Name));
  end
  else
    Result := ERROR_ALREADY_EXISTS;

  if GetLastError = ERROR_ALREADY_EXISTS then
    Result := ERROR_ALREADY_EXISTS
  else
  begin
    if FileMappingHandle = 0 then
      RaiseLastOSError;
  end;

  // map view
  Pointer(P) := MapViewOfFile(FileMappingHandle, DesiredAccess, 0, 0, Size);
  if Pointer(P) = nil then
  begin
    try
      RaiseLastOSError;
    except
      CloseHandle(FileMappingHandle);
      raise;
    end;
  end;

  // add list item to MMFHandleList
  New(NewListItem);
  NewListItem^.Name := Name;
  NewListItem^.Handle := FileMappingHandle;
  NewListItem^.Memory := Pointer(P);
  NewListItem^.References := 1;

  NewListItem^.Next := MMFHandleList;
  MMFHandleList := NewListItem;
end;

function SharedAllocMem(const Name: string; Size: Cardinal;
  DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Pointer;
begin
  Result := nil;
  if (SharedGetMem(Result, Name, Size, DesiredAccess) <> ERROR_ALREADY_EXISTS) and
    ((DesiredAccess and (FILE_MAP_WRITE or FILE_MAP_COPY)) <> 0) and
    (Size > 0) and (Result <> nil) then
      ResetMemory(Pointer(Result)^, Size);
end;

function SharedFreeMem(var P{: Pointer}): Boolean;
var
  N, Iterate: PMMFHandleListItem;
  {$IFDEF THREADSAFE}
  HandleListAccess: IInterface;
  {$ENDIF THREADSAFE}
begin
  if Pointer(P) <> nil then
  begin
    Result := False;
    {$IFDEF THREADSAFE}
    HandleListAccess := GetAccessToHandleList;
    {$ENDIF THREADSAFE}
    Iterate := MMFHandleList;
    N := nil;
    while Iterate <> nil do
    begin
      if Iterate^.Memory = Pointer(P) then
      begin
        if Iterate^.References > 1 then
        begin
          Dec(Iterate^.References);
          Pointer(P) := nil;
          Result := True;
          Exit;
        end;

        UnmapViewOfFile(Iterate^.Memory);
        CloseHandle(Iterate^.Handle);

        if N = nil then
          MMFHandleList := Iterate^.Next
        else
          N^.Next := Iterate^.Next;

        Dispose(Iterate);
        Pointer(P) := nil;
        Result := True;
        Break;
      end;
      N := Iterate;
      Iterate := Iterate^.Next;
    end;
  end
  else
    Result := True;
end;

function SharedOpenMem(var P{: Pointer}; const Name: string;
  DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Boolean;
begin
  Result := SharedGetMem(P, Name, 0, DesiredAccess) = ERROR_ALREADY_EXISTS;
end;

function SharedOpenMem(const Name: string;
  DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Pointer;
begin
  Result := nil;
  SharedGetMem(Result, Name, 0, DesiredAccess);
end;

function SharedCloseMem(var P{: Pointer}): Boolean;
begin
  Result := SharedFreeMem(P);
end;

{$ENDIF MSWINDOWS}

//=== Binary search ==========================================================

function SearchSortedList(List: TList; SortFunc: TListSortCompare; Item: Pointer; Nearest: Boolean): Integer;
var
  L, H, I, C: Integer;
  B: Boolean;
begin
  Result := -1;
  if List <> nil then
  begin
    L := 0;
    H := List.Count - 1;
    B := False;
    while L <= H do
    begin
      I := (L + H) shr 1;
      C := SortFunc(List.List^[I], Item);
      if C < 0 then
        L := I + 1
      else
      begin
        H := I - 1;
        if C = 0 then
        begin
          B := True;
          L := I;
        end;
      end;
    end;
    if B then
      Result := L
    else
    if Nearest and (H >= 0) then
      Result := H;
  end;
end;

function SearchSortedUntyped(Param: Pointer; ItemCount: Integer; SearchFunc: TUntypedSearchCompare;
  const Value; Nearest: Boolean): Integer;
var
  L, H, I, C: Integer;
  B: Boolean;
begin
  Result := -1;
  if ItemCount > 0 then
  begin
    L := 0;
    H := ItemCount - 1;
    B := False;
    while L <= H do
    begin
      I := (L + H) shr 1;
      C := SearchFunc(Param, I, Value);
      if C < 0 then
        L := I + 1
      else
      begin
        H := I - 1;
        if C = 0 then
        begin
          B := True;
          L := I;
        end;
      end;
    end;
    if B then
      Result := L
    else
    if Nearest and (H >= 0) then
      Result := H;
  end;
end;

//=== Dynamic array sort and search routines =================================

procedure SortDynArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortCompare);
var
  TempBuf: TDynByteArray;

  function ArrayItemPointer(Item: Integer): Pointer;
  begin
    Result := Pointer(TJclAddr(ArrayPtr) + (Cardinal(Item) * ElementSize));
  end;

  procedure QuickSort(L, R: Integer);
  var
    I, J, T: Integer;
    P, IPtr, JPtr: Pointer;
  begin
    repeat
      I := L;
      J := R;
      P := ArrayItemPointer((L + R) shr 1);
      repeat
        while SortFunc(ArrayItemPointer(I), P) < 0 do
          Inc(I);
        while SortFunc(ArrayItemPointer(J), P) > 0 do
          Dec(J);
        if I <= J then
        begin
          IPtr := ArrayItemPointer(I);
          JPtr := ArrayItemPointer(J);
          case ElementSize of
            SizeOf(Byte):
              begin
                T := PByte(IPtr)^;
                PByte(IPtr)^ := PByte(JPtr)^;
                PByte(JPtr)^ := T;
              end;
            SizeOf(Word):
              begin
                T := PWord(IPtr)^;
                PWord(IPtr)^ := PWord(JPtr)^;
                PWord(JPtr)^ := T;
              end;
            SizeOf(Integer):
              begin
                T := PInteger(IPtr)^;
                PInteger(IPtr)^ := PInteger(JPtr)^;
                PInteger(JPtr)^ := T;
              end;
          else
            Move(IPtr^, TempBuf[0], ElementSize);
            Move(JPtr^, IPtr^, ElementSize);
            Move(TempBuf[0], JPtr^, ElementSize);
          end;
          if P = IPtr then
            P := JPtr
          else
          if P = JPtr then
            P := IPtr;
          Inc(I);
          Dec(J);
        end;
      until I > J;
      if L < J then
        QuickSort(L, J);
      L := I;
    until I >= R;
  end;

begin
  if ArrayPtr <> nil then
  begin
    SetLength(TempBuf, ElementSize);
    QuickSort(0, PInteger(TJclAddr(ArrayPtr) - 4)^ - 1);
  end;
end;

function SearchDynArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortCompare;
  ValuePtr: Pointer; Nearest: Boolean): Integer;
var
  L, H, I, C: Integer;
  B: Boolean;
begin
  Result := -1;
  if ArrayPtr <> nil then
  begin
    L := 0;
    H := PInteger(TJclAddr(ArrayPtr) - 4)^ - 1;
    B := False;
    while L <= H do
    begin
      I := (L + H) shr 1;
      C := SortFunc(Pointer(TJclAddr(ArrayPtr) + (Cardinal(I) * ElementSize)), ValuePtr);
      if C < 0 then
        L := I + 1
      else
      begin
        H := I - 1;
        if C = 0 then
        begin
          B := True;
          L := I;
        end;
      end;
    end;
    if B then
      Result := L
    else
    if Nearest and (H >= 0) then
      Result := H;
  end;
end;

{ Various compare functions for basic types }

function DynArrayCompareByte(Item1, Item2: Pointer): Integer;
begin
  Result := PByte(Item1)^ - PByte(Item2)^;
end;

function DynArrayCompareShortInt(Item1, Item2: Pointer): Integer;
begin
  Result := PShortInt(Item1)^ - PShortInt(Item2)^;
end;

function DynArrayCompareWord(Item1, Item2: Pointer): Integer;
begin
  Result := PWord(Item1)^ - PWord(Item2)^;
end;

function DynArrayCompareSmallInt(Item1, Item2: Pointer): Integer;
begin
  Result := PSmallInt(Item1)^ - PSmallInt(Item2)^;
end;

function DynArrayCompareInteger(Item1, Item2: Pointer): Integer;
begin
  Result := PInteger(Item1)^ - PInteger(Item2)^;
end;

function DynArrayCompareCardinal(Item1, Item2: Pointer): Integer;
begin
  if PCardinal(Item1)^ < PCardinal(Item2)^ then
    Result := -1
  else
  if PCardinal(Item1)^ > PCardinal(Item2)^ then
    Result := 1
  else
    Result := 0;
end;

function DynArrayCompareInt64(Item1, Item2: Pointer): Integer;
begin
  if PInt64(Item1)^ < PInt64(Item2)^ then
    Result := -1
  else
  if PInt64(Item1)^ > PInt64(Item2)^ then
    Result := 1
  else
    Result := 0;
end;

function DynArrayCompareSingle(Item1, Item2: Pointer): Integer;
begin
  if PSingle(Item1)^ < PSingle(Item2)^ then
    Result := -1
  else
  if PSingle(Item1)^ > PSingle(Item2)^ then
    Result := 1
  else
    Result := 0;
end;

function DynArrayCompareDouble(Item1, Item2: Pointer): Integer;
begin
  if PDouble(Item1)^ < PDouble(Item2)^ then
    Result := -1
  else
  if PDouble(Item1)^ > PDouble(Item2)^ then
    Result := 1
  else
    Result := 0;
end;

function DynArrayCompareExtended(Item1, Item2: Pointer): Integer;
begin
  if PExtended(Item1)^ < PExtended(Item2)^ then
    Result := -1
  else
  if PExtended(Item1)^ > PExtended(Item2)^ then
    Result := 1
  else
    Result := 0;
end;

function DynArrayCompareFloat(Item1, Item2: Pointer): Integer;
begin
  if PFloat(Item1)^ < PFloat(Item2)^ then
    Result := -1
  else
  if PFloat(Item1)^ > PFloat(Item2)^ then
    Result := 1
  else
    Result := 0;
end;

function DynArrayCompareAnsiString(Item1, Item2: Pointer): Integer;
begin
  Result := AnsiCompareStr(PAnsiString(Item1)^, PAnsiString(Item2)^);
end;

function DynArrayCompareAnsiText(Item1, Item2: Pointer): Integer;
begin
  Result := AnsiCompareText(PAnsiString(Item1)^, PAnsiString(Item2)^);
end;

function DynArrayCompareWideString(Item1, Item2: Pointer): Integer;
begin
  Result := WideCompareStr(PWideString(Item1)^, PWideString(Item2)^);
end;

function DynArrayCompareWideText(Item1, Item2: Pointer): Integer;
begin
  Result := WideCompareText(PWideString(Item1)^, PWideString(Item2)^);
end;

function DynArrayCompareString(Item1, Item2: Pointer): Integer;
begin
  Result := CompareStr(PString(Item1)^, PString(Item2)^);
end;

function DynArrayCompareText(Item1, Item2: Pointer): Integer;
begin
  Result := CompareText(PString(Item1)^, PString(Item2)^);
end;

//=== Object lists ===========================================================

procedure ClearObjectList(List: TList);
var
  I: Integer;
begin
  if List <> nil then
  begin
    for I := List.Count - 1 downto 0 do
    begin
      if List[I] <> nil then
      begin
        if TObject(List[I]) is TList then
        begin
          // recursively delete TList sublists
          ClearObjectList(TList(List[I]));
        end;
        TObject(List[I]).Free;
        if (not (List is TComponentList))
          and ((not(List is TObjectList)) or not TObjectList(List).OwnsObjects) then
          List[I] := nil;
      end;
    end;
    List.Clear;
  end;
end;

procedure FreeObjectList(var List: TList);
begin
  if List <> nil then
  begin
    ClearObjectList(List);
    FreeAndNil(List);
  end;
end;

//=== { TJclReferenceMemoryStream } ==========================================

constructor TJclReferenceMemoryStream.Create(const Ptr: Pointer; Size: Longint);
begin
  {$IFDEF MSWINDOWS}
  Assert(not IsBadReadPtr(Ptr, Size));
  {$ENDIF MSWINDOWS}
  inherited Create;
  SetPointer(Ptr, Size);
end;

function TJclReferenceMemoryStream.Write(const Buffer; Count: Longint): Longint;
begin
  raise EJclError.CreateRes(@RsCannotWriteRefStream);
end;

//=== { TJclAutoPtr } ========================================================

constructor TJclAutoPtr.Create(AValue: TObject);
begin
  inherited Create;
  FValue := AValue;
end;

destructor TJclAutoPtr.Destroy;
begin
  FValue.Free;
  inherited Destroy;
end;

function TJclAutoPtr.AsObject: TObject;
begin
  Result := FValue;
end;

function TJclAutoPtr.AsPointer: Pointer;
begin
  Result := FValue;
end;

function TJclAutoPtr.ReleaseObject: TObject;
begin
  Result := FValue;
  FValue := nil;
end;

function CreateAutoPtr(Value: TObject): IAutoPtr;
begin
  Result := TJclAutoPtr.Create(Value);
end;

//=== replacement for the C distfix operator ? : =============================

function Iff(const Condition: Boolean; const TruePart, FalsePart: string): string;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function Iff(const Condition: Boolean; const TruePart, FalsePart: Char): Char;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function Iff(const Condition: Boolean; const TruePart, FalsePart: Byte): Byte;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function Iff(const Condition: Boolean; const TruePart, FalsePart: Integer): Integer;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function Iff(const Condition: Boolean; const TruePart, FalsePart: Cardinal): Cardinal;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function Iff(const Condition: Boolean; const TruePart, FalsePart: Float): Float;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function Iff(const Condition: Boolean; const TruePart, FalsePart: Boolean): Boolean;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function Iff(const Condition: Boolean; const TruePart, FalsePart: Pointer): Pointer;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

function Iff(const Condition: Boolean; const TruePart, FalsePart: Int64): Int64;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;

{$IFDEF SUPPORTS_VARIANT}
function Iff(const Condition: Boolean; const TruePart, FalsePart: Variant): Variant; overload;
begin
  if Condition then
    Result := TruePart
  else
    Result := FalsePart;
end;
{$ENDIF SUPPORTS_VARIANT}

//=== Classes information and manipulation ===================================
// Virtual Methods
// Helper method

procedure SetVMTPointer(AClass: TClass; Offset: Integer; Value: Pointer);
var
  WrittenBytes: DWORD;
  PatchAddress: PPointer;
begin
  {$OVERFLOWCHECKS OFF}
  PatchAddress := Pointer(TJclAddr(AClass) + TJclAddr(Offset));
  {$IFDEF OVERFLOWCHECKS_ON}
  {$OVERFLOWCHECKS ON}
  {$ENDIF OVERFLOWCHECKS_ON}
  if not WriteProtectedMemory(PatchAddress, @Value, SizeOf(Value), WrittenBytes) then
    raise EJclVMTError.CreateResFmt(@RsVMTMemoryWriteError,
      [SysErrorMessage({$IFDEF FPC}GetLastOSError{$ELSE}GetLastError{$ENDIF})]);

  if WrittenBytes <> SizeOf(Pointer) then
    raise EJclVMTError.CreateResFmt(@RsVMTMemoryWriteError, [IntToStr(WrittenBytes)]);

  // make sure that everything keeps working in a dual processor setting
  // (outchy) done by WriteProtectedMemory
  // FlushInstructionCache{$IFDEF MSWINDOWS}(GetCurrentProcess, PatchAddress, SizeOf(Pointer)){$ENDIF};
end;

{$IFNDEF FPC}
function GetVirtualMethodCount(AClass: TClass): Integer;
type
  PINT_PTR = ^INT_PTR;
var
  BeginVMT: INT_PTR;
  EndVMT: INT_PTR;
  TablePointer: INT_PTR;
  I: Integer;
begin
  BeginVMT := INT_PTR(AClass);

  // Scan the offset entries in the class table for the various fields,
  // namely vmtIntfTable, vmtAutoTable, ..., vmtDynamicTable
  // The last entry is always the vmtClassName, so stop once we got there
  // After the last virtual method there is one of these entries.

  EndVMT := PINT_PTR(INT_PTR(AClass) + vmtClassName)^;
  // Set iterator to first item behind VMT table pointer
  I := vmtSelfPtr + SizeOf(Pointer);
  repeat
    TablePointer := PINT_PTR(INT_PTR(AClass) + I)^;
    if (TablePointer <> 0) and (TablePointer >= BeginVMT) and
       (TablePointer < EndVMT) then
      EndVMT := INT_PTR(TablePointer);
    Inc(I, SizeOf(Pointer));
  until I >= vmtClassName;

  Result := (EndVMT - BeginVMT) div SizeOf(Pointer);
end;
{$ENDIF ~FPC}

function GetVirtualMethod(AClass: TClass; const Index: Integer): Pointer;
begin
  {$OVERFLOWCHECKS OFF}
  Result := PPointer(TJclAddr(AClass) + TJclAddr(Index * SizeOf(Pointer)))^;
  {$IFDEF OVERFLOWCHECKS_ON}
  {$OVERFLOWCHECKS ON}
  {$ENDIF OVERFLOWCHECKS_ON}
end;

procedure SetVirtualMethod(AClass: TClass; const Index: Integer; const Method: Pointer);
begin
  SetVMTPointer(AClass, Index * SizeOf(Pointer), Method);
end;

function GetDynamicMethodCount(AClass: TClass): Integer; assembler;
asm
        {$IFDEF CPU32}
        // --> RAX AClass
        // <-- EAX Result
        MOV     EAX, [EAX].vmtDynamicTable
        TEST    EAX, EAX
        JE      @@Exit
        MOVZX   EAX, WORD PTR [EAX]
        {$ENDIF CPU32}
        {$IFDEF CPU64}
        // --> RCX AClass
        // <-- EAX Result
        MOV     RAX, [RCX].vmtDynamicTable
        TEST    RAX, RAX
        JE      @@Exit
        MOVZX   RAX, WORD PTR [RAX]
        {$ENDIF CPU64}
@@Exit:
end;

function GetDynamicIndexList(AClass: TClass): PDynamicIndexList; assembler;
asm
        {$IFDEF CPU32}
        // --> EAX AClass
        // <-- EAX Result
        MOV     EAX, [EAX].vmtDynamicTable
        ADD     EAX, 2
        {$ENDIF CPU32}
        {$IFDEF CPU64}
        // --> RCX AClass
        // <-- RAX Result
        MOV     RAX, [RCX].vmtDynamicTable
        ADD     RAX, 2
        {$ENDIF CPU64}
end;

function GetDynamicAddressList(AClass: TClass): PDynamicAddressList; assembler;
asm
        {$IFDEF CPU32}
        // --> EAX AClass
        // <-- EAX Result
        MOV     EAX, [EAX].vmtDynamicTable
        MOVZX   EDX, Word ptr [EAX]
        ADD     EAX, EDX
        ADD     EAX, EDX
        ADD     EAX, 2
        {$ENDIF CPU32}
        {$IFDEF CPU64}
        // --> RCX AClass
        // <-- RAX Result
        MOV     RAX, [RCX].vmtDynamicTable
        MOVZX   RDX, Word ptr [RAX]
        ADD     RAX, RDX
        ADD     RAX, RDX
        ADD     RAX, 2
        {$ENDIF CPU64}
end;

function HasDynamicMethod(AClass: TClass; Index: Integer): Boolean; assembler;
// Mainly copied from System.GetDynaMethod
asm
        {$IFDEF CPU32}
        // --> EAX AClass
        //     EDX Index
        // <-- AL  Result
        PUSH    EDI
        XCHG    EAX, EDX
        JMP     @@HaveVMT
@@OuterLoop:
        MOV     EDX, [EDX]
@@HaveVMT:
        MOV     EDI, [EDX].vmtDynamicTable
        TEST    EDI, EDI
        JE      @@Parent
        MOVZX   ECX, WORD PTR [EDI]
        PUSH    ECX
        ADD     EDI,2
        REPNE   SCASW
        JE      @@Found
        POP     ECX
@@Parent:
        MOV     EDX,[EDX].vmtParent
        TEST    EDX,EDX
        JNE     @@OuterLoop
        MOV     EAX, 0
        JMP     @@Exit
@@Found:
        POP     EAX
        MOV     EAX, 1
@@Exit:
        POP     EDI
        {$ENDIF CPU32}
        {$IFDEF CPU64}
        // --> RCX AClass
        //     EDX Index
        // <-- AL  Result
        MOV     EAX, EDX
        MOV     RDX, RCX
        JMP     @@HaveVMT
@@OuterLoop:
        MOV     RDX, [RDX]
@@HaveVMT:
        MOV     RDI, [RDX].vmtDynamicTable
        TEST    RDI, RDI
        JE      @@Parent
        MOVZX   RCX, WORD PTR [RDI]
        PUSH    RCX
        ADD     RDI,2
        REPNE   SCASW
        JE      @@Found
        POP     RCX
@@Parent:
        MOV     RDX,[RDX].vmtParent
        TEST    RDX,RDX
        JNE     @@OuterLoop
        MOV     RAX, 0
        JMP     @@Exit
@@Found:
        POP     RAX
        MOV     RAX, 1
@@Exit:
        {$ENDIF CPU64}
end;

{$IFNDEF FPC}
function GetDynamicMethod(AClass: TClass; Index: Integer): Pointer; assembler;
asm
        CALL    System.@FindDynaClass
end;
{$ENDIF ~FPC}

//=== Interface Table ========================================================

function GetInitTable(AClass: TClass): PTypeInfo; assembler;
asm
        {$IFDEF CPU32}
        // --> EAX AClass
        // <-- EAX Result
        MOV     EAX, [EAX].vmtInitTable
        {$ENDIF CPU32}
        {$IFDEF CPU64}
        // --> RCX AClass
        // <-- RAX Result
        MOV     RAX, [RCX].vmtInitTable
        {$ENDIF CPU64}
end;

function GetFieldTable(AClass: TClass): PFieldTable; assembler;
asm
        {$IFDEF CPU32}
        // --> EAX AClass
        // <-- EAX Result
        MOV     EAX, [EAX].vmtFieldTable
        {$ENDIF CPU32}
        {$IFDEF CPU64}
        // --> RCX AClass
        // <-- RAX Result
        MOV     RAX, [RCX].vmtFieldTable
        {$ENDIF CPU64}
end;

function GetMethodTable(AClass: TClass): PMethodTable; assembler;
asm
        {$IFDEF CPU32}
        // --> EAX AClass
        // <-- EAX Result
        MOV     EAX, [EAX].vmtMethodTable
        {$ENDIF CPU32}
        {$IFDEF CPU64}
        // --> RCX AClass
        // <-- RAX Result
        MOV     RAX, [RCX].vmtMethodTable
        {$ENDIF CPU64}
end;

function GetMethodEntry(MethodTable: PMethodTable; Index: Integer): PMethodEntry;
begin
  Result := Pointer(TJclAddr(MethodTable) + 2);
  for Index := Index downto 1 do
    Inc(TJclAddr(Result), Result^.EntrySize);
end;

//=== Class Parent methods ===================================================

procedure SetClassParent(AClass: TClass; NewClassParent: TClass);
var
  WrittenBytes: DWORD;
  PatchAddress: Pointer;
begin
  {$OVERFLOWCHECKS OFF}
  PatchAddress := PPointer(TJclAddr(AClass) + TJclAddr(vmtParent))^;
  {$IFDEF OVERFLOWCHECKS_ON}
  {$OVERFLOWCHECKS ON}
  {$ENDIF OVERFLOWCHECKS_ON}
  if not WriteProtectedMemory(PatchAddress, @NewClassParent, SizeOf(Pointer), WrittenBytes) then
    raise EJclVMTError.CreateResFmt(@RsVMTMemoryWriteError,
      [SysErrorMessage({$IFDEF FPC}GetLastOSError{$ELSE}GetLastError{$ENDIF})]);
  if WrittenBytes <> SizeOf(Pointer) then
    raise EJclVMTError.CreateResFmt(@RsVMTMemoryWriteError, [IntToStr(WrittenBytes)]);
  // make sure that everything keeps working in a dual processor setting
  // (outchy) done by WriteProtectedMemory
  // FlushInstructionCache{$IFDEF MSWINDOWS}(GetCurrentProcess, PatchAddress, SizeOf(Pointer)){$ENDIF};
end;

function GetClassParent(AClass: TClass): TClass; assembler;
asm
        {$IFDEF CPU32}
        // --> EAX AClass
        // <-- EAX Result
        MOV     EAX, [EAX].vmtParent
        TEST    EAX, EAX
        JE      @@Exit
        MOV     EAX, [EAX]
        {$ENDIF CPU32}
        {$IFDEF CPU64}
        // --> RCX AClass
        // <-- RAX Result
        MOV     RAX, [RCX].vmtParent
        TEST    RAX, RAX
        JE      @@Exit
        MOV     RAX, [RAX]
        {$ENDIF CPU64}
@@Exit:
end;

{$IFDEF BORLAND}
function IsClass(Address: Pointer): Boolean; assembler;
asm
        CMP     Address, Address.vmtSelfPtr
        JNZ     @False
        MOV     Result, True
        JMP     @Exit
@False:
        MOV     Result, False
@Exit:
end;
{$ENDIF BORLAND}

{$IFDEF BORLAND}
function IsObject(Address: Pointer): Boolean; assembler;
asm
// or IsClass(Pointer(Address^));
        MOV     EAX, [Address]
        CMP     EAX, EAX.vmtSelfPtr
        JNZ     @False
        MOV     Result, True
        JMP     @Exit
@False:
        MOV     Result, False
@Exit:
end;
{$ENDIF BORLAND}

function InheritsFromByName(AClass: TClass; const AClassName: string): Boolean;
begin
  while (AClass <> nil) and not AClass.ClassNameIs(AClassName) do
    AClass := AClass.ClassParent;
  Result := AClass <> nil;
end;

//=== Interface information ==================================================

function GetImplementorOfInterface(const I: IInterface): TObject;
{ TODO -cDOC : Original code by Hallvard Vassbotn }
{ TODO -cTesting : Check the implemetation for any further version of compiler }
const
  AddByte = $04244483; // opcode for ADD DWORD PTR [ESP+4], Shortint
  AddLong = $04244481; // opcode for ADD DWORD PTR [ESP+4], Longint
type
  PAdjustSelfThunk = ^TAdjustSelfThunk;
  TAdjustSelfThunk = packed record
    case AddInstruction: Longint of
      AddByte: (AdjustmentByte: ShortInt);
      AddLong: (AdjustmentLong: Longint);
  end;
  PInterfaceMT = ^TInterfaceMT;
  TInterfaceMT = packed record
    QueryInterfaceThunk: PAdjustSelfThunk;
  end;
  TInterfaceRef = ^PInterfaceMT;
var
  QueryInterfaceThunk: PAdjustSelfThunk;
begin
  try
    Result := Pointer(I);
    if Assigned(Result) then
    begin
      QueryInterfaceThunk := TInterfaceRef(I)^.QueryInterfaceThunk;
      case QueryInterfaceThunk.AddInstruction of
        AddByte:
          Inc(PByte(Result), QueryInterfaceThunk.AdjustmentByte);
        AddLong:
          Inc(PByte(Result), QueryInterfaceThunk.AdjustmentLong);
      else
        Result := nil;
      end;
    end;
  except
    Result := nil;
  end;
end;

//=== Numeric formatting routines ============================================

function IntToStrZeroPad(Value, Count: Integer): string;
begin
  Result := IntToStr(Value);
  if Length(Result) < Count then
    Result := StrRepeatChar('0', Count - Length(Result)) + Result;
end;

//=== { TJclNumericFormat } ==================================================

{ TODO -cHelp : Author: Robert Rossmair }
{ Digit:         converts a digit value (number) to a digit (char)
  DigitValue:    converts a digit (char) into a number (digit value)
  IntToStr,
  FloatToStr,
  FloatToHTML:   converts a numeric value to a base <Base> numeric representation with formating options
  StrToIn:       converts a base <Base> numeric representation into an integer, if possible
  GetMantisseExponent: similar to AsString, but returns the Exponent separately as an integer
}
const
  {$IFDEF MATH_EXTENDED_PRECISION}
  BinaryPrecision = 64;
  {$ENDIF MATH_EXTENDED_PRECISION}
  {$IFDEF MATH_DOUBLE_PRECISION}
  BinaryPrecision = 53;
  {$ENDIF MATH_DOUBLE_PRECISION}
  {$IFDEF MATH_SINGLE_PRECISION}
  BinaryPrecision = 24;
  {$ENDIF MATH_SINGLE_PRECISION}

constructor TJclNumericFormat.Create;
begin
  inherited Create;
  { TODO : Initialize, when possible, from locale info }
  FBase := 10;
  FExpDivision := 1;
  SetPrecision(6);
  FNumberOfFractionalDigits := BinaryPrecision;
  FSignChars[False] := '-';
  FSignChars[True] := '+';
  FPaddingChar := ' ';
  FMultiplier := '<27>';
  FFractionalPartSeparator := DecimalSeparator;
  FDigitBlockSeparator := ThousandSeparator;
end;

procedure TJclNumericFormat.InvalidDigit(Digit: Char);
begin
  raise EConvertError.CreateResFmt(@RsInvalidDigit, [Base, Digit]);
end;

function TJclNumericFormat.Digit(DigitValue: TDigitValue): Char;
begin
  Assert(DigitValue < Base, Format(LoadResString(@RsInvalidDigitValue), [Base, DigitValue]));
  if DigitValue > 9 then
    Result := Chr(Ord('A') + DigitValue - 10)
  else
    Result := Chr(Ord('0') + DigitValue);
end;

function TJclNumericFormat.GetDigitValue(Digit: Char): Integer;
begin
  Result := CharHex(Digit);
  if (Result = $FF) or (Result >= Base) then
    Result := -1;
end;

function TJclNumericFormat.DigitValue(Digit: Char): TDigitValue;
begin
  Result := GetDigitValue(Digit);
  if Result = -1 then
    InvalidDigit(Digit);
end;

function TJclNumericFormat.IsDigit(Value: Char): Boolean;
begin
  Result := GetDigitValue(Value) <> -1;
end;

function TJclNumericFormat.FloatToHTML(const Value: Float): string;
var
  Mantissa: string;
  Exponent: Integer;
begin
  GetMantissaExp(Value, Mantissa, Exponent);
  Result := Format('%s %s %d<sup>%d</sup>', [Mantissa, Multiplier, Base, Exponent]);
end;

procedure TJclNumericFormat.GetMantissaExp(const Value: Float;
  out Mantissa: string; out Exponent: Integer);
const
  {$IFDEF FPC}
  InfMantissa: array [Boolean] of string[4] = ('inf', '-inf');
  {$ElSE ~FPC}
  InfMantissa: array [Boolean] of string = ('inf', '-inf');
  {$ENDIF ~FPC}
var
  BlockDigits: TDigitCount;
  IntDigits, FracDigits: Integer;
  FirstDigitPos, Prec: Integer;
  I, J, N: Integer;
  K: Int64;
  X: Extended;
  HighDigit: Char;

  function GetDigit(X: Extended): Char;
  var
    N: Integer;
  begin
    N := Trunc(X);
    if N > 9 then
      Result := Chr(Ord('A') + N - 10)
    else
      Result := Chr(Ord('0') + N);
  end;

begin
  X := Abs(Value);

  if X > MaxFloatingPoint then
  begin
    Mantissa := InfMantissa[Value < 0];
    Exponent := 1;
    Exit;
  end
  else
  if X < MinFloatingPoint then
  begin
    Mantissa := Format('%.*f', [Precision, 0.0]);
    Exponent := 1;
    Exit;
  end;

  IntDigits := 1;
  Prec := Precision;

  Exponent := Trunc(LogBaseN(Base, X));
  if FExpDivision > 1 then
  begin
    N := Exponent mod FExpDivision;
    Dec(Exponent, N);
    Inc(IntDigits, N);
  end;
  X := X / Power(Base, Exponent);

  if X < 1.0 then
  begin
    Dec(Exponent, FExpDivision);
    X := X * PowerInt(Base, FExpDivision);
    Inc(IntDigits, FExpDivision - 1);
  end;

{ TODO : Here's a problem if X > High(Int64).
It *seems* to surface only if ExponentDivision > 12, but it
has not been investigated if ExponentDivision <= 12 is safe. }
  K := Trunc(X);
  if Value < 0 then
    K := -K;

  Mantissa := IntToStr(K, FirstDigitPos);

  FracDigits := Prec - IntDigits;
  if FracDigits > NumberOfFractionalDigits then
    FracDigits := NumberOfFractionalDigits;

  if FracDigits > 0 then
  begin
    J := Length(Mantissa) + 1;
    // allocate sufficient space for point + digits + digit block separators
    SetLength(Mantissa, FracDigits * 2 + J);
    Mantissa[J] := FractionalPartSeparator;
    I := J + 1;
    BlockDigits := 0;
    while FracDigits > 0 do
    begin
      if (BlockDigits > 0) and (BlockDigits = DigitBlockSize) then
      begin
        Mantissa[I] := DigitBlockSeparator;
        Inc(I);
        BlockDigits := 0;
      end;
      X := Frac(X) * Base;
      Mantissa[I] := GetDigit(X);
      Inc(I);
      Inc(BlockDigits);
      Dec(FracDigits);
    end;
    Mantissa[I] := #0;
    StrResetLength(Mantissa);
  end;

  if Frac(X) >= 0.5 then
  // round up
  begin
    HighDigit := Digit(Base - 1);
    for I := Length(Mantissa) downto 1 do
    begin
      if Mantissa[I] = HighDigit then
        if (I = FirstDigitPos) then
        begin
          Mantissa[I] := '1';
          Inc(Exponent);
          Break;
        end
        else
          Mantissa[I] := '0'
      else
      if (Mantissa[I] = DigitBlockSeparator) or (Mantissa[I] = FractionalPartSeparator) then
        Continue
      else
      begin
        if Mantissa[I] = '9' then
          Mantissa[I] := 'A'
        else
          Mantissa[I] := Succ(Mantissa[I]);
        Break;
      end;
    end;
  end;
end;

function TJclNumericFormat.FloatToStr(const Value: Float): string;
var
  Mantissa: string;
  Exponent: Integer;
begin
  GetMantissaExp(Value, Mantissa, Exponent);
  Result := Format('%s %s %d^%d', [Mantissa, Multiplier, Base, Exponent]);
end;

function TJclNumericFormat.IntToStr(const Value: Int64): string;
var
  FirstDigitPos: Integer;
begin
  Result := IntToStr(Value, FirstDigitPos);
end;

function TJclNumericFormat.IntToStr(const Value: Int64; out FirstDigitPos: Integer): string;
const
  MaxResultLen = 64 + 63 + 1; // max. digits + max. group separators + sign
var
  Remainder: Int64;
  I, N: Integer;
  Chars, Digits: Cardinal;
  LoopFinished, HasSign, SpacePadding: Boolean;
begin
  SpacePadding := PaddingChar = ' ';
  HasSign := ShowSign(Value);
  Chars := MaxResultLen;
  if Width > Chars then
    Chars := Width;
  Result := StrRepeatChar(' ', Chars);

  Remainder := Abs(Value);
  Digits := 0;

  Chars := 0;
  if HasSign then
    Chars := 1;

  I := MaxResultLen;

  while True do
  begin
    N := Remainder mod Base;
    Remainder := Remainder div Base;
    if N > 9 then
      Result[I] := Chr(Ord('A') + N - 10)
    else
      Result[I] := Chr(Ord('0') + N);
    Dec(I);
    Inc(Digits);
    Inc(Chars);
    if (Remainder = 0) and (SpacePadding or (Chars >= Width)) then
      Break;
    if (Digits = DigitBlockSize) then
    begin
      Inc(Chars);
      LoopFinished := (Remainder = 0) and (Chars = Width);
      if LoopFinished then
        Result[I] := ' '
      else
        Result[I] := DigitBlockSeparator;
      Dec(I);
      if LoopFinished then
        Break;
      Digits := 0;
    end;
  end;

  FirstDigitPos := I + 1;

  if HasSign then
    Result[I] := SignChar(Value)
  else
    Inc(I);
  N := MaxResultLen - Width + 1;
  if N < I then
    I := N;
  Result := Copy(Result, I, MaxResultLen);
  Dec(FirstDigitPos, I - 1);
end;

procedure TJclNumericFormat.SetBase(const Value: TNumericSystemBase);
begin
  FBase := Value;
  SetPrecision(FWantedPrecision);
end;

procedure TJclNumericFormat.SetExpDivision(const Value: Integer);
begin
  if Value <= 1 then
    FExpDivision := 1
  else
  // see TODO in GetMantissaExp
  if Value > 12 then
    FExpDivision := 12
  else
    FExpDivision := Value;
end;

procedure TJclNumericFormat.SetPrecision(const Value: TDigitCount);
begin
  FWantedPrecision := Value;
  // Do not display more digits than Float precision justifies
  if Base = 2 then
    FPrecision := BinaryPrecision
  else
    FPrecision := Trunc(BinaryPrecision / LogBase2(Base));
  if Value < FPrecision then
    FPrecision := Value;
end;

function TJclNumericFormat.Sign(Value: Char): Integer;
begin
  Result := 0;
  if Value = FSignChars[False] then
    Result := -1;
  if Value = FSignChars[True] then
    Result := +1;
end;

function TJclNumericFormat.StrToInt(const Value: string): Int64;
var
  I, N: Integer;
  C: Char;
begin
  Result := 0;
  I := 1;
  if (Length(Value) >= I)
    and ((Value[I] = '+') or (Value[I] = '-')) then
    Inc(I);
  for I := I to Length(Value) do
  begin
    C := Value[I];
    if C = DigitBlockSeparator then
      Continue
    else
    begin
      N := CharHex(C);
      if (N = $FF) or (N >= Base) then
        InvalidDigit(C);
      Result := Result * Base + N;
    end;
  end;
  if Value[1] = '-' then
    Result := -Result;
end;

function TJclNumericFormat.ShowSign(const Value: Float): Boolean;
begin
  Result := FShowPositiveSign or (Value < 0);
end;

function TJclNumericFormat.ShowSign(const Value: Int64): Boolean;
begin
  Result := FShowPositiveSign or (Value < 0);
end;

function TJclNumericFormat.SignChar(const Value: Float): Char;
begin
  Result := FSignChars[Value >= 0];
end;

function TJclNumericFormat.SignChar(const Value: Int64): Char;
begin
  Result := FSignChars[Value >= 0];
end;

function TJclNumericFormat.GetNegativeSign: Char;
begin
  Result := FSignChars[False];
end;

function TJclNumericFormat.GetPositiveSign: Char;
begin
  Result := FSignChars[True];
end;

procedure TJclNumericFormat.SetNegativeSign(const Value: Char);
begin
  FSignChars[False] := Value;
end;

procedure TJclNumericFormat.SetPositiveSign(const Value: Char);
begin
  FSignChars[True] := Value;
end;

//=== Child processes ========================================================

// MuteCRTerminatedLines was "outsourced" from Win32ExecAndRedirectOutput

function MuteCRTerminatedLines(const RawOutput: string): string;
const
  Delta = 1024;
var
  BufPos, OutPos, LfPos, EndPos: Integer;
  C: Char;
begin
  SetLength(Result, Length(RawOutput));
  OutPos := 1;
  LfPos := OutPos;
  EndPos := OutPos;
  for BufPos := 1 to Length(RawOutput) do
  begin
    if OutPos >= Length(Result)-2 then
      SetLength(Result, Length(Result) + Delta);
    C := RawOutput[BufPos];
    case C of
      NativeCarriageReturn:
        OutPos := LfPos;
      NativeLineFeed:
        begin
          OutPos := EndPos;
          Result[OutPos] := NativeCarriageReturn;
          Inc(OutPos);
          Result[OutPos] := C;
          Inc(OutPos);
          EndPos := OutPos;
          LfPos := OutPos;
        end;
    else
      Result[OutPos] := C;
      Inc(OutPos);
      EndPos := OutPos;
    end;
  end;
  SetLength(Result, OutPos - 1);
end;

function InternalExecute(CommandLine: string; var Output: string; OutputLineCallback: TTextHandler;
  RawOutput: Boolean; AbortPtr: PBoolean): Cardinal;

const
  BufferSize = 255;
type
  TBuffer = array [0..BufferSize] of AnsiChar;

  procedure ProcessLine(const Line: string; LineEnd: Integer);
  begin
    if RawOutput or (Line[LineEnd] <> NativeCarriageReturn) then
    begin
      while (LineEnd > 0) and CharIsReturn(Line[LineEnd]) do
        Dec(LineEnd);
      OutputLineCallback(Copy(Line, 1, LineEnd));
    end;
  end;

  procedure ProcessBuffer(var Buffer: TBuffer; var Line: string; PipeBytesRead: Cardinal);
  var
    CR, LF: Integer;
  begin
    Buffer[PipeBytesRead] := #0;
    Line := Line + string(Buffer);
    if Assigned(OutputLineCallback) then
    repeat
      CR := Pos(NativeCarriageReturn, Line);
      if CR = Length(Line) then
        CR := 0;        // line feed at CR + 1 might be missing
      LF := Pos(NativeLineFeed, Line);
      if (CR > 0) and ((LF > CR + 1) or (LF = 0)) then
        LF := CR;       // accept CR as line end
      if LF > 0 then
      begin
        ProcessLine(Line, LF);
        Delete(Line, 1, LF);
      end;
    until LF = 0;
  end;

var
  Buffer: TBuffer;
  Line: string;
  PipeBytesRead: Cardinal;
{$IFDEF MSWINDOWS}
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  SecurityAttr: TSecurityAttributes;
  PipeRead, PipeWrite: THandle;
begin
  Result := $FFFFFFFF;
  SecurityAttr.nLength := SizeOf(SecurityAttr);
  SecurityAttr.lpSecurityDescriptor := nil;
  SecurityAttr.bInheritHandle := True;
  PipeWrite := 0;
  PipeRead := 0;
  Line := '';
  ResetMemory(Buffer, SizeOf(Buffer));
  if not CreatePipe(PipeRead, PipeWrite, @SecurityAttr, 0) then
  begin
    Result := GetLastError;
    Exit;
  end;
  ResetMemory(StartupInfo, SizeOf(TStartupInfo));
  StartupInfo.cb := SizeOf(TStartupInfo);
  StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
  StartupInfo.wShowWindow := SW_HIDE;
  StartupInfo.hStdInput := GetStdHandle(STD_INPUT_HANDLE);
  StartupInfo.hStdOutput := PipeWrite;
  StartupInfo.hStdError := PipeWrite;
  UniqueString(CommandLine); // CommandLine must be in a writable memory block
  ProcessInfo.dwProcessId := 0;
  try
    if CreateProcess(nil, PChar(CommandLine), nil, nil, True, NORMAL_PRIORITY_CLASS,
      nil, nil, StartupInfo, ProcessInfo) then
    begin
      CloseHandle(PipeWrite);
      PipeWrite := 0;
      if AbortPtr <> nil then
        {$IFDEF FPC}
        AbortPtr^ := 0;
        {$ELSE ~FPC}
        AbortPtr^ := False;
        {$ENDIF ~FPC}
      PipeBytesRead := 0;
      while ((AbortPtr = nil) or not LongBool(AbortPtr^)) and
        ReadFile(PipeRead, Buffer, BufferSize, PipeBytesRead, nil) and (PipeBytesRead > 0) do
        ProcessBuffer(Buffer, Line, PipeBytesRead);
      if (AbortPtr <> nil) and LongBool(AbortPtr^) then
        TerminateProcess(ProcessInfo.hProcess, Cardinal(ABORT_EXIT_CODE));
      if (WaitForSingleObject(ProcessInfo.hProcess, INFINITE) = WAIT_OBJECT_0) and
        not GetExitCodeProcess(ProcessInfo.hProcess, Result) then
          Result := $FFFFFFFF;
      CloseHandle(ProcessInfo.hThread);
      ProcessInfo.hThread := 0;
      CloseHandle(ProcessInfo.hProcess);
      ProcessInfo.hProcess := 0;
    end
    else
    begin
      CloseHandle(PipeWrite);
      PipeWrite := 0;
    end;
    CloseHandle(PipeRead);
    PipeRead := 0;
  finally
    if PipeRead <> 0 then
      CloseHandle(PipeRead);
    if PipeWrite <> 0 then
      CloseHandle(PipeWrite);
    if ProcessInfo.hThread <> 0 then
      CloseHandle(ProcessInfo.hThread);
    if ProcessInfo.hProcess <> 0 then
    begin
      TerminateProcess(ProcessInfo.hProcess, Cardinal(ABORT_EXIT_CODE));
      WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
      GetExitCodeProcess(ProcessInfo.hProcess, Result);
      CloseHandle(ProcessInfo.hProcess);
    end;
  end;
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
var
  Pipe: PIOFile;
  Cmd: string;
begin
  Cmd := Format('%s 2>&1', [CommandLine]);
  Pipe := nil;
  try
    Pipe := Libc.popen(PChar(Cmd), 'r');
    { TODO : handle Abort }
    repeat
      PipeBytesRead := fread_unlocked(@Buffer, 1, BufferSize, Pipe);
      if PipeBytesRead > 0 then
        ProcessBuffer(Buffer, Line, PipeBytesRead);
    until PipeBytesRead = 0;
    Result := pclose(Pipe);
    Pipe := nil;
    wait(nil);
  finally
    if Pipe <> nil then
      pclose(Pipe);
    wait(nil);
  end;
{$ENDIF UNIX}
  if Line <> '' then
    if Assigned(OutputLineCallback) then
      // output wasn't terminated by a line feed...
      // (shouldn't happen, but you never know)
      ProcessLine(Line, Length(Line))
    else
      if RawOutput then
        Output := Output + Line
      else
        Output := Output + MuteCRTerminatedLines(Line);
end;

{ TODO -cHelp :
RawOutput: Do not process isolated carriage returns (#13).
That is, for RawOutput = False, lines not terminated by a line feed (#10) are deleted from Output. }

function Execute(const CommandLine: string; var Output: string; RawOutput: Boolean = False;
  AbortPtr: PBoolean = nil): Cardinal;
begin
  Result := InternalExecute(CommandLine, Output, nil, RawOutput, AbortPtr);
end;

{ TODO -cHelp :
Author: Robert Rossmair
OutputLineCallback called once per line of output. }

function Execute(const CommandLine: string; OutputLineCallback: TTextHandler; RawOutput: Boolean = False;
  AbortPtr: PBoolean = nil): Cardinal; overload;
var
  Dummy: string;
begin
  Dummy := '';
  Result := InternalExecute(CommandLine, Dummy, OutputLineCallback, RawOutput, AbortPtr);
end;

//=== { TJclCommandLineTool } ================================================

constructor TJclCommandLineTool.Create(const AExeName: string);
begin
  inherited Create;
  FOptions := TStringList.Create;
  FExeName := AExeName;
end;

destructor TJclCommandLineTool.Destroy;
begin
  FreeAndNil(FOptions);
  inherited Destroy;
end;

procedure TJclCommandLineTool.AddPathOption(const Option, Path: string);
var
  S: string;
begin
  S := PathRemoveSeparator(Path);
  {$IFDEF MSWINDOWS}
  S := LowerCase(S); // file names are case insensitive
  {$ENDIF MSWINDOWS}
  S := Format('-%s%s', [Option, S]);
  // avoid duplicate entries (note that search is case sensitive)
  if GetOptions.IndexOf(S) = -1 then
    GetOptions.Add(S);
end;

function TJclCommandLineTool.Execute(const CommandLine: string): Boolean;
begin
  if Assigned(FOutputCallback) then
    Result := JclSysUtils.Execute(Format('"%s" %s', [ExeName, CommandLine]), FOutputCallback) = 0
  else
    Result := JclSysUtils.Execute(Format('"%s" %s', [ExeName, CommandLine]), FOutput) = 0;
end;

function TJclCommandLineTool.GetExeName: string;
begin
  Result := FExeName;
end;

function TJclCommandLineTool.GetOptions: TStrings;
begin
  Result := FOptions;
end;

function TJclCommandLineTool.GetOutput: string;
begin
  Result := FOutput;
end;

function TJclCommandLineTool.GetOutputCallback: TTextHandler;
begin
  Result := FOutputCallback;
end;

procedure TJclCommandLineTool.SetOutputCallback(const CallbackMethod: TTextHandler);
begin
  FOutputCallback := CallbackMethod;
end;

//=== Console Utilities ======================================================

function ReadKey: Char;
{$IFDEF MSWINDOWS}
{ TODO -cHelp : Contributor: Robert Rossmair }
var
  Console: TJclConsole;
  InputMode: TJclConsoleInputModes;
begin
  Console := TJclConsole.Default;
  InputMode := Console.Input.Mode;
  Console.Input.Mode := [imProcessed];
  Console.Input.Clear;
  Result := Char(Console.Input.GetEvent.Event.KeyEvent.AsciiChar);
  Console.Input.Mode := InputMode;
end;
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
{ TODO -cHelp : Donator: Wayne Sherman }
var
  ReadFileDescriptor: TFDSet;
  TimeVal: TTimeVal;
  SaveTerminalSettings: TTermIos;
  RawTerminalSettings: TTermIos;
begin
  Result := #0;

  //Save Original Terminal Settings
  tcgetattr(stdin, SaveTerminalSettings);
  tcgetattr(stdin, RawTerminalSettings);

  //Put Terminal in RAW mode
  cfmakeraw(RawTerminalSettings);
  tcsetattr(stdin, TCSANOW, RawTerminalSettings);
  try
    //Setup file I/O descriptor for STDIN
    FD_ZERO(ReadFileDescriptor);
    FD_SET(stdin, ReadFileDescriptor);
    TimeVal.tv_sec := High(LongInt); //wait forever
    TimeVal.tv_usec := 0;

    //clear keyboard buffer first
    TCFlush(stdin, TCIFLUSH);

    //wait for a key to be pressed
    if select(1, @ReadFileDescriptor, nil, nil, @TimeVal) > 0 then
    begin
      //Now read the character
      Result := Char(getchar);
    end
    else
      raise EJclError.CreateRes(@RsReadKeyError);
  finally
    //Restore Original Terminal Settings
    tcsetattr(stdin, TCSANOW, SaveTerminalSettings);
  end;
end;
{$ENDIF UNIX}

//=== Loading of modules (DLLs) ==============================================

function LoadModule(var Module: TModuleHandle; FileName: string): Boolean;
{$IFDEF MSWINDOWS}
begin
  if Module = INVALID_MODULEHANDLE_VALUE then
    Module := SafeLoadLibrary(FileName);
  Result := Module <> INVALID_MODULEHANDLE_VALUE;
end;
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
begin
  if Module = INVALID_MODULEHANDLE_VALUE then
    Module := dlopen(PChar(FileName), RTLD_NOW);
  Result := Module <> INVALID_MODULEHANDLE_VALUE;
end;
{$ENDIF UNIX}

function LoadModuleEx(var Module: TModuleHandle; FileName: string; Flags: Cardinal): Boolean;
{$IFDEF MSWINDOWS}
begin
  if Module = INVALID_MODULEHANDLE_VALUE then
    Module := LoadLibraryEx(PChar(FileName), 0, Flags); // SafeLoadLibrary?
  Result := Module <> INVALID_MODULEHANDLE_VALUE;
end;
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
begin
  if Module = INVALID_MODULEHANDLE_VALUE then
    Module := dlopen(PChar(FileName), Flags);
  Result := Module <> INVALID_MODULEHANDLE_VALUE;
end;
{$ENDIF UNIX}

procedure UnloadModule(var Module: TModuleHandle);
{$IFDEF MSWINDOWS}
begin
  if Module <> INVALID_MODULEHANDLE_VALUE then
    FreeLibrary(Module);
  Module := INVALID_MODULEHANDLE_VALUE;
end;
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
begin
  if Module <> INVALID_MODULEHANDLE_VALUE then
    dlclose(Pointer(Module));
  Module := INVALID_MODULEHANDLE_VALUE;
end;
{$ENDIF UNIX}

function GetModuleSymbol(Module: TModuleHandle; SymbolName: string): Pointer;
{$IFDEF MSWINDOWS}
begin
  Result := nil;
  if Module <> INVALID_MODULEHANDLE_VALUE then
    Result := GetProcAddress(Module, PChar(SymbolName));
end;
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
begin
  Result := nil;
  if Module <> INVALID_MODULEHANDLE_VALUE then
    Result := dlsym(Module, PChar(SymbolName));
end;
{$ENDIF UNIX}

function GetModuleSymbolEx(Module: TModuleHandle; SymbolName: string; var Accu: Boolean): Pointer;
{$IFDEF MSWINDOWS}
begin
  Result := nil;
  if Module <> INVALID_MODULEHANDLE_VALUE then
    Result := GetProcAddress(Module, PChar(SymbolName));
  Accu := Accu and (Result <> nil);
end;
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
begin
  Result := nil;
  if Module <> INVALID_MODULEHANDLE_VALUE then
    Result := dlsym(Module, PChar(SymbolName));
  Accu := Accu and (Result <> nil);
end;
{$ENDIF UNIX}

function ReadModuleData(Module: TModuleHandle; SymbolName: string; var Buffer; Size: Cardinal): Boolean;
var
  Sym: Pointer;
begin
  Result := True;
  Sym := GetModuleSymbolEx(Module, SymbolName, Result);
  if Result then
    Move(Sym^, Buffer, Size);
end;

function WriteModuleData(Module: TModuleHandle; SymbolName: string; var Buffer; Size: Cardinal): Boolean;
var
  Sym: Pointer;
begin
  Result := True;
  Sym := GetModuleSymbolEx(Module, SymbolName, Result);
  if Result then
    Move(Buffer, Sym^, Size);
end;

//=== Conversion Utilities ===================================================

const
  DefaultTrueBoolStr  = 'True';  // DO NOT LOCALIZE
  DefaultFalseBoolStr = 'False'; // DO NOT LOCALIZE

  DefaultYesBoolStr   = 'Yes';   // DO NOT LOCALIZE
  DefaultNoBoolStr    = 'No';    // DO NOT LOCALIZE

function StrToBoolean(const S: string): Boolean;
var
  LowerCasedText: string;
begin
  { TODO : Possibility to add localized strings, like in Delphi 7 }
  { TODO : Lower case constants }
  LowerCasedText := LowerCase(S);
  Result := ((S = '1') or
    (LowerCasedText = LowerCase(DefaultTrueBoolStr)) or (LowerCasedText = LowerCase(DefaultYesBoolStr))) or
    (LowerCasedText = LowerCase(DefaultTrueBoolStr[1])) or (LowerCasedText = LowerCase(DefaultYesBoolStr[1]));
  if not Result then
  begin
    Result := not ((S = '0') or
      (LowerCasedText = LowerCase(DefaultFalseBoolStr)) or (LowerCasedText = LowerCase(DefaultNoBoolStr)) or
      (LowerCasedText = LowerCase(DefaultFalseBoolStr[1])) or (LowerCasedText = LowerCase(DefaultNoBoolStr[1])));
    if Result then
      raise EJclConversionError.CreateResFmt(@RsStringToBoolean, [S]);
  end;
end;

function BooleanToStr(B: Boolean): string;
begin
  if B then
    Result := DefaultTrueBoolStr
  else
    Result := DefaultFalseBoolStr;
end;

function IntToBool(I: Integer): Boolean;
begin
  Result := I <> 0;
end;

function BoolToInt(B: Boolean): Integer;
begin
  Result := Ord(B);
end;

//=== RTL package information ================================================

function SystemTObjectInstance: TJclAddr;
begin
  Result := ModuleFromAddr(Pointer(System.TObject));
end;

function IsCompiledWithPackages: Boolean;
begin
  Result := SystemTObjectInstance <> HInstance;
end;

//=== GUID ===================================================================

function JclGUIDToString(const GUID: TGUID): string;
begin
  Result := Format('{%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x}',
    [GUID.D1, GUID.D2, GUID.D3, GUID.D4[0], GUID.D4[1], GUID.D4[2],
     GUID.D4[3], GUID.D4[4], GUID.D4[5], GUID.D4[6], GUID.D4[7]]);
end;

function JclStringToGUID(const S: string): TGUID;
begin
  if (Length(S) <> 38) or (S[1] <> '{') or (S[10] <> '-') or (S[15] <> '-') or
    (S[20] <> '-') or (S[25] <> '-') or (S[38] <> '}') then
    raise EJclConversionError.CreateResFmt(@RsInvalidGUIDString, [S]);

  Result.D1 := StrToInt('$' + Copy(S, 2, 8));
  Result.D2 := StrToInt('$' + Copy(S, 11, 4));
  Result.D3 := StrToInt('$' + Copy(S, 16, 4));
  Result.D4[0] := StrToInt('$' + Copy(S, 21, 2));
  Result.D4[1] := StrToInt('$' + Copy(S, 23, 2));
  Result.D4[2] := StrToInt('$' + Copy(S, 26, 2));
  Result.D4[3] := StrToInt('$' + Copy(S, 28, 2));
  Result.D4[4] := StrToInt('$' + Copy(S, 30, 2));
  Result.D4[5] := StrToInt('$' + Copy(S, 32, 2));
  Result.D4[6] := StrToInt('$' + Copy(S, 34, 2));
  Result.D4[7] := StrToInt('$' + Copy(S, 36, 2));
end;

// add items at the end
procedure ListAddItems(var List: string; const Separator, Items: string);
var
  StrList, NewItems: TStringList;
  Index: Integer;
begin
  StrList := TStringList.Create;
  try
    StrToStrings(List, Separator, StrList);

    NewItems := TStringList.Create;
    try
      StrToStrings(Items, Separator, NewItems);

      for Index := 0 to NewItems.Count - 1 do
        StrList.Add(NewItems.Strings[Index]);

      List := StringsToStr(StrList, Separator);
    finally
      NewItems.Free;
    end;
  finally
    StrList.Free;
  end;
end;

// add items at the end if they are not present
procedure ListIncludeItems(var List: string; const Separator, Items: string);
var
  StrList, NewItems: TStringList;
  Index: Integer;
  Item: string;
begin
  StrList := TStringList.Create;
  try
    StrToStrings(List, Separator, StrList);

    NewItems := TStringList.Create;
    try
      StrToStrings(Items, Separator, NewItems);

      for Index := 0 to NewItems.Count - 1 do
      begin
        Item := NewItems.Strings[Index];
        if StrList.IndexOf(Item) = -1 then
          StrList.Add(Item);
      end;

      List := StringsToStr(StrList, Separator);
    finally
      NewItems.Free;
    end;
  finally
    StrList.Free;
  end;
end;

// delete multiple items
procedure ListRemoveItems(var List: string; const Separator, Items: string);
var
  StrList, RemItems: TStringList;
  Index, Position: Integer;
  Item: string;
begin
  StrList := TStringList.Create;
  try
    StrToStrings(List, Separator, StrList);

    RemItems := TStringList.Create;
    try
      StrToStrings(Items, Separator, RemItems);

      for Index := 0 to RemItems.Count - 1 do
      begin
        Item := RemItems.Strings[Index];
        repeat
          Position := StrList.IndexOf(Item);
          if Position >= 0 then
            StrList.Delete(Position);
        until Position < 0;
      end;

      List := StringsToStr(StrList, Separator);
    finally
      RemItems.Free;
    end;
  finally
    StrList.Free;
  end;
end;

// delete one item
procedure ListDelItem(var List: string; const Separator: string; const Index: Integer);
var
  StrList: TStringList;
begin
  StrList := TStringList.Create;
  try
    StrToStrings(List, Separator, StrList);

    StrList.Delete(Index);

    List := StringsToStr(StrList, Separator);
  finally
    StrList.Free;
  end;
end;

// return the number of item
function ListItemCount(const List, Separator: string): Integer;
var
  StrList: TStringList;
begin
  StrList := TStringList.Create;
  try
    StrToStrings(List, Separator, StrList);

    Result := StrList.Count;
  finally
    StrList.Free;
  end;
end;

// return the Nth item
function ListGetItem(const List, Separator: string; const Index: Integer): string;
var
  StrList: TStringList;
begin
  StrList := TStringList.Create;
  try
    StrToStrings(List, Separator, StrList);

    Result := StrList.Strings[Index];
  finally
    StrList.Free;
  end;
end;

// set the Nth item
procedure ListSetItem(var List: string; const Separator: string;
  const Index: Integer; const Value: string);
var
  StrList: TStringList;
begin
  StrList := TStringList.Create;
  try
    StrToStrings(List, Separator, StrList);

    StrList.Strings[Index] := Value;

    List := StringsToStr(StrList, Separator);
  finally
    StrList.Free;
  end;
end;

// return the index of an item
function ListItemIndex(const List, Separator, Item: string): Integer;
var
  StrList: TStringList;
begin
  StrList := TStringList.Create;
  try
    StrToStrings(List, Separator, StrList);

    Result := StrList.IndexOf(Item);
  finally
    StrList.Free;
  end;
end;

//=== { TJclIntfCriticalSection } ============================================

constructor TJclIntfCriticalSection.Create;
begin
  inherited Create;
  FCriticalSection := TCriticalSection.Create;
end;

destructor TJclIntfCriticalSection.Destroy;
begin
  FCriticalSection.Free;
  inherited Destroy;
end;

function TJclIntfCriticalSection._AddRef: Integer;
begin
  FCriticalSection.Acquire;
  Result := 0;
end;

function TJclIntfCriticalSection._Release: Integer;
begin
  FCriticalSection.Release;
  Result := 0;
end;

function TJclIntfCriticalSection.QueryInterface(const IID: TGUID; out Obj): HRESULT;
begin
  if GetInterface(IID, Obj) then
    Result := S_OK
  else
    Result := E_NOINTERFACE;
end;

//=== { TJclSimpleLog } ======================================================

{$IFDEF LINUX}
const
  INVALID_HANDLE_VALUE = 0;
{$ENDIF LINUX}

constructor TJclSimpleLog.Create(const ALogFileName: string = '');
begin
  if ALogFileName = '' then
    FLogFileName := CreateDefaultFileName
  else
    FLogFileName := ALogFileName;
  {$IFDEF BORLAND}
  FLogFileHandle := Integer(INVALID_HANDLE_VALUE);
  {$ELSE ~BORLAND}
  FLogFileHandle := INVALID_HANDLE_VALUE;
  {$ENDIF ~BORLAND}
  FLoggingActive := True;
end;

function TJclSimpleLog.CreateDefaultFileName: string;
begin
  Result := PathExtractFileDirFixed(ParamStr(0)) +
    PathExtractFileNameNoExt(ParamStr(0)) + '_Err.log';
end;

destructor TJclSimpleLog.Destroy;
begin
  CloseLog;
  inherited Destroy;
end;

procedure TJclSimpleLog.ClearLog;
var
  WasOpen: Boolean;
begin
  WasOpen := LogOpen;
  if WasOpen then
    CloseLog;
  if not FileExists(FlogFileName) then
    Exit;
  FLogFileHandle := FileCreate(FLogFileName);
  FLogWasEmpty := True;
  if Not WasOpen then
    CloseLog;
end;

procedure TJclSimpleLog.CloseLog;
begin
  if LogOpen then
  begin
    FileClose(FLogFileHandle);
    {$IFDEF BORLAND}
    FLogFileHandle := Integer(INVALID_HANDLE_VALUE);
    {$ELSE ~BORLAND}
    FLogFileHandle := INVALID_HANDLE_VALUE;
    {$ENDIF ~BORLAND}
    FLogWasEmpty := False;
  end;
end;

function TJclSimpleLog.GetLogOpen: Boolean;
begin
  Result := DWORD_PTR(FLogFileHandle) <> INVALID_HANDLE_VALUE;
end;

procedure TJclSimpleLog.OpenLog;
begin
  if not LogOpen then
  begin
    FLogFileHandle := FileOpen(FLogFileName, fmOpenWrite or fmShareDenyWrite);
    if LogOpen then
      FLogWasEmpty := FileSeek(FLogFileHandle, 0, soFromEnd) = 0
    else
    begin
      FLogFileHandle := FileCreate(FLogFileName);
      FLogWasEmpty := True;
      if LogOpen then
        FileWrite(FLogFileHandle, BOM_UTF8[0], Length(BOM_UTF8));
    end;
  end
  else
    FLogWasEmpty := False;
end;

procedure TJclSimpleLog.Write(const Text: string; Indent: Integer = 0; KeepOpen: Boolean = true);
var
  S: string;
  UTF8S: TUTF8String;
  SL: TStringList;
  I: Integer;
  WasOpen: Boolean;
begin
  if LoggingActive then
  begin
    WasOpen := LogOpen;
    if not WasOpen then
      OpenLog;
    if LogOpen then
    begin
      SL := TStringList.Create;
      try
        SL.Text := Text;
        for I := 0 to SL.Count - 1 do
        begin
          S := StringOfChar(' ', Indent) + StrEnsureSuffix(NativeLineBreak, TrimRight(SL[I]));
          UTF8S := StringToUTF8(S);
          FileWrite(FLogFileHandle, UTF8S[1], Length(UTF8S));
        end;
      finally
        SL.Free;
      end;
      // Keep the logfile Open when it was opened before and the KeepOpen is active
      if Not (WasOpen and KeepOpen) then
        CloseLog;
    end;
  end;
end;

procedure TJclSimpleLog.Write(Strings: TStrings; Indent: Integer = 0; KeepOpen: Boolean = true);
begin
  if Assigned(Strings) then
    Write(Strings.Text, Indent, KeepOpen);
end;

procedure TJclSimpleLog.TimeWrite(const Text: string; Indent: Integer = 0; KeepOpen: Boolean = true);
var
  S: string;
  UTF8S: TUTF8String;
  SL: TStringList;
  I: Integer;
  WasOpen: Boolean;
begin
  if LoggingActive then
  begin
    WasOpen := LogOpen;
    if not LogOpen then
      OpenLog;
    if LogOpen then
    begin
      SL := TStringList.Create;
      try
        SL.Text := Text;
        for I := 0 to SL.Count - 1 do
        begin
          if DateTimeFormatStr = '' then
            S := DateTimeToStr(Now)+' : '+StringOfChar(' ', Indent) + StrEnsureSuffix(NativeLineBreak, TrimRight(SL[I]))
          else
            S := FormatDateTime( DateTimeFormatStr, Now)+' : '+StringOfChar(' ', Indent) + StrEnsureSuffix(NativeLineBreak, TrimRight(SL[I]));
          UTF8S := StringToUTF8(S);
          FileWrite(FLogFileHandle, UTF8S[1], Length(UTF8S));
        end;
      finally
        SL.Free;
      end;
      if Not WasOpen and Not KeepOpen then
        CloseLog;
    end;
  end;
end;

procedure TJclSimpleLog.TimeWrite(Strings: TStrings; Indent: Integer = 0; KeepOpen: Boolean = true);
begin
  if Assigned(Strings) then
    TimeWrite(Strings.Text, Indent, KeepOpen);
end;

procedure TJclSimpleLog.WriteStamp(SeparatorLen: Integer = 0; KeepOpen: Boolean = true);
var
  WasOpen: Boolean;
begin
  if SeparatorLen <= 0 then
    SeparatorLen := 40;
  if LoggingActive then
  begin
    WasOpen := LogOpen;
    if not LogOpen then
    begin
      OpenLog;
      if LogOpen and not FLogWasEmpty then
        Write(NativeLineBreak);
    end;
    if LogOpen then
    begin
      Write(StrRepeat('=', SeparatorLen), 0, True);
      if DateTimeFormatStr = '' then
        Write(Format('= %-*s =', [SeparatorLen - 4, DateTimeToStr(Now)]), 0, True)
      else
        Write(Format('= %-*s =', [SeparatorLen - 4, FormatDateTime( DateTimeFormatStr, Now)]), 0, True);
      Write(StrRepeat('=', SeparatorLen), 0, True);
      if Not WasOpen and Not KeepOpen then
        CloseLog;
    end;
  end;
end;

procedure InitSimpleLog(const ALogFileName: string = ''; AOpenLog: Boolean = true);
begin
  if Assigned(SimpleLog) then
    FreeAndNil(SimpleLog);
  SimpleLog := TJclSimpleLog.Create(ALogFileName);
  if AOpenLog then
    SimpleLog.OpenLog;
end;

initialization
  SimpleLog := nil;
  {$IFDEF UNITVERSIONING}
  RegisterUnitVersion(HInstance, UnitVersioning);
  {$ENDIF UNITVERSIONING}

finalization
  {$IFDEF UNITVERSIONING}
  UnregisterUnitVersion(HInstance);
  {$ENDIF UNITVERSIONING}
  {$IFDEF MSWINDOWS}
  {$IFDEF THREADSAFE}
  // The user must release shared memory blocks himself. We don't clean up his
  // memory leaks and make it impossible to release the shared memory in other
  // unit's finalization blocks.
  MMFFinalized := True;
  FreeAndNil(GlobalMMFHandleListCS);
  {$ENDIF THREADSAFE}
  {$ENDIF MSWINDOWS}
  if Assigned(SimpleLog) then
    FreeAndNil(SimpleLog);
end.