{ *********************************************************************** }

{                                                                         }

{ Delphi / Kylix Cross-Platform Runtime Library                           }

{ System Utilities Unit                                                   }

{                                                                         }

{ Copyright (c) 1995-2004 Borland Software Corporation                    }

{                                                                         }

{ Copyright and license exceptions noted in source                        }

{                                                                         }

{ *********************************************************************** }



unit SysUtils;



{$H+}

{$WARN SYMBOL_PLATFORM OFF}

{$WARN UNSAFE_TYPE OFF}



interface



uses

{$IFDEF MSWINDOWS}

Windows, kol,

{$ENDIF}

{$IFDEF LINUX}

Types,

Libc,

{$ENDIF}

SysConst;



const

{ File open modes }



{$IFDEF LINUX}

  fmOpenRead       = O_RDONLY;

  fmOpenWrite      = O_WRONLY;

  fmOpenReadWrite  = O_RDWR;

//  fmShareCompat not supported

  fmShareExclusive = $0010;

  fmShareDenyWrite = $0020;

//  fmShareDenyRead  not supported

  fmShareDenyNone  = $0030;

{$ENDIF}

{$IFDEF MSWINDOWS}

  fmOpenRead       = $0000;

  fmOpenWrite      = $0001;

  fmOpenReadWrite  = $0002;



  fmShareCompat    = $0000 platform; // DOS compatibility mode is not portable

  fmShareExclusive = $0010;

  fmShareDenyWrite = $0020;

  fmShareDenyRead  = $0030 platform; // write-only not supported on all platforms

  fmShareDenyNone  = $0040;

{$ENDIF}



{ File attribute constants }



  faReadOnly  = $00000001 platform;

  faHidden    = $00000002 platform;

  faSysFile   = $00000004 platform;

  faVolumeID  = $00000008 platform deprecated;  // not used in Win32

  faDirectory = $00000010;

  faArchive   = $00000020 platform;

  faSymLink   = $00000040 platform;

  faAnyFile   = $0000003F;



{ Units of time }



  HoursPerDay   = 24;

  MinsPerHour   = 60;

  SecsPerMin    = 60;

  MSecsPerSec   = 1000;

  MinsPerDay    = HoursPerDay * MinsPerHour;

  SecsPerDay    = MinsPerDay * SecsPerMin;

  MSecsPerDay   = SecsPerDay * MSecsPerSec;



{ Days between 1/1/0001 and 12/31/1899 }



  DateDelta = 693594;



{ Days between TDateTime basis (12/31/1899) and Unix time_t basis (1/1/1970) }



  UnixDateDelta = 25569;



type



{ Standard Character set type }



  TSysCharSet = set of Char;



{ Set access to an integer }



  TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1;



{ Type conversion records }



  WordRec = packed record

    case Integer of

      0: (Lo, Hi: Byte);

      1: (Bytes: array [0..1] of Byte);

  end;



  LongRec = packed record

    case Integer of

      0: (Lo, Hi: Word);

      1: (Words: array [0..1] of Word);

      2: (Bytes: array [0..3] of Byte);

  end;



  Int64Rec = packed record

    case Integer of

      0: (Lo, Hi: Cardinal);

      1: (Cardinals: array [0..1] of Cardinal);

      2: (Words: array [0..3] of Word);

      3: (Bytes: array [0..7] of Byte);

  end;



{ General arrays }



  PByteArray = ^TByteArray;

  TByteArray = array[0..32767] of Byte;



  PWordArray = ^TWordArray;

  TWordArray = array[0..16383] of Word;



{ Generic procedure pointer }



  TProcedure = procedure;



{ Generic filename type }



  TFileName = type string;



{ Search record used by FindFirst, FindNext, and FindClose }



  TSearchRec = record

    Time: Integer;

    Size: Integer;

    Attr: Integer;

    Name: TFileName;

    ExcludeAttr: Integer;

{$IFDEF MSWINDOWS}

    FindHandle: THandle  platform;

    FindData: TWin32FindData  platform;

{$ENDIF}

{$IFDEF LINUX}

    Mode: mode_t  platform;

    FindHandle: Pointer  platform;

    PathOnly: String  platform;

    Pattern: String  platform;

{$ENDIF}

  end;



{ FloatToText, FloatToTextFmt, TextToFloat, and FloatToDecimal type codes }



  TFloatValue = (fvExtended, fvCurrency);



{ FloatToText format codes }



  TFloatFormat = (ffGeneral, ffExponent, ffFixed, ffNumber, ffCurrency);



{ FloatToDecimal result record }



  TFloatRec = packed record

    Exponent: Smallint;

    Negative: Boolean;

    Digits: array[0..20] of Char;

  end;



{ Date and time record }



  TTimeStamp = record

    Time: Integer;      { Number of milliseconds since midnight }

    Date: Integer;      { One plus number of days since 1/1/0001 }

  end;



{ MultiByte Character Set (MBCS) byte type }

  TMbcsByteType = (mbSingleByte, mbLeadByte, mbTrailByte);



{ System Locale information record }

  TSysLocale = packed record

    DefaultLCID: Integer;

    PriLangID: Integer;

    SubLangID: Integer;

    FarEast: Boolean;

    MiddleEast: Boolean;

  end;



{$IFDEF MSWINDOWS}

{ This is used by TLanguages }

  TLangRec = packed record

    FName: string;

    FLCID: LCID;

    FExt: string;

  end;



{ This stores the languages that the system supports }

  TLanguages = class

  private

    FSysLangs: array of TLangRec;

    function LocalesCallback(LocaleID: PChar): Integer; stdcall;

    function GetExt(Index: Integer): string;

    function GetID(Index: Integer): string;

    function GetLCID(Index: Integer): LCID;

    function GetName(Index: Integer): string;

    function GetNameFromLocaleID(ID: LCID): string;

    function GetNameFromLCID(const ID: string): string;

    function GetCount: integer;

  public

    constructor Create;

    function IndexOf(ID: LCID): Integer;

    property Count: Integer read GetCount;

    property Name[Index: Integer]: string read GetName;

    property NameFromLocaleID[ID: LCID]: string read GetNameFromLocaleID;

    property NameFromLCID[const ID: string]: string read GetNameFromLCID;

    property ID[Index: Integer]: string read GetID;

    property LocaleID[Index: Integer]: LCID read GetLCID;

    property Ext[Index: Integer]: string read GetExt;

  end platform;

{$ENDIF}



{$IFDEF LINUX}

  TEraRange = record

    StartDate : Integer;         // whole days since 12/31/1899 (TDateTime basis)

    EndDate   : Integer;         // whole days since 12/31/1899 (TDateTime basis)

//    Direction : Char;

  end;

{$ENDIF}



{ Exceptions }



  Exception = class(TObject)

  private

    FMessage: string;

    FHelpContext: Integer;

  public

    constructor Create(const Msg: string);

    constructor CreateFmt(const Msg: string; const Args: array of const);

    constructor CreateRes(Ident: Integer); overload;

    constructor CreateRes(const ResStringRec: string); overload;

    constructor CreateResFmt(Ident: Integer; const Args: array of const); overload;

    constructor CreateResFmt(const ResStringRec: string; const Args: array of const); overload;

    constructor CreateHelp(const Msg: string; AHelpContext: Integer);

    constructor CreateFmtHelp(const Msg: string; const Args: array of const;

      AHelpContext: Integer);

    constructor CreateResHelp(Ident: Integer; AHelpContext: Integer); overload;

    constructor CreateResHelp(ResStringRec: PResStringRec; AHelpContext: Integer); overload;

    constructor CreateResFmtHelp(ResStringRec: PResStringRec; const Args: array of const;

      AHelpContext: Integer); overload;

    constructor CreateResFmtHelp(Ident: Integer; const Args: array of const;

      AHelpContext: Integer); overload;

    property HelpContext: Integer read FHelpContext write FHelpContext;

    property Message: string read FMessage write FMessage;

  end;



  ExceptClass = class of Exception;



  EAbort = class(Exception);



  EHeapException = class(Exception)

  private

    AllowFree: Boolean;

  public

    procedure FreeInstance; override;

  end;



  EOutOfMemory = class(EHeapException);



  EInOutError = class(Exception)

  public

    ErrorCode: Integer;

  end;



{$IFDEF MSWINDOWS}

  PExceptionRecord = ^TExceptionRecord;

  TExceptionRecord = record

    ExceptionCode: Cardinal;

    ExceptionFlags: Cardinal;

    ExceptionRecord: PExceptionRecord;

    ExceptionAddress: Pointer;

    NumberParameters: Cardinal;

    ExceptionInformation: array[0..14] of Cardinal;

  end;

{$ENDIF}



  EExternal = class(Exception)

  public

{$IFDEF MSWINDOWS}

    ExceptionRecord: PExceptionRecord platform;

{$ENDIF}

{$IFDEF LINUX}

    ExceptionAddress: LongWord platform;

    AccessAddress: LongWord platform;

    SignalNumber: Integer platform;

{$ENDIF}

  end;



  EExternalException = class(EExternal);



  EIntError = class(EExternal);

  EDivByZero = class(EIntError);

  ERangeError = class(EIntError);

  EIntOverflow = class(EIntError);



  EMathError = class(EExternal);

  EInvalidOp = class(EMathError);

  EZeroDivide = class(EMathError);

  EOverflow = class(EMathError);

  EUnderflow = class(EMathError);



  EInvalidPointer = class(EHeapException);



  EInvalidCast = class(Exception);



  EConvertError = class(Exception);



  EAccessViolation = class(EExternal);

  EPrivilege = class(EExternal);

  EStackOverflow = class(EExternal)

    end deprecated;

  EControlC = class(EExternal);

{$IFDEF LINUX}

  EQuit = class(EExternal) end platform;

{$ENDIF}



{$IFDEF LINUX}

  ECodesetConversion = class(Exception) end platform;

{$ENDIF}



  EVariantError = class(Exception);



  EPropReadOnly = class(Exception);

  EPropWriteOnly = class(Exception);



  EAssertionFailed = class(Exception);



{$IFNDEF PC_MAPPED_EXCEPTIONS}

  EAbstractError = class(Exception) end platform;

{$ENDIF}



  EIntfCastError = class(Exception);



  EInvalidContainer = class(Exception);

  EInvalidInsert = class(Exception);



  EPackageError = class(Exception);



  EOSError = class(Exception)

  public

    ErrorCode: DWORD;

  end;

{$IFDEF MSWINDOWS}

  EWin32Error = class(EOSError)

  end deprecated;

{$ENDIF}



  ESafecallException = class(Exception);



{$IFDEF LINUX}



{

        Signals



    External exceptions, or signals, are, by default, converted to language

    exceptions by the Delphi RTL.  Under Linux, a Delphi application installs

    signal handlers to trap the raw signals, and convert them.  Delphi libraries

    do not install handlers by default.  So if you are implementing a standalone

    library, such as an Apache DSO, and you want to have signals converted to

    language exceptions that you can catch, you must install signal hooks

    manually, using the interfaces that the Delphi RTL provides.



    For most libraries, installing signal handlers is pretty

    straightforward.  Call HookSignal(RTL_SIGDEFAULT) at initialization time,

    and UnhookSignal(RTL_SIGNALDEFAULT) at shutdown.  This will install handlers

    for a set of signals that the RTL normally hooks for Delphi applications.



    There are some cases where the above initialization will not work properly:

    The proper behaviour for setting up signal handlers is to set

    a signal handler, and then later restore the signal handler to its previous

    state when you clean up.  If you have two libraries lib1 and lib2, and lib1

    installs a signal handler, and then lib2 installs a signal handler, those

    libraries have to uninstall in the proper order if they restore signal

    handlers, or the signal handlers can be left in an inconsistent and

    potentially fatal state.  Not all libraries behave well with respect to

    installing signal handlers.  To hedge against this possibility, and allow

    you to manage signal handlers better in the face of whatever behaviour

    you may find in external libraries, we provide a set of four interfaces to

    allow you to tailor the Delphi signal handler hooking/unhooking in the

    event of an emergency.  These are:

        InquireSignal

        AbandonSignalHandler

        HookSignal

        UnhookSignal



    InquireSignal allows you to look at the state of a signal handler, so

    that you can find out if someone grabbed it out from under you.



    AbandonSignalHandler tells the RTL never to unhook a particular

    signal handler.  This can be used if you find a case where it would

    be unsafe to return to the previous state of signal handling.  For

    example, if the previous signal handler was installed by a library

    which has since been unloaded.



    HookSignal/UnhookSignal setup signal handlers that map certain signals

    into language exceptions.



    See additional notes at InquireSignal, et al, below.

}



const

    RTL_SIGINT          = 0;    // User interrupt (SIGINT)

    RTL_SIGFPE          = 1;    // Floating point exception (SIGFPE)

    RTL_SIGSEGV         = 2;    // Segmentation violation (SIGSEGV)

    RTL_SIGILL          = 3;    // Illegal instruction (SIGILL)

    RTL_SIGBUS          = 4;    // Bus error (SIGBUS)

    RTL_SIGQUIT         = 5;    // User interrupt (SIGQUIT)

    RTL_SIGLAST         = RTL_SIGQUIT; // Used internally.  Don't use this.

    RTL_SIGDEFAULT      = -1;   // Means all of a set of signals that the we capture

                                // normally.  This is currently all of the preceding

                                // signals.  You cannot pass this to InquireSignal.



type

    { TSignalState is the state of a given signal handler, as returned by

      InquireSignal.  See InquireSignal, below.

    }

    TSignalState = (ssNotHooked, ssHooked, ssOverridden);



var



  {

    If DeferUserInterrupts is set, we do not raise either SIGINT or SIGQUIT as

    an exception, instead, we set SIGINTIssued or SIGQUITIssued when the

    signal arrives, and swallow the signal where the OS issued it.  This gives

    GUI applications the chance to defer the actual handling of the signal

    until a time when it is safe to do so.

  }



  DeferUserInterrupts: Boolean;

  SIGINTIssued: Boolean;

  SIGQUITIssued: Boolean;

{$ENDIF}



{$IFDEF LINUX}

const

  MAX_PATH = 4095;  // From /usr/include/linux/limits.h PATH_MAX

{$ENDIF}



var



{ Empty string and null string pointer. These constants are provided for

  backwards compatibility only.  }



  EmptyStr: string = '';

  NullStr: PString = @EmptyStr;



  EmptyWideStr: WideString = '';

  NullWideStr: PWideString = @EmptyWideStr;



{$IFDEF MSWINDOWS}

{ Win32 platform identifier.  This will be one of the following values:



    VER_PLATFORM_WIN32s

    VER_PLATFORM_WIN32_WINDOWS

    VER_PLATFORM_WIN32_NT



  See WINDOWS.PAS for the numerical values. }



  Win32Platform: Integer = 0;



{ Win32 OS version information -



  see TOSVersionInfo.dwMajorVersion/dwMinorVersion/dwBuildNumber }



  Win32MajorVersion: Integer = 0;

  Win32MinorVersion: Integer = 0;

  Win32BuildNumber: Integer = 0;



{ Win32 OS extra version info string -



  see TOSVersionInfo.szCSDVersion }



  Win32CSDVersion: string = '';



{ Win32 OS version tester }



function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean;



{ GetFileVersion returns the most significant 32 bits of a file's binary

  version number. Typically, this includes the major and minor version placed

  together in one 32-bit integer. It generally does not include the release

  or build numbers. It returns Cardinal(-1) if it failed. }

function GetFileVersion(const AFileName: string): Cardinal;



{$ENDIF}



{ Currency and date/time formatting options



  The initial values of these variables are fetched from the system registry

  using the GetLocaleInfo function in the Win32 API. The description of each

  variable specifies the LOCALE_XXXX constant used to fetch the initial

  value.



  CurrencyString - Defines the currency symbol used in floating-point to

  decimal conversions. The initial value is fetched from LOCALE_SCURRENCY.



  CurrencyFormat - Defines the currency symbol placement and separation

  used in floating-point to decimal conversions. Possible values are:



    0 = '$1'

    1 = '1$'

    2 = '$ 1'

    3 = '1 $'



  The initial value is fetched from LOCALE_ICURRENCY.



  NegCurrFormat - Defines the currency format for used in floating-point to

  decimal conversions of negative numbers. Possible values are:



    0 = '($1)'      4 = '(1$)'      8 = '-1 $'      12 = '$ -1'

    1 = '-$1'       5 = '-1$'       9 = '-$ 1'      13 = '1- $'

    2 = '$-1'       6 = '1-$'      10 = '1 $-'      14 = '($ 1)'

    3 = '$1-'       7 = '1$-'      11 = '$ 1-'      15 = '(1 $)'



  The initial value is fetched from LOCALE_INEGCURR.



  ThousandSeparator - The character used to separate thousands in numbers

  with more than three digits to the left of the decimal separator. The

  initial value is fetched from LOCALE_STHOUSAND.  A value of #0 indicates

  no thousand separator character should be output even if the format string

  specifies thousand separators.



  DecimalSeparator - The character used to separate the integer part from

  the fractional part of a number. The initial value is fetched from

  LOCALE_SDECIMAL.  DecimalSeparator must be a non-zero value.



  CurrencyDecimals - The number of digits to the right of the decimal point

  in a currency amount. The initial value is fetched from LOCALE_ICURRDIGITS.



  DateSeparator - The character used to separate the year, month, and day

  parts of a date value. The initial value is fetched from LOCATE_SDATE.



  ShortDateFormat - The format string used to convert a date value to a

  short string suitable for editing. For a complete description of date and

  time format strings, refer to the documentation for the FormatDate

  function. The short date format should only use the date separator

  character and the  m, mm, d, dd, yy, and yyyy format specifiers. The

  initial value is fetched from LOCALE_SSHORTDATE.



  LongDateFormat - The format string used to convert a date value to a long

  string suitable for display but not for editing. For a complete description

  of date and time format strings, refer to the documentation for the

  FormatDate function. The initial value is fetched from LOCALE_SLONGDATE.



  TimeSeparator - The character used to separate the hour, minute, and

  second parts of a time value. The initial value is fetched from

  LOCALE_STIME.



  TimeAMString - The suffix string used for time values between 00:00 and

  11:59 in 12-hour clock format. The initial value is fetched from

  LOCALE_S1159.



  TimePMString - The suffix string used for time values between 12:00 and

  23:59 in 12-hour clock format. The initial value is fetched from

  LOCALE_S2359.



  ShortTimeFormat - The format string used to convert a time value to a

  short string with only hours and minutes. The default value is computed

  from LOCALE_ITIME and LOCALE_ITLZERO.



  LongTimeFormat - The format string used to convert a time value to a long

  string with hours, minutes, and seconds. The default value is computed

  from LOCALE_ITIME and LOCALE_ITLZERO.



  ShortMonthNames - Array of strings containing short month names. The mmm

  format specifier in a format string passed to FormatDate causes a short

  month name to be substituted. The default values are fecthed from the

  LOCALE_SABBREVMONTHNAME system locale entries.



  LongMonthNames - Array of strings containing long month names. The mmmm

  format specifier in a format string passed to FormatDate causes a long

  month name to be substituted. The default values are fecthed from the

  LOCALE_SMONTHNAME system locale entries.



  ShortDayNames - Array of strings containing short day names. The ddd

  format specifier in a format string passed to FormatDate causes a short

  day name to be substituted. The default values are fecthed from the

  LOCALE_SABBREVDAYNAME system locale entries.



  LongDayNames - Array of strings containing long day names. The dddd

  format specifier in a format string passed to FormatDate causes a long

  day name to be substituted. The default values are fecthed from the

  LOCALE_SDAYNAME system locale entries.



  ListSeparator - The character used to separate items in a list.  The

  initial value is fetched from LOCALE_SLIST.



  TwoDigitYearCenturyWindow - Determines what century is added to two

  digit years when converting string dates to numeric dates.  This value

  is subtracted from the current year before extracting the century.

  This can be used to extend the lifetime of existing applications that

  are inextricably tied to 2 digit year data entry.  The best solution

  to Year 2000 (Y2k) issues is not to accept 2 digit years at all - require

  4 digit years in data entry to eliminate century ambiguities.



  Examples:



  Current TwoDigitCenturyWindow  Century  StrToDate() of:

  Year    Value                  Pivot    '01/01/03' '01/01/68' '01/01/50'

  -------------------------------------------------------------------------

  1998    0                      1900     1903       1968       1950

  2002    0                      2000     2003       2068       2050

  1998    50 (default)           1948     2003       1968       1950

  2002    50 (default)           1952     2003       1968       2050

  2020    50 (default)           1970     2003       2068       2050

 }



var

  CurrencyString: string;

  CurrencyFormat: Byte;

  NegCurrFormat: Byte;

  ThousandSeparator: Char;

  DecimalSeparator: Char;

  CurrencyDecimals: Byte;

  DateSeparator: Char;

  ShortDateFormat: string;

  LongDateFormat: string;

  TimeSeparator: Char;

  TimeAMString: string;

  TimePMString: string;

  ShortTimeFormat: string;

  LongTimeFormat: string;

  ShortMonthNames: array[1..12] of string;

  LongMonthNames: array[1..12] of string;

  ShortDayNames: array[1..7] of string;

  LongDayNames: array[1..7] of string;

  SysLocale: TSysLocale;

  TwoDigitYearCenturyWindow: Word = 50;

  ListSeparator: Char;





{ Thread safe currency and date/time formatting



  The TFormatSettings record is designed to allow thread safe formatting,

  equivalent to the gloabal variables described above. Each of the

  formatting routines that use the gloabal variables have overloaded

  equivalents, requiring an additional parameter of type TFormatSettings.



  A TFormatSettings record must be populated before use. This can be done

  using the GetLocaleFormatSettings function, which will populate the

  record with values based on the given locale (using the Win32 API

  function GetLocaleInfo). Note that some format specifiers still require

  specific thread locale settings (such as period/era names).

}



type

  TFormatSettings = record

    CurrencyFormat: Byte;

    NegCurrFormat: Byte;

    ThousandSeparator: Char;

    DecimalSeparator: Char;

    CurrencyDecimals: Byte;

    DateSeparator: Char;

    TimeSeparator: Char;

    ListSeparator: Char;

    CurrencyString: string;

    ShortDateFormat: string;

    LongDateFormat: string;

    TimeAMString: string;

    TimePMString: string;

    ShortTimeFormat: string;

    LongTimeFormat: string;

    ShortMonthNames: array[1..12] of string;

    LongMonthNames: array[1..12] of string;

    ShortDayNames: array[1..7] of string;

    LongDayNames: array[1..7] of string;

    TwoDigitYearCenturyWindow: Word;

  end;



  TLocaleOptions = (loInvariantLocale, loUserLocale);



const

  MaxEraCount = 7;



var

  EraNames: array [1..MaxEraCount] of string;

  EraYearOffsets: array [1..MaxEraCount] of Integer;

{$IFDEF LINUX}

  EraRanges : array [1..MaxEraCount] of TEraRange platform;

  EraYearFormats: array [1..MaxEraCount] of string platform;

  EraCount: Byte platform;

{$ENDIF}



const

  PathDelim  = {$IFDEF MSWINDOWS} '\'; {$ELSE} '/'; {$ENDIF}

  DriveDelim = {$IFDEF MSWINDOWS} ':'; {$ELSE} '';  {$ENDIF}

  PathSep    = {$IFDEF MSWINDOWS} ';'; {$ELSE} ':'; {$ENDIF}



{$IFDEF MSWINDOWS}

function Languages: TLanguages;

{$ENDIF}



{ Memory management routines }



{ AllocMem allocates a block of the given size on the heap. Each byte in

  the allocated buffer is set to zero. To dispose the buffer, use the

  FreeMem standard procedure. }



function AllocMem(Size: Cardinal): Pointer;



{ Exit procedure handling }



{ AddExitProc adds the given procedure to the run-time library's exit

  procedure list. When an application terminates, its exit procedures are

  executed in reverse order of definition, i.e. the last procedure passed

  to AddExitProc is the first one to get executed upon termination. }



procedure AddExitProc(Proc: TProcedure);



{ String handling routines }



{ NewStr allocates a string on the heap. NewStr is provided for backwards

  compatibility only. }



function NewStr(const S: string): PString; deprecated;



{ DisposeStr disposes a string pointer that was previously allocated using

  NewStr. DisposeStr is provided for backwards compatibility only. }



procedure DisposeStr(P: PString); deprecated;



{ AssignStr assigns a new dynamically allocated string to the given string

  pointer. AssignStr is provided for backwards compatibility only. }



procedure AssignStr(var P: PString; const S: string); deprecated;



{ AppendStr appends S to the end of Dest. AppendStr is provided for

  backwards compatibility only. Use "Dest := Dest + S" instead. }



procedure AppendStr(var Dest: string; const S: string); deprecated;



{ UpperCase converts all ASCII characters in the given string to upper case.

  The conversion affects only 7-bit ASCII characters between 'a' and 'z'. To

  convert 8-bit international characters, use AnsiUpperCase. }



function UpperCase(const S: string): string; overload;

function UpperCase(const S: string; LocaleOptions: TLocaleOptions): string; overload; inline;



{ LowerCase converts all ASCII characters in the given string to lower case.

  The conversion affects only 7-bit ASCII characters between 'A' and 'Z'. To

  convert 8-bit international characters, use AnsiLowerCase. }



function LowerCase(const S: string): string; overload;

function LowerCase(const S: string; LocaleOptions: TLocaleOptions): string; overload; inline;



{ CompareStr compares S1 to S2, with case-sensitivity. The return value is

  less than 0 if S1 < S2, 0 if S1 = S2, or greater than 0 if S1 > S2. The

  compare operation is based on the 8-bit ordinal value of each character

  and is not affected by the current user locale. }



function CompareStr(const S1, S2: string): Integer; overload;

function CompareStr(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer; overload;



{ SameStr compares S1 to S2, with case-sensitivity. Returns true if

  S1 and S2 are the equal, that is, if CompareStr would return 0. }



function SameStr(const S1, S2: string): Boolean; overload;

function SameStr(const S1, S2: string; LocaleOptions: TLocaleOptions): Boolean; overload;



{ CompareMem performs a binary compare of Length bytes of memory referenced

  by P1 to that of P2.  CompareMem returns True if the memory referenced by

  P1 is identical to that of P2. }



function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;



{ CompareText compares S1 to S2, without case-sensitivity. The return value

  is the same as for CompareStr. The compare operation is based on the 8-bit

  ordinal value of each character, after converting 'a'..'z' to 'A'..'Z',

  and is not affected by the current user locale. }



function CompareText(const S1, S2: string): Integer; overload;

function CompareText(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer; overload;



{ SameText compares S1 to S2, without case-sensitivity. Returns true if

  S1 and S2 are the equal, that is, if CompareText would return 0. SameText

  has the same 8-bit limitations as CompareText }



function SameText(const S1, S2: string): Boolean; overload;

function SameText(const S1, S2: string; LocaleOptions: TLocaleOptions): Boolean; overload;



{ AnsiUpperCase converts all characters in the given string to upper case.

  The conversion uses the current user locale. }



function AnsiUpperCase(const S: string): string;



{ AnsiLowerCase converts all characters in the given string to lower case.

  The conversion uses the current user locale. }



function AnsiLowerCase(const S: string): string;



{ AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare

  operation is controlled by the current user locale. The return value

  is the same as for CompareStr. }



function AnsiCompareStr(const S1, S2: string): Integer; inline;



{ AnsiSameStr compares S1 to S2, with case-sensitivity. The compare

  operation is controlled by the current user locale. The return value

  is True if AnsiCompareStr would have returned 0. }



function AnsiSameStr(const S1, S2: string): Boolean; inline;



{ AnsiCompareText compares S1 to S2, without case-sensitivity. The compare

  operation is controlled by the current user locale. The return value

  is the same as for CompareStr. }



function AnsiCompareText(const S1, S2: string): Integer; inline;



{ AnsiSameText compares S1 to S2, without case-sensitivity. The compare

  operation is controlled by the current user locale. The return value

  is True if AnsiCompareText would have returned 0. }



function AnsiSameText(const S1, S2: string): Boolean; inline;



{ AnsiStrComp compares S1 to S2, with case-sensitivity. The compare

  operation is controlled by the current user locale. The return value

  is the same as for CompareStr. }



function AnsiStrComp(S1, S2: PChar): Integer; inline;



{ AnsiStrIComp compares S1 to S2, without case-sensitivity. The compare

  operation is controlled by the current user locale. The return value

  is the same as for CompareStr. }



function AnsiStrIComp(S1, S2: PChar): Integer; inline;



{ AnsiStrLComp compares S1 to S2, with case-sensitivity, up to a maximum

  length of MaxLen bytes. The compare operation is controlled by the

  current user locale. The return value is the same as for CompareStr. }



function AnsiStrLComp(S1, S2: PChar; MaxLen: Cardinal): Integer;



{ AnsiStrLIComp compares S1 to S2, without case-sensitivity, up to a maximum

  length of MaxLen bytes. The compare operation is controlled by the

  current user locale. The return value is the same as for CompareStr. }



function AnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer;



{ AnsiStrLower converts all characters in the given string to lower case.

  The conversion uses the current user locale. }



function AnsiStrLower(Str: PChar): PChar;



{ AnsiStrUpper converts all characters in the given string to upper case.

  The conversion uses the current user locale. }



function AnsiStrUpper(Str: PChar): PChar;



{ AnsiLastChar returns a pointer to the last full character in the string.

  This function supports multibyte characters  }



function AnsiLastChar(const S: string): PChar;



{ AnsiStrLastChar returns a pointer to the last full character in the string.

  This function supports multibyte characters.  }



function AnsiStrLastChar(P: PChar): PChar;



{ WideUpperCase converts all characters in the given string to upper case. }



function WideUpperCase(const S: WideString): WideString;



{ WideLowerCase converts all characters in the given string to lower case. }



function WideLowerCase(const S: WideString): WideString;



{ WideCompareStr compares S1 to S2, with case-sensitivity. The return value

  is the same as for CompareStr. }



function WideCompareStr(const S1, S2: WideString): Integer;



{ WideSameStr compares S1 to S2, with case-sensitivity. The return value

  is True if WideCompareStr would have returned 0. }



function WideSameStr(const S1, S2: WideString): Boolean; inline;



{ WideCompareText compares S1 to S2, without case-sensitivity. The return value

  is the same as for CompareStr. }



function WideCompareText(const S1, S2: WideString): Integer;



{ WideSameText compares S1 to S2, without case-sensitivity. The return value

  is True if WideCompareText would have returned 0. }



function WideSameText(const S1, S2: WideString): Boolean; inline;



{ Trim trims leading and trailing spaces and control characters from the

  given string. }



function Trim(const S: string): string; overload;

function Trim(const S: WideString): WideString; overload;



{ TrimLeft trims leading spaces and control characters from the given

  string. }



function TrimLeft(const S: string): string; overload;

function TrimLeft(const S: WideString): WideString; overload;



{ TrimRight trims trailing spaces and control characters from the given

  string. }



function TrimRight(const S: string): string; overload;

function TrimRight(const S: WideString): WideString; overload;



{ QuotedStr returns the given string as a quoted string. A single quote

  character is inserted at the beginning and the end of the string, and

  for each single quote character in the string, another one is added. }



function QuotedStr(const S: string): string;



{ AnsiQuotedStr returns the given string as a quoted string, using the

  provided Quote character.  A Quote character is inserted at the beginning

  and end of the string, and each Quote character in the string is doubled.

  This function supports multibyte character strings (MBCS). }



function AnsiQuotedStr(const S: string; Quote: Char): string;



{ AnsiExtractQuotedStr removes the Quote characters from the beginning and end

  of a quoted string, and reduces pairs of Quote characters within the quoted

  string to a single character. If the first character in Src is not the Quote

  character, the function returns an empty string.  The function copies

  characters from the Src to the result string until the second solitary

  Quote character or the first null character in Src. The Src parameter is

  updated to point to the first character following the quoted string.  If

  the Src string does not contain a matching end Quote character, the Src

  parameter is updated to point to the terminating null character in Src.

  This function supports multibyte character strings (MBCS).  }



function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string;



{ AnsiDequotedStr is a simplified version of AnsiExtractQuotedStr }



function AnsiDequotedStr(const S: string; AQuote: Char): string;



{ AdjustLineBreaks adjusts all line breaks in the given string to the

  indicated style.

  When Style is tlbsCRLF, the function changes all

  CR characters not followed by LF and all LF characters not preceded

  by a CR into CR/LF pairs.

  When Style is tlbsLF, the function changes all CR/LF pairs and CR characters

  not followed by LF to LF characters. }



function AdjustLineBreaks(const S: string; Style: TTextLineBreakStyle =

        {$IFDEF LINUX} tlbsLF {$ENDIF}

        {$IFDEF MSWINDOWS} tlbsCRLF {$ENDIF}): string;



{ IsValidIdent returns true if the given string is a valid identifier. An

  identifier is defined as a character from the set ['A'..'Z', 'a'..'z', '_']

  followed by zero or more characters from the set ['A'..'Z', 'a'..'z',

  '0..'9', '_']. With DotNet code we need to allow dots in the names.}



function IsValidIdent(const Ident: string; AllowDots: Boolean = False): Boolean;



{ IntToStr converts the given value to its decimal string representation. }



function IntToStr(Value: Integer): string; overload;

function IntToStr(Value: Int64): string; overload;



{ IntToHex converts the given value to a hexadecimal string representation

  with the minimum number of digits specified. }



function IntToHex(Value: Integer; Digits: Integer): string; overload;

function IntToHex(Value: Int64; Digits: Integer): string; overload;



{ StrToInt converts the given string to an integer value. If the string

  doesn't contain a valid value, an EConvertError exception is raised. }



function StrToInt(const S: string): Integer;

function StrToIntDef(const S: string; Default: Integer): Integer;

function TryStrToInt(const S: string; out Value: Integer): Boolean;



{ Similar to the above functions but for Int64 instead }



function StrToInt64(const S: string): Int64;

function StrToInt64Def(const S: string; const Default: Int64): Int64;

function TryStrToInt64(const S: string; out Value: Int64): Boolean;



{ StrToBool converts the given string to a boolean value.  If the string

  doesn't contain a valid value, an EConvertError exception is raised.

  BoolToStr converts boolean to a string value that in turn can be converted

  back into a boolean.  BoolToStr will always pick the first element of

  the TrueStrs/FalseStrs arrays. }



var

  TrueBoolStrs: array of String;

  FalseBoolStrs: array of String;



const

  DefaultTrueBoolStr = 'True';   // DO NOT LOCALIZE

  DefaultFalseBoolStr = 'False'; // DO NOT LOCALIZE



function StrToBool(const S: string): Boolean;

function StrToBoolDef(const S: string; const Default: Boolean): Boolean;

function TryStrToBool(const S: string; out Value: Boolean): Boolean;



function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string;



{ LoadStr loads the string resource given by Ident from the application's

  executable file or associated resource module. If the string resource

  does not exist, LoadStr returns an empty string. }



function LoadStr(Ident: Integer): string;



{ FmtLoadStr loads the string resource given by Ident from the application's

  executable file or associated resource module, and uses it as the format

  string in a call to the Format function with the given arguments. }



function FmtLoadStr(Ident: Integer; const Args: array of const): string;



{ File management routines }



{ FileOpen opens the specified file using the specified access mode. The

  access mode value is constructed by OR-ing one of the fmOpenXXXX constants

  with one of the fmShareXXXX constants. If the return value is positive,

  the function was successful and the value is the file handle of the opened

  file. A return value of -1 indicates that an error occurred. }



function FileOpen(const FileName: string; Mode: LongWord): Integer;



{ FileCreate creates a new file by the specified name. If the return value

  is positive, the function was successful and the value is the file handle

  of the new file. A return value of -1 indicates that an error occurred.

  On Linux, this calls FileCreate(FileName, DEFFILEMODE) to create

  the file with read and write access for the current user only.  }



function FileCreate(const FileName: string): Integer; overload; inline;



{ This second version of FileCreate lets you specify the access rights to put on the newly

  created file.  The access rights parameter is ignored on Win32 }



function FileCreate(const FileName: string; Rights: Integer): Integer; overload; inline;



{ FileRead reads Count bytes from the file given by Handle into the buffer

  specified by Buffer. The return value is the number of bytes actually

  read; it is less than Count if the end of the file was reached. The return

  value is -1 if an error occurred. }



function FileRead(Handle: Integer; var Buffer; Count: LongWord): Integer;



{ FileWrite writes Count bytes to the file given by Handle from the buffer

  specified by Buffer. The return value is the number of bytes actually

  written, or -1 if an error occurred. }



function FileWrite(Handle: Integer; const Buffer; Count: LongWord): Integer;



{ FileSeek changes the current position of the file given by Handle to be

  Offset bytes relative to the point given by Origin. Origin = 0 means that

  Offset is relative to the beginning of the file, Origin = 1 means that

  Offset is relative to the current position, and Origin = 2 means that

  Offset is relative to the end of the file. The return value is the new

  current position, relative to the beginning of the file, or -1 if an error

  occurred. }



function FileSeek(Handle, Offset, Origin: Integer): Integer; overload;

function FileSeek(Handle: Integer; const Offset: Int64; Origin: Integer): Int64; overload;



{ FileClose closes the specified file. }



procedure FileClose(Handle: Integer); inline;



{ FileAge returns the date-and-time stamp of the specified file. The return

  value can be converted to a TDateTime value using the FileDateToDateTime

  function. The return value is -1 if the file does not exist. }



function FileAge(const FileName: string): Integer;



{ FileExists returns a boolean value that indicates whether the specified

  file exists. }



function FileExists(const FileName: string): Boolean; inline;



{ DirectoryExists returns a boolean value that indicates whether the

  specified directory exists (and is actually a directory) }



function DirectoryExists(const Directory: string): Boolean;



{ ForceDirectories ensures that all the directories in a specific path exist.

  Any portion that does not already exist will be created.  Function result

  indicates success of the operation.  The function can fail if the current

  user does not have sufficient file access rights to create directories in

  the given path.  }



function ForceDirectories(Dir: string): Boolean;



{ FindFirst searches the directory given by Path for the first entry that

  matches the filename given by Path and the attributes given by Attr. The

  result is returned in the search record given by SearchRec. The return

  value is zero if the function was successful. Otherwise the return value

  is a system error code. After calling FindFirst, always call FindClose.

  FindFirst is typically used with FindNext and FindClose as follows:



    Result := FindFirst(Path, Attr, SearchRec);

    while Result = 0 do

    begin

      ProcessSearchRec(SearchRec);

      Result := FindNext(SearchRec);

    end;

    FindClose(SearchRec);



  where ProcessSearchRec represents user-defined code that processes the

  information in a search record. }



function FindFirst(const Path: string; Attr: Integer;

  var F: TSearchRec): Integer;



{ FindNext returs the next entry that matches the name and attributes

  specified in a previous call to FindFirst. The search record must be one

  that was passed to FindFirst. The return value is zero if the function was

  successful. Otherwise the return value is a system error code. }



function FindNext(var F: TSearchRec): Integer;



{ FindClose terminates a FindFirst/FindNext sequence and frees memory and system

  resources allocated by FindFirst.

  Every FindFirst/FindNext must end with a call to FindClose. }



procedure FindClose(var F: TSearchRec);



{ FileGetDate returns the OS date-and-time stamp of the file given by

  Handle. The return value is -1 if the handle is invalid. The

  FileDateToDateTime function can be used to convert the returned value to

  a TDateTime value. }



function FileGetDate(Handle: Integer): Integer;



{ FileSetDate sets the OS date-and-time stamp of the file given by FileName

  to the value given by Age. The DateTimeToFileDate function can be used to

  convert a TDateTime value to an OS date-and-time stamp. The return value

  is zero if the function was successful. Otherwise the return value is a

  system error code.        }



function FileSetDate(const FileName: string; Age: Integer): Integer; overload;



{$IFDEF MSWINDOWS}

{  FileSetDate by handle is not available on Unix platforms because there

  is no standard way to set a file's modification time using only a file

  handle, and no standard way to obtain the file name of an open

  file handle.  }



function FileSetDate(Handle: Integer; Age: Integer): Integer; overload; platform;



{ FileGetAttr returns the file attributes of the file given by FileName. The

  attributes can be examined by AND-ing with the faXXXX constants defined

  above. A return value of -1 indicates that an error occurred. }



function FileGetAttr(const FileName: string): Integer; platform;



{ FileSetAttr sets the file attributes of the file given by FileName to the

  value given by Attr. The attribute value is formed by OR-ing the

  appropriate faXXXX constants. The return value is zero if the function was

  successful. Otherwise the return value is a system error code. }



function FileSetAttr(const FileName: string; Attr: Integer): Integer; platform;

{$ENDIF}



{ FileIsReadOnly tests whether a given file is read-only for the current

  process and effective user id.  If the file does not exist, the

  function returns False.  (Check FileExists before calling FileIsReadOnly)

  This function is platform portable. }



function FileIsReadOnly(const FileName: string): Boolean; inline;



{ FileSetReadOnly sets the read only state of a file.  The file must

  exist and the current effective user id must be the owner of the file.

  On Unix systems, FileSetReadOnly attempts to set or remove

  all three (user, group, and other) write permissions on the file.

  If you want to grant partial permissions (writeable for owner but not

  for others), use platform specific functions such as chmod.

  The function returns True if the file was successfully modified,

  False if there was an error.  This function is platform portable.  }



function FileSetReadOnly(const FileName: string; ReadOnly: Boolean): Boolean;



{ DeleteFile deletes the file given by FileName. The return value is True if

  the file was successfully deleted, or False if an error occurred. }



function DeleteFile(const FileName: string): Boolean; inline;



{ RenameFile renames the file given by OldName to the name given by NewName.

  The return value is True if the file was successfully renamed, or False if

  an error occurred. }



function RenameFile(const OldName, NewName: string): Boolean; inline;



{ ChangeFileExt changes the extension of a filename. FileName specifies a

  filename with or without an extension, and Extension specifies the new

  extension for the filename. The new extension can be a an empty string or

  a period followed by up to three characters. }



function ChangeFileExt(const FileName, Extension: string): string;



{ ExtractFilePath extracts the drive and directory parts of the given

  filename. The resulting string is the leftmost characters of FileName,

  up to and including the colon or backslash that separates the path

  information from the name and extension. The resulting string is empty

  if FileName contains no drive and directory parts. }



function ExtractFilePath(const FileName: string): string;



{ ExtractFileDir extracts the drive and directory parts of the given

  filename. The resulting string is a directory name suitable for passing

  to SetCurrentDir, CreateDir, etc. The resulting string is empty if

  FileName contains no drive and directory parts. }



function ExtractFileDir(const FileName: string): string;



{ ExtractFileDrive extracts the drive part of the given filename.  For

  filenames with drive letters, the resulting string is '<drive>:'.

  For filenames with a UNC path, the resulting string is in the form

  '\\<servername>\<sharename>'.  If the given path contains neither

  style of filename, the result is an empty string. }



function ExtractFileDrive(const FileName: string): string;



{ ExtractFileName extracts the name and extension parts of the given

  filename. The resulting string is the leftmost characters of FileName,

  starting with the first character after the colon or backslash that

  separates the path information from the name and extension. The resulting

  string is equal to FileName if FileName contains no drive and directory

  parts. }



function ExtractFileName(const FileName: string): string;



{ ExtractFileExt extracts the extension part of the given filename. The

  resulting string includes the period character that separates the name

  and extension parts. The resulting string is empty if the given filename

  has no extension. }



function ExtractFileExt(const FileName: string): string;



{ ExpandFileName expands the given filename to a fully qualified filename.

  The resulting string consists of a drive letter, a colon, a root relative

  directory path, and a filename. Embedded '.' and '..' directory references

  are removed. }



function ExpandFileName(const FileName: string): string;



{ ExpandFilenameCase returns a fully qualified filename like ExpandFilename,

  but performs a case-insensitive filename search looking for a close match

  in the actual file system, differing only in uppercase versus lowercase of

  the letters.  This is useful to convert lazy user input into useable file

  names, or to convert filename data created on a case-insensitive file

  system (Win32) to something useable on a case-sensitive file system (Linux).



  The MatchFound out parameter indicates what kind of match was found in the

  file system, and what the function result is based upon:



  ( in order of increasing difficulty or complexity )

  mkExactMatch:  Case-sensitive match.  Result := ExpandFileName(FileName).

  mkSingleMatch: Exactly one file in the given directory path matches the

        given filename on a case-insensitive basis.

        Result := ExpandFileName(FileName as found in file system).

  mkAmbiguous: More than one file in the given directory path matches the

        given filename case-insensitively.

        In many cases, this should be considered an error.

        Result := ExpandFileName(First matching filename found).

  mkNone:  File not found at all.  Result := ExpandFileName(FileName).



  Note that because this function has to search the file system it may be

  much slower than ExpandFileName, particularly when the given filename is

  ambiguous or does not exist.  Use ExpandFilenameCase only when you have

  a filename of dubious orgin - such as from user input - and you want

  to make a best guess before failing.  }



type

  TFilenameCaseMatch = (mkNone, mkExactMatch, mkSingleMatch, mkAmbiguous);



function ExpandFileNameCase(const FileName: string;

  out MatchFound: TFilenameCaseMatch): string;



{ ExpandUNCFileName expands the given filename to a fully qualified filename.

  This function is the same as ExpandFileName except that it will return the

  drive portion of the filename in the format '\\<servername>\<sharename> if

  that drive is actually a network resource instead of a local resource.

  Like ExpandFileName, embedded '.' and '..' directory references are

  removed. }



function ExpandUNCFileName(const FileName: string): string;



{ ExtractRelativePath will return a file path name relative to the given

  BaseName.  It strips the common path dirs and adds '..\' on Windows,

  and '../' on Linux for each level up from the BaseName path. }



function ExtractRelativePath(const BaseName, DestName: string): string;



{$IFDEF MSWINDOWS}

{ ExtractShortPathName will convert the given filename to the short form

  by calling the GetShortPathName API.  Will return an empty string if

  the file or directory specified does not exist }



function ExtractShortPathName(const FileName: string): string;

{$ENDIF}



{ FileSearch searches for the file given by Name in the list of directories

  given by DirList. The directory paths in DirList must be separated by

  PathSep chars. The search always starts with the current directory of the

  current drive. The returned value is a concatenation of one of the

  directory paths and the filename, or an empty string if the file could not

  be located. }



function FileSearch(const Name, DirList: string): string;



{$IFDEF MSWINDOWS}

{ DiskFree returns the number of free bytes on the specified drive number,

  where 0 = Current, 1 = A, 2 = B, etc. DiskFree returns -1 if the drive

  number is invalid. }



function DiskFree(Drive: Byte): Int64;



{ DiskSize returns the size in bytes of the specified drive number, where

  0 = Current, 1 = A, 2 = B, etc. DiskSize returns -1 if the drive number

  is invalid. }



function DiskSize(Drive: Byte): Int64;

{$ENDIF}



{ FileDateToDateTime converts an OS date-and-time value to a TDateTime

  value. The FileAge, FileGetDate, and FileSetDate routines operate on OS

  date-and-time values, and the Time field of a TSearchRec used by the

  FindFirst and FindNext functions contains an OS date-and-time value. }



function FileDateToDateTime(FileDate: Integer): TDateTime;



{ DateTimeToFileDate converts a TDateTime value to an OS date-and-time

  value. The FileAge, FileGetDate, and FileSetDate routines operate on OS

  date-and-time values, and the Time field of a TSearchRec used by the

  FindFirst and FindNext functions contains an OS date-and-time value. }



function DateTimeToFileDate(DateTime: TDateTime): Integer;



{ GetCurrentDir returns the current directory. }



function GetCurrentDir: string;



{ SetCurrentDir sets the current directory. The return value is True if

  the current directory was successfully changed, or False if an error

  occurred. }



function SetCurrentDir(const Dir: string): Boolean;



{ CreateDir creates a new directory. The return value is True if a new

  directory was successfully created, or False if an error occurred. }



function CreateDir(const Dir: string): Boolean;



{ RemoveDir deletes an existing empty directory. The return value is

  True if the directory was successfully deleted, or False if an error

  occurred. }



function RemoveDir(const Dir: string): Boolean;



{ PChar routines }

{ const params help simplify C++ code.  No effect on pascal code }



{ StrLen returns the number of characters in Str, not counting the null

  terminator. }



function StrLen(const Str: PChar): Cardinal;



{ StrEnd returns a pointer to the null character that terminates Str. }



function StrEnd(const Str: PChar): PChar;



{ StrMove copies exactly Count characters from Source to Dest and returns

  Dest. Source and Dest may overlap. }



function StrMove(Dest: PChar; const Source: PChar; Count: Cardinal): PChar;



{ StrCopy copies Source to Dest and returns Dest. }



function StrCopy(Dest: PChar; const Source: PChar): PChar;



{ StrECopy copies Source to Dest and returns StrEnd(Dest). }



function StrECopy(Dest:PChar; const Source: PChar): PChar;



{ StrLCopy copies at most MaxLen characters from Source to Dest and

  returns Dest. }



function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar;



{ StrPCopy copies the Pascal style string Source into Dest and

  returns Dest. }



function StrPCopy(Dest: PChar; const Source: string): PChar;



{ StrPLCopy copies at most MaxLen characters from the Pascal style string

  Source into Dest and returns Dest. }



function StrPLCopy(Dest: PChar; const Source: string;

  MaxLen: Cardinal): PChar;



{ StrCat appends a copy of Source to the end of Dest and returns Dest. }



function StrCat(Dest: PChar; const Source: PChar): PChar;



{ StrLCat appends at most MaxLen - StrLen(Dest) characters from Source to

  the end of Dest, and returns Dest. }



function StrLCat(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar;



{ StrComp compares Str1 to Str2. The return value is less than 0 if

  Str1 < Str2, 0 if Str1 = Str2, or greater than 0 if Str1 > Str2. }



function StrComp(const Str1, Str2: PChar): Integer;



{ StrIComp compares Str1 to Str2, without case sensitivity. The return

  value is the same as StrComp. }



function StrIComp(const Str1, Str2: PChar): Integer;



{ StrLComp compares Str1 to Str2, for a maximum length of MaxLen

  characters. The return value is the same as StrComp. }



function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;



{ StrLIComp compares Str1 to Str2, for a maximum length of MaxLen

  characters, without case sensitivity. The return value is the same

  as StrComp. }



function StrLIComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;



{ StrScan returns a pointer to the first occurrence of Chr in Str. If Chr

  does not occur in Str, StrScan returns NIL. The null terminator is

  considered to be part of the string. }



function StrScan(const Str: PChar; Chr: Char): PChar;



{ StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr

  does not occur in Str, StrRScan returns NIL. The null terminator is

  considered to be part of the string. }



function StrRScan(const Str: PChar; Chr: Char): PChar;



{ StrPos returns a pointer to the first occurrence of Str2 in Str1. If

  Str2 does not occur in Str1, StrPos returns NIL. }



function StrPos(const Str1, Str2: PChar): PChar;



{ StrUpper converts Str to upper case and returns Str. }



function StrUpper(Str: PChar): PChar;



{ StrLower converts Str to lower case and returns Str. }



function StrLower(Str: PChar): PChar;



{ StrPas converts Str to a Pascal style string. This function is provided

  for backwards compatibility only. To convert a null terminated string to

  a Pascal style string, use a string type cast or an assignment. }



function StrPas(const Str: PChar): string;



{ StrAlloc allocates a buffer of the given size on the heap. The size of

  the allocated buffer is encoded in a four byte header that immediately

  preceeds the buffer. To dispose the buffer, use StrDispose. }



function StrAlloc(Size: Cardinal): PChar;



{ StrBufSize returns the allocated size of the given buffer, not including

  the two byte header. }



function StrBufSize(const Str: PChar): Cardinal;



{ StrNew allocates a copy of Str on the heap. If Str is NIL, StrNew returns

  NIL and doesn't allocate any heap space. Otherwise, StrNew makes a

  duplicate of Str, obtaining space with a call to the StrAlloc function,

  and returns a pointer to the duplicated string. To dispose the string,

  use StrDispose. }



function StrNew(const Str: PChar): PChar;



{ StrDispose disposes a string that was previously allocated with StrAlloc

  or StrNew. If Str is NIL, StrDispose does nothing. }



procedure StrDispose(Str: PChar);



{ String formatting routines }



{ The Format routine formats the argument list given by the Args parameter

  using the format string given by the Format parameter.



  Format strings contain two types of objects--plain characters and format

  specifiers. Plain characters are copied verbatim to the resulting string.

  Format specifiers fetch arguments from the argument list and apply

  formatting to them.



  Format specifiers have the following form:



    "%" [index ":"] ["-"] [width] ["." prec] type



  A format specifier begins with a % character. After the % come the

  following, in this order:



  -  an optional argument index specifier, [index ":"]

  -  an optional left-justification indicator, ["-"]

  -  an optional width specifier, [width]

  -  an optional precision specifier, ["." prec]

  -  the conversion type character, type



  The following conversion characters are supported:



  d  Decimal. The argument must be an integer value. The value is converted

     to a string of decimal digits. If the format string contains a precision

     specifier, it indicates that the resulting string must contain at least

     the specified number of digits; if the value has less digits, the

     resulting string is left-padded with zeros.



  u  Unsigned decimal.  Similar to 'd' but no sign is output.



  e  Scientific. The argument must be a floating-point value. The value is

     converted to a string of the form "-d.ddd...E+ddd". The resulting

     string starts with a minus sign if the number is negative, and one digit

     always precedes the decimal point. The total number of digits in the

     resulting string (including the one before the decimal point) is given

     by the precision specifer in the format string--a default precision of

     15 is assumed if no precision specifer is present. The "E" exponent

     character in the resulting string is always followed by a plus or minus

     sign and at least three digits.



  f  Fixed. The argument must be a floating-point value. The value is

     converted to a string of the form "-ddd.ddd...". The resulting string

     starts with a minus sign if the number is negative. The number of digits

     after the decimal point is given by the precision specifier in the

     format string--a default of 2 decimal digits is assumed if no precision

     specifier is present.



  g  General. The argument must be a floating-point value. The value is

     converted to the shortest possible decimal string using fixed or

     scientific format. The number of significant digits in the resulting

     string is given by the precision specifier in the format string--a

     default precision of 15 is assumed if no precision specifier is present.

     Trailing zeros are removed from the resulting string, and a decimal

     point appears only if necessary. The resulting string uses fixed point

     format if the number of digits to the left of the decimal point in the

     value is less than or equal to the specified precision, and if the

     value is greater than or equal to 0.00001. Otherwise the resulting

     string uses scientific format.



  n  Number. The argument must be a floating-point value. The value is

     converted to a string of the form "-d,ddd,ddd.ddd...". The "n" format

     corresponds to the "f" format, except that the resulting string

     contains thousand separators.



  m  Money. The argument must be a floating-point value. The value is

     converted to a string that represents a currency amount. The conversion

     is controlled by the CurrencyString, CurrencyFormat, NegCurrFormat,

     ThousandSeparator, DecimalSeparator, and CurrencyDecimals global

     variables, all of which are initialized from locale settings provided

     by the operating system.  For example, Currency Format preferences can be

     set in the International section of the Windows Control Panel. If the format

     string contains a precision specifier, it overrides the value given

     by the CurrencyDecimals global variable.



  p  Pointer. The argument must be a pointer value. The value is converted

     to a string of the form "XXXX:YYYY" where XXXX and YYYY are the

     segment and offset parts of the pointer expressed as four hexadecimal

     digits.



  s  String. The argument must be a character, a string, or a PChar value.

     The string or character is inserted in place of the format specifier.

     The precision specifier, if present in the format string, specifies the

     maximum length of the resulting string. If the argument is a string

     that is longer than this maximum, the string is truncated.



  x  Hexadecimal. The argument must be an integer value. The value is

     converted to a string of hexadecimal digits. If the format string

     contains a precision specifier, it indicates that the resulting string

     must contain at least the specified number of digits; if the value has

     less digits, the resulting string is left-padded with zeros.



  Conversion characters may be specified in upper case as well as in lower

  case--both produce the same results.



  For all floating-point formats, the actual characters used as decimal and

  thousand separators are obtained from the DecimalSeparator and

  ThousandSeparator global variables.



  Index, width, and precision specifiers can be specified directly using

  decimal digit string (for example "%10d"), or indirectly using an asterisk

  charcater (for example "%*.*f"). When using an asterisk, the next argument

  in the argument list (which must be an integer value) becomes the value

  that is actually used. For example "Format('%*.*f', [8, 2, 123.456])" is

  the same as "Format('%8.2f', [123.456])".



  A width specifier sets the minimum field width for a conversion. If the

  resulting string is shorter than the minimum field width, it is padded

  with blanks to increase the field width. The default is to right-justify

  the result by adding blanks in front of the value, but if the format

  specifier contains a left-justification indicator (a "-" character

  preceding the width specifier), the result is left-justified by adding

  blanks after the value.



  An index specifier sets the current argument list index to the specified

  value. The index of the first argument in the argument list is 0. Using

  index specifiers, it is possible to format the same argument multiple

  times. For example "Format('%d %d %0:d %d', [10, 20])" produces the string

  '10 20 10 20'.



  The Format function can be combined with other formatting functions. For

  example



    S := Format('Your total was %s on %s', [

      FormatFloat('$#,##0.00;;zero', Total),

      FormatDateTime('mm/dd/yy', Date)]);



  which uses the FormatFloat and FormatDateTime functions to customize the

  format beyond what is possible with Format.



  Each of the string formatting routines that uses global variables for

  formatting (separators, decimals, date/time formats etc.), has an

  overloaded equivalent requiring a parameter of type TFormatSettings. This

  additional parameter provides the formatting information rather than the

  global variables. For more information see the notes at TFormatSettings.  }



function Format(const Format: string;

  const Args: array of const): string; overload;

function Format(const Format: string; const Args: array of const;

  const FormatSettings: TFormatSettings): string; overload;



{ FmtStr formats the argument list given by Args using the format string

  given by Format into the string variable given by Result. For further

  details, see the description of the Format function. }



procedure FmtStr(var Result: string; const Format: string;

  const Args: array of const); overload;

procedure FmtStr(var Result: string; const Format: string;

  const Args: array of const; const FormatSettings: TFormatSettings); overload;



{ StrFmt formats the argument list given by Args using the format string

  given by Format into the buffer given by Buffer. It is up to the caller to

  ensure that Buffer is large enough for the resulting string. The returned

  value is Buffer. For further details, see the description of the Format

  function. }



function StrFmt(Buffer, Format: PChar;

  const Args: array of const): PChar; overload;

function StrFmt(Buffer, Format: PChar; const Args: array of const;

  const FormatSettings: TFormatSettings): PChar; overload;



{ StrLFmt formats the argument list given by Args using the format string

  given by Format into the buffer given by Buffer. The resulting string will

  contain no more than MaxBufLen characters, not including the null terminator.

  The returned value is Buffer. For further details, see the description of

  the Format function. }



function StrLFmt(Buffer: PChar; MaxBufLen: Cardinal; Format: PChar;

  const Args: array of const): PChar; overload;

function StrLFmt(Buffer: PChar; MaxBufLen: Cardinal; Format: PChar;

  const Args: array of const;

  const FormatSettings: TFormatSettings): PChar; overload;



{ FormatBuf formats the argument list given by Args using the format string

  given by Format and FmtLen into the buffer given by Buffer and BufLen.

  The Format parameter is a reference to a buffer containing FmtLen

  characters, and the Buffer parameter is a reference to a buffer of BufLen

  characters. The returned value is the number of characters actually stored

  in Buffer. The returned value is always less than or equal to BufLen. For

  further details, see the description of the Format function. }



function FormatBuf(var Buffer; BufLen: Cardinal; const Format;

  FmtLen: Cardinal; const Args: array of const): Cardinal; overload;

function FormatBuf(var Buffer; BufLen: Cardinal; const Format;

  FmtLen: Cardinal; const Args: array of const;

  const FormatSettings: TFormatSettings): Cardinal; overload;



{ The WideFormat routine formats the argument list given by the Args parameter

  using the format WideString given by the Format parameter. This routine is

  the WideString equivalent of Format. For further details, see the description

  of the Format function. }

function WideFormat(const Format: WideString;

  const Args: array of const): WideString; overload;

function WideFormat(const Format: WideString;

  const Args: array of const;

  const FormatSettings: TFormatSettings): WideString; overload;



{ WideFmtStr formats the argument list given by Args using the format WideString

  given by Format into the WideString variable given by Result. For further

  details, see the description of the Format function. }

procedure WideFmtStr(var Result: WideString; const Format: WideString;

  const Args: array of const); overload;

procedure WideFmtStr(var Result: WideString; const Format: WideString;

  const Args: array of const; const FormatSettings: TFormatSettings); overload;



{ WideFormatBuf formats the argument list given by Args using the format string

  given by Format and FmtLen into the buffer given by Buffer and BufLen.

  The Format parameter is a reference to a buffer containing FmtLen

  UNICODE characters (WideChar), and the Buffer parameter is a reference to a

  buffer of BufLen UNICODE characters (WideChar). The return value is the number

  of UNICODE characters actually stored in Buffer. The return value is always

  less than or equal to BufLen. For further details, see the description of the

  Format function.



  Important: BufLen, FmtLen and the return result are always the number of

  UNICODE characters, *not* the number of bytes. To calculate the number of bytes

  multiply them by SizeOf(WideChar). }

function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format;

  FmtLen: Cardinal; const Args: array of const): Cardinal; overload;

function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format;

  FmtLen: Cardinal; const Args: array of const;

  const FormatSettings: TFormatSettings): Cardinal; overload;



{ Floating point conversion routines }



{ Each of the floating point conversion routines that uses global variables

  for formatting (separators, decimals, etc.), has an overloaded equivalent

  requiring a parameter of type TFormatSettings. This additional parameter

  provides the formatting information rather than the global variables. For

  more information see the notes at TFormatSettings.  }



{ FloatToStr converts the floating-point value given by Value to its string

  representation. The conversion uses general number format with 15

  significant digits. For further details, see the description of the

  FloatToStrF function. }



function FloatToStr(Value: Extended): string; overload;

function FloatToStr(Value: Extended;

  const FormatSettings: TFormatSettings): string; overload;



{ CurrToStr converts the currency value given by Value to its string

  representation. The conversion uses general number format. For further

  details, see the description of the CurrToStrF function. }



function CurrToStr(Value: Currency): string; overload;

function CurrToStr(Value: Currency;

  const FormatSettings: TFormatSettings): string; overload;



{ FloatToCurr will range validate a value to make sure it falls

  within the acceptable currency range }



const

  MinCurrency: Currency = -922337203685477.5807 {$IFDEF LINUX} + 1 {$ENDIF};  //!! overflow?

  MaxCurrency: Currency =  922337203685477.5807 {$IFDEF LINUX} - 1 {$ENDIF};  //!! overflow?



function FloatToCurr(const Value: Extended): Currency;

function TryFloatToCurr(const Value: Extended; out AResult: Currency): Boolean;



{ FloatToStrF converts the floating-point value given by Value to its string

  representation. The Format parameter controls the format of the resulting

  string. The Precision parameter specifies the precision of the given value.

  It should be 7 or less for values of type Single, 15 or less for values of

  type Double, and 18 or less for values of type Extended. The meaning of the

  Digits parameter depends on the particular format selected.



  The possible values of the Format parameter, and the meaning of each, are

  described below.



  ffGeneral - General number format. The value is converted to the shortest

  possible decimal string using fixed or scientific format. Trailing zeros

  are removed from the resulting string, and a decimal point appears only

  if necessary. The resulting string uses fixed point format if the number

  of digits to the left of the decimal point in the value is less than or

  equal to the specified precision, and if the value is greater than or

  equal to 0.00001. Otherwise the resulting string uses scientific format,

  and the Digits parameter specifies the minimum number of digits in the

  exponent (between 0 and 4).



  ffExponent - Scientific format. The value is converted to a string of the

  form "-d.ddd...E+dddd". The resulting string starts with a minus sign if

  the number is negative, and one digit always precedes the decimal point.

  The total number of digits in the resulting string (including the one

  before the decimal point) is given by the Precision parameter. The "E"

  exponent character in the resulting string is always followed by a plus

  or minus sign and up to four digits. The Digits parameter specifies the

  minimum number of digits in the exponent (between 0 and 4).



  ffFixed - Fixed point format. The value is converted to a string of the

  form "-ddd.ddd...". The resulting string starts with a minus sign if the

  number is negative, and at least one digit always precedes the decimal

  point. The number of digits after the decimal point is given by the Digits

  parameter--it must be between 0 and 18. If the number of digits to the

  left of the decimal point is greater than the specified precision, the

  resulting value will use scientific format.



  ffNumber - Number format. The value is converted to a string of the form

  "-d,ddd,ddd.ddd...". The ffNumber format corresponds to the ffFixed format,

  except that the resulting string contains thousand separators.



  ffCurrency - Currency format. The value is converted to a string that

  represents a currency amount. The conversion is controlled by the

  CurrencyString, CurrencyFormat, NegCurrFormat, ThousandSeparator, and

  DecimalSeparator global variables, all of which are initialized from

  locale settings provided by the operating system.  For example,

  Currency Format preferences can be set in the International section

  of the Windows Control Panel.

  The number of digits after the decimal point is given by the Digits

  parameter--it must be between 0 and 18.



  For all formats, the actual characters used as decimal and thousand

  separators are obtained from the DecimalSeparator and ThousandSeparator

  global variables.



  If the given value is a NAN (not-a-number), the resulting string is 'NAN'.

  If the given value is positive infinity, the resulting string is 'INF'. If

  the given value is negative infinity, the resulting string is '-INF'. }



function FloatToStrF(Value: Extended; Format: TFloatFormat;

  Precision, Digits: Integer): string; overload;

function FloatToStrF(Value: Extended; Format: TFloatFormat;

  Precision, Digits: Integer;

  const FormatSettings: TFormatSettings): string; overload;



{ CurrToStrF converts the currency value given by Value to its string

  representation. A call to CurrToStrF corresponds to a call to

  FloatToStrF with an implied precision of 19 digits. }



function CurrToStrF(Value: Currency; Format: TFloatFormat;

  Digits: Integer): string; overload;

function CurrToStrF(Value: Currency; Format: TFloatFormat;

  Digits: Integer; const FormatSettings: TFormatSettings): string; overload;



{ FloatToText converts the given floating-point value to its decimal

  representation using the specified format, precision, and digits. The

  Value parameter must be a variable of type Extended or Currency, as

  indicated by the ValueType parameter. The resulting string of characters

  is stored in the given buffer, and the returned value is the number of

  characters stored. The resulting string is not null-terminated. For

  further details, see the description of the FloatToStrF function. }



function FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue;

  Format: TFloatFormat; Precision, Digits: Integer): Integer; overload;

function FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue;

  Format: TFloatFormat; Precision, Digits: Integer;

  const FormatSettings: TFormatSettings): Integer; overload;



{ FormatFloat formats the floating-point value given by Value using the

  format string given by Format. The following format specifiers are

  supported in the format string:



  0     Digit placeholder. If the value being formatted has a digit in the

        position where the '0' appears in the format string, then that digit

        is copied to the output string. Otherwise, a '0' is stored in that

        position in the output string.



  #     Digit placeholder. If the value being formatted has a digit in the

        position where the '#' appears in the format string, then that digit

        is copied to the output string. Otherwise, nothing is stored in that

        position in the output string.



  .     Decimal point. The first '.' character in the format string

        determines the location of the decimal separator in the formatted

        value; any additional '.' characters are ignored. The actual

        character used as a the decimal separator in the output string is

        determined by the DecimalSeparator global variable, which is initialized

        from locale settings obtained from the operating system.



  ,     Thousand separator. If the format string contains one or more ','

        characters, the output will have thousand separators inserted between

        each group of three digits to the left of the decimal point. The

        placement and number of ',' characters in the format string does not

        affect the output, except to indicate that thousand separators are

        wanted. The actual character used as a the thousand separator in the

        output is determined by the ThousandSeparator global variable, which

        is initialized from locale settings obtained from the operating system.



  E+    Scientific notation. If any of the strings 'E+', 'E-', 'e+', or 'e-'

  E-    are contained in the format string, the number is formatted using

  e+    scientific notation. A group of up to four '0' characters can

  e-    immediately follow the 'E+', 'E-', 'e+', or 'e-' to determine the

        minimum number of digits in the exponent. The 'E+' and 'e+' formats

        cause a plus sign to be output for positive exponents and a minus

        sign to be output for negative exponents. The 'E-' and 'e-' formats

        output a sign character only for negative exponents.



  'xx'  Characters enclosed in single or double quotes are output as-is, and

  "xx"  do not affect formatting.



  ;     Separates sections for positive, negative, and zero numbers in the

        format string.



  The locations of the leftmost '0' before the decimal point in the format

  string and the rightmost '0' after the decimal point in the format string

  determine the range of digits that are always present in the output string.



  The number being formatted is always rounded to as many decimal places as

  there are digit placeholders ('0' or '#') to the right of the decimal

  point. If the format string contains no decimal point, the value being

  formatted is rounded to the nearest whole number.



  If the number being formatted has more digits to the left of the decimal

  separator than there are digit placeholders to the left of the '.'

  character in the format string, the extra digits are output before the

  first digit placeholder.



  To allow different formats for positive, negative, and zero values, the

  format string can contain between one and three sections separated by

  semicolons.



  One section - The format string applies to all values.



  Two sections - The first section applies to positive values and zeros, and

  the second section applies to negative values.



  Three sections - The first section applies to positive values, the second

  applies to negative values, and the third applies to zeros.



  If the section for negative values or the section for zero values is empty,

  that is if there is nothing between the semicolons that delimit the

  section, the section for positive values is used instead.



  If the section for positive values is empty, or if the entire format string

  is empty, the value is formatted using general floating-point formatting

  with 15 significant digits, corresponding to a call to FloatToStrF with

  the ffGeneral format. General floating-point formatting is also used if

  the value has more than 18 digits to the left of the decimal point and

  the format string does not specify scientific notation.



  The table below shows some sample formats and the results produced when

  the formats are applied to different values:



  Format string          1234        -1234       0.5         0

  -----------------------------------------------------------------------

                         1234        -1234       0.5         0

  0                      1234        -1234       1           0

  0.00                   1234.00     -1234.00    0.50        0.00

  #.##                   1234        -1234       .5

  #,##0.00               1,234.00    -1,234.00   0.50        0.00

  #,##0.00;(#,##0.00)    1,234.00    (1,234.00)  0.50        0.00

  #,##0.00;;Zero         1,234.00    -1,234.00   0.50        Zero

  0.000E+00              1.234E+03   -1.234E+03  5.000E-01   0.000E+00

  #.###E-0               1.234E3     -1.234E3    5E-1        0E0

  ----------------------------------------------------------------------- }



function FormatFloat(const Format: string; Value: Extended): string; overload;

function FormatFloat(const Format: string; Value: Extended;

  const FormatSettings: TFormatSettings): string; overload;



{ FormatCurr formats the currency value given by Value using the format

  string given by Format. For further details, see the description of the

  FormatFloat function. }



function FormatCurr(const Format: string; Value: Currency): string; overload;

function FormatCurr(const Format: string; Value: Currency;

  const FormatSettings: TFormatSettings): string; overload;



{ FloatToTextFmt converts the given floating-point value to its decimal

  representation using the specified format. The Value parameter must be a

  variable of type Extended or Currency, as indicated by the ValueType

  parameter. The resulting string of characters is stored in the given

  buffer, and the returned value is the number of characters stored. The

  resulting string is not null-terminated. For further details, see the

  description of the FormatFloat function. }



function FloatToTextFmt(Buf: PChar; const Value; ValueType: TFloatValue;

  Format: PChar): Integer; overload;

function FloatToTextFmt(Buf: PChar; const Value; ValueType: TFloatValue;

  Format: PChar; const FormatSettings: TFormatSettings): Integer; overload;



{ StrToFloat converts the given string to a floating-point value. The string

  must consist of an optional sign (+ or -), a string of digits with an

  optional decimal point, and an optional 'E' or 'e' followed by a signed

  integer. Leading and trailing blanks in the string are ignored. The

  DecimalSeparator global variable defines the character that must be used

  as a decimal point. Thousand separators and currency symbols are not

  allowed in the string. If the string doesn't contain a valid value, an

  EConvertError exception is raised. }



function StrToFloat(const S: string): Extended; overload;

function StrToFloat(const S: string;

  const FormatSettings: TFormatSettings): Extended; overload;



function StrToFloatDef(const S: string;

  const Default: Extended): Extended; overload;

function StrToFloatDef(const S: string; const Default: Extended;

  const FormatSettings: TFormatSettings): Extended; overload;



function TryStrToFloat(const S: string; out Value: Extended): Boolean; overload;

function TryStrToFloat(const S: string; out Value: Extended;

  const FormatSettings: TFormatSettings): Boolean; overload;



function TryStrToFloat(const S: string; out Value: Double): Boolean; overload;

function TryStrToFloat(const S: string; out Value: Double;

  const FormatSettings: TFormatSettings): Boolean; overload;



function TryStrToFloat(const S: string; out Value: Single): Boolean; overload;

function TryStrToFloat(const S: string; out Value: Single;

  const FormatSettings: TFormatSettings): Boolean; overload;



{ StrToCurr converts the given string to a currency value. For further

  details, see the description of the StrToFloat function. }



function StrToCurr(const S: string): Currency; overload;

function StrToCurr(const S: string;

  const FormatSettings: TFormatSettings): Currency; overload;



function StrToCurrDef(const S: string;

  const Default: Currency): Currency; overload;

function StrToCurrDef(const S: string; const Default: Currency;

  const FormatSettings: TFormatSettings): Currency; overload;



function TryStrToCurr(const S: string; out Value: Currency): Boolean; overload;

function TryStrToCurr(const S: string; out Value: Currency;

  const FormatSettings: TFormatSettings): Boolean; overload;



{ TextToFloat converts the null-terminated string given by Buffer to a

  floating-point value which is returned in the variable given by Value.

  The Value parameter must be a variable of type Extended or Currency, as

  indicated by the ValueType parameter. The return value is True if the

  conversion was successful, or False if the string is not a valid

  floating-point value. For further details, see the description of the

  StrToFloat function. }



function TextToFloat(Buffer: PChar; var Value;

  ValueType: TFloatValue): Boolean; overload;

function TextToFloat(Buffer: PChar; var Value; ValueType: TFloatValue;

  const FormatSettings: TFormatSettings): Boolean; overload;



{ FloatToDecimal converts a floating-point value to a decimal representation

  that is suited for further formatting. The Value parameter must be a

  variable of type Extended or Currency, as indicated by the ValueType

  parameter. For values of type Extended, the Precision parameter specifies

  the requested number of significant digits in the result--the allowed range

  is 1..18. For values of type Currency, the Precision parameter is ignored,

  and the implied precision of the conversion is 19 digits. The Decimals

  parameter specifies the requested maximum number of digits to the left of

  the decimal point in the result. Precision and Decimals together control

  how the result is rounded. To produce a result that always has a given

  number of significant digits regardless of the magnitude of the number,

  specify 9999 for the Decimals parameter. The result of the conversion is

  stored in the specified TFloatRec record as follows:



  Exponent - Contains the magnitude of the number, i.e. the number of

  significant digits to the right of the decimal point. The Exponent field

  is negative if the absolute value of the number is less than one. If the

  number is a NAN (not-a-number), Exponent is set to -32768. If the number

  is INF or -INF (positive or negative infinity), Exponent is set to 32767.



  Negative - True if the number is negative, False if the number is zero

  or positive.



  Digits - Contains up to 18 (for type Extended) or 19 (for type Currency)

  significant digits followed by a null terminator. The implied decimal

  point (if any) is not stored in Digits. Trailing zeros are removed, and

  if the resulting number is zero, NAN, or INF, Digits contains nothing but

  the null terminator. }



procedure FloatToDecimal(var Result: TFloatRec; const Value;

  ValueType: TFloatValue; Precision, Decimals: Integer);



{ Date/time support routines }



function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp;



function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime;

function MSecsToTimeStamp(MSecs: Comp): TTimeStamp;

function TimeStampToMSecs(const TimeStamp: TTimeStamp): Comp;



{ EncodeDate encodes the given year, month, and day into a TDateTime value.

  The year must be between 1 and 9999, the month must be between 1 and 12,

  and the day must be between 1 and N, where N is the number of days in the

  specified month. If the specified values are not within range, an

  EConvertError exception is raised. The resulting value is the number of

  days between 12/30/1899 and the given date. }



function EncodeDate(Year, Month, Day: Word): TDateTime;



{ EncodeTime encodes the given hour, minute, second, and millisecond into a

  TDateTime value. The hour must be between 0 and 23, the minute must be

  between 0 and 59, the second must be between 0 and 59, and the millisecond

  must be between 0 and 999. If the specified values are not within range, an

  EConvertError exception is raised. The resulting value is a number between

  0 (inclusive) and 1 (not inclusive) that indicates the fractional part of

  a day given by the specified time. The value 0 corresponds to midnight,

  0.5 corresponds to noon, 0.75 corresponds to 6:00 pm, etc. }



function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime;



{ Instead of generating errors the following variations of EncodeDate and

  EncodeTime simply return False if the parameters given are not valid.

  Other than that, these functions are functionally the same as the above

  functions. }



function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean;

function TryEncodeTime(Hour, Min, Sec, MSec: Word; out Time: TDateTime): Boolean;



{ DecodeDate decodes the integral (date) part of the given TDateTime value

  into its corresponding year, month, and day. If the given TDateTime value

  is less than or equal to zero, the year, month, and day return parameters

  are all set to zero. }



procedure DecodeDate(const DateTime: TDateTime; var Year, Month, Day: Word);



{ This variation of DecodeDate works similarly to the above function but

  returns more information.  The result value of this function indicates

  whether the year decoded is a leap year or not.  }



function DecodeDateFully(const DateTime: TDateTime; var Year, Month, Day,

  DOW: Word): Boolean;



{$IFDEF LINUX}

function InternalDecodeDate(const DateTime: TDateTime; var Year, Month, Day, DOW: Word): Boolean;

{$ENDIF}



{ DecodeTime decodes the fractional (time) part of the given TDateTime value

  into its corresponding hour, minute, second, and millisecond. }



procedure DecodeTime(const DateTime: TDateTime; var Hour, Min, Sec, MSec: Word);



{$IFDEF MSWINDOWS}

{ DateTimeToSystemTime converts a date and time from Delphi's TDateTime

  format into the Win32 API's TSystemTime format. }



procedure DateTimeToSystemTime(const DateTime: TDateTime; var SystemTime: TSystemTime);



{ SystemTimeToDateTime converts a date and time from the Win32 API's

  TSystemTime format into Delphi's TDateTime format. }



function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime;

{$ENDIF}



{ DayOfWeek returns the day of the week of the given date. The result is an

  integer between 1 and 7, corresponding to Sunday through Saturday.

  This function is not ISO 8601 compliant, for that see the DateUtils unit. }



function DayOfWeek(const DateTime: TDateTime): Word;



{ Date returns the current date. }



function Date: TDateTime;



{ Time returns the current time. }



function Time: TDateTime;

{$IFDEF LINUX}

  { clashes with Time in <X11/Xlib.h>, use GetTime instead }

  {$EXTERNALSYM Time}

{$ENDIF}

function GetTime: TDateTime;



{ Now returns the current date and time, corresponding to Date + Time. }



function Now: TDateTime;



{ Current year returns the year portion of the date returned by Now }



function CurrentYear: Word;



{ IncMonth returns Date shifted by the specified number of months.

  NumberOfMonths parameter can be negative, to return a date N months ago.

  If the input day of month is greater than the last day of the resulting

  month, the day is set to the last day of the resulting month.

  Input time of day is copied to the DateTime result.  }



function IncMonth(const DateTime: TDateTime; NumberOfMonths: Integer = 1): TDateTime;



{ Optimized version of IncMonth that works with years, months and days

  directly.  See above comments for more detail as to what happens to the day

  when incrementing months }



procedure IncAMonth(var Year, Month, Day: Word; NumberOfMonths: Integer = 1);



{ ReplaceTime replaces the time portion of the DateTime parameter with the given

  time value, adjusting the signs as needed if the date is prior to 1900

  (Date value less than zero)  }



procedure ReplaceTime(var DateTime: TDateTime; const NewTime: TDateTime);



{ ReplaceDate replaces the date portion of the DateTime parameter with the given

  date value, adjusting as needed for negative dates }



procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime);



{ IsLeapYear determines whether the given year is a leap year. }



function IsLeapYear(Year: Word): Boolean;



type

  PDayTable = ^TDayTable;

  TDayTable = array[1..12] of Word;



{ The MonthDays array can be used to quickly find the number of

  days in a month:  MonthDays[IsLeapYear(Y), M]      }



const

  MonthDays: array [Boolean] of TDayTable =

    ((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),

     (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31));



{ Each of the date/time formatting routines that uses global variables

  for formatting (separators, decimals, etc.), has an overloaded equivalent

  requiring a parameter of type TFormatSettings. This additional parameter

  provides the formatting information rather than the global variables. For

  more information see the note at TFormatSettings.  }



{ DateToStr converts the date part of the given TDateTime value to a string.

  The conversion uses the format specified by the ShortDateFormat global

  variable. }



function DateToStr(const DateTime: TDateTime): string; overload; inline;

function DateToStr(const DateTime: TDateTime;

  const FormatSettings: TFormatSettings): string; overload; inline;



{ TimeToStr converts the time part of the given TDateTime value to a string.

  The conversion uses the format specified by the LongTimeFormat global

  variable. }



function TimeToStr(const DateTime: TDateTime): string; overload; inline;

function TimeToStr(const DateTime: TDateTime;

  const FormatSettings: TFormatSettings): string; overload; inline;



{ DateTimeToStr converts the given date and time to a string. The resulting

  string consists of a date and time formatted using the ShortDateFormat and

  LongTimeFormat global variables. Time information is included in the

  resulting string only if the fractional part of the given date and time

  value is non-zero. }



function DateTimeToStr(const DateTime: TDateTime): string; overload; inline;

function DateTimeToStr(const DateTime: TDateTime;

  const FormatSettings: TFormatSettings): string; overload; inline;



{ StrToDate converts the given string to a date value. The string must

  consist of two or three numbers, separated by the character defined by

  the DateSeparator global variable. The order for month, day, and year is

  determined by the ShortDateFormat global variable--possible combinations

  are m/d/y, d/m/y, and y/m/d. If the string contains only two numbers, it

  is interpreted as a date (m/d or d/m) in the current year. Year values

  between 0 and 99 are assumed to be in the current century. If the given

  string does not contain a valid date, an EConvertError exception is

  raised. }



function StrToDate(const S: string): TDateTime; overload;

function StrToDate(const S: string;

  const FormatSettings: TFormatSettings): TDateTime; overload;



function StrToDateDef(const S: string;

  const Default: TDateTime): TDateTime; overload;

function StrToDateDef(const S: string; const Default: TDateTime;

  const FormatSettings: TFormatSettings): TDateTime; overload;



function TryStrToDate(const S: string; out Value: TDateTime): Boolean; overload;

function TryStrToDate(const S: string; out Value: TDateTime;

  const FormatSettings: TFormatSettings): Boolean; overload;



{ StrToTime converts the given string to a time value. The string must

  consist of two or three numbers, separated by the character defined by

  the TimeSeparator global variable, optionally followed by an AM or PM

  indicator. The numbers represent hour, minute, and (optionally) second,

  in that order. If the time is followed by AM or PM, it is assumed to be

  in 12-hour clock format. If no AM or PM indicator is included, the time

  is assumed to be in 24-hour clock format. If the given string does not

  contain a valid time, an EConvertError exception is raised. }



function StrToTime(const S: string): TDateTime; overload;

function StrToTime(const S: string;

  const FormatSettings: TFormatSettings): TDateTime; overload;



function StrToTimeDef(const S: string;

  const Default: TDateTime): TDateTime; overload;

function StrToTimeDef(const S: string; const Default: TDateTime;

  const FormatSettings: TFormatSettings): TDateTime; overload;



function TryStrToTime(const S: string; out Value: TDateTime): Boolean; overload;

function TryStrToTime(const S: string; out Value: TDateTime;

  const FormatSettings: TFormatSettings): Boolean; overload;



{ StrToDateTime converts the given string to a date and time value. The

  string must contain a date optionally followed by a time. The date and

  time parts of the string must follow the formats described for the

  StrToDate and StrToTime functions. }



function StrToDateTime(const S: string): TDateTime; overload;

function StrToDateTime(const S: string;

  const FormatSettings: TFormatSettings): TDateTime; overload;



function StrToDateTimeDef(const S: string;

  const Default: TDateTime): TDateTime; overload;

function StrToDateTimeDef(const S: string; const Default: TDateTime;

  const FormatSettings: TFormatSettings): TDateTime; overload;



function TryStrToDateTime(const S: string;

  out Value: TDateTime): Boolean; overload;

function TryStrToDateTime(const S: string; out Value: TDateTime;

  const FormatSettings: TFormatSettings): Boolean; overload;



{ FormatDateTime formats the date-and-time value given by DateTime using the

  format given by Format. The following format specifiers are supported:



  c       Displays the date using the format given by the ShortDateFormat

          global variable, followed by the time using the format given by

          the LongTimeFormat global variable. The time is not displayed if

          the fractional part of the DateTime value is zero.



  d       Displays the day as a number without a leading zero (1-31).



  dd      Displays the day as a number with a leading zero (01-31).



  ddd     Displays the day as an abbreviation (Sun-Sat) using the strings

          given by the ShortDayNames global variable.



  dddd    Displays the day as a full name (Sunday-Saturday) using the strings

          given by the LongDayNames global variable.



  ddddd   Displays the date using the format given by the ShortDateFormat

          global variable.



  dddddd  Displays the date using the format given by the LongDateFormat

          global variable.



  g       Displays the period/era as an abbreviation (Japanese and

          Taiwanese locales only).



  gg      Displays the period/era as a full name.



  e       Displays the year in the current period/era as a number without

          a leading zero (Japanese, Korean and Taiwanese locales only).



  ee      Displays the year in the current period/era as a number with

          a leading zero (Japanese, Korean and Taiwanese locales only).



  m       Displays the month as a number without a leading zero (1-12). If

          the m specifier immediately follows an h or hh specifier, the

          minute rather than the month is displayed.



  mm      Displays the month as a number with a leading zero (01-12). If

          the mm specifier immediately follows an h or hh specifier, the

          minute rather than the month is displayed.



  mmm     Displays the month as an abbreviation (Jan-Dec) using the strings

          given by the ShortMonthNames global variable.



  mmmm    Displays the month as a full name (January-December) using the

          strings given by the LongMonthNames global variable.



  yy      Displays the year as a two-digit number (00-99).



  yyyy    Displays the year as a four-digit number (0000-9999).



  h       Displays the hour without a leading zero (0-23).



  hh      Displays the hour with a leading zero (00-23).



  n       Displays the minute without a leading zero (0-59).



  nn      Displays the minute with a leading zero (00-59).



  s       Displays the second without a leading zero (0-59).



  ss      Displays the second with a leading zero (00-59).



  z       Displays the millisecond without a leading zero (0-999).



  zzz     Displays the millisecond with a leading zero (000-999).



  t       Displays the time using the format given by the ShortTimeFormat

          global variable.



  tt      Displays the time using the format given by the LongTimeFormat

          global variable.



  am/pm   Uses the 12-hour clock for the preceding h or hh specifier, and

          displays 'am' for any hour before noon, and 'pm' for any hour

          after noon. The am/pm specifier can use lower, upper, or mixed

          case, and the result is displayed accordingly.



  a/p     Uses the 12-hour clock for the preceding h or hh specifier, and

          displays 'a' for any hour before noon, and 'p' for any hour after

          noon. The a/p specifier can use lower, upper, or mixed case, and

          the result is displayed accordingly.



  ampm    Uses the 12-hour clock for the preceding h or hh specifier, and

          displays the contents of the TimeAMString global variable for any

          hour before noon, and the contents of the TimePMString global

          variable for any hour after noon.



  /       Displays the date separator character given by the DateSeparator

          global variable.



  :       Displays the time separator character given by the TimeSeparator

          global variable.



  'xx'    Characters enclosed in single or double quotes are displayed as-is,

  "xx"    and do not affect formatting.



  Format specifiers may be written in upper case as well as in lower case

  letters--both produce the same result.



  If the string given by the Format parameter is empty, the date and time

  value is formatted as if a 'c' format specifier had been given.



  The following example:



    S := FormatDateTime('"The meeting is on" dddd, mmmm d, yyyy, ' +

      '"at" hh:mm AM/PM', StrToDateTime('2/15/95 10:30am'));



  assigns 'The meeting is on Wednesday, February 15, 1995 at 10:30 AM' to

  the string variable S. }



function FormatDateTime(const Format: string;

  DateTime: TDateTime): string; overload; inline;

function FormatDateTime(const Format: string; DateTime: TDateTime;

  const FormatSettings: TFormatSettings): string; overload;



{ DateTimeToString converts the date and time value given by DateTime using

  the format string given by Format into the string variable given by Result.

  For further details, see the description of the FormatDateTime function. }



procedure DateTimeToString(var Result: string; const Format: string;

  DateTime: TDateTime); overload;

procedure DateTimeToString(var Result: string; const Format: string;

  DateTime: TDateTime; const FormatSettings: TFormatSettings); overload;



{ FloatToDateTime will range validate a value to make sure it falls

  within the acceptable date range }



const

  MinDateTime: TDateTime = -657434.0;      { 01/01/0100 12:00:00.000 AM }

  MaxDateTime: TDateTime =  2958465.99999; { 12/31/9999 11:59:59.999 PM }



function FloatToDateTime(const Value: Extended): TDateTime;

function TryFloatToDateTime(const Value: Extended; out AResult: TDateTime): Boolean;



{ System error messages }



function SysErrorMessage(ErrorCode: Integer): string;



{ Initialization file support }



function GetLocaleStr(Locale, LocaleType: Integer; const Default: string): string; platform;

function GetLocaleChar(Locale, LocaleType: Integer; Default: Char): Char; platform;



{ GetFormatSettings resets all locale-specific variables (date, time, number,

  currency formats, system locale) to the values provided by the operating system. }



procedure GetFormatSettings;



{ GetLocaleFormatSettings loads locale-specific variables (date, time, number,

  currency formats) with values provided by the operating system for the

  specified locale (LCID). The values are stored in the FormatSettings record. }



{$IFDEF MSWINDOWS}

procedure GetLocaleFormatSettings(LCID: Integer;

  var FormatSettings: TFormatSettings);

{$ENDIF}



{ Exception handling routines }



{$IFDEF LINUX}

{   InquireSignal is used to determine the state of an OS signal handler.

    Pass it one of the RTL_SIG* constants, and it will return a TSignalState

    which will tell you if the signal has been hooked, not hooked, or overriden

    by some other module.  You can use this function to determine if some other

    module has hijacked your signal handlers, should you wish to reinstall your

    own. This is a risky proposition under Linux, and is only recommended as a

    last resort.  Do not pass RTL_SIGDEFAULT to this function.

}

function InquireSignal(RtlSigNum: Integer): TSignalState;



{ AbandonSignalHandler tells the RTL to leave a signal handler

    in place, even if we believe that we hooked it at startup time.



    Once you have called AbandonSignalHandler with a specific signal number,

    neither UnhookSignal nor the RTL will restore any previous signal handler

    under any condition.

}

procedure AbandonSignalHandler(RtlSigNum: Integer);



{ HookSignal is used to hook individual signals, or an RTL-defined default

    set of signals.  It does not test whether a signal has already been

    hooked, so it should be used in conjunction with InquireSignal.  It is

    exposed to enable users to hook signals in standalone libraries, or in the

    event that an external module hijacks the RTL installed signal handlers.

    Pass RTL_SIGDEFAULT if you want to hook all the signals that the RTL

    normally hooks at startup time.

}

procedure HookSignal(RtlSigNum: Integer);



{ UnhookSignal is used to remove signal handlers installed by HookSignal.

    It can remove individual signal handlers, or the RTL-defined default set

    of signals.  If OnlyIfHooked is True, then we will only unhook the signal

    if the signal handler has been hooked, and has not since been overriden by

    some foreign handler.

}

procedure UnhookSignal(RtlSigNum: Integer; OnlyIfHooked: Boolean = True);



{ HookOSExceptions is used internally by thread support.  DON'T call this

  function yourself. }

procedure HookOSExceptions;



{ MapSignal is used internally as well.  It maps a signal and associated

  context to an internal value that represents the type of Exception

  class to raise. }

function MapSignal(SigNum: Integer; Context: PSigContext): LongWord;



{ SignalConverter is used internally to properly reinit the FPU and properly

  raise an external OS exception object.  DON'T call this function yourself. }

procedure SignalConverter(ExceptionEIP: LongWord; FaultAddr: LongWord; ErrorCode: LongWord);



{

    See the comment at the threadvar declarations for these below.  The access

    to these has been implemented through getter/setter functions because you

    cannot use threadvars across packages.

}

procedure SetSafeCallExceptionMsg(const Msg: String);

procedure SetSafeCallExceptionAddr(Addr: Pointer);

function GetSafeCallExceptionMsg: String;

function GetSafeCallExceptionAddr: Pointer;



{ HookOSExceptionsProc is used internally and cannot be used in a conventional

  manner.  DON'T ever set this variable. }

var

  HookOSExceptionsProc: procedure = nil platform deprecated;



{ LoadLibrary / FreeLibrary are defined here only for convenience.  On Linux,

  they map directly to dlopen / dlclose.  Note that module loading semantics

  on Linux are not identical to Windows.  }



function LoadLibrary(ModuleName: PChar): HMODULE;



function FreeLibrary(Module: HMODULE): LongBool;



{ GetProcAddress does what it implies.  It performs the same function as the like

  named function under Windows.  dlsym does not quite have the same sematics as

  GetProcAddress as it will return the address of a symbol in another module if

  it was not found in the given HMODULE.  This function will verify that the 'Proc'

  is actually found within the 'Module', and if not returns nil }

function GetProcAddress(Module: HMODULE; Proc: PChar): Pointer;



{ Given a module name, this function will return the module handle.  There is no

  direct equivalent in Linux so this function provides that capability.  Also

  note, this function is specific to glibc. }

function GetModuleHandle(ModuleName: PChar): HMODULE;



{ This function works just like GetModuleHandle, except it will look for a module

  that matches the given base package name.  For example, given the base package

  name 'package', the actual module name is, by default, 'bplpackage.so'.  This

  function will search for the string 'package' within the module name. }

function GetPackageModuleHandle(PackageName: PChar): HMODULE;



{$ENDIF}



{ In Linux, the parameter to sleep() is in whole seconds.  In Windows, the

  parameter is in milliseconds.  To ease headaches, we implement a version

  of sleep here for Linux that takes milliseconds and calls a Linux system

  function with sub-second resolution.  This maps directly to the Windows

  API on Windows. }



procedure Sleep(milliseconds: Cardinal);{$IFDEF MSWINDOWS} stdcall; {$ENDIF}

{$IFDEF MSWINDOWS}

(*$EXTERNALSYM Sleep*)

{$ENDIF}



function GetModuleName(Module: HMODULE): string;



function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;

  Buffer: PChar; Size: Integer): Integer;



procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);



procedure Abort;



procedure OutOfMemoryError;



procedure Beep;



{ MBCS functions }



{ LeadBytes is a char set that indicates which char values are lead bytes

  in multibyte character sets (Japanese, Chinese, etc).

  This set is always empty for western locales. }

var

  LeadBytes: set of Char = [];

(*$EXTERNALSYM LeadBytes*)

(*$HPPEMIT 'namespace Sysutils {'*)

(*$HPPEMIT 'extern PACKAGE System::Set<Byte, 0, 255>  LeadBytes;'*)

(*$HPPEMIT '} // namespace Sysutils'*)



{ ByteType indicates what kind of byte exists at the Index'th byte in S.

  Western locales always return mbSingleByte.  Far East multibyte locales

  may also return mbLeadByte, indicating the byte is the first in a multibyte

  character sequence, and mbTrailByte, indicating that the byte is one of

  a sequence of bytes following a lead byte.  One or more trail bytes can

  follow a lead byte, depending on locale charset encoding and OS platform.

  Parameters are assumed to be valid. }



function ByteType(const S: string; Index: Integer): TMbcsByteType;



{ StrByteType works the same as ByteType, but on null-terminated PChar strings }



function StrByteType(Str: PChar; Index: Cardinal): TMbcsByteType;



{ ByteToCharLen returns the character length of a MBCS string, scanning the

  string for up to MaxLen bytes.  In multibyte character sets, the number of

  characters in a string may be less than the number of bytes.  }



function ByteToCharLen(const S: string; MaxLen: Integer): Integer;



{ CharToByteLen returns the byte length of a MBCS string, scanning the string

  for up to MaxLen characters. }



function CharToByteLen(const S: string; MaxLen: Integer): Integer;



{ ByteToCharIndex returns the 1-based character index of the Index'th byte in

  a MBCS string.  Returns zero if Index is out of range:

  (Index <= 0) or (Index > Length(S)) }



function ByteToCharIndex(const S: string; Index: Integer): Integer;



{ CharToByteIndex returns the 1-based byte index of the Index'th character

  in a MBCS string.  Returns zero if Index or Result are out of range:

  (Index <= 0) or (Index > Length(S)) or (Result would be > Length(S)) }



function CharToByteIndex(const S: string; Index: Integer): Integer;



{ StrCharLength returns the number of bytes required by the first character

  in Str.  In Windows, multibyte characters can be up to two bytes in length.

  In Linux, multibyte characters can be up to six bytes in length (UTF-8). }



function StrCharLength(const Str: PChar): Integer;



{ StrNextChar returns a pointer to the first byte of the character following

  the character pointed to by Str.  }



function StrNextChar(const Str: PChar): PChar;



{ CharLength returns the number of bytes required by the character starting

  at bytes S[Index].  }



function CharLength(const S: String; Index: Integer): Integer;



{ NextCharIndex returns the byte index of the first byte of the character

  following the character starting at S[Index].  }



function NextCharIndex(const S: String; Index: Integer): Integer;



{ IsPathDelimiter returns True if the character at byte S[Index]

  is a PathDelimiter ('\' or '/'), and it is not a MBCS lead or trail byte. }



function IsPathDelimiter(const S: string; Index: Integer): Boolean;



{ IsDelimiter returns True if the character at byte S[Index] matches any

  character in the Delimiters string, and the character is not a MBCS lead or

  trail byte.  S may contain multibyte characters; Delimiters must contain

  only single byte characters. }



function IsDelimiter(const Delimiters, S: string; Index: Integer): Boolean;



{ IncludeTrailingPathDelimiter returns the path with a PathDelimiter

  ('/' or '\') at the end.  This function is MBCS enabled. }



function IncludeTrailingPathDelimiter(const S: string): string;



{ IncludeTrailingBackslash is the old name for IncludeTrailingPathDelimiter. }



function IncludeTrailingBackslash(const S: string): string; platform; inline;



{ ExcludeTrailingPathDelimiter returns the path without a PathDelimiter

  ('\' or '/') at the end.  This function is MBCS enabled. }



function ExcludeTrailingPathDelimiter(const S: string): string;



{ ExcludeTrailingBackslash is the old name for ExcludeTrailingPathDelimiter. }



function ExcludeTrailingBackslash(const S: string): string; platform; inline;



{ LastDelimiter returns the byte index in S of the rightmost whole

  character that matches any character in Delimiters (except null (#0)).

  S may contain multibyte characters; Delimiters must contain only single

  byte non-null characters.

  Example: LastDelimiter('\.:', 'c:\filename.ext') returns 12. }



function LastDelimiter(const Delimiters, S: string): Integer;



{ AnsiCompareFileName supports DOS file name comparison idiosyncracies

  in Far East locales (Zenkaku) on Windows.

  In non-MBCS locales on Windows, AnsiCompareFileName is identical to

  AnsiCompareText (case insensitive).

  On Linux, AnsiCompareFileName is identical to AnsiCompareStr (case sensitive).

  For general purpose file name comparisions, you should use this function

  instead of AnsiCompareText. }



function AnsiCompareFileName(const S1, S2: string): Integer; inline;



function SameFileName(const S1, S2: string): Boolean; inline;



{ AnsiLowerCaseFileName supports lowercase conversion idiosyncracies of

  DOS file names in Far East locales (Zenkaku).  In non-MBCS locales,

  AnsiLowerCaseFileName is identical to AnsiLowerCase. }



function AnsiLowerCaseFileName(const S: string): string;



{ AnsiUpperCaseFileName supports uppercase conversion idiosyncracies of

  DOS file names in Far East locales (Zenkaku).  In non-MBCS locales,

  AnsiUpperCaseFileName is identical to AnsiUpperCase. }



function AnsiUpperCaseFileName(const S: string): string;



{ AnsiPos:  Same as Pos but supports MBCS strings }



function AnsiPos(const Substr, S: string): Integer;



{ AnsiStrPos: Same as StrPos but supports MBCS strings }



function AnsiStrPos(Str, SubStr: PChar): PChar;



{ AnsiStrRScan: Same as StrRScan but supports MBCS strings }



function AnsiStrRScan(Str: PChar; Chr: Char): PChar;



{ AnsiStrScan: Same as StrScan but supports MBCS strings }



function AnsiStrScan(Str: PChar; Chr: Char): PChar;



{ StringReplace replaces occurances of <oldpattern> with <newpattern> in a

  given string.  Assumes the string may contain Multibyte characters }



type

  TReplaceFlags = set of (rfReplaceAll, rfIgnoreCase);



function StringReplace(const S, OldPattern, NewPattern: string;

  Flags: TReplaceFlags): string;



{ WrapText will scan a string for BreakChars and insert the BreakStr at the

  last BreakChar position before MaxCol.  Will not insert a break into an

  embedded quoted string (both ''' and '"' supported) }



function WrapText(const Line, BreakStr: string; const BreakChars: TSysCharSet;

  MaxCol: Integer): string; overload;

function WrapText(const Line: string; MaxCol: Integer = 45): string; overload;



{ FindCmdLineSwitch determines whether the string in the Switch parameter

  was passed as a command line argument to the application.  SwitchChars

  identifies valid argument-delimiter characters (i.e., "-" and "/" are

  common delimiters). The IgnoreCase paramter controls whether a

  case-sensistive or case-insensitive search is performed. }



const

  SwitchChars = {$IFDEF MSWINDOWS} ['/','-']; {$ENDIF}

                {$IFDEF LINUX}  ['-'];  {$ENDIF}



function FindCmdLineSwitch(const Switch: string; const Chars: TSysCharSet;

  IgnoreCase: Boolean): Boolean; overload;



{ These versions of FindCmdLineSwitch are convenient for writing portable

  code.  The characters that are valid to indicate command line switches vary

  on different platforms.  For example, '/' cannot be used as a switch char

  on Linux because '/' is the path delimiter. }



{ This version uses SwitchChars defined above, and IgnoreCase False. }

function FindCmdLineSwitch(const Switch: string): Boolean; overload;



{ This version uses SwitchChars defined above. }

function FindCmdLineSwitch(const Switch: string; IgnoreCase: Boolean): Boolean; overload;



{ FreeAndNil frees the given TObject instance and sets the variable reference

  to nil.  Be careful to only pass TObjects to this routine. }



procedure FreeAndNil(var Obj);



{ Interface support routines }



function Supports(const Instance: IInterface; const IID: TGUID; out Intf): Boolean; overload;

function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; overload;

function Supports(const Instance: IInterface; const IID: TGUID): Boolean; overload;

function Supports(const Instance: TObject; const IID: TGUID): Boolean; overload;

function Supports(const AClass: TClass; const IID: TGUID): Boolean; overload;



function CreateGUID(out Guid: TGUID): HResult;

{$IFDEF MSWINDOWS}

  stdcall;

{$ENDIF}

function StringToGUID(const S: string): TGUID;

function GUIDToString(const GUID: TGUID): string;

function IsEqualGUID(const guid1, guid2: TGUID): Boolean;

{$IFDEF MSWINDOWS}

  stdcall;  {$EXTERNALSYM IsEqualGUID}

{$ENDIF}



{ Package support routines }



{ Package Info flags }



const

  pfNeverBuild = $00000001;

  pfDesignOnly = $00000002;

  pfRunOnly = $00000004;

  pfIgnoreDupUnits = $00000008;

  pfModuleTypeMask = $C0000000;

  pfExeModule = $00000000;

  pfPackageModule = $40000000;

  pfProducerMask = $0C000000;

  pfV3Produced =  $00000000;

  pfProducerUndefined = $04000000;

  pfBCB4Produced = $08000000;

  pfDelphi4Produced = $0C000000;

  pfLibraryModule = $80000000;



{ Unit info flags }



const

  ufMainUnit = $01;

  ufPackageUnit = $02;

  ufWeakUnit = $04;

  ufOrgWeakUnit = $08;

  ufImplicitUnit = $10;



  ufWeakPackageUnit = ufPackageUnit or ufWeakUnit;



{$IFDEF LINUX}

var

  PkgLoadingMode: Integer = RTLD_LAZY;

{$ENDIF}



{ Procedure type of the callback given to GetPackageInfo.  Name is the actual

  name of the package element.  If IsUnit is True then Name is the name of

  a contained unit; a required package if False.  Param is the value passed

  to GetPackageInfo }



type

  TNameType = (ntContainsUnit, ntRequiresPackage, ntDcpBpiName);



  TPackageInfoProc = procedure (const Name: string; NameType: TNameType; Flags: Byte; Param: Pointer);



{ LoadPackage loads a given package DLL, checks for duplicate units and

  calls the initialization blocks of all the contained units }



function LoadPackage(const Name: string): HMODULE;



{ UnloadPackage does the opposite of LoadPackage by calling the finalization

  blocks of all contained units, then unloading the package DLL }



procedure UnloadPackage(Module: HMODULE);



{ GetPackageInfo accesses the given package's info table and enumerates

  all the contained units and required packages }



procedure GetPackageInfo(Module: HMODULE; Param: Pointer; var Flags: Integer;

  InfoProc: TPackageInfoProc);



{ GetPackageDescription loads the description resource from the package

  library. If the description resource does not exist,

  an empty string is returned. }

function GetPackageDescription(ModuleName: PChar): string;



{ InitializePackage validates and initializes the given package DLL }



procedure InitializePackage(Module: HMODULE);



{ FinalizePackage finalizes the given package DLL }



procedure FinalizePackage(Module: HMODULE);



{ RaiseLastOSError calls GetLastError to retrieve the code for

  the last occuring error in a call to an OS or system library function.

  If GetLastError returns an error code,  RaiseLastOSError raises

  an EOSError exception with the error code and a system-provided

  message associated with with error. }



procedure RaiseLastOSError; overload;

procedure RaiseLastOSError(LastError: Integer); overload;



{$IFDEF MSWINDOWS}

procedure RaiseLastWin32Error; deprecated;  // use RaiseLastOSError



{ Win32Check is used to check the return value of a Win32 API function     }

{ which returns a BOOL to indicate success.  If the Win32 API function     }

{ returns False (indicating failure), Win32Check calls RaiseLastOSError }

{ to raise an exception.  If the Win32 API function returns True,          }

{ Win32Check returns True. }



function Win32Check(RetVal: BOOL): BOOL; platform;

{$ENDIF}



{ Termination procedure support }



type

  TTerminateProc = function: Boolean;



{ Call AddTerminateProc to add a terminate procedure to the system list of }

{ termination procedures.  Delphi will call all of the function in the     }

{ termination procedure list before an application terminates.  The user-  }

{ defined TermProc function should return True if the application can      }

{ safely terminate or False if the application cannot safely terminate.    }

{ If one of the functions in the termination procedure list returns False, }

{ the application will not terminate. }



procedure AddTerminateProc(TermProc: TTerminateProc);



{ CallTerminateProcs is called by VCL when an application is about to }

{ terminate.  It returns True only if all of the functions in the     }

{ system's terminate procedure list return True.  This function is    }

{ intended only to be called by Delphi, and it should not be called   }

{ directly. }



function CallTerminateProcs: Boolean;



function GDAL: LongWord;

procedure RCS;

procedure RPR;





{ HexDisplayPrefix contains the prefix to display on hexadecimal

  values - '$' for Pascal syntax, '0x' for C++ syntax.  This is

  for display only - this does not affect the string-to-integer

  conversion routines. }

var

  HexDisplayPrefix: string = '$';



{$IFDEF MSWINDOWS}

{ The GetDiskFreeSpace Win32 API does not support partitions larger than 2GB

  under Win95.  A new Win32 function, GetDiskFreeSpaceEx, supports partitions

  larger than 2GB but only exists on Win NT 4.0 and Win95 OSR2.

  The GetDiskFreeSpaceEx function pointer variable below will be initialized

  at startup to point to either the actual OS API function if it exists on

  the system, or to an internal Delphi function if it does not.  When running

  on Win95 pre-OSR2, the output of this function will still be limited to

  the 2GB range reported by Win95, but at least you don't have to worry

  about which API function to call in code you write.  }



var

  GetDiskFreeSpaceEx: function (Directory: PChar; var FreeAvailable,

    TotalSpace: TLargeInteger; TotalFree: PLargeInteger): Bool stdcall = nil;



{ SafeLoadLibrary calls LoadLibrary, disabling normal Win32 error message

  popup dialogs if the requested file can't be loaded.  SafeLoadLibrary also

  preserves the current FPU control word (precision, exception masks) across

  the LoadLibrary call (in case the DLL you're loading hammers the FPU control

  word in its initialization, as many MS DLLs do)}



function SafeLoadLibrary(const FileName: string;

  ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE;



{$ENDIF}



{$IFDEF LINUX}

{ SafeLoadLibrary calls LoadLibrary preserves the current FPU control

  word (precision, exception masks) across the LoadLibrary call (in

  case the shared object you're loading hammers the FPU control

  word in its initialization, as many MS DLLs do) }



function SafeLoadLibrary(const FileName: string;

  Dummy: LongWord = 0): HMODULE;

{$ENDIF}



{ Thread synchronization }



{ IReadWriteSync is an abstract interface for general read/write synchronization.

  Some implementations may allow simultaneous readers, but writers always have

  exclusive locks.



  Worst case is that this class behaves identical to a TRTLCriticalSection -

  that is, read and write locks block all other threads. }



type

  IReadWriteSync = interface

    ['{7B108C52-1D8F-4CDB-9CDF-57E071193D3F}']

    procedure BeginRead;

    procedure EndRead;

    function BeginWrite: Boolean;

    procedure EndWrite;

  end;



  TSimpleRWSync = class(TInterfacedObject, IReadWriteSync)

  private

    FLock: TRTLCriticalSection;

  public

    constructor Create;

    destructor Destroy; override;

    procedure BeginRead;

    procedure EndRead;

    function BeginWrite: Boolean;

    procedure EndWrite;

  end;



{ TThreadLocalCounter



  This class implements a lightweight non-blocking thread local storage

  mechanism specifically built for tracking per-thread recursion counts

  in TMultiReadExclusiveWriteSynchronizer.  This class is intended for

  Delphi RTL internal use only.  In the future it may be generalized

  and "hardened" for general application use, but until then leave it alone.



  Rules of Use:

  The tls object must be opened to gain access to the thread-specific data

  structure.  If a threadinfo block does not exist for the current thread,

  Open will allocate one.  Every call to Open must be matched with a call

  to Close.  The pointer returned by Open is invalid after the matching call

  to Close (or Delete).



  The thread info structure is unique to each thread.  Once you have it, it's

  yours.  You don't need to guard against concurrent access to the thread

  data by multiple threads - your thread is the only thread that will ever

  have access to the structure that Open returns.  The thread info structure

  is allocated and owned by the tls object.  If you put allocated pointers

  in the thread info make sure you free them before you delete the threadinfo

  node.



  When thread data is no longer needed, call the Delete method on the pointer.

  This must be done between calls to Open and Close.  You should not use the

  thread data after calling Delete.



  Important:  Do not keep the tls object open for long periods of time.

  In particular, be careful not to wait on a thread synchronization event or

  critical section while you have the tls object open.  It's much better to

  open and close the tls object before and after the blocking event than to

  leave the tls object open while waiting.



  Implementation Notes:

  The main purpose of this storage class is to provide thread-local storage

  without using limited / problematic OS tls slots and without requiring

  expensive blocking thread synchronization.  This class performs no

  blocking waits or spin loops!  (except for memory allocation)



  Thread info is kept in linked lists to facilitate non-blocking threading

  techniques.  A hash table indexed by a hash of the current thread ID

  reduces linear search times.



  When a node is deleted, its thread ID is stripped and its Active field is

  set to zero, meaning it is available to be recycled for other threads.

  Nodes are never removed from the live list or freed while the class is in

  use.  All nodes are freed when the class is destroyed.



  Nodes are only inserted at the front of the list (each list in the hash table).



  The linked list management relies heavily on InterlockedExchange to perform

  atomic node pointer replacements.  There are brief windows of time where

  the linked list may be circular while a two-step insertion takes place.

  During that brief window, other threads traversing the lists may see

  the same node more than once more than once. (pun!) This is fine for what this

  implementation needs.  Don't do anything silly like try to count the

  nodes during a traversal.

}



type

  PThreadInfo = ^TThreadInfo;

  TThreadInfo = record

    Next: PThreadInfo;

    ThreadID: Cardinal;

    Active: Integer;

    RecursionCount: Cardinal;

  end;



  TThreadLocalCounter = class

  private

    FHashTable: array [0..15] of PThreadInfo;

    function HashIndex: Byte;

    function Recycle: PThreadInfo;

  public

    destructor Destroy; override;

    procedure Open(var Thread: PThreadInfo);

    procedure Delete(var Thread: PThreadInfo);

    procedure Close(var Thread: PThreadInfo);

  end;



{$IFDEF MSWINDOWS}



{ TMultiReadExclusiveWriteSynchronizer minimizes thread serialization to gain

  read access to a resource shared among threads while still providing complete

  exclusivity to callers needing write access to the shared resource.

  (multithread shared reads, single thread exclusive write)

  Read locks are allowed while owning a write lock.

  Read locks can be promoted to write locks within the same thread.

  (BeginRead, BeginWrite, EndWrite, EndRead)



  Note: Other threads have an opportunity to modify the protected resource

  when you call BeginWrite before you are granted the write lock, even

  if you already have a read lock open.  Best policy is not to retain

  any info about the protected resource (such as count or size) across a

  write lock.  Always reacquire samples of the protected resource after

  acquiring or releasing a write lock.



  The function result of BeginWrite indicates whether another thread got

  the write lock while the current thread was waiting for the write lock.

  Return value of True means that the write lock was acquired without

  any intervening modifications by other threads.  Return value of False

  means another thread got the write lock while you were waiting, so the

  resource protected by the MREWS object should be considered modified.

  Any samples of the protected resource should be discarded.



  In general, it's better to just always reacquire samples of the protected

  resource after obtaining a write lock.  The boolean result of BeginWrite

  and the RevisionLevel property help cases where reacquiring the samples

  is computationally expensive or time consuming.



  RevisionLevel changes each time a write lock is granted.  You can test

  RevisionLevel for equality with a previously sampled value of the property

  to determine if a write lock has been granted, implying that the protected

  resource may be changed from its state when the original RevisionLevel

  value was sampled.  Do not rely on the sequentiality of the current

  RevisionLevel implementation (it will wrap around to zero when it tops out).

  Do not perform greater than / less than comparisons on RevisionLevel values.

  RevisionLevel indicates only the stability of the protected resource since

  your original sample.  It should not be used to calculate how many

  revisions have been made.

}



type

  TMultiReadExclusiveWriteSynchronizer = class(TInterfacedObject, IReadWriteSync)

  private

    FSentinel: Integer;

    FReadSignal: THandle;

    FWriteSignal: THandle;

    FWaitRecycle: Cardinal;

    FWriteRecursionCount: Cardinal;

    tls: TThreadLocalCounter;

    FWriterID: Cardinal;

    FRevisionLevel: Cardinal;

    procedure BlockReaders;

    procedure UnblockReaders;

    procedure UnblockOneWriter;

    procedure WaitForReadSignal;

    procedure WaitForWriteSignal;

{$IFDEF DEBUG_MREWS}

    procedure Debug(const Msg: string);

{$ENDIF}

  public

    constructor Create;

    destructor Destroy; override;

    procedure BeginRead;

    procedure EndRead;

    function BeginWrite: Boolean;

    procedure EndWrite;

    property RevisionLevel: Cardinal read FRevisionLevel;

  end;

{$ELSE}

type

  TMultiReadExclusiveWriteSynchronizer = TSimpleRWSync;

{$ENDIF}



type

  TMREWSync = TMultiReadExclusiveWriteSynchronizer;  // short form



function GetEnvironmentVariable(const Name: string): string; overload;



{$IFDEF LINUX}

function InterlockedIncrement(var I: Integer): Integer;

function InterlockedDecrement(var I: Integer): Integer;

function InterlockedExchange(var A: Integer; B: Integer): Integer;

function InterlockedExchangeAdd(var A: Integer; B: Integer): Integer;

{$ENDIF}



implementation



{$IFDEF LINUX}

{

        Exceptions raised in methods that are safecall will be filtered

        through the virtual method SafeCallException on the class.  The

        implementation of this method under Linux has the option of setting

        the following thread vars:  SafeCallExceptionMsg, SafeCallExceptionAddr.

        If these are set, then the implementation of SafeCallError here will

        reraise a generic exception based on these.  One might consider actually

        having the SafeCallException implementation store off the exception

        object itself, but this raises the issue that the exception object

        might have to live a long time (if an external application calls a

        Delphi safecall method).  Since an arbitrary exception object could

        be holding large resources hostage, we hold only the string and

        address as a hedge.

}

threadvar

    SafeCallExceptionMsg: String;

    SafeCallExceptionAddr: Pointer;



procedure SetSafeCallExceptionMsg(const Msg: String);

begin

  SafeCallExceptionMsg := Msg;

end;



procedure SetSafeCallExceptionAddr(Addr: Pointer);

begin

  SafeCallExceptionAddr := Addr;

end;



function GetSafeCallExceptionMsg: String;

begin

  Result := SafeCallExceptionMsg;

end;



function GetSafeCallExceptionAddr: Pointer;

begin

  Result := SafeCallExceptionAddr;

end;

{$ENDIF}



{ Utility routines }



procedure DivMod(Dividend: Integer; Divisor: Word;

  var Result, Remainder: Word);

asm

        PUSH    EBX

        MOV     EBX,EDX

        MOV     EDX,EAX

        SHR     EDX,16

        DIV     BX

        MOV     EBX,Remainder

        MOV     [ECX],AX

        MOV     [EBX],DX

        POP     EBX

end;



{$IFDEF PIC}

function GetGOT: Pointer; export;

begin

  asm

        MOV     Result,EBX

  end;

end;

{$ENDIF}



procedure ConvertError(const ResString: string); local;

begin

  raise EConvertError.Create(ResString);

end;



procedure ConvertErrorFmt(const ResString: string; const Args: array of const); local;

begin

  raise EConvertError.CreateFmt(ResString, Args);

end;



{$IFDEF MSWINDOWS}

{$EXTERNALSYM CoCreateGuid}

function CoCreateGuid(out guid: TGUID): HResult; stdcall; external 'ole32.dll' name 'CoCreateGuid';



function CreateGUID(out Guid: TGUID): HResult;

begin

  Result := CoCreateGuid(Guid);

end;

//function CreateGUID; external 'ole32.dll' name 'CoCreateGuid';

{$ENDIF}

{$IFDEF LINUX}



{ CreateGUID }



{ libuuid.so implements the tricky code to create GUIDs using the

  MAC address of the network adapter plus other flavor bits.

  libuuid.so is currently distributed with the ext2 file system

  package, but does not depend upon the ext2 file system libraries.

  Ideally, libuuid.so should be distributed separately.



  If you do not have libuuid.so.1 on your Linux distribution, you

  can extract the library from the e2fsprogs RPM.



  Note:  Do not use the generic uuid_generate function in libuuid.so.

  In the current implementation (e2fsprogs-1.19), uuid_generate

  gives preference to generating guids entirely from random number

  streams over generating guids based on the NIC MAC address.

  No matter how "random" a random number generator is, it will

  never produce guids that can be guaranteed unique across all

  systems on the planet.  MAC-address based guids are guaranteed

  unique because the MAC address of the NIC is guaranteed unique

  by the manufacturer.



  For this reason, we call uuid_generate_time instead of the

  generic uuid_generate.  uuid_generate_time constructs the guid

  using the MAC address, and falls back to randomness if no NIC

  can be found.  }



var

  libuuidHandle: Pointer;

  uuid_generate_time: procedure (out Guid: TGUID) cdecl;



function CreateGUID(out Guid: TGUID): HResult;



const

  E_NOTIMPL = HRESULT($80004001);



begin

  Result := E_NOTIMPL;

  if libuuidHandle = nil then

  begin

    libuuidHandle := dlopen('libuuid.so.1', RTLD_LAZY);

    if libuuidHandle = nil then Exit;

    uuid_generate_time := dlsym(libuuidHandle, 'uuid_generate_time');

    if @uuid_generate_time = nil then Exit;

  end;

  uuid_generate_time(Guid);

  Result := 0;

end;

{$ENDIF}





{$IFDEF MSWINDOWS}

function StringFromCLSID(const clsid: TGUID; out psz: PWideChar): HResult; stdcall;

  external 'ole32.dll' name 'StringFromCLSID';

procedure CoTaskMemFree(pv: Pointer); stdcall;

  external 'ole32.dll' name 'CoTaskMemFree';

function CLSIDFromString(psz: PWideChar; out clsid: TGUID): HResult; stdcall;

  external 'ole32.dll' name 'CLSIDFromString';

{$ENDIF MSWINDOWS}



function StringToGUID(const S: string): TGUID;

{$IFDEF MSWINDOWS}

begin

  if not Succeeded(CLSIDFromString(PWideChar(WideString(S)), Result)) then

    ConvertErrorFmt(SInvalidGUID, [s]);

end;

{$ENDIF}

{$IFDEF LINUX}



  procedure InvalidGUID;

  begin

    ConvertErrorFmt(@SInvalidGUID, [s]);

  end;



  function HexChar(c: Char): Byte;

  begin

    case c of

      '0'..'9':  Result := Byte(c) - Byte('0');

      'a'..'f':  Result := (Byte(c) - Byte('a')) + 10;

      'A'..'F':  Result := (Byte(c) - Byte('A')) + 10;

    else

      InvalidGUID;

      Result := 0;

    end;

  end;



  function HexByte(p: PChar): Char;

  begin

    Result := Char((HexChar(p[0]) shl 4) + HexChar(p[1]));

  end;



var

  i: Integer;

  src, dest: PChar;

begin

  if ((Length(S) <> 38) or (s[1] <> '{')) then InvalidGUID;

  dest := @Result;

  src := PChar(s);

  Inc(src);

  for i := 0 to 3 do

    dest[i] := HexByte(src+(3-i)*2);

  Inc(src, 8);

  Inc(dest, 4);

  if src[0] <> '-' then InvalidGUID;

  Inc(src);

  for i := 0 to 1 do

  begin

    dest^ := HexByte(src+2);

    Inc(dest);

    dest^ := HexByte(src);

    Inc(dest);

    Inc(src, 4);

    if src[0] <> '-' then InvalidGUID;

    inc(src);

  end;

  dest^ := HexByte(src);

  Inc(dest);

  Inc(src, 2);

  dest^ := HexByte(src);

  Inc(dest);

  Inc(src, 2);

  if src[0] <> '-' then InvalidGUID;

  Inc(src);

  for i := 0 to 5 do

  begin

    dest^ := HexByte(src);

    Inc(dest);

    Inc(src, 2);

  end;

end;

{$ENDIF LINUX}



{$IFDEF MSWINDOWS}

function GUIDToString(const GUID: TGUID): string;

var

  P: PWideChar;

begin

  if not Succeeded(StringFromCLSID(GUID, P)) then

    ConvertError(SInvalidGUID);

  Result := P;

  CoTaskMemFree(P);

end;

{$ENDIF}

{$IFDEF LINUX}

function GUIDToString(const GUID: TGUID): string;

begin

  SetLength(Result, 38);

  StrLFmt(PChar(Result), 38,'{%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x}',   // do not localize

    [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;

{$ENDIF}



{$IFDEF MSWINDOWS}

function IsEqualGUID; external 'ole32.dll' name 'IsEqualGUID';

{$ENDIF MSWINDOWS}

{$IFDEF LINUX}

function IsEqualGUID(const guid1, guid2: TGUID): Boolean;

var

  a, b: PIntegerArray;

begin

  a := PIntegerArray(@guid1);

  b := PIntegerArray(@guid2);

  Result := (a^[0] = b^[0]) and (a^[1] = b^[1]) and (a^[2] = b^[2]) and (a^[3] = b^[3]);

end;

{$ENDIF LINUX}





{ Memory management routines }



function AllocMem(Size: Cardinal): Pointer;

begin

  GetMem(Result, Size);

  FillChar(Result^, Size, 0);

end;



{ Exit procedure handling }



type

  PExitProcInfo = ^TExitProcInfo;

  TExitProcInfo = record

    Next: PExitProcInfo;

    SaveExit: Pointer;

    Proc: TProcedure;

  end;



var

  ExitProcList: PExitProcInfo = nil;



procedure DoExitProc;

var

  P: PExitProcInfo;

  Proc: TProcedure;

begin

  P := ExitProcList;

  ExitProcList := P^.Next;

  ExitProc := P^.SaveExit;

  Proc := P^.Proc;

  Dispose(P);

  Proc;

end;



procedure AddExitProc(Proc: TProcedure);

var

  P: PExitProcInfo;

begin

  New(P);

  P^.Next := ExitProcList;

  P^.SaveExit := ExitProc;

  P^.Proc := Proc;

  ExitProcList := P;

  ExitProc := @DoExitProc;

end;



{ String handling routines }



function NewStr(const S: string): PString;

begin

  if S = '' then Result := NullStr else

  begin

    New(Result);

    Result^ := S;

  end;

end;



procedure DisposeStr(P: PString);

begin

  if (P <> nil) and (P^ <> '') then Dispose(P);

end;



procedure AssignStr(var P: PString; const S: string);

var

  Temp: PString;

begin

  Temp := P;

  P := NewStr(S);

  DisposeStr(Temp);

end;



procedure AppendStr(var Dest: string; const S: string);

begin

  Dest := Dest + S;

end;



function UpperCase(const S: string): string;

var

  Ch: Char;

  L: Integer;

  Source, Dest: PChar;

begin

  L := Length(S);

  SetLength(Result, L);

  Source := Pointer(S);

  Dest := Pointer(Result);

  while L <> 0 do

  begin

    Ch := Source^;

    if (Ch >= 'a') and (Ch <= 'z') then Dec(Ch, 32);

    Dest^ := Ch;

    Inc(Source);

    Inc(Dest);

    Dec(L);

  end;

end;



function UpperCase(const S: string; LocaleOptions: TLocaleOptions): string;

begin

  if LocaleOptions = loUserLocale then

    Result := AnsiUpperCase(S)

  else

    Result := UpperCase(S);

end;



function LowerCase(const S: string): string;

var

  Ch: Char;

  L: Integer;

  Source, Dest: PChar;

begin

  L := Length(S);

  SetLength(Result, L);

  Source := Pointer(S);

  Dest := Pointer(Result);

  while L <> 0 do

  begin

    Ch := Source^;

    if (Ch >= 'A') and (Ch <= 'Z') then Inc(Ch, 32);

    Dest^ := Ch;

    Inc(Source);

    Inc(Dest);

    Dec(L);

  end;

end;



function LowerCase(const S: string; LocaleOptions: TLocaleOptions): string;

begin

  if LocaleOptions = loUserLocale then

    Result := AnsiLowerCase(S)

  else

    Result := LowerCase(S);

end;



function CompareStr(const S1, S2: string): Integer; assembler;

asm

        PUSH    ESI

        PUSH    EDI

        MOV     ESI,EAX

        MOV     EDI,EDX

        OR      EAX,EAX

        JE      @@1

        MOV     EAX,[EAX-4]

@@1:    OR      EDX,EDX

        JE      @@2

        MOV     EDX,[EDX-4]

@@2:    MOV     ECX,EAX

        CMP     ECX,EDX

        JBE     @@3

        MOV     ECX,EDX

@@3:    CMP     ECX,ECX

        REPE    CMPSB

        JE      @@4

        MOVZX   EAX,BYTE PTR [ESI-1]

        MOVZX   EDX,BYTE PTR [EDI-1]

@@4:    SUB     EAX,EDX

        POP     EDI

        POP     ESI

end;



function CompareStr(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer;

begin

  if LocaleOptions = loUserLocale then

    Result := AnsiCompareStr(S1, S2)

  else

    Result := CompareStr(S1, S2);

end;



function SameStr(const S1, S2: string): Boolean;

asm

        CMP     EAX,EDX

        JZ      @1

        OR      EAX,EAX

        JZ      @2

        OR      EDX,EDX

        JZ      @3

        MOV     ECX,[EAX-4]

        CMP     ECX,[EDX-4]

        JNE     @3

        CALL    CompareStr

        TEST    EAX,EAX

        JNZ     @3

@1:     MOV     AL,1

@2:     RET

@3:     XOR     EAX,EAX

end;



function SameStr(const S1, S2: string; LocaleOptions: TLocaleOptions): Boolean;

begin

  if LocaleOptions = loUserLocale then

    Result := AnsiSameStr(S1, S2)

  else

    Result := SameStr(S1, S2);

end;



function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;

asm

        PUSH    ESI

        PUSH    EDI

        MOV     ESI,P1

        MOV     EDI,P2

        MOV     EDX,ECX

        XOR     EAX,EAX

        AND     EDX,3

        SAR     ECX,2

        JS      @@1     // Negative Length implies identity.

        REPE    CMPSD

        JNE     @@2

        MOV     ECX,EDX

        REPE    CMPSB

        JNE     @@2

@@1:    INC     EAX

@@2:    POP     EDI

        POP     ESI

end;



(* ***** BEGIN LICENSE BLOCK *****

 * Version: MPL 1.1

 *

 * The implementation of function CompareText is 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 Fastcode

 *

 * The Initial Developer of the Original Code is

 * Fastcode

 *

 * Portions created by the Initial Developer are Copyright (C) 2002-2004

 * the Initial Developer. All Rights Reserved.

 *

 * Contributor(s): John O'Harrow

 *

 * ***** END LICENSE BLOCK ***** *)

function CompareText(const S1, S2: string): Integer;

asm

        TEST   EAX, EAX

        JNZ    @@CheckS2

        TEST   EDX, EDX

        JZ     @@Ret

        MOV    EAX, [EDX-4]

        NEG    EAX

@@Ret:

        RET

@@CheckS2:

        TEST   EDX, EDX

        JNZ    @@Compare

        MOV    EAX, [EAX-4]

        RET

@@Compare:

        PUSH   EBX

        PUSH   EBP

        PUSH   ESI

        MOV    EBP, [EAX-4]     // length(S1)

        MOV    EBX, [EDX-4]     // length(S2)

        SUB    EBP, EBX         // Result if All Compared Characters Match

        SBB    ECX, ECX

        AND    ECX, EBP

        ADD    ECX, EBX         // min(length(S1),length(S2)) = Compare Length

        LEA    ESI, [EAX+ECX]   // Last Compare Position in S1

        ADD    EDX, ECX         // Last Compare Position in S2

        NEG    ECX

        JZ     @@SetResult      // Exit if Smallest Length = 0

@@Loop:                         // Load Next 2 Chars from S1 and S2

                                // May Include Null Terminator}

        MOVZX  EAX, WORD PTR [ESI+ECX]

        MOVZX  EBX, WORD PTR [EDX+ECX]

        CMP    EAX, EBX

        JE     @@Next           // Next 2 Chars Match

        CMP    AL, BL

        JE     @@SecondPair     // First Char Matches

        MOV    AH, 0

        MOV    BH, 0

        CMP    AL, 'a'

        JL     @@UC1

        CMP    AL, 'z'

        JG     @@UC1

        SUB    EAX, 'a'-'A'

@@UC1:

        CMP    BL, 'a'

        JL     @@UC2

        CMP    BL, 'z'

        JG     @@UC2

        SUB    EBX, 'a'-'A'

@@UC2:

        SUB    EAX, EBX         // Compare Both Uppercase Chars

        JNE    @@Done           // Exit with Result in EAX if Not Equal

        MOVZX  EAX, WORD PTR [ESI+ECX] // Reload Same 2 Chars from S1

        MOVZX  EBX, WORD PTR [EDX+ECX] // Reload Same 2 Chars from S2

        CMP    AH, BH

        JE     @@Next           // Second Char Matches

@@SecondPair:

        SHR    EAX, 8

        SHR    EBX, 8

        CMP    AL, 'a'

        JL     @@UC3

        CMP    AL, 'z'

        JG     @@UC3

        SUB    EAX, 'a'-'A'

@@UC3:

        CMP    BL, 'a'

        JL     @@UC4

        CMP    BL, 'z'

        JG     @@UC4

        SUB    EBX, 'a'-'A'

@@UC4:

        SUB    EAX, EBX         // Compare Both Uppercase Chars

        JNE    @@Done           // Exit with Result in EAX if Not Equal

@@Next:

        ADD    ECX, 2

        JL     @@Loop           // Loop until All required Chars Compared

@@SetResult:

        MOV    EAX, EBP         // All Matched, Set Result from Lengths

@@Done:

        POP    ESI

        POP    EBP

        POP    EBX

end;



function CompareText(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer;

begin

  if LocaleOptions = loUserLocale then

    Result := AnsiCompareText(S1, S2)

  else

    Result := CompareText(S1, S2);

end;



function SameText(const S1, S2: string): Boolean; assembler;

asm

        CMP     EAX,EDX

        JZ      @1

        OR      EAX,EAX

        JZ      @2

        OR      EDX,EDX

        JZ      @3

        MOV     ECX,[EAX-4]

        CMP     ECX,[EDX-4]

        JNE     @3

        CALL    CompareText

        TEST    EAX,EAX

        JNZ     @3

@1:     MOV     AL,1

@2:     RET

@3:     XOR     EAX,EAX

end;



function SameText(const S1, S2: string; LocaleOptions: TLocaleOptions): Boolean;

begin

  if LocaleOptions = loUserLocale then

    Result := AnsiSameText(S1, S2)

  else

    Result := SameText(S1, S2);

end;



function AnsiUpperCase(const S: string): string;

{$IFDEF MSWINDOWS}

var

  Len: Integer;

begin

  Len := Length(S);

  SetString(Result, PChar(S), Len);

  if Len > 0 then CharUpperBuff(Pointer(Result), Len);

end;

{$ENDIF}

{$IFDEF LINUX}

begin

  Result := WideUpperCase(S);

end;

{$ENDIF}



function AnsiLowerCase(const S: string): string;

{$IFDEF MSWINDOWS}

var

  Len: Integer;

begin

  Len := Length(S);

  SetString(Result, PChar(S), Len);

  if Len > 0 then CharLowerBuff(Pointer(Result), Len);

end;

{$ENDIF}

{$IFDEF LINUX}

begin

  Result := WideLowerCase(S);

end;

{$ENDIF}



function AnsiCompareStr(const S1, S2: string): Integer;

begin

{$IFDEF MSWINDOWS}

  Result := CompareString(LOCALE_USER_DEFAULT, 0, PChar(S1), Length(S1),

    PChar(S2), Length(S2)) - 2;

{$ENDIF}

{$IFDEF LINUX}

  // glibc 2.1.2 / 2.1.3 implementations of strcoll() and strxfrm()

  // have severe capacity limits.  Comparing two 100k strings may

  // exhaust the stack and kill the process.

  // Fixed in glibc 2.1.91 and later.

  Result := strcoll(PChar(S1), PChar(S2));

{$ENDIF}

end;



function AnsiSameStr(const S1, S2: string): Boolean;

begin

  Result := AnsiCompareStr(S1, S2) = 0;

end;



function AnsiCompareText(const S1, S2: string): Integer;

begin

{$IFDEF MSWINDOWS}

  Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PChar(S1),

    Length(S1), PChar(S2), Length(S2)) - 2;

{$ENDIF}

{$IFDEF LINUX}

  Result := WideCompareText(S1, S2);

{$ENDIF}

end;



function AnsiSameText(const S1, S2: string): Boolean;

begin

  Result := AnsiCompareText(S1, S2) = 0;

end;



function AnsiStrComp(S1, S2: PChar): Integer;

begin

{$IFDEF MSWINDOWS}

  Result := CompareString(LOCALE_USER_DEFAULT, 0, S1, -1, S2, -1) - 2;

{$ENDIF}

{$IFDEF LINUX}

  Result := strcoll(S1, S2);

{$ENDIF}

end;



function AnsiStrIComp(S1, S2: PChar): Integer;

begin

{$IFDEF MSWINDOWS}

  Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1,

    S2, -1) - 2;

{$ENDIF}

{$IFDEF LINUX}

  Result := AnsiCompareText(S1, S2);

{$ENDIF}

end;



// StrLenLimit:  Scan Src for a null terminator up to MaxLen bytes

function StrLenLimit(Src: PChar; MaxLen: Cardinal): Cardinal;

begin

  if Src = nil then

  begin

    Result := 0;

    Exit;

  end;

  Result := MaxLen;

  while (Src^ <> #0) and (Result > 0) do

  begin

    Inc(Src);

    Dec(Result);

  end;

  Result := MaxLen - Result;

end;



{ StrBufLimit: Return a pointer to a buffer that contains no more than MaxLen

  bytes of Src, avoiding heap allocation if possible.

  If clipped Src length is less than MaxLen, return Src.  Allocated = False.

  If clipped Src length is less than StaticBufLen, return StaticBuf with a

    copy of Src.  Allocated = False.

  Otherwise, return a heap allocated buffer with a copy of Src.  Allocated = True.

}

function StrBufLimit(Src: PChar; MaxLen: Cardinal; StaticBuf: PChar;

  StaticBufLen: Cardinal; var Allocated: Boolean): PChar;

var

  Len: Cardinal;

begin

  Len := StrLenLimit(Src, MaxLen);

  Allocated := False;

  if Len < MaxLen then

    Result := Src

  else

  begin

    if Len < StaticBufLen then

      Result := StaticBuf

    else

    begin

      GetMem(Result, Len+1);

      Allocated := True;

    end;

    Move(Src^, Result^, Len);

    Result[Len] := #0;

  end;

end;



function InternalAnsiStrLComp(S1, S2: PChar; MaxLen: Cardinal; CaseSensitive: Boolean): Integer;

var

  Buf1, Buf2: array [0..4095] of Char;

  P1, P2: PChar;

  Allocated1, Allocated2: Boolean;

begin

  // glibc has no length-limited strcoll!

  P1 := nil;

  P2 := nil;

  Allocated1 := False;

  Allocated2 := False;

  try

    P1 := StrBufLimit(S1, MaxLen, Buf1, High(Buf1), Allocated1);

    P2 := StrBufLimit(S2, MaxLen, Buf2, High(Buf2), Allocated2);

    if CaseSensitive then

      Result := AnsiStrComp(P1, P2)

    else

      Result := AnsiStrIComp(P1, P2);

  finally

    if Allocated1 then

      FreeMem(P1);

    if Allocated2 then

      FreeMem(P2);

  end;

end;



function AnsiStrLComp(S1, S2: PChar; MaxLen: Cardinal): Integer;

{$IFDEF MSWINDOWS}

begin

  Result := CompareString(LOCALE_USER_DEFAULT, 0,

    S1, MaxLen, S2, MaxLen) - 2;

end;

{$ENDIF}

{$IFDEF LINUX}

begin

  Result := InternalAnsiStrLComp(S1, S2, MaxLen, True);

end;

{$ENDIF}



function AnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer;

begin

{$IFDEF MSWINDOWS}

  Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE,

    S1, MaxLen, S2, MaxLen) - 2;

{$ENDIF}

{$IFDEF LINUX}

  Result := InternalAnsiStrLComp(S1, S2, MaxLen, False);

{$ENDIF}

end;



function AnsiStrLower(Str: PChar): PChar;

{$IFDEF MSWINDOWS}

begin

  CharLower(Str);

  Result := Str;

end;

{$ENDIF}

{$IFDEF LINUX}

var

  Temp: WideString;

  Squish: AnsiString;

  I: Integer;

begin

  Temp := Str;     // expand and copy multibyte to widechar

  for I := 1 to Length(Temp) do

    Temp[I] := WideChar(towlower(UCS4Char(Temp[I])));

  Squish := Temp;  // reduce and copy widechar to multibyte



  if Cardinal(Length(Squish)) > StrLen(Str) then

    raise ERangeError.CreateRes(@SRangeError);



  Move(Squish[1], Str^, Length(Squish));

  Result := Str;

end;

{$ENDIF}



function AnsiStrUpper(Str: PChar): PChar;

{$IFDEF MSWINDOWS}

begin

  CharUpper(Str);

  Result := Str;

end;

{$ENDIF}

{$IFDEF LINUX}

var

  Temp: WideString;

  Squish: AnsiString;

  I: Integer;

begin

  Temp := Str;    // expand and copy multibyte to widechar

  for I := 1 to Length(Temp) do

    Temp[I] := WideChar(towupper(UCS4Char(Temp[I])));

  Squish := Temp;  // reduce and copy widechar to multibyte

  if Cardinal(Length(Squish)) > StrLen(Str) then

    raise ERangeError.CreateRes(@SRangeError);



  Move(Squish[1], Str^, Length(Squish));

  Result := Str;

end;

{$ENDIF}



function WideUpperCase(const S: WideString): WideString;

{$IFDEF MSWINDOWS}

var

  Len: Integer;

begin

  Len := Length(S);

  SetString(Result, PWideChar(S), Len);

  if Len > 0 then CharUpperBuffW(Pointer(Result), Len);

end;

{$ENDIF}

{$IFDEF LINUX}

var

  I: Integer;

  P: PWideChar;

begin

  SetLength(Result, Length(S));

  P := @Result[1];

  for I := 1 to Length(S) do

    P[I-1] := WideChar(towupper(UCS4Char(S[I])));

end;

{$ENDIF}



function WideLowerCase(const S: WideString): WideString;

{$IFDEF MSWINDOWS}

var

  Len: Integer;

begin

  Len := Length(S);

  SetString(Result, PWideChar(S), Len);

  if Len > 0 then CharLowerBuffW(Pointer(Result), Len);

end;

{$ENDIF}

{$IFDEF LINUX}

var

  I: Integer;

  P: PWideChar;

begin

  SetLength(Result, Length(S));

  P := @Result[1];

  for I := 1 to Length(S) do

    P[I-1] := WideChar(towlower(UCS4Char(S[I])));

end;

{$ENDIF}



{$IFDEF MSWINDOWS}

function DumbItDownFor95(const S1, S2: WideString; CmpFlags: Integer): Integer;

var

  a1, a2: AnsiString;

begin

  a1 := s1;

  a2 := s2;

  Result := CompareStringA(LOCALE_USER_DEFAULT, CmpFlags, PChar(a1), Length(a1),

    PChar(a2), Length(a2)) - 2;

end;

{$ENDIF}



function WideCompareStr(const S1, S2: WideString): Integer;

{$IFDEF MSWINDOWS}

begin

  SetLastError(0);

  Result := CompareStringW(LOCALE_USER_DEFAULT, 0, PWideChar(S1), Length(S1),

    PWideChar(S2), Length(S2)) - 2;

  case GetLastError of

    0: ;

    ERROR_CALL_NOT_IMPLEMENTED: Result := DumbItDownFor95(S1, S2, 0);

  else

    RaiseLastOSError;

  end;

end;

{$ENDIF}

{$IFDEF LINUX}

var

  UCS4_S1, UCS4_S2: UCS4String;

begin

  UCS4_S1 := WideStringToUCS4String(S1);

  UCS4_S2 := WideStringToUCS4String(S2);

  // glibc 2.1.2 / 2.1.3 implementations of wcscoll() and wcsxfrm()

  // have severe capacity limits.  Comparing two 100k strings may

  // exhaust the stack and kill the process.

  // Fixed in glibc 2.1.91 and later.

  SetLastError(0);

  Result := wcscoll(PUCS4Chars(UCS4_S1), PUCS4Chars(UCS4_S2));

  if GetLastError <> 0 then

    RaiseLastOSError;

end;

{$ENDIF}



function WideSameStr(const S1, S2: WideString): Boolean;

begin

  Result := WideCompareStr(S1, S2) = 0;

end;



function WideCompareText(const S1, S2: WideString): Integer;

begin

{$IFDEF MSWINDOWS}

  SetLastError(0);

  Result := CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PWideChar(S1),

    Length(S1), PWideChar(S2), Length(S2)) - 2;

  case GetLastError of

    0: ;

    ERROR_CALL_NOT_IMPLEMENTED: Result := DumbItDownFor95(S1, S2, NORM_IGNORECASE);

  else

    RaiseLastOSError;

  end;

{$ENDIF}

{$IFDEF LINUX}

  Result := WideCompareStr(WideUpperCase(S1), WideUpperCase(S2));

{$ENDIF}

end;



function WideSameText(const S1, S2: WideString): Boolean;

begin

  Result := WideCompareText(S1, S2) = 0;

end;



function Trim(const S: string): string;

var

  I, L: Integer;

begin

  L := Length(S);

  I := 1;

  while (I <= L) and (S[I] <= ' ') do Inc(I);

  if I > L then Result := '' else

  begin

    while S[L] <= ' ' do Dec(L);

    Result := Copy(S, I, L - I + 1);

  end;

end;



function Trim(const S: WideString): WideString;

var

  I, L: Integer;

begin

  L := Length(S);

  I := 1;

  while (I <= L) and (S[I] <= ' ') do Inc(I);

  if I > L then

    Result := ''

  else

  begin

    while S[L] <= ' ' do Dec(L);

    Result := Copy(S, I, L - I + 1);

  end;

end;



function TrimLeft(const S: string): string;

var

  I, L: Integer;

begin

  L := Length(S);

  I := 1;

  while (I <= L) and (S[I] <= ' ') do Inc(I);

  Result := Copy(S, I, Maxint);

end;



function TrimLeft(const S: WideString): WideString;

var

  I, L: Integer;

begin

  L := Length(S);

  I := 1;

  while (I <= L) and (S[I] <= ' ') do Inc(I);

  Result := Copy(S, I, Maxint);

end;



function TrimRight(const S: string): string;

var

  I: Integer;

begin

  I := Length(S);

  while (I > 0) and (S[I] <= ' ') do Dec(I);

  Result := Copy(S, 1, I);

end;



function TrimRight(const S: WideString): WideString;

var

  I: Integer;

begin

  I := Length(S);

  while (I > 0) and (S[I] <= ' ') do Dec(I);

  Result := Copy(S, 1, I);

end;



function QuotedStr(const S: string): string;

var

  I: Integer;

begin

  Result := S;

  for I := Length(Result) downto 1 do

    if Result[I] = '''' then Insert('''', Result, I);

  Result := '''' + Result + '''';

end;



function AnsiQuotedStr(const S: string; Quote: Char): string;

var

  P, Src, Dest: PChar;

  AddCount: Integer;

begin

  AddCount := 0;

  P := AnsiStrScan(PChar(S), Quote);

  while P <> nil do

  begin

    Inc(P);

    Inc(AddCount);

    P := AnsiStrScan(P, Quote);

  end;

  if AddCount = 0 then

  begin

    Result := Quote + S + Quote;

    Exit;

  end;

  SetLength(Result, Length(S) + AddCount + 2);

  Dest := Pointer(Result);

  Dest^ := Quote;

  Inc(Dest);

  Src := Pointer(S);

  P := AnsiStrScan(Src, Quote);

  repeat

    Inc(P);

    Move(Src^, Dest^, P - Src);

    Inc(Dest, P - Src);

    Dest^ := Quote;

    Inc(Dest);

    Src := P;

    P := AnsiStrScan(Src, Quote);

  until P = nil;

  P := StrEnd(Src);

  Move(Src^, Dest^, P - Src);

  Inc(Dest, P - Src);

  Dest^ := Quote;

end;



function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string;

var

  P, Dest: PChar;

  DropCount: Integer;

begin

  Result := '';

  if (Src = nil) or (Src^ <> Quote) then Exit;

  Inc(Src);

  DropCount := 1;

  P := Src;

  Src := AnsiStrScan(Src, Quote);

  while Src <> nil do   // count adjacent pairs of quote chars

  begin

    Inc(Src);

    if Src^ <> Quote then Break;

    Inc(Src);

    Inc(DropCount);

    Src := AnsiStrScan(Src, Quote);

  end;

  if Src = nil then Src := StrEnd(P);

  if ((Src - P) <= 1) then Exit;

  if DropCount = 1 then

    SetString(Result, P, Src - P - 1)

  else

  begin

    SetLength(Result, Src - P - DropCount);

    Dest := PChar(Result);

    Src := AnsiStrScan(P, Quote);

    while Src <> nil do

    begin

      Inc(Src);

      if Src^ <> Quote then Break;

      Move(P^, Dest^, Src - P);

      Inc(Dest, Src - P);

      Inc(Src);

      P := Src;

      Src := AnsiStrScan(Src, Quote);

    end;

    if Src = nil then Src := StrEnd(P);

    Move(P^, Dest^, Src - P - 1);

  end;

end;



function AnsiDequotedStr(const S: string; AQuote: Char): string;

var

  LText: PChar;

begin

  LText := PChar(S);

  Result := AnsiExtractQuotedStr(LText, AQuote);

  if Result = '' then

    Result := S;

end;



function AdjustLineBreaks(const S: string; Style: TTextLineBreakStyle): string;

var

  Source, SourceEnd, Dest: PChar;

  DestLen: Integer;

  L: Integer;

begin

  Source := Pointer(S);

  SourceEnd := Source + Length(S);

  DestLen := Length(S);

  while Source < SourceEnd do

  begin

    case Source^ of

      #10:

        if Style = tlbsCRLF then

          Inc(DestLen);

      #13:

        if Style = tlbsCRLF then

          if Source[1] = #10 then

            Inc(Source)

          else

            Inc(DestLen)

        else

          if Source[1] = #10 then

            Dec(DestLen);

    else

      if Source^ in LeadBytes then

      begin

        Source := StrNextChar(Source);

        continue;

      end;

    end;

    Inc(Source);

  end;

  if DestLen = Length(Source) then

    Result := S

  else

  begin

    Source := Pointer(S);

    SetString(Result, nil, DestLen);

    Dest := Pointer(Result);

    while Source < SourceEnd do

      case Source^ of

        #10:

          begin

            if Style = tlbsCRLF then

            begin

              Dest^ := #13;

              Inc(Dest);

            end;

            Dest^ := #10;

            Inc(Dest);

            Inc(Source);

          end;

        #13:

          begin

            if Style = tlbsCRLF then

            begin

              Dest^ := #13;

              Inc(Dest);

            end;

            Dest^ := #10;

            Inc(Dest);

            Inc(Source);

            if Source^ = #10 then Inc(Source);

          end;

      else

        if Source^ in LeadBytes then

        begin

          L := StrCharLength(Source);

          Move(Source^, Dest^, L);

          Inc(Dest, L);

          Inc(Source, L);

          continue;

        end;

        Dest^ := Source^;

        Inc(Dest);

        Inc(Source);

      end;

  end;

end;



function IsValidIdent(const Ident: string; AllowDots: Boolean): Boolean;

const

  Alpha = ['A'..'Z', 'a'..'z', '_'];

  AlphaNumeric = Alpha + ['0'..'9'];

  AlphaNumericDot = AlphaNumeric + ['.'];



var

  I: Integer;

begin

  Result := False;

  if (Length(Ident) = 0) or not (Ident[1] in Alpha) then Exit;

  if AllowDots then

    for I := 2 to Length(Ident) do

      begin

	if not (Ident[I] in AlphaNumericDot) then Exit

      end

  else

    for I := 2 to Length(Ident) do if not (Ident[I] in AlphaNumeric) then Exit;

  Result := True;

end;



procedure CvtInt;

{ IN:

    EAX:  The integer value to be converted to text

    ESI:  Ptr to the right-hand side of the output buffer:  LEA ESI, StrBuf[16]

    ECX:  Base for conversion: 0 for signed decimal, 10 or 16 for unsigned

    EDX:  Precision: zero padded minimum field width

  OUT:

    ESI:  Ptr to start of converted text (not start of buffer)

    ECX:  Length of converted text

}

asm

        OR      CL,CL

        JNZ     @CvtLoop

@C1:    OR      EAX,EAX

        JNS     @C2

        NEG     EAX

        CALL    @C2

        MOV     AL,'-'

        INC     ECX

        DEC     ESI

        MOV     [ESI],AL

        RET

@C2:    MOV     ECX,10



@CvtLoop:

        PUSH    EDX

        PUSH    ESI

@D1:    XOR     EDX,EDX

        DIV     ECX

        DEC     ESI

        ADD     DL,'0'

        CMP     DL,'0'+10

        JB      @D2

        ADD     DL,('A'-'0')-10

@D2:    MOV     [ESI],DL

        OR      EAX,EAX

        JNE     @D1

        POP     ECX

        POP     EDX

        SUB     ECX,ESI

        SUB     EDX,ECX

        JBE     @D5

        ADD     ECX,EDX

        MOV     AL,'0'

        SUB     ESI,EDX

        JMP     @z

@zloop: MOV     [ESI+EDX],AL

@z:     DEC     EDX

        JNZ     @zloop

        MOV     [ESI],AL

@D5:

end;



procedure CvtIntW;

{ IN:

    EAX:  The integer value to be converted to text

    ESI:  Ptr to the right-hand side of the widechar output buffer:  LEA ESI, WStrBuf[32]

    ECX:  Base for conversion: 0 for signed decimal, 10 or 16 for unsigned

    EDX:  Precision: zero padded minimum field width

  OUT:

    ESI:  Ptr to start of converted widechar text (not start of buffer)

    ECX:  Character length of converted text

}

asm

        OR      CL,CL

        JNZ     @CvtLoop

@C1:    OR      EAX,EAX

        JNS     @C2

        NEG     EAX

        CALL    @C2

        MOV     AX,'-'

        MOV     [ESI-2],AX

        SUB     ESI, 2

        INC     ECX

        RET

@C2:    MOV     ECX,10



@CvtLoop:

        PUSH    EDX

        PUSH    ESI

@D1:    XOR     EDX,EDX

        DIV     ECX

        ADD     DX,'0'

        SUB     ESI,2

        CMP     DX,'0'+10

        JB      @D2

        ADD     DX,('A'-'0')-10

@D2:    MOV     [ESI],DX

        OR      EAX,EAX

        JNE     @D1

        POP     ECX

        POP     EDX

        SUB     ECX,ESI

        SHR     ECX, 1

        SUB     EDX,ECX

        JBE     @D5

        ADD     ECX,EDX

        SUB     ESI,EDX

        MOV     AX,'0'

        SUB     ESI,EDX

        JMP     @z

@zloop: MOV     [ESI+EDX*2],AX

@z:     DEC     EDX

        JNZ     @zloop

        MOV     [ESI],AX

@D5:

end;



function IntToStr(Value: Integer): string;

//  FmtStr(Result, '%d', [Value]);

asm

        PUSH    ESI

        MOV     ESI, ESP

        SUB     ESP, 16

        XOR     ECX, ECX       // base: 0 for signed decimal

        PUSH    EDX            // result ptr

        XOR     EDX, EDX       // zero filled field width: 0 for no leading zeros

        CALL    CvtInt

        MOV     EDX, ESI

        POP     EAX            // result ptr

        CALL    System.@LStrFromPCharLen

        ADD     ESP, 16

        POP     ESI

end;



procedure CvtInt64W;

{ IN:

    EAX:  Address of the int64 value to be converted to text

    ESI:  Ptr to the right-hand side of the widechar output buffer:  LEA ESI, WStrBuf[32]

    ECX:  Base for conversion: 10 or 16

    EDX:  Precision: zero padded minimum field width

  OUT:

    ESI:  Ptr to start of converted widechar text (not start of buffer)

    ECX:  Character length of converted text

}

asm

        OR      CL, CL

        JNZ     @start

        MOV     ECX, 10

        TEST    [EAX + 4], $80000000

        JZ      @start

        PUSH    [EAX + 4]

        PUSH    [EAX]

        MOV     EAX, ESP

        NEG     [ESP]              // negate the value

        ADC     [ESP + 4],0

        NEG     [ESP + 4]

        CALL    @start

        INC     ECX

        MOV     [ESI-2].Word, '-'

        SUB     ESI, 2

        ADD     ESP, 8

        JMP     @done



@start:

        PUSH    ESI

        SUB     ESP, 4

        FNSTCW  [ESP+2].Word       // save

        FNSTCW  [ESP].Word         // scratch

        OR      [ESP].Word, $0F00  // trunc toward zero, full precision

        FLDCW   [ESP].Word



        MOV     [ESP].Word, CX

        FLD1

        TEST    [EAX + 4], $80000000 // test for negative

        JZ      @ld1                 // FPU doesn't understand unsigned ints

        PUSH    [EAX + 4]            // copy value before modifying

        PUSH    [EAX]

        AND     [ESP + 4], $7FFFFFFF // clear the sign bit

        PUSH    $7FFFFFFF

        PUSH    $FFFFFFFF

        FILD    [ESP + 8].QWord     // load value

        FILD    [ESP].QWord

        FADD    ST(0), ST(2)        // Add 1.  Produces unsigned $80000000 in ST(0)

        FADDP   ST(1), ST(0)        // Add $80000000 to value to replace the sign bit

        ADD     ESP, 16

        JMP     @ld2

@ld1:

        FILD    [EAX].QWord         // value

@ld2:

        FILD    [ESP].Word          // base

        FLD     ST(1)

@loop:

        SUB     ESI, 2

        FPREM                       // accumulator mod base

        FISTP   [ESI].Word

        FDIV    ST(1), ST(0)        // accumulator := acumulator / base

        MOV     AX, [ESI].Word      // overlap long division op with int ops

        ADD     AX, '0'

        CMP     AX, '0'+10

        JB      @store

        ADD     AX, ('A'-'0')-10

@store:

        MOV     [ESI].Word, AX

        FLD     ST(1)           // copy accumulator

        FCOM    ST(3)           // if accumulator >= 1.0 then loop

        FSTSW   AX

        SAHF

        JAE @loop



        FLDCW   [ESP+2].Word

        ADD     ESP,4



        FFREE   ST(3)

        FFREE   ST(2)

        FFREE   ST(1);

        FFREE   ST(0);



@zeropad:

        POP     ECX             // original ESI

        SUB     ECX,ESI

        SHR     ECX, 1          // ECX = char length of converted string

        OR      EDX,EDX

        JS      @done

        SUB     EDX,ECX

        JBE     @done           // output longer than field width = no pad

        SUB     ESI,EDX

        MOV     AX,'0'

        SUB     ESI,EDX

        ADD     ECX,EDX

        JMP     @z

@zloop: MOV     [ESI+EDX*2].Word,AX

@z:     DEC     EDX

        JNZ     @zloop

        MOV     [ESI].Word,AX

@done:

end;



procedure CvtInt64;

{ IN:

    EAX:  Address of the int64 value to be converted to text

    ESI:  Ptr to the right-hand side of the output buffer:  LEA ESI, StrBuf[32]

    ECX:  Base for conversion: 0 for signed decimal, or 10 or 16 for unsigned

    EDX:  Precision: zero padded minimum field width

  OUT:

    ESI:  Ptr to start of converted text (not start of buffer)

    ECX:  Byte length of converted text

}

asm

        OR      CL, CL

        JNZ     @start             // CL = 0  => signed integer conversion

        MOV     ECX, 10

        TEST    [EAX + 4], $80000000

        JZ      @start

        PUSH    [EAX + 4]

        PUSH    [EAX]

        MOV     EAX, ESP

        NEG     [ESP]              // negate the value

        ADC     [ESP + 4],0

        NEG     [ESP + 4]

        CALL    @start             // perform unsigned conversion

        MOV     [ESI-1].Byte, '-'  // tack on the negative sign

        DEC     ESI

        INC     ECX

        ADD     ESP, 8

        RET



@start:   // perform unsigned conversion

        PUSH    ESI

        SUB     ESP, 4

        FNSTCW  [ESP+2].Word     // save

        FNSTCW  [ESP].Word       // scratch

        OR      [ESP].Word, $0F00  // trunc toward zero, full precision

        FLDCW   [ESP].Word



        MOV     [ESP].Word, CX

        FLD1

        TEST    [EAX + 4], $80000000 // test for negative

        JZ      @ld1                 // FPU doesn't understand unsigned ints

        PUSH    [EAX + 4]            // copy value before modifying

        PUSH    [EAX]

        AND     [ESP + 4], $7FFFFFFF // clear the sign bit

        PUSH    $7FFFFFFF

        PUSH    $FFFFFFFF

        FILD    [ESP + 8].QWord     // load value

        FILD    [ESP].QWord

        FADD    ST(0), ST(2)        // Add 1.  Produces unsigned $80000000 in ST(0)

        FADDP   ST(1), ST(0)        // Add $80000000 to value to replace the sign bit

        ADD     ESP, 16

        JMP     @ld2

@ld1:

        FILD    [EAX].QWord         // value

@ld2:

        FILD    [ESP].Word          // base

        FLD     ST(1)

@loop:

        DEC     ESI

        FPREM                       // accumulator mod base

        FISTP   [ESP].Word

        FDIV    ST(1), ST(0)        // accumulator := acumulator / base

        MOV     AL, [ESP].Byte      // overlap long FPU division op with int ops

        ADD     AL, '0'

        CMP     AL, '0'+10

        JB      @store

        ADD     AL, ('A'-'0')-10

@store:

        MOV     [ESI].Byte, AL

        FLD     ST(1)           // copy accumulator

        FCOM    ST(3)           // if accumulator >= 1.0 then loop

        FSTSW   AX

        SAHF

        JAE @loop



        FLDCW   [ESP+2].Word

        ADD     ESP,4



        FFREE   ST(3)

        FFREE   ST(2)

        FFREE   ST(1);

        FFREE   ST(0);



        POP     ECX             // original ESI

        SUB     ECX, ESI        // ECX = length of converted string

        SUB     EDX,ECX

        JBE     @done           // output longer than field width = no pad

        SUB     ESI,EDX

        MOV     AL,'0'

        ADD     ECX,EDX

        JMP     @z

@zloop: MOV     [ESI+EDX].Byte,AL

@z:     DEC     EDX

        JNZ     @zloop

        MOV     [ESI].Byte,AL

@done:

end;



function IntToStr(Value: Int64): string;

//  FmtStr(Result, '%d', [Value]);

asm

        PUSH    ESI

        MOV     ESI, ESP

        SUB     ESP, 32        // 32 chars

        XOR     ECX, ECX       // base 10 signed

        PUSH    EAX            // result ptr

        XOR     EDX, EDX       // zero filled field width: 0 for no leading zeros

        LEA     EAX, Value;

        CALL    CvtInt64



        MOV     EDX, ESI

        POP     EAX            // result ptr

        CALL    System.@LStrFromPCharLen

        ADD     ESP, 32

        POP     ESI

end;



function IntToHex(Value: Integer; Digits: Integer): string;

//  FmtStr(Result, '%.*x', [Digits, Value]);

asm

        CMP     EDX, 32        // Digits < buffer length?

        JBE     @A1

        XOR     EDX, EDX

@A1:    PUSH    ESI

        MOV     ESI, ESP

        SUB     ESP, 32

        PUSH    ECX            // result ptr

        MOV     ECX, 16        // base 16     EDX = Digits = field width

        CALL    CvtInt

        MOV     EDX, ESI

        POP     EAX            // result ptr

        CALL    System.@LStrFromPCharLen

        ADD     ESP, 32

        POP     ESI

end;



function IntToHex(Value: Int64; Digits: Integer): string;

//  FmtStr(Result, '%.*x', [Digits, Value]);

asm

        CMP     EAX, 32        // Digits < buffer length?

        JLE     @A1

        XOR     EAX, EAX

@A1:    PUSH    ESI

        MOV     ESI, ESP

        SUB     ESP, 32        // 32 chars

        MOV     ECX, 16        // base 16

        PUSH    EDX            // result ptr

        MOV     EDX, EAX       // zero filled field width: 0 for no leading zeros

        LEA     EAX, Value;

        CALL    CvtInt64



        MOV     EDX, ESI

        POP     EAX            // result ptr

        CALL    System.@LStrFromPCharLen

        ADD     ESP, 32

        POP     ESI

end;



function StrToInt(const S: string): Integer;

var

  E: Integer;

begin

  Val(S, Result, E);

  if E <> 0 then ConvertErrorFmt(SInvalidInteger, [S]);

end;



function StrToIntDef(const S: string; Default: Integer): Integer;

var

  E: Integer;

begin

  Val(S, Result, E);

  if E <> 0 then Result := Default;

end;



function TryStrToInt(const S: string; out Value: Integer): Boolean;

var

  E: Integer;

begin

  Val(S, Value, E);

  Result := E = 0;

end;



function StrToInt64(const S: string): Int64;

var

  E: Integer;

begin

  Val(S, Result, E);

  if E <> 0 then ConvertErrorFmt(SInvalidInteger, [S]);

end;



function StrToInt64Def(const S: string; const Default: Int64): Int64;

var

  E: Integer;

begin

  Val(S, Result, E);

  if E <> 0 then Result := Default;

end;



function TryStrToInt64(const S: string; out Value: Int64): Boolean;

var

  E: Integer;

begin

  Val(S, Value, E);

  Result := E = 0;

end;



procedure VerifyBoolStrArray;

begin

  if Length(TrueBoolStrs) = 0 then

  begin

    SetLength(TrueBoolStrs, 1);

    TrueBoolStrs[0] := DefaultTrueBoolStr;

  end;

  if Length(FalseBoolStrs) = 0 then

  begin

    SetLength(FalseBoolStrs, 1);

    FalseBoolStrs[0] := DefaultFalseBoolStr;

  end;

end;



function StrToBool(const S: string): Boolean;

begin

  if not TryStrToBool(S, Result) then

    ConvertErrorFmt(SInvalidBoolean, [S]);

end;



function StrToBoolDef(const S: string; const Default: Boolean): Boolean;

begin

  if not TryStrToBool(S, Result) then

    Result := Default;

end;



function TryStrToBool(const S: string; out Value: Boolean): Boolean;

  function CompareWith(const aArray: array of string): Boolean;

  var

    I: Integer;

  begin

    Result := False;

    for I := Low(aArray) to High(aArray) do

      if AnsiSameText(S, aArray[I]) then

      begin

        Result := True;

        Break;

      end;

  end;

var

  LResult: Extended;

begin

  Result := TryStrToFloat(S, LResult);

  if Result then

    Value := LResult <> 0

  else

  begin

    VerifyBoolStrArray;

    Result := CompareWith(TrueBoolStrs);

    if Result then

      Value := True

    else

    begin

      Result := CompareWith(FalseBoolStrs);

      if Result then

        Value := False;

    end;

  end;

end;



function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string;

const

  cSimpleBoolStrs: array [boolean] of String = ('0', '-1');

begin

  if UseBoolStrs then

  begin

    VerifyBoolStrArray;

    if B then

      Result := TrueBoolStrs[0]

    else

      Result := FalseBoolStrs[0];

  end

  else

    Result := cSimpleBoolStrs[B];

end;



type

  PStrData = ^TStrData;

  TStrData = record

    Ident: Integer;

    Str: string;

  end;



function EnumStringModules(Instance: Longint; Data: Pointer): Boolean;

{$IFDEF MSWINDOWS}

var

  Buffer: array [0..1023] of char;

begin

  with PStrData(Data)^ do

  begin

    SetString(Str, Buffer,

      LoadString(Instance, Ident, Buffer, sizeof(Buffer)));

    Result := Str = '';

  end;

end;

{$ENDIF}

{$IFDEF LINUX}

var

  rs: TResStringRec;

  Module: HModule;

begin

  Module := Instance;

  rs.Module := @Module;

  with PStrData(Data)^ do

  begin

    rs.Identifier := Ident;

    Str := LoadResString(@rs);

    Result := Str = '';

  end;

end;

{$ENDIF}



function FindStringResource(Ident: Integer): string;

var

  StrData: TStrData;

begin

  StrData.Ident := Ident;

  StrData.Str := '';

  EnumResourceModules(EnumStringModules, @StrData);

  Result := StrData.Str;

end;



function LoadStr(Ident: Integer): string;

begin

  Result := FindStringResource(Ident);

end;



function FmtLoadStr(Ident: Integer; const Args: array of const): string;

begin

  FmtStr(Result, FindStringResource(Ident), Args);

end;



{ File management routines }



function FileOpen(const FileName: string; Mode: LongWord): Integer;

{$IFDEF MSWINDOWS}

const

  AccessMode: array[0..2] of LongWord = (

    GENERIC_READ,

    GENERIC_WRITE,

    GENERIC_READ or GENERIC_WRITE);

  ShareMode: array[0..4] of LongWord = (

    0,

    0,

    FILE_SHARE_READ,

    FILE_SHARE_WRITE,

    FILE_SHARE_READ or FILE_SHARE_WRITE);

begin

  Result := -1;

  if ((Mode and 3) <= fmOpenReadWrite) and

    ((Mode and $F0) <= fmShareDenyNone) then

    Result := Integer(CreateFile(PChar(FileName), AccessMode[Mode and 3],

      ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING,

      FILE_ATTRIBUTE_NORMAL, 0));

end;

{$ENDIF}

{$IFDEF LINUX}

const

  ShareMode: array[0..fmShareDenyNone shr 4] of Byte = (

    0,        //No share mode specified

    F_WRLCK,  //fmShareExclusive

    F_RDLCK,  //fmShareDenyWrite

    0);       //fmShareDenyNone

var

  FileHandle, Tvar: Integer;

  LockVar: TFlock;

  smode: Byte;

begin

  Result := -1;

  if FileExists(FileName) and

     ((Mode and 3) <= fmOpenReadWrite) and

     ((Mode and $F0) <= fmShareDenyNone) then

  begin

    FileHandle := open(PChar(FileName), (Mode and 3), FileAccessRights);



    if FileHandle = -1 then  Exit;



    smode := Mode and $F0 shr 4;

    if ShareMode[smode] <> 0 then

    begin

      with LockVar do

      begin

        l_whence := SEEK_SET;

        l_start := 0;

        l_len := 0;

        l_type := ShareMode[smode];

      end;

      Tvar :=  fcntl(FileHandle, F_SETLK, LockVar);

      if Tvar = -1 then

      begin

        __close(FileHandle);

        Exit;

      end;

    end;

    Result := FileHandle;

  end;

end;

{$ENDIF}



function FileCreate(const FileName: string): Integer;

{$IFDEF MSWINDOWS}

begin

  Result := Integer(CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE,

    0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0));

end;

{$ENDIF}

{$IFDEF LINUX}

begin

  Result := FileCreate(FileName, FileAccessRights);

end;

{$ENDIF}



function FileCreate(const FileName: string; Rights: Integer): Integer;

{$IFDEF MSWINDOWS}

begin

  Result := FileCreate(FileName);

end;

{$ENDIF}

{$IFDEF LINUX}

begin

  Result := Integer(open(PChar(FileName), O_RDWR or O_CREAT or O_TRUNC, Rights));

end;

{$ENDIF}



function FileRead(Handle: Integer; var Buffer; Count: LongWord): Integer;

begin

{$IFDEF MSWINDOWS}

  if not ReadFile(THandle(Handle), Buffer, Count, LongWord(Result), nil) then

    Result := -1;

{$ENDIF}

{$IFDEF LINUX}

  Result := __read(Handle, Buffer, Count);

{$ENDIF}

end;



function FileWrite(Handle: Integer; const Buffer; Count: LongWord): Integer;

begin

{$IFDEF MSWINDOWS}

  if not WriteFile(THandle(Handle), Buffer, Count, LongWord(Result), nil) then

    Result := -1;

{$ENDIF}

{$IFDEF LINUX}

  Result := __write(Handle, Buffer, Count);

{$ENDIF}

end;



function FileSeek(Handle, Offset, Origin: Integer): Integer;

begin

{$IFDEF MSWINDOWS}

  Result := SetFilePointer(THandle(Handle), Offset, nil, Origin);

{$ENDIF}

{$IFDEF LINUX}

  Result := __lseek(Handle, Offset, Origin);

{$ENDIF}

end;



function FileSeek(Handle: Integer; const Offset: Int64; Origin: Integer): Int64;

{$IFDEF MSWINDOWS}

begin

  Result := Offset;

  Int64Rec(Result).Lo := SetFilePointer(THandle(Handle), Int64Rec(Result).Lo,

    @Int64Rec(Result).Hi, Origin);

end;

{$ENDIF}

{$IFDEF LINUX}

var

  Temp: Integer;

begin

  Temp := Offset;  // allow for range-checking

  Result := FileSeek(Handle, Temp, Origin);

end;

{$ENDIF}



procedure FileClose(Handle: Integer);

begin

{$IFDEF MSWINDOWS}

  CloseHandle(THandle(Handle));

{$ENDIF}

{$IFDEF LINUX}

  __close(Handle); // No need to unlock since all locks are released on close.

{$ENDIF}

end;



function FileAge(const FileName: string): Integer;

{$IFDEF MSWINDOWS}

var

  Handle: THandle;

  FindData: TWin32FindData;

  LocalFileTime: TFileTime;

begin

  Handle := FindFirstFile(PChar(FileName), FindData);

  if Handle <> INVALID_HANDLE_VALUE then

  begin

    Windows.FindClose(Handle);

    if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then

    begin

      FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);

      if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi,

        LongRec(Result).Lo) then Exit;

    end;

  end;

  Result := -1;

end;

{$ENDIF}

{$IFDEF LINUX}

var

  st: TStatBuf;

begin

  if stat(PChar(FileName), st) = 0 then

    Result := st.st_mtime

  else

    Result := -1;

end;

{$ENDIF}



function FileExists(const FileName: string): Boolean;

{$IFDEF MSWINDOWS}

begin

  Result := FileAge(FileName) <> -1;

end;

{$ENDIF}

{$IFDEF LINUX}

begin

  Result := euidaccess(PChar(FileName), F_OK) = 0;

end;

{$ENDIF}



function DirectoryExists(const Directory: string): Boolean;

{$IFDEF LINUX}

var

  st: TStatBuf;

begin

  if stat(PChar(Directory), st) = 0 then

    Result := S_ISDIR(st.st_mode)

  else

    Result := False;

end;

{$ENDIF}

{$IFDEF MSWINDOWS}

var

  Code: Integer;

begin

  Code := GetFileAttributes(PChar(Directory));

  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);

end;

{$ENDIF}



function ForceDirectories(Dir: string): Boolean;

var

  E: EInOutError;

begin

  Result := True;

  if Dir = '' then

  begin

    E := EInOutError.CreateRes(SCannotCreateDir);

    E.ErrorCode := 3;

    raise E;

  end;

  Dir := ExcludeTrailingPathDelimiter(Dir);

{$IFDEF MSWINDOWS}

  if (Length(Dir) < 3) or DirectoryExists(Dir)

    or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.

{$ENDIF}

{$IFDEF LINUX}

  if (Dir = '') or DirectoryExists(Dir) then Exit;

{$ENDIF}

  Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);

end;



function FileGetDate(Handle: Integer): Integer;

{$IFDEF MSWINDOWS}

var

  FileTime, LocalFileTime: TFileTime;

begin

  if GetFileTime(THandle(Handle), nil, nil, @FileTime) and

    FileTimeToLocalFileTime(FileTime, LocalFileTime) and

    FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi,

      LongRec(Result).Lo) then Exit;

  Result := -1;

end;

{$ENDIF}

{$IFDEF LINUX}

var

  st: TStatBuf;

begin

  if fstat(Handle, st) = 0 then

    Result := st.st_mtime

  else

    Result := -1;

end;

{$ENDIF}



function FileSetDate(const FileName: string; Age: Integer): Integer;

{$IFDEF MSWINDOWS}

var

  f: THandle;

begin

  f := FileOpen(FileName, fmOpenWrite);

  if f = THandle(-1) then

    Result := GetLastError

  else

  begin

    Result := FileSetDate(f, Age);

    FileClose(f);

  end;

end;

{$ENDIF}

{$IFDEF LINUX}

var

  ut: TUTimeBuffer;

begin

  Result := 0;

  ut.actime := Age;

  ut.modtime := Age;

  if utime(PChar(FileName), @ut) = -1 then

    Result := GetLastError;

end;

{$ENDIF}



{$IFDEF MSWINDOWS}

function FileSetDate(Handle: Integer; Age: Integer): Integer;

var

  LocalFileTime, FileTime: TFileTime;

begin

  Result := 0;

  if DosDateTimeToFileTime(LongRec(Age).Hi, LongRec(Age).Lo, LocalFileTime) and

    LocalFileTimeToFileTime(LocalFileTime, FileTime) and

    SetFileTime(Handle, nil, nil, @FileTime) then Exit;

  Result := GetLastError;

end;



function FileGetAttr(const FileName: string): Integer;

begin

  Result := GetFileAttributes(PChar(FileName));

end;



function FileSetAttr(const FileName: string; Attr: Integer): Integer;

begin

  Result := 0;

  if not SetFileAttributes(PChar(FileName), Attr) then

    Result := GetLastError;

end;

{$ENDIF}



function FileIsReadOnly(const FileName: string): Boolean;

begin

{$IFDEF MSWINDOWS}

  Result := (GetFileAttributes(PChar(FileName)) and faReadOnly) <> 0;

{$ENDIF}

{$IFDEF LINUX}

  Result := (euidaccess(PChar(FileName), R_OK) = 0) and

    (euidaccess(PChar(FileName), W_OK) <> 0);

{$ENDIF}

end;



function FileSetReadOnly(const FileName: string; ReadOnly: Boolean): Boolean;

{$IFDEF MSWINDOWS}

var

  Flags: Integer;

begin

  Result := False;

  Flags := GetFileAttributes(PChar(FileName));

  if Flags = -1 then Exit;

  if ReadOnly then

    Flags := Flags or faReadOnly

  else

    Flags := Flags and not faReadOnly;

  Result := SetFileAttributes(PChar(FileName), Flags);

end;

{$ENDIF}

{$IFDEF LINUX}

var

  st: TStatBuf;

  Flags: Integer;

begin

  Result := False;

  if stat(PChar(FileName), st) <> 0 then Exit;

  if ReadOnly then

    Flags := st.st_mode and not (S_IWUSR or S_IWGRP or S_IWOTH)

  else

    Flags := st.st_mode or (S_IWUSR or S_IWGRP or S_IWOTH);

  Result := chmod(PChar(FileName), Flags) = 0;

end;

{$ENDIF}





function FindMatchingFile(var F: TSearchRec): Integer;

{$IFDEF MSWINDOWS}

var

  LocalFileTime: TFileTime;

begin

  with F do

  begin

    while FindData.dwFileAttributes and ExcludeAttr <> 0 do

      if not FindNextFile(FindHandle, FindData) then

      begin

        Result := GetLastError;

        Exit;

      end;

    FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);

    FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi,

      LongRec(Time).Lo);

    Size := FindData.nFileSizeLow;

    Attr := FindData.dwFileAttributes;

    Name := FindData.cFileName;

  end;

  Result := 0;

end;

{$ENDIF}

{$IFDEF LINUX}

var

  PtrDirEnt: PDirEnt;

  Scratch: TDirEnt;

  StatBuf: TStatBuf;

  LinkStatBuf: TStatBuf;

  FName: string;

  Attr: Integer;

  Mode: mode_t;

begin

  Result := -1;

  PtrDirEnt := nil;

  if readdir_r(F.FindHandle, @Scratch, PtrDirEnt) <> 0 then

    Exit;

  while PtrDirEnt <> nil do

  begin

    if fnmatch(PChar(F.Pattern), PtrDirEnt.d_name, 0) = 0 then

    begin   // F.PathOnly must include trailing backslash

      FName := F.PathOnly + string(PtrDirEnt.d_name);



      if lstat(PChar(FName), StatBuf) = 0 then

      begin

        Attr := 0;

        Mode := StatBuf.st_mode;



        if S_ISDIR(Mode) then

          Attr := Attr or faDirectory

        else

        if not S_ISREG(Mode) then  // directories shouldn't be treated as system files

        begin

          if S_ISLNK(Mode) then

          begin

            Attr := Attr or faSymLink;

            if (stat(PChar(FName), LinkStatBuf) = 0) and

              S_ISDIR(LinkStatBuf.st_mode) then

                Attr := Attr or faDirectory

          end;

          Attr := Attr or faSysFile;

        end;



        if (PtrDirEnt.d_name[0] = '.') and (PtrDirEnt.d_name[1] <> #0) then

        begin

          if not ((PtrDirEnt.d_name[1] = '.') and (PtrDirEnt.d_name[2] = #0)) then

            Attr := Attr or faHidden;

        end;



        if euidaccess(PChar(FName), W_OK) <> 0 then

          Attr := Attr or faReadOnly;



        if Attr and F.ExcludeAttr = 0 then

        begin

          F.Size := StatBuf.st_size;

          F.Attr := Attr;

          F.Mode := StatBuf.st_mode;

          F.Name := PtrDirEnt.d_name;

          F.Time := StatBuf.st_mtime;

          Result := 0;

          Break;

        end;

      end;

    end;

    Result := -1;

    if readdir_r(F.FindHandle, @Scratch, PtrDirEnt) <> 0 then

      Break;

  end // End of While

end;

{$ENDIF}



function FindFirst(const Path: string; Attr: Integer;

  var  F: TSearchRec): Integer;

const

  faSpecial = faHidden or faSysFile or faDirectory;

{$IFDEF MSWINDOWS}

begin

  F.ExcludeAttr := not Attr and faSpecial;

  F.FindHandle := FindFirstFile(PChar(Path), F.FindData);

  if F.FindHandle <> INVALID_HANDLE_VALUE then

  begin

    Result := FindMatchingFile(F);

    if Result <> 0 then FindClose(F);

  end else

    Result := GetLastError;

end;

{$ENDIF}

{$IFDEF LINUX}

begin

  F.ExcludeAttr := not Attr and faSpecial;

  F.PathOnly := ExtractFilePath(Path);

  F.Pattern := ExtractFileName(Path);

  if F.PathOnly = '' then

    F.PathOnly := IncludeTrailingPathDelimiter(GetCurrentDir);



  F.FindHandle := opendir(PChar(F.PathOnly));

  if F.FindHandle <> nil then

  begin

    Result := FindMatchingFile(F);

    if Result <> 0 then

      FindClose(F);

  end

  else

    Result:= GetLastError;

end;

{$ENDIF}



function FindNext(var F: TSearchRec): Integer;

begin

{$IFDEF MSWINDOWS}

  if FindNextFile(F.FindHandle, F.FindData) then

    Result := FindMatchingFile(F) else

    Result := GetLastError;

{$ENDIF}

{$IFDEF LINUX}

  Result := FindMatchingFile(F);

{$ENDIF}

end;



procedure FindClose(var F: TSearchRec);

begin

{$IFDEF MSWINDOWS}

  if F.FindHandle <> INVALID_HANDLE_VALUE then

  begin

    Windows.FindClose(F.FindHandle);

    F.FindHandle := INVALID_HANDLE_VALUE;

  end;

{$ENDIF}

{$IFDEF LINUX}

  if F.FindHandle <> nil then

  begin

    closedir(F.FindHandle);

    F.FindHandle := nil;

  end;

{$ENDIF}

end;



function DeleteFile(const FileName: string): Boolean;

begin

{$IFDEF MSWINDOWS}

  Result := Windows.DeleteFile(PChar(FileName));

{$ENDIF}

{$IFDEF LINUX}

  Result := unlink(PChar(FileName)) <> -1;

{$ENDIF}

end;



function RenameFile(const OldName, NewName: string): Boolean;

begin

{$IFDEF MSWINDOWS}

  Result := MoveFile(PChar(OldName), PChar(NewName));

{$ENDIF}

{$IFDEF LINUX}

  Result := __rename(PChar(OldName), PChar(NewName)) = 0;

{$ENDIF}

end;



function AnsiStrLastChar(P: PChar): PChar;

var

  LastByte: Integer;

begin

  LastByte := StrLen(P) - 1;

  Result := @P[LastByte];

{$IFDEF MSWINDOWS}

  if StrByteType(P, LastByte) = mbTrailByte then Dec(Result);

{$ENDIF}

{$IFDEF LINUX}

  while StrByteType(P, Result - P) = mbTrailByte do Dec(Result);

{$ENDIF}

end;



function AnsiLastChar(const S: string): PChar;

var

  LastByte: Integer;

begin

  LastByte := Length(S);

  if LastByte <> 0 then

  begin

    while ByteType(S, LastByte) = mbTrailByte do Dec(LastByte);

    Result := @S[LastByte];

  end

  else

    Result := nil;

end;



function LastDelimiter(const Delimiters, S: string): Integer;

var

  P: PChar;

begin

  Result := Length(S);

  P := PChar(Delimiters);

  while Result > 0 do

  begin

    if (S[Result] <> #0) and (StrScan(P, S[Result]) <> nil) then

{$IFDEF MSWINDOWS}

      if (ByteType(S, Result) = mbTrailByte) then

        Dec(Result)

      else

        Exit;

{$ENDIF}

{$IFDEF LINUX}

    begin

      if (ByteType(S, Result) <> mbTrailByte) then

        Exit;

      Dec(Result);

      while ByteType(S, Result) = mbTrailByte do Dec(Result);

    end;

{$ENDIF}

    Dec(Result);

  end;

end;



function ChangeFileExt(const FileName, Extension: string): string;

var

  I: Integer;

begin

  I := LastDelimiter('.' + PathDelim + DriveDelim,Filename);

  if (I = 0) or (FileName[I] <> '.') then I := MaxInt;

  Result := Copy(FileName, 1, I - 1) + Extension;

end;



function ExtractFilePath(const FileName: string): string;

var

  I: Integer;

begin

  I := LastDelimiter(PathDelim + DriveDelim, FileName);

  Result := Copy(FileName, 1, I);

end;



function ExtractFileDir(const FileName: string): string;

var

  I: Integer;

begin

  I := LastDelimiter(PathDelim + DriveDelim, Filename);

  if (I > 1) and (FileName[I] = PathDelim) and

    (not IsDelimiter( PathDelim + DriveDelim, FileName, I-1)) then Dec(I);

  Result := Copy(FileName, 1, I);

end;



function ExtractFileDrive(const FileName: string): string;

{$IFDEF MSWINDOWS}

var

  I, J: Integer;

begin

  if (Length(FileName) >= 2) and (FileName[2] = DriveDelim) then

    Result := Copy(FileName, 1, 2)

  else if (Length(FileName) >= 2) and (FileName[1] = PathDelim) and

    (FileName[2] = PathDelim) then

  begin

    J := 0;

    I := 3;

    While (I < Length(FileName)) and (J < 2) do

    begin

      if FileName[I] = PathDelim then Inc(J);

      if J < 2 then Inc(I);

    end;

    if FileName[I] = PathDelim then Dec(I);

    Result := Copy(FileName, 1, I);

  end else Result := '';

end;

{$ENDIF}

{$IFDEF LINUX}

begin

  Result := '';  // Linux doesn't support drive letters

end;

{$ENDIF}



function ExtractFileName(const FileName: string): string;

var

  I: Integer;

begin

  I := LastDelimiter(PathDelim + DriveDelim, FileName);

  Result := Copy(FileName, I + 1, MaxInt);

end;



function ExtractFileExt(const FileName: string): string;

var

  I: Integer;

begin

  I := LastDelimiter('.' + PathDelim + DriveDelim, FileName);

  if (I > 0) and (FileName[I] = '.') then

    Result := Copy(FileName, I, MaxInt) else

    Result := '';

end;



function ExpandFileName(const FileName: string): string;

{$IFDEF MSWINDOWS}

var

  FName: PChar;

  Buffer: array[0..MAX_PATH - 1] of Char;

begin

  SetString(Result, Buffer, GetFullPathName(PChar(FileName), SizeOf(Buffer),

    Buffer, FName));

end;

{$ENDIF}



{$IFDEF LINUX}

function ExpandTilde(const InString: string): string;

var

  W: wordexp_t;

  SpacePos: Integer;

  PostSpaceStr: string;

begin

  Result := InString;

  SpacePos := AnsiPos(' ', Result);  // only expand stuff up to the first space in the filename

  if SpacePos > 0 then               // then just add the space and the rest of the string

    PostSpaceStr := Copy(Result, SpacePos, Length(Result) - (SpacePos-1));

  case wordexp(PChar(Result), W, WRDE_NOCMD) of

    0:             // success

      begin

        Result := PChar(W.we_wordv^);

        wordfree(W);

      end;

    WRDE_NOSPACE:  // error, but W may be partially allocated

      wordfree(W);

  end;

  if PostSpaceStr <> '' then

    Result := Result + PostSpaceStr;

end;



var

  I, J: Integer;

  LastWasPathDelim: Boolean;

  TempName: string;

begin

  Result := '';

  if Length(Filename) = 0 then Exit;



  if FileName[1] = PathDelim then

    TempName := FileName

  else

  begin

    TempName := FileName;

    if FileName[1] = '~' then

      TempName := ExpandTilde(TempName)

    else

      TempName := IncludeTrailingPathDelimiter(GetCurrentDir) + TempName;

  end;



  I := 1;

  J := 1;



  LastWasPathDelim := False;



  while I <= Length(TempName) do

  begin

    case TempName[I] of

      PathDelim:

        if J < I then

        begin

          // Check for consecutive 'PathDelim' characters and skip them if present

          if (I = 1) or (TempName[I - 1] <> PathDelim) then

            Result := Result + Copy(TempName, J, I - J);

          J := I;

          // Set a flag indicating that we just processed a path delimiter

          LastWasPathDelim := True;

        end;

      '.':

        begin

          // If the last character was a path delimiter then this '.' is

          // possibly a relative path modifier

          if LastWasPathDelim then

          begin

            // Check if the path ends in a '.'

            if I < Length(TempName) then

            begin

              // If the next character is another '.' then this may be a relative path

              // except if there is another '.' after that one.  In this case simply

              // treat this as just another filename.

              if (TempName[I + 1] = '.') and

                ((I + 1 >= Length(TempName)) or (TempName[I + 2] <> '.')) then

              begin

                // Don't attempt to backup past the Root dir

                if Length(Result) > 1 then

                  // For the purpose of this excercise, treat the last dir as a

                  // filename so we can use this function to remove it

                  Result := ExtractFilePath(ExcludeTrailingPathDelimiter(Result));

                J := I;

              end

              // Simply skip over and ignore any 'current dir' constrcucts, './'

              // or the remaining './' from a ../ constrcut.

              else if TempName[I + 1] = PathDelim then

              begin

                Result := IncludeTrailingPathDelimiter(Result);

                if TempName[I] in LeadBytes then

                  Inc(I, StrCharLength(@TempName[I]))

                else

                  Inc(I);

                J := I + 1;

              end else

                // If any of the above tests fail, then this is not a 'current dir' or

                // 'parent dir' construct so just clear the state and continue.

                LastWasPathDelim := False;

            end else

            begin

              // Don't let the expanded path end in a 'PathDelim' character

              Result := ExcludeTrailingPathDelimiter(Result);

              J := I + 1;

            end;

          end;

        end;

    else

      LastWasPathDelim := False;

    end;

    if TempName[I] in LeadBytes then

      Inc(I, StrCharLength(@TempName[I]))

    else

      Inc(I);

  end;

  // This will finally append what is left

  if (I - J > 1) or (TempName[I] <> PathDelim) then

    Result := Result + Copy(TempName, J, I - J);

end;

{$ENDIF}



function ExpandFileNameCase(const FileName: string;

  out MatchFound: TFilenameCaseMatch): string;

var

  SR: TSearchRec;

  FullPath, Name: string;

  Temp: Integer;

  FoundOne: Boolean;

  {$IFDEF LINUX}

  Scans: Byte;

  FirstLetter, TestLetter: string;

  {$ENDIF}

begin

  Result := ExpandFileName(FileName);

  FullPath := ExtractFilePath(Result);

  Name := ExtractFileName(Result);

  MatchFound := mkNone;



  // if FullPath is not the root directory  (portable)

  if not SameFileName(FullPath, IncludeTrailingPathDelimiter(ExtractFileDrive(FullPath))) then

  begin  // Does the path need case-sensitive work?

    Temp := FindFirst(FullPath, faAnyFile, SR);

    FindClose(SR);   // close search before going recursive

    if Temp <> 0 then

    begin

      FullPath := ExcludeTrailingPathDelimiter(FullPath);

      FullPath := ExpandFileNameCase(FullPath, MatchFound);

      if MatchFound = mkNone then

        Exit;    // if we can't find the path, we certainly can't find the file!

      FullPath := IncludeTrailingPathDelimiter(FullPath);

    end;

  end;



  // Path is validated / adjusted.  Now for the file itself

  try

    if FindFirst(FullPath + Name, faAnyFile, SR)= 0 then    // exact match on filename

    begin

      if not (MatchFound in [mkSingleMatch, mkAmbiguous]) then  // path might have been inexact

        MatchFound := mkExactMatch;

      Result := FullPath + SR.Name;

      Exit;

    end;

  finally

    FindClose(SR);

  end;



  FoundOne := False; // Windows should never get to here except for file-not-found



{$IFDEF LINUX}



{ Scan the directory.

  To minimize the number of filenames tested, scan the directory

  using upper/lowercase first letter + wildcard.

  This results in two scans of the directory (particularly on Linux) but

  vastly reduces the number of times we have to perform an expensive

  locale-charset case-insensitive string compare.  }



  // First, scan for lowercase first letter

  FirstLetter := AnsiLowerCase(Name[1]);

  for Scans := 0 to 1 do

  begin

    Temp := FindFirst(FullPath + FirstLetter + '*', faAnyFile, SR);

    while Temp = 0 do

    begin

      if AnsiSameText(SR.Name, Name) then

      begin

        if FoundOne then

        begin  // this is the second match

          MatchFound := mkAmbiguous;

          Exit;

        end

        else

        begin

          FoundOne := True;

          Result := FullPath + SR.Name;

        end;

      end;

      Temp := FindNext(SR);

    end;

    FindClose(SR);

    TestLetter := AnsiUpperCase(Name[1]);

    if TestLetter = FirstLetter then Break;

    FirstLetter := TestLetter;

  end;

{$ENDIF}



  if MatchFound <> mkAmbiguous then

  begin

    if FoundOne then

      MatchFound := mkSingleMatch

    else

      MatchFound := mkNone;

  end;

end;



{$IFDEF MSWINDOWS}

function GetUniversalName(const FileName: string): string;

type

  PNetResourceArray = ^TNetResourceArray;

  TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource;

var

  I, BufSize, NetResult: Integer;

  Count, Size: LongWord;

  Drive: Char;

  NetHandle: THandle;

  NetResources: PNetResourceArray;

  RemoteNameInfo: array[0..1023] of Byte;

begin

  Result := FileName;

  if (Win32Platform <> VER_PLATFORM_WIN32_WINDOWS) or (Win32MajorVersion > 4) then

  begin

    Size := SizeOf(RemoteNameInfo);

    if WNetGetUniversalName(PChar(FileName), UNIVERSAL_NAME_INFO_LEVEL,

      @RemoteNameInfo, Size) <> NO_ERROR then Exit;

    Result := PRemoteNameInfo(@RemoteNameInfo).lpUniversalName;

  end else

  begin

  { The following works around a bug in WNetGetUniversalName under Windows 95 }

    Drive := UpCase(FileName[1]);

    if (Drive < 'A') or (Drive > 'Z') or (Length(FileName) < 3) or

      (FileName[2] <> ':') or (FileName[3] <> '\') then

      Exit;

    if WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_DISK, 0, nil,

      NetHandle) <> NO_ERROR then Exit;

    try

      BufSize := 50 * SizeOf(TNetResource);

      GetMem(NetResources, BufSize);

      try

        while True do

        begin

          Count := $FFFFFFFF;

          Size := BufSize;

          NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);

          if NetResult = ERROR_MORE_DATA then

          begin

            BufSize := Size;

            ReallocMem(NetResources, BufSize);

            Continue;

          end;

          if NetResult <> NO_ERROR then Exit;

          for I := 0 to Count - 1 do

            with NetResources^[I] do

              if (lpLocalName <> nil) and (Drive = UpCase(lpLocalName[0])) then

              begin

                Result := lpRemoteName + Copy(FileName, 3, Length(FileName) - 2);

                Exit;

              end;

        end;

      finally

        FreeMem(NetResources, BufSize);

      end;

    finally

      WNetCloseEnum(NetHandle);

    end;

  end;

end;



function ExpandUNCFileName(const FileName: string): string;

begin

  { First get the local resource version of the file name }

  Result := ExpandFileName(FileName);

  if (Length(Result) >= 3) and (Result[2] = ':') and (Upcase(Result[1]) >= 'A')

    and (Upcase(Result[1]) <= 'Z') then

    Result := GetUniversalName(Result);

end;

{$ENDIF}

{$IFDEF LINUX}

function ExpandUNCFileName(const FileName: string): string;

begin

  Result := ExpandFileName(FileName);

end;

{$ENDIF}



function ExtractRelativePath(const BaseName, DestName: string): string;

var

  BasePath, DestPath: string;

  BaseLead, DestLead: PChar;

  BasePtr, DestPtr: PChar;



  function ExtractFilePathNoDrive(const FileName: string): string;

  begin

    Result := ExtractFilePath(FileName);

    Delete(Result, 1, Length(ExtractFileDrive(FileName)));

  end;



  function Next(var Lead: PChar): PChar;

  begin

    Result := Lead;

    if Result = nil then Exit;

    Lead := AnsiStrScan(Lead, PathDelim);

    if Lead <> nil then

    begin

      Lead^ := #0;

      Inc(Lead);

    end;

  end;



begin

  if SameFilename(ExtractFileDrive(BaseName), ExtractFileDrive(DestName)) then

  begin

    BasePath := ExtractFilePathNoDrive(BaseName);

    UniqueString(BasePath);

    DestPath := ExtractFilePathNoDrive(DestName);

    UniqueString(DestPath);

    BaseLead := Pointer(BasePath);

    BasePtr := Next(BaseLead);

    DestLead := Pointer(DestPath);

    DestPtr := Next(DestLead);

    while (BasePtr <> nil) and (DestPtr <> nil) and SameFilename(BasePtr, DestPtr) do

    begin

      BasePtr := Next(BaseLead);

      DestPtr := Next(DestLead);

    end;

    Result := '';

    while BaseLead <> nil do

    begin

      Result := Result + '..' + PathDelim;             { Do not localize }

      Next(BaseLead);

    end;

    if (DestPtr <> nil) and (DestPtr^ <> #0) then

      Result := Result + DestPtr + PathDelim;

    if DestLead <> nil then

      Result := Result + DestLead;     // destlead already has a trailing backslash

    Result := Result + ExtractFileName(DestName);

  end

  else

    Result := DestName;

end;



{$IFDEF MSWINDOWS}

function ExtractShortPathName(const FileName: string): string;

var

  Buffer: array[0..MAX_PATH - 1] of Char;

begin

  SetString(Result, Buffer,

    GetShortPathName(PChar(FileName), Buffer, SizeOf(Buffer)));

end;

{$ENDIF}



function FileSearch(const Name, DirList: string): string;

var

  I, P, L: Integer;

  C: Char;

begin

  Result := Name;

  P := 1;

  L := Length(DirList);

  while True do

  begin

    if FileExists(Result) then Exit;

    while (P <= L) and (DirList[P] = PathSep) do Inc(P);

    if P > L then Break;

    I := P;

    while (P <= L) and (DirList[P] <> PathSep) do

    begin

      if DirList[P] in LeadBytes then

        P := NextCharIndex(DirList, P)

      else

        Inc(P);

    end;

    Result := Copy(DirList, I, P - I);

    C := AnsiLastChar(Result)^;

    if (C <> DriveDelim) and (C <> PathDelim) then

      Result := Result + PathDelim;

    Result := Result + Name;

  end;

  Result := '';

end;



{$IFDEF MSWINDOWS}

// This function is used if the OS doesn't support GetDiskFreeSpaceEx

function BackfillGetDiskFreeSpaceEx(Directory: PChar; var FreeAvailable,

    TotalSpace: TLargeInteger; TotalFree: PLargeInteger): Bool; stdcall;

var

  SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters: LongWord;

  Temp: Int64;

  Dir: PChar;

begin

  if Directory <> nil then

    Dir := Directory

  else

    Dir := nil;

  Result := GetDiskFreeSpaceA(Dir, SectorsPerCluster, BytesPerSector,

    FreeClusters, TotalClusters);

  Temp := SectorsPerCluster * BytesPerSector;

  FreeAvailable := Temp * FreeClusters;

  TotalSpace := Temp * TotalClusters;

end;



function InternalGetDiskSpace(Drive: Byte;

  var TotalSpace, FreeSpaceAvailable: Int64): Bool;

var

  RootPath: array[0..4] of Char;

  RootPtr: PChar;

begin

  RootPtr := nil;

  if Drive > 0 then

  begin

    RootPath[0] := Char(Drive + $40);

    RootPath[1] := ':';

    RootPath[2] := '\';

    RootPath[3] := #0;

    RootPtr := RootPath;

  end;

  Result := GetDiskFreeSpaceEx(RootPtr, FreeSpaceAvailable, TotalSpace, nil);

end;



function DiskFree(Drive: Byte): Int64;

var

  TotalSpace: Int64;

begin

  if not InternalGetDiskSpace(Drive, TotalSpace, Result) then

    Result := -1;

end;



function DiskSize(Drive: Byte): Int64;

var

  FreeSpace: Int64;

begin

  if not InternalGetDiskSpace(Drive, Result, FreeSpace) then

    Result := -1;

end;

{$ENDIF}



function FileDateToDateTime(FileDate: Integer): TDateTime;

{$IFDEF MSWINDOWS}

begin

  Result :=

    EncodeDate(

      LongRec(FileDate).Hi shr 9 + 1980,

      LongRec(FileDate).Hi shr 5 and 15,

      LongRec(FileDate).Hi and 31) +

    EncodeTime(

      LongRec(FileDate).Lo shr 11,

      LongRec(FileDate).Lo shr 5 and 63,

      LongRec(FileDate).Lo and 31 shl 1, 0);

end;

{$ENDIF}

{$IFDEF LINUX}

var

  UT: TUnixTime;

begin

  localtime_r(@FileDate, UT);

  Result := EncodeDate(UT.tm_year + 1900, UT.tm_mon + 1, UT.tm_mday) +

              EncodeTime(UT.tm_hour, UT.tm_min, UT.tm_sec, 0);

end;

{$ENDIF}



function DateTimeToFileDate(DateTime: TDateTime): Integer;

{$IFDEF MSWINDOWS}

var

  Year, Month, Day, Hour, Min, Sec, MSec: Word;

begin

  DecodeDate(DateTime, Year, Month, Day);

  if (Year < 1980) or (Year > 2107) then Result := 0 else

  begin

    DecodeTime(DateTime, Hour, Min, Sec, MSec);

    LongRec(Result).Lo := (Sec shr 1) or (Min shl 5) or (Hour shl 11);

    LongRec(Result).Hi := Day or (Month shl 5) or ((Year - 1980) shl 9);

  end;

end;

{$ENDIF}

{$IFDEF LINUX}

var

  tm: TUnixTime;

  Year, Month, Day, Hour, Min, Sec, MSec: Word;

begin

  DecodeDate(DateTime, Year, Month, Day);

  { Valid range for 32 bit Unix time_t:  1970 through 2038  }

  if (Year < 1970) or (Year > 2038) then

    Result := 0

  else

  begin

    DecodeTime(DateTime, Hour, Min, Sec, MSec);

    FillChar(tm, sizeof(tm), 0);

    with tm do

    begin

      tm_sec := Sec;

      tm_min := Min;

      tm_hour := Hour;

      tm_mday := Day;

      tm_mon  := Month - 1;

      tm_year := Year - 1900;

      tm_isdst := -1;

    end;

    Result := mktime(tm);

  end;

end;

{$ENDIF}



function GetCurrentDir: string;

begin

  GetDir(0, Result);

end;



function SetCurrentDir(const Dir: string): Boolean;

begin

{$IFDEF MSWINDOWS}

  Result := SetCurrentDirectory(PChar(Dir));

{$ENDIF}

{$IFDEF LINUX}

  Result := __chdir(PChar(Dir)) = 0;

{$ENDIF}

end;



function CreateDir(const Dir: string): Boolean;

begin

{$IFDEF MSWINDOWS}

  Result := CreateDirectory(PChar(Dir), nil);

{$ENDIF}

{$IFDEF LINUX}

  Result := __mkdir(PChar(Dir), mode_t(-1)) = 0;

{$ENDIF}

end;



function RemoveDir(const Dir: string): Boolean;

begin

{$IFDEF MSWINDOWS}

  Result := RemoveDirectory(PChar(Dir));

{$ENDIF}

{$IFDEF LINUX}

  Result := __rmdir(PChar(Dir)) = 0;

{$ENDIF}

end;



{ PChar routines }



function StrLen(const Str: PChar): Cardinal; assembler;

asm

        MOV     EDX,EDI

        MOV     EDI,EAX

        MOV     ECX,0FFFFFFFFH

        XOR     AL,AL

        REPNE   SCASB

        MOV     EAX,0FFFFFFFEH

        SUB     EAX,ECX

        MOV     EDI,EDX

end;



function StrEnd(const Str: PChar): PChar; assembler;

asm

        MOV     EDX,EDI

        MOV     EDI,EAX

        MOV     ECX,0FFFFFFFFH

        XOR     AL,AL

        REPNE   SCASB

        LEA     EAX,[EDI-1]

        MOV     EDI,EDX

end;



function StrMove(Dest: PChar; const Source: PChar; Count: Cardinal): PChar;

begin

  Result := Dest;

  Move(Source^, Dest^, Count);

end;



function StrCopy(Dest: PChar; const Source: PChar): PChar;

asm

        PUSH    EDI

        PUSH    ESI

        MOV     ESI,EAX

        MOV     EDI,EDX

        MOV     ECX,0FFFFFFFFH

        XOR     AL,AL

        REPNE   SCASB

        NOT     ECX

        MOV     EDI,ESI

        MOV     ESI,EDX

        MOV     EDX,ECX

        MOV     EAX,EDI

        SHR     ECX,2

        REP     MOVSD

        MOV     ECX,EDX

        AND     ECX,3

        REP     MOVSB

        POP     ESI

        POP     EDI

end;



function StrECopy(Dest: PChar; const Source: PChar): PChar; assembler;

asm

        PUSH    EDI

        PUSH    ESI

        MOV     ESI,EAX

        MOV     EDI,EDX

        MOV     ECX,0FFFFFFFFH

        XOR     AL,AL

        REPNE   SCASB

        NOT     ECX

        MOV     EDI,ESI

        MOV     ESI,EDX

        MOV     EDX,ECX

        SHR     ECX,2

        REP     MOVSD

        MOV     ECX,EDX

        AND     ECX,3

        REP     MOVSB

        LEA     EAX,[EDI-1]

        POP     ESI

        POP     EDI

end;



function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; assembler;

asm

        PUSH    EDI

        PUSH    ESI

        PUSH    EBX

        MOV     ESI,EAX

        MOV     EDI,EDX

        MOV     EBX,ECX

        XOR     AL,AL

        TEST    ECX,ECX

        JZ      @@1

        REPNE   SCASB

        JNE     @@1

        INC     ECX

@@1:    SUB     EBX,ECX

        MOV     EDI,ESI

        MOV     ESI,EDX

        MOV     EDX,EDI

        MOV     ECX,EBX

        SHR     ECX,2

        REP     MOVSD

        MOV     ECX,EBX

        AND     ECX,3

        REP     MOVSB

        STOSB

        MOV     EAX,EDX

        POP     EBX

        POP     ESI

        POP     EDI

end;



function StrPCopy(Dest: PChar; const Source: string): PChar;

begin

  Result := StrLCopy(Dest, PChar(Source), Length(Source));

end;



function StrPLCopy(Dest: PChar; const Source: string;

  MaxLen: Cardinal): PChar;

begin

  Result := StrLCopy(Dest, PChar(Source), MaxLen);

end;



function StrCat(Dest: PChar; const Source: PChar): PChar;

begin

  StrCopy(StrEnd(Dest), Source);

  Result := Dest;

end;



function StrLCat(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; assembler;

asm

        PUSH    EDI

        PUSH    ESI

        PUSH    EBX

        MOV     EDI,Dest

        MOV     ESI,Source

        MOV     EBX,MaxLen

        CALL    StrEnd

        MOV     ECX,EDI

        ADD     ECX,EBX

        SUB     ECX,EAX

        JBE     @@1

        MOV     EDX,ESI

        CALL    StrLCopy

@@1:    MOV     EAX,EDI

        POP     EBX

        POP     ESI

        POP     EDI

end;



function StrComp(const Str1, Str2: PChar): Integer; assembler;

asm

        PUSH    EDI

        PUSH    ESI

        MOV     EDI,EDX

        MOV     ESI,EAX

        MOV     ECX,0FFFFFFFFH

        XOR     EAX,EAX

        REPNE   SCASB

        NOT     ECX

        MOV     EDI,EDX

        XOR     EDX,EDX

        REPE    CMPSB

        MOV     AL,[ESI-1]

        MOV     DL,[EDI-1]

        SUB     EAX,EDX

        POP     ESI

        POP     EDI

end;



function StrIComp(const Str1, Str2: PChar): Integer; assembler;

asm

        PUSH    EDI

        PUSH    ESI

        MOV     EDI,EDX

        MOV     ESI,EAX

        MOV     ECX,0FFFFFFFFH

        XOR     EAX,EAX

        REPNE   SCASB

        NOT     ECX

        MOV     EDI,EDX

        XOR     EDX,EDX

@@1:    REPE    CMPSB

        JE      @@4

        MOV     AL,[ESI-1]

        CMP     AL,'a'

        JB      @@2

        CMP     AL,'z'

        JA      @@2

        SUB     AL,20H

@@2:    MOV     DL,[EDI-1]

        CMP     DL,'a'

        JB      @@3

        CMP     DL,'z'

        JA      @@3

        SUB     DL,20H

@@3:    SUB     EAX,EDX

        JE      @@1

@@4:    POP     ESI

        POP     EDI

end;



function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; assembler;

asm

        PUSH    EDI

        PUSH    ESI

        PUSH    EBX

        MOV     EDI,EDX

        MOV     ESI,EAX

        MOV     EBX,ECX

        XOR     EAX,EAX

        OR      ECX,ECX

        JE      @@1

        REPNE   SCASB

        SUB     EBX,ECX

        MOV     ECX,EBX

        MOV     EDI,EDX

        XOR     EDX,EDX

        REPE    CMPSB

        MOV     AL,[ESI-1]

        MOV     DL,[EDI-1]

        SUB     EAX,EDX

@@1:    POP     EBX

        POP     ESI

        POP     EDI

end;



function StrLIComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; assembler;

asm

        PUSH    EDI

        PUSH    ESI

        PUSH    EBX

        MOV     EDI,EDX

        MOV     ESI,EAX

        MOV     EBX,ECX

        XOR     EAX,EAX

        OR      ECX,ECX

        JE      @@4

        REPNE   SCASB

        SUB     EBX,ECX

        MOV     ECX,EBX

        MOV     EDI,EDX

        XOR     EDX,EDX

@@1:    REPE    CMPSB

        JE      @@4

        MOV     AL,[ESI-1]

        CMP     AL,'a'

        JB      @@2

        CMP     AL,'z'

        JA      @@2

        SUB     AL,20H

@@2:    MOV     DL,[EDI-1]

        CMP     DL,'a'

        JB      @@3

        CMP     DL,'z'

        JA      @@3

        SUB     DL,20H

@@3:    SUB     EAX,EDX

        JE      @@1

@@4:    POP     EBX

        POP     ESI

        POP     EDI

end;



function StrScan(const Str: PChar; Chr: Char): PChar;

begin

  Result := Str;

  while Result^ <> Chr do

  begin

    if Result^ = #0 then

    begin

      Result := nil;

      Exit;

    end;

    Inc(Result);

  end;

end;



function StrRScan(const Str: PChar; Chr: Char): PChar;

var

  MostRecentFound: PChar;

begin

  if Chr = #0 then

    Result := StrEnd(Str)

  else

  begin

    Result := nil;



    MostRecentFound := Str;

    while True do

    begin

      while MostRecentFound^ <> Chr do

      begin

        if MostRecentFound^ = #0 then

          Exit;

        Inc(MostRecentFound);

      end;

      Result := MostRecentFound;

      Inc(MostRecentFound);

    end;

  end;

end;



function StrPos(const Str1, Str2: PChar): PChar; assembler;

asm

        PUSH    EDI

        PUSH    ESI

        PUSH    EBX

        OR      EAX,EAX

        JE      @@2

        OR      EDX,EDX

        JE      @@2

        MOV     EBX,EAX

        MOV     EDI,EDX

        XOR     AL,AL

        MOV     ECX,0FFFFFFFFH

        REPNE   SCASB

        NOT     ECX

        DEC     ECX

        JE      @@2

        MOV     ESI,ECX

        MOV     EDI,EBX

        MOV     ECX,0FFFFFFFFH

        REPNE   SCASB

        NOT     ECX

        SUB     ECX,ESI

        JBE     @@2

        MOV     EDI,EBX

        LEA     EBX,[ESI-1]

@@1:    MOV     ESI,EDX

        LODSB

        REPNE   SCASB

        JNE     @@2

        MOV     EAX,ECX

        PUSH    EDI

        MOV     ECX,EBX

        REPE    CMPSB

        POP     EDI

        MOV     ECX,EAX

        JNE     @@1

        LEA     EAX,[EDI-1]

        JMP     @@3

@@2:    XOR     EAX,EAX

@@3:    POP     EBX

        POP     ESI

        POP     EDI

end;



function StrUpper(Str: PChar): PChar; assembler;

asm

        PUSH    ESI

        MOV     ESI,Str

        MOV     EDX,Str

@@1:    LODSB

        OR      AL,AL

        JE      @@2

        CMP     AL,'a'

        JB      @@1

        CMP     AL,'z'

        JA      @@1

        SUB     AL,20H

        MOV     [ESI-1],AL

        JMP     @@1

@@2:    XCHG    EAX,EDX

        POP     ESI

end;



function StrLower(Str: PChar): PChar; assembler;

asm

        PUSH    ESI

        MOV     ESI,Str

        MOV     EDX,Str

@@1:    LODSB

        OR      AL,AL

        JE      @@2

        CMP     AL,'A'

        JB      @@1

        CMP     AL,'Z'

        JA      @@1

        ADD     AL,20H

        MOV     [ESI-1],AL

        JMP     @@1

@@2:    XCHG    EAX,EDX

        POP     ESI

end;



function StrPas(const Str: PChar): string;

begin

  Result := Str;

end;



function StrAlloc(Size: Cardinal): PChar;

begin

  Inc(Size, SizeOf(Cardinal));

  GetMem(Result, Size);

  Cardinal(Pointer(Result)^) := Size;

  Inc(Result, SizeOf(Cardinal));

end;



function StrBufSize(const Str: PChar): Cardinal;

var

  P: PChar;

begin

  P := Str;

  Dec(P, SizeOf(Cardinal));

  Result := Cardinal(Pointer(P)^) - SizeOf(Cardinal);

end;



function StrNew(const Str: PChar): PChar;

var

  Size: Cardinal;

begin

  if Str = nil then Result := nil else

  begin

    Size := StrLen(Str) + 1;

    Result := StrMove(StrAlloc(Size), Str, Size);

  end;

end;



procedure StrDispose(Str: PChar);

begin

  if Str <> nil then

  begin

    Dec(Str, SizeOf(Cardinal));

    FreeMem(Str, Cardinal(Pointer(Str)^));

  end;

end;



{ String formatting routines }



procedure FormatError(ErrorCode: Integer; Format: PChar; FmtLen: Cardinal);

const

  FormatErrorStrs: array[0..1] of string = (

    SInvalidFormat, SArgumentMissing);

var

  Buffer: array[0..31] of Char;

begin

  if FmtLen > 31 then FmtLen := 31;

  if StrByteType(Format, FmtLen-1) = mbLeadByte then Dec(FmtLen);

  StrMove(Buffer, Format, FmtLen);

  Buffer[FmtLen] := #0;

  ConvertErrorFmt(FormatErrorStrs[ErrorCode], [PChar(@Buffer)]);

end;



procedure FormatVarToStr(var S: string; const V: Variant);

begin

  {if Assigned(System.VarToLStr) then

    System.is(S, V)

  else

    System.Error(reVarInvalidOp); }

    S:='';

end;



procedure FormatClearStr(var S: string);

begin

  S := '';

end;



function FloatToTextEx(BufferArg: PChar; const Value; ValueType: TFloatValue;

  Format: TFloatFormat; Precision, Digits: Integer;

  const FormatSettings: TFormatSettings): Integer;

begin

  Result := FloatToText(BufferArg, Value, ValueType, Format, Precision, Digits,

    FormatSettings);

end;



function FormatBuf(var Buffer; BufLen: Cardinal; const Format;

  FmtLen: Cardinal; const Args: array of const): Cardinal;

var

  ArgIndex, Width, Prec: Integer;

  BufferOrg, FormatOrg, FormatPtr, TempStr: PChar;

  JustFlag: Byte;

  StrBuf: array[0..64] of Char;

  TempAnsiStr: string;

  SaveGOT: Integer;

{ in: eax <-> Buffer }

{ in: edx <-> BufLen }

{ in: ecx <-> Format }



asm

        PUSH    EBX

        PUSH    ESI

        PUSH    EDI

        MOV     EDI,EAX

        MOV     ESI,ECX

{$IFDEF PIC}

        PUSH    ECX

        CALL    GetGOT

        POP     ECX

{$ELSE}

        XOR     EAX,EAX

{$ENDIF}

        MOV     SaveGOT,EAX

        ADD     ECX,FmtLen

        MOV     BufferOrg,EDI

        XOR     EAX,EAX

        MOV     ArgIndex,EAX

        MOV     TempStr,EAX

        MOV     TempAnsiStr,EAX



@Loop:

        OR      EDX,EDX

        JE      @Done



@NextChar:

        CMP     ESI,ECX

        JE      @Done

        LODSB

        CMP     AL,'%'

        JE      @Format



@StoreChar:

        STOSB

        DEC     EDX

        JNE     @NextChar



@Done:

        MOV     EAX,EDI

        SUB     EAX,BufferOrg

        JMP     @Exit



@Format:

        CMP     ESI,ECX

        JE      @Done

        LODSB

        CMP     AL,'%'

        JE      @StoreChar

        LEA     EBX,[ESI-2]

        MOV     FormatOrg,EBX

@A0:    MOV     JustFlag,AL

        CMP     AL,'-'

        JNE     @A1

        CMP     ESI,ECX

        JE      @Done

        LODSB

@A1:    CALL    @Specifier

        CMP     AL,':'

        JNE     @A2

        MOV     ArgIndex,EBX

        CMP     ESI,ECX

        JE      @Done

        LODSB

        JMP     @A0



@A2:    MOV     Width,EBX

        MOV     EBX,-1

        CMP     AL,'.'

        JNE     @A3

        CMP     ESI,ECX

        JE      @Done

        LODSB

        CALL    @Specifier

@A3:    MOV     Prec,EBX

        MOV     FormatPtr,ESI

        PUSH    ECX

        PUSH    EDX



        CALL    @Convert



        POP     EDX

        MOV     EBX,Width

        SUB     EBX,ECX        //(* ECX <=> number of characters output *)

        JAE     @A4            //(*         jump -> output smaller than width *)

        XOR     EBX,EBX



@A4:    CMP     JustFlag,'-'

        JNE     @A6

        SUB     EDX,ECX

        JAE     @A5

        ADD     ECX,EDX

        XOR     EDX,EDX



@A5:    REP     MOVSB



@A6:    XCHG    EBX,ECX

        SUB     EDX,ECX

        JAE     @A7

        ADD     ECX,EDX

        XOR     EDX,EDX

@A7:    MOV     AL,' '

        REP     STOSB

        XCHG    EBX,ECX

        SUB     EDX,ECX

        JAE     @A8

        ADD     ECX,EDX

        XOR     EDX,EDX

@A8:    REP     MOVSB

        CMP     TempStr,0

        JE      @A9

        PUSH    EDX

        LEA     EAX,TempStr

//      PUSH    EBX                   // GOT setup unnecessary for

//      MOV     EBX, SaveGOT          // same-unit calls to Pascal procedures

        CALL    FormatClearStr

//        POP     EBX

        POP     EDX

@A9:    POP     ECX

        MOV     ESI,FormatPtr

        JMP     @Loop



@Specifier:

        XOR     EBX,EBX

        CMP     AL,'*'

        JE      @B3

@B1:    CMP     AL,'0'

        JB      @B5

        CMP     AL,'9'

        JA      @B5

        IMUL    EBX,EBX,10

        SUB     AL,'0'

        MOVZX   EAX,AL

        ADD     EBX,EAX

        CMP     ESI,ECX

        JE      @B2

        LODSB

        JMP     @B1

@B2:    POP     EAX

        JMP     @Done

@B3:    MOV     EAX,ArgIndex

        CMP     EAX,Args.Integer[-4]

        JG      @B4

        INC     ArgIndex

        MOV     EBX,Args

        CMP     [EBX+EAX*8].Byte[4],vtInteger

        MOV     EBX,[EBX+EAX*8]

        JE      @B4

        XOR     EBX,EBX

@B4:    CMP     ESI,ECX

        JE      @B2

        LODSB

@B5:    RET



@Convert:

        AND     AL,0DFH

        MOV     CL,AL

        MOV     EAX,1

        MOV     EBX,ArgIndex

        CMP     EBX,Args.Integer[-4]

        JG      @ErrorExit

        INC     ArgIndex

        MOV     ESI,Args

        LEA     ESI,[ESI+EBX*8]

        MOV     EAX,[ESI].Integer[0]       // TVarRec.data

        MOVZX   EDX,[ESI].Byte[4]          // TVarRec.VType

{$IFDEF PIC}

        MOV     EBX, SaveGOT

        ADD     EBX, offset @CvtVector

        MOV     EBX, [EBX+EDX*4]

        ADD     EBX, SaveGOT

        JMP     EBX

{$ELSE}

        JMP     @CvtVector.Pointer[EDX*4]

{$ENDIF}



@CvtVector:

        DD      @CvtInteger                // vtInteger

        DD      @CvtBoolean                // vtBoolean

        DD      @CvtChar                   // vtChar

        DD      @CvtExtended               // vtExtended

        DD      @CvtShortStr               // vtString

        DD      @CvtPointer                // vtPointer

        DD      @CvtPChar                  // vtPChar

        DD      @CvtObject                 // vtObject

        DD      @CvtClass                  // vtClass

        DD      @CvtWideChar               // vtWideChar

        DD      @CvtPWideChar              // vtPWideChar

        DD      @CvtAnsiStr                // vtAnsiString

        DD      @CvtCurrency               // vtCurrency

        DD      @CvtVariant                // vtVariant

        DD      @CvtInterface              // vtInterface

        DD      @CvtWideString             // vtWideString

        DD      @CvtInt64                  // vtInt64



@CvtBoolean:

@CvtObject:

@CvtClass:

@CvtWideChar:

@CvtInterface:

@CvtError:

        XOR     EAX,EAX



@ErrorExit:

        CALL    @ClearTmpAnsiStr

        MOV     EDX,FormatOrg

        MOV     ECX,FormatPtr

        SUB     ECX,EDX

{$IFDEF PC_MAPPED_EXCEPTIONS}

        //  Because of all the assembly code here, we can't call a routine

        //  that throws an exception if it looks like we're still on the

        //  stack.  The static disassembler cannot give sufficient unwind

        //  frame info to unwind the confusion that is generated from the

        //  assembly code above.  So before we throw the exception, we

        //  go to some lengths to excise ourselves from the stack chain.

        //  We were passed 12 bytes of parameters on the stack, and we have

        //  to make sure that we get rid of those, too.

        MOV     EBX, SaveGOT

        MOV     ESP, EBP        // Ditch everthing to the frame

        MOV     EBP, [ESP + 4]  // Get the return addr

        MOV     [ESP + 16], EBP // Move the ret addr up in the stack

        POP     EBP             // Ditch the rest of the frame

        ADD     ESP, 12         // Ditch the space that was taken by params

        JMP     FormatError     // Off to FormatErr

{$ELSE}

        MOV     EBX, SaveGOT

        CALL    FormatError

{$ENDIF}

        // The above call raises an exception and does not return



@CvtInt64:

        // CL  <= format character

        // EAX <= address of int64

        // EBX <= TVarRec.VType



        LEA     ESI,StrBuf[32]

        MOV     EDX, Prec

        CMP     EDX, 32

        JBE     @I64_1           // zero padded field width > buffer => no padding

        XOR     EDX, EDX

@I64_1: MOV     EBX, ECX

        SUB     CL, 'D'

        JZ      CvtInt64         // branch predict backward jump taken

        MOV     ECX, 16

        CMP     BL, 'X'

        JE      CvtInt64

        MOV     ECX, 10

        CMP     BL, 'U'

        JE      CvtInt64

        JMP     @CvtError



{        LEA     EBX, TempInt64       // (input is array of const; save original)

        MOV     EDX, [EAX]

        MOV     [EBX], EDX

        MOV     EDX, [EAX + 4]

        MOV     [EBX + 4], EDX



        // EBX <= address of TempInt64



        CMP     CL,'D'

        JE      @DecI64

        CMP     CL,'U'

        JE      @DecI64_2

        CMP     CL,'X'

        JNE     @CvtError



@HexI64:

        MOV     ECX,16               // hex divisor

        JMP     @CvtI64



@DecI64:

        TEST    DWORD PTR [EBX + 4], $80000000      // sign bit set?

        JE      @DecI64_2            //   no -> bypass '-' output



        NEG     DWORD PTR [EBX]      // negate lo-order, then hi-order

        ADC     DWORD PTR [EBX+4], 0

        NEG     DWORD PTR [EBX+4]



        CALL    @DecI64_2



        MOV     AL,'-'

        INC     ECX

        DEC     ESI

        MOV     [ESI],AL

        RET



@DecI64_2:                           // unsigned int64 output

        MOV     ECX,10               // decimal divisor



@CvtI64:

        LEA     ESI,StrBuf[32]



@CvtI64_1:

        PUSH    EBX

        PUSH    ECX                  // save radix

        PUSH    0

        PUSH    ECX                  // radix divisor (10 or 16 only)

        MOV     EAX, [EBX]

        MOV     EDX, [EBX + 4]

        MOV     EBX, SaveGOT

        CALL    System.@_llumod

        POP     ECX                  // saved radix

        POP     EBX



        XCHG    EAX, EDX             // lo-value to EDX for character output

        ADD     DL,'0'

        CMP     DL,'0'+10

        JB      @CvtI64_2



        ADD     DL,('A'-'0')-10



@CvtI64_2:

        DEC     ESI

        MOV     [ESI],DL



        PUSH    EBX

        PUSH    ECX                  // save radix

        PUSH    0

        PUSH    ECX                  // radix divisor (10 or 16 only)

        MOV     EAX, [EBX]           // value := value DIV radix

        MOV     EDX, [EBX + 4]

        MOV     EBX, SaveGOT

        CALL    System.@_lludiv

        POP     ECX                  // saved radix

        POP     EBX

        MOV     [EBX], EAX

        MOV     [EBX + 4], EDX

        OR      EAX,EDX              // anything left to output?

        JNE     @CvtI64_1            //   no jump => EDX:EAX = 0



        LEA     ECX,StrBuf[32]

        SUB     ECX,ESI

        MOV     EDX,Prec

        CMP     EDX,16

        JBE     @CvtI64_3

        RET



@CvtI64_3:

        SUB     EDX,ECX

        JBE     @CvtI64_5

        ADD     ECX,EDX

        MOV     AL,'0'



@CvtI64_4:

        DEC     ESI

        MOV     [ESI],AL

        DEC     EDX

        JNE     @CvtI64_4



@CvtI64_5:

        RET

}

////////////////////////////////////////////////



@CvtInteger:

        LEA     ESI,StrBuf[16]

        MOV     EDX, Prec

        MOV     EBX, ECX

        CMP     EDX, 16

        JBE     @C1             // zero padded field width > buffer => no padding

        XOR     EDX, EDX

@C1:    SUB     CL, 'D'

        JZ      CvtInt          // branch predict backward jump taken

        MOV     ECX, 16

        CMP     BL, 'X'

        JE      CvtInt

        MOV     ECX, 10

        CMP     BL, 'U'

        JE      CvtInt

        JMP     @CvtError



{        CMP     CL,'D'

        JE      @C1

        CMP     CL,'U'

        JE      @C2

        CMP     CL,'X'

        JNE     @CvtError

        MOV     ECX,16

        JMP     @CvtLong

@C1:    OR      EAX,EAX

        JNS     @C2

        NEG     EAX

        CALL    @C2

        MOV     AL,'-'

        INC     ECX

        DEC     ESI

        MOV     [ESI],AL

        RET

@C2:    MOV     ECX,10



@CvtLong:

        LEA     ESI,StrBuf[16]

@D1:    XOR     EDX,EDX

        DIV     ECX

        ADD     DL,'0'

        CMP     DL,'0'+10

        JB      @D2

        ADD     DL,('A'-'0')-10

@D2:    DEC     ESI

        MOV     [ESI],DL

        OR      EAX,EAX

        JNE     @D1

        LEA     ECX,StrBuf[16]

        SUB     ECX,ESI

        MOV     EDX,Prec

        CMP     EDX,16

        JBE     @D3

        RET

@D3:    SUB     EDX,ECX

        JBE     @D5

        ADD     ECX,EDX

        MOV     AL,'0'

@D4:    DEC     ESI

        MOV     [ESI],AL

        DEC     EDX

        JNE     @D4

@D5:    RET

}

@CvtChar:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ECX,1

        RET



@CvtVariant:

        CMP     CL,'S'

        JNE     @CvtError

        CMP     [EAX].TVarData.VType,varNull

        JBE     @CvtEmptyStr

        MOV     EDX,EAX

        LEA     EAX,TempStr

//      PUSH    EBX                   // GOT setup unnecessary for

//      MOV     EBX, SaveGOT          // same-unit calls to Pascal procedures

        CALL    FormatVarToStr

//        POP     EBX

        MOV     ESI,TempStr

        JMP     @CvtStrRef



@CvtEmptyStr:

        XOR     ECX,ECX

        RET



@CvtShortStr:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ESI,EAX

        LODSB

        MOVZX   ECX,AL

        JMP     @CvtStrLen



@CvtPWideChar:

        MOV    ESI,OFFSET System.@LStrFromPWChar

        JMP    @CvtWideThing



@CvtWideString:

        MOV    ESI,OFFSET System.@LStrFromWStr



@CvtWideThing:

        ADD    ESI, SaveGOT

{$IFDEF PIC}

        MOV    ESI, [ESI]

{$ENDIF}

        CMP    CL,'S'

        JNE    @CvtError

        MOV    EDX,EAX

        LEA    EAX,TempAnsiStr

        PUSH   EBX

        MOV    EBX, SaveGOT

        CALL   ESI

        POP    EBX

        MOV    ESI,TempAnsiStr

        MOV    EAX,ESI

        JMP    @CvtStrRef



@CvtAnsiStr:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ESI,EAX



@CvtStrRef:

        OR      ESI,ESI

        JE      @CvtEmptyStr

        MOV     ECX,[ESI-4]



@CvtStrLen:

        CMP     ECX,Prec

        JA      @E1

        RET

@E1:    MOV     ECX,Prec

        RET



@CvtPChar:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ESI,EAX

        PUSH    EDI

        MOV     EDI,EAX

        XOR     AL,AL

        MOV     ECX,Prec

        JECXZ   @F1

        REPNE   SCASB

        JNE     @F1

        DEC     EDI

@F1:    MOV     ECX,EDI

        SUB     ECX,ESI

        POP     EDI

        RET



@CvtPointer:

        CMP     CL,'P'

        JNE     @CvtError

        MOV     EDX,8

        MOV     ECX,16

        LEA     ESI,StrBuf[16]

        JMP     CvtInt



@CvtCurrency:

        MOV     BH,fvCurrency

        JMP     @CvtFloat



@CvtExtended:

        MOV     BH,fvExtended



@CvtFloat:

        MOV     ESI,EAX

        MOV     BL,ffGeneral

        CMP     CL,'G'

        JE      @G2

        MOV     BL,ffExponent

        CMP     CL,'E'

        JE      @G2

        MOV     BL,ffFixed

        CMP     CL,'F'

        JE      @G1

        MOV     BL,ffNumber

        CMP     CL,'N'

        JE      @G1

        CMP     CL,'M'

        JNE     @CvtError

        MOV     BL,ffCurrency

@G1:    MOV     EAX,18

        MOV     EDX,Prec

        CMP     EDX,EAX

        JBE     @G3

        MOV     EDX,2

        CMP     CL,'M'

        JNE     @G3

        MOVZX   EDX,CurrencyDecimals

        JMP     @G3

@G2:    MOV     EAX,Prec

        MOV     EDX,3

        CMP     EAX,18

        JBE     @G3

        MOV     EAX,15

@G3:    PUSH    EBX

        PUSH    EAX

        PUSH    EDX

        LEA     EAX,StrBuf

        MOV     EDX,ESI

        MOVZX   ECX,BH

        MOV     EBX, SaveGOT

        CALL    FloatToText

        MOV     ECX,EAX

        LEA     ESI,StrBuf

        RET



@ClearTmpAnsiStr:

        PUSH    EBX

        PUSH    EAX

        LEA     EAX,TempAnsiStr

        MOV     EBX, SaveGOT

        CALL    System.@LStrClr

        POP     EAX

        POP     EBX

        RET



@Exit:

        CALL    @ClearTmpAnsiStr

        POP     EDI

        POP     ESI

        POP     EBX

end;



function FormatBuf(var Buffer; BufLen: Cardinal; const Format;

  FmtLen: Cardinal; const Args: array of const;

  const FormatSettings: TFormatSettings): Cardinal;

var

  ArgIndex, Width, Prec: Integer;

  BufferOrg, FormatOrg, FormatPtr, TempStr: PChar;

  JustFlag: Byte;

  StrBuf: array[0..64] of Char;

  TempAnsiStr: string;

  SaveGOT: Integer;

{ in: eax <-> Buffer }

{ in: edx <-> BufLen }

{ in: ecx <-> Format }



asm

        PUSH    EBX

        PUSH    ESI

        PUSH    EDI

        MOV     EDI,EAX

        MOV     ESI,ECX

{$IFDEF PIC}

        PUSH    ECX

        CALL    GetGOT

        POP     ECX

{$ELSE}

        XOR     EAX,EAX

{$ENDIF}

        MOV     SaveGOT,EAX

        ADD     ECX,FmtLen

        MOV     BufferOrg,EDI

        XOR     EAX,EAX

        MOV     ArgIndex,EAX

        MOV     TempStr,EAX

        MOV     TempAnsiStr,EAX



@Loop:

        OR      EDX,EDX

        JE      @Done



@NextChar:

        CMP     ESI,ECX

        JE      @Done

        LODSB

        CMP     AL,'%'

        JE      @Format



@StoreChar:

        STOSB

        DEC     EDX

        JNE     @NextChar



@Done:

        MOV     EAX,EDI

        SUB     EAX,BufferOrg

        JMP     @Exit



@Format:

        CMP     ESI,ECX

        JE      @Done

        LODSB

        CMP     AL,'%'

        JE      @StoreChar

        LEA     EBX,[ESI-2]

        MOV     FormatOrg,EBX

@A0:    MOV     JustFlag,AL

        CMP     AL,'-'

        JNE     @A1

        CMP     ESI,ECX

        JE      @Done

        LODSB

@A1:    CALL    @Specifier

        CMP     AL,':'

        JNE     @A2

        MOV     ArgIndex,EBX

        CMP     ESI,ECX

        JE      @Done

        LODSB

        JMP     @A0



@A2:    MOV     Width,EBX

        MOV     EBX,-1

        CMP     AL,'.'

        JNE     @A3

        CMP     ESI,ECX

        JE      @Done

        LODSB

        CALL    @Specifier

@A3:    MOV     Prec,EBX

        MOV     FormatPtr,ESI

        PUSH    ECX

        PUSH    EDX



        CALL    @Convert



        POP     EDX

        MOV     EBX,Width

        SUB     EBX,ECX        //(* ECX <=> number of characters output *)

        JAE     @A4            //(*         jump -> output smaller than width *)

        XOR     EBX,EBX



@A4:    CMP     JustFlag,'-'

        JNE     @A6

        SUB     EDX,ECX

        JAE     @A5

        ADD     ECX,EDX

        XOR     EDX,EDX



@A5:    REP     MOVSB



@A6:    XCHG    EBX,ECX

        SUB     EDX,ECX

        JAE     @A7

        ADD     ECX,EDX

        XOR     EDX,EDX

@A7:    MOV     AL,' '

        REP     STOSB

        XCHG    EBX,ECX

        SUB     EDX,ECX

        JAE     @A8

        ADD     ECX,EDX

        XOR     EDX,EDX

@A8:    REP     MOVSB

        CMP     TempStr,0

        JE      @A9

        PUSH    EDX

        LEA     EAX,TempStr

//      PUSH    EBX                   // GOT setup unnecessary for

//      MOV     EBX, SaveGOT          // same-unit calls to Pascal procedures

        CALL    FormatClearStr

//        POP     EBX

        POP     EDX

@A9:    POP     ECX

        MOV     ESI,FormatPtr

        JMP     @Loop



@Specifier:

        XOR     EBX,EBX

        CMP     AL,'*'

        JE      @B3

@B1:    CMP     AL,'0'

        JB      @B5

        CMP     AL,'9'

        JA      @B5

        IMUL    EBX,EBX,10

        SUB     AL,'0'

        MOVZX   EAX,AL

        ADD     EBX,EAX

        CMP     ESI,ECX

        JE      @B2

        LODSB

        JMP     @B1

@B2:    POP     EAX

        JMP     @Done

@B3:    MOV     EAX,ArgIndex

        CMP     EAX,Args.Integer[-4]

        JG      @B4

        INC     ArgIndex

        MOV     EBX,Args

        CMP     [EBX+EAX*8].Byte[4],vtInteger

        MOV     EBX,[EBX+EAX*8]

        JE      @B4

        XOR     EBX,EBX

@B4:    CMP     ESI,ECX

        JE      @B2

        LODSB

@B5:    RET



@Convert:

        AND     AL,0DFH

        MOV     CL,AL

        MOV     EAX,1

        MOV     EBX,ArgIndex

        CMP     EBX,Args.Integer[-4]

        JG      @ErrorExit

        INC     ArgIndex

        MOV     ESI,Args

        LEA     ESI,[ESI+EBX*8]

        MOV     EAX,[ESI].Integer[0]       // TVarRec.data

        MOVZX   EDX,[ESI].Byte[4]          // TVarRec.VType

{$IFDEF PIC}

        MOV     EBX, SaveGOT

        ADD     EBX, offset @CvtVector

        MOV     EBX, [EBX+EDX*4]

        ADD     EBX, SaveGOT

        JMP     EBX

{$ELSE}

        JMP     @CvtVector.Pointer[EDX*4]

{$ENDIF}



@CvtVector:

        DD      @CvtInteger                // vtInteger

        DD      @CvtBoolean                // vtBoolean

        DD      @CvtChar                   // vtChar

        DD      @CvtExtended               // vtExtended

        DD      @CvtShortStr               // vtString

        DD      @CvtPointer                // vtPointer

        DD      @CvtPChar                  // vtPChar

        DD      @CvtObject                 // vtObject

        DD      @CvtClass                  // vtClass

        DD      @CvtWideChar               // vtWideChar

        DD      @CvtPWideChar              // vtPWideChar

        DD      @CvtAnsiStr                // vtAnsiString

        DD      @CvtCurrency               // vtCurrency

        DD      @CvtVariant                // vtVariant

        DD      @CvtInterface              // vtInterface

        DD      @CvtWideString             // vtWideString

        DD      @CvtInt64                  // vtInt64



@CvtBoolean:

@CvtObject:

@CvtClass:

@CvtWideChar:

@CvtInterface:

@CvtError:

        XOR     EAX,EAX



@ErrorExit:

        CALL    @ClearTmpAnsiStr

        MOV     EDX,FormatOrg

        MOV     ECX,FormatPtr

        SUB     ECX,EDX

{$IFDEF PC_MAPPED_EXCEPTIONS}

        //  Because of all the assembly code here, we can't call a routine

        //  that throws an exception if it looks like we're still on the

        //  stack.  The static disassembler cannot give sufficient unwind

        //  frame info to unwind the confusion that is generated from the

        //  assembly code above.  So before we throw the exception, we

        //  go to some lengths to excise ourselves from the stack chain.

        //  We were passed 12 bytes of parameters on the stack, and we have

        //  to make sure that we get rid of those, too.

        MOV     EBX, SaveGOT

        MOV     ESP, EBP        // Ditch everthing to the frame

        MOV     EBP, [ESP + 4]  // Get the return addr

        MOV     [ESP + 16], EBP // Move the ret addr up in the stack

        POP     EBP             // Ditch the rest of the frame

        ADD     ESP, 12         // Ditch the space that was taken by params

        JMP     FormatError     // Off to FormatErr

{$ELSE}

        MOV     EBX, SaveGOT

        CALL    FormatError

{$ENDIF}

        // The above call raises an exception and does not return



@CvtInt64:

        // CL  <= format character

        // EAX <= address of int64

        // EBX <= TVarRec.VType



        LEA     ESI,StrBuf[32]

        MOV     EDX, Prec

        CMP     EDX, 32

        JBE     @I64_1           // zero padded field width > buffer => no padding

        XOR     EDX, EDX

@I64_1: MOV     EBX, ECX

        SUB     CL, 'D'

        JZ      CvtInt64         // branch predict backward jump taken

        MOV     ECX, 16

        CMP     BL, 'X'

        JE      CvtInt64

        MOV     ECX, 10

        CMP     BL, 'U'

        JE      CvtInt64

        JMP     @CvtError

////////////////////////////////////////////////



@CvtInteger:

        LEA     ESI,StrBuf[16]

        MOV     EDX, Prec

        MOV     EBX, ECX

        CMP     EDX, 16

        JBE     @C1             // zero padded field width > buffer => no padding

        XOR     EDX, EDX

@C1:    SUB     CL, 'D'

        JZ      CvtInt          // branch predict backward jump taken

        MOV     ECX, 16

        CMP     BL, 'X'

        JE      CvtInt

        MOV     ECX, 10

        CMP     BL, 'U'

        JE      CvtInt

        JMP     @CvtError



@CvtChar:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ECX,1

        RET



@CvtVariant:

        CMP     CL,'S'

        JNE     @CvtError

        CMP     [EAX].TVarData.VType,varNull

        JBE     @CvtEmptyStr

        MOV     EDX,EAX

        LEA     EAX,TempStr

//      PUSH    EBX                   // GOT setup unnecessary for

//      MOV     EBX, SaveGOT          // same-unit calls to Pascal procedures

        CALL    FormatVarToStr

//        POP     EBX

        MOV     ESI,TempStr

        JMP     @CvtStrRef



@CvtEmptyStr:

        XOR     ECX,ECX

        RET



@CvtShortStr:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ESI,EAX

        LODSB

        MOVZX   ECX,AL

        JMP     @CvtStrLen



@CvtPWideChar:

        MOV    ESI,OFFSET System.@LStrFromPWChar

        JMP    @CvtWideThing



@CvtWideString:

        MOV    ESI,OFFSET System.@LStrFromWStr



@CvtWideThing:

        ADD    ESI, SaveGOT

{$IFDEF PIC}

        MOV    ESI, [ESI]

{$ENDIF}

        CMP    CL,'S'

        JNE    @CvtError

        MOV    EDX,EAX

        LEA    EAX,TempAnsiStr

        PUSH   EBX

        MOV    EBX, SaveGOT

        CALL   ESI

        POP    EBX

        MOV    ESI,TempAnsiStr

        MOV    EAX,ESI

        JMP    @CvtStrRef



@CvtAnsiStr:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ESI,EAX



@CvtStrRef:

        OR      ESI,ESI

        JE      @CvtEmptyStr

        MOV     ECX,[ESI-4]



@CvtStrLen:

        CMP     ECX,Prec

        JA      @E1

        RET

@E1:    MOV     ECX,Prec

        RET



@CvtPChar:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ESI,EAX

        PUSH    EDI

        MOV     EDI,EAX

        XOR     AL,AL

        MOV     ECX,Prec

        JECXZ   @F1

        REPNE   SCASB

        JNE     @F1

        DEC     EDI

@F1:    MOV     ECX,EDI

        SUB     ECX,ESI

        POP     EDI

        RET



@CvtPointer:

        CMP     CL,'P'

        JNE     @CvtError

        MOV     EDX,8

        MOV     ECX,16

        LEA     ESI,StrBuf[16]

        JMP     CvtInt



@CvtCurrency:

        MOV     BH,fvCurrency

        JMP     @CvtFloat



@CvtExtended:

        MOV     BH,fvExtended



@CvtFloat:

        MOV     ESI,EAX

        MOV     BL,ffGeneral

        CMP     CL,'G'

        JE      @G2

        MOV     BL,ffExponent

        CMP     CL,'E'

        JE      @G2

        MOV     BL,ffFixed

        CMP     CL,'F'

        JE      @G1

        MOV     BL,ffNumber

        CMP     CL,'N'

        JE      @G1

        CMP     CL,'M'

        JNE     @CvtError

        MOV     BL,ffCurrency

@G1:    MOV     EAX,18

        MOV     EDX,Prec

        CMP     EDX,EAX

        JBE     @G3

        MOV     EDX,2

        CMP     CL,'M'

        JNE     @G3

        MOV     EDX,FormatSettings

        MOVZX   EDX,[EDX].TFormatSettings.CurrencyDecimals

        JMP     @G3

@G2:    MOV     EAX,Prec

        MOV     EDX,3

        CMP     EAX,18

        JBE     @G3

        MOV     EAX,15

@G3:    PUSH    EBX

        PUSH    EAX

        PUSH    EDX

        MOV     EDX,[FormatSettings]

        PUSH    EDX

        LEA     EAX,StrBuf

        MOV     EDX,ESI

        MOVZX   ECX,BH

        MOV     EBX, SaveGOT

        CALL    FloatToTextEx

        MOV     ECX,EAX

        LEA     ESI,StrBuf

        RET



@ClearTmpAnsiStr:

        PUSH    EBX

        PUSH    EAX

        LEA     EAX,TempAnsiStr

        MOV     EBX, SaveGOT

        CALL    System.@LStrClr

        POP     EAX

        POP     EBX

        RET



@Exit:

        CALL    @ClearTmpAnsiStr

        POP     EDI

        POP     ESI

        POP     EBX

end;



function StrFmt(Buffer, Format: PChar; const Args: array of const): PChar;

begin

  if (Buffer <> nil) and (Format <> nil) then

  begin

    Buffer[FormatBuf(Buffer^, MaxInt, Format^, StrLen(Format), Args)] := #0;

    Result := Buffer;

  end

  else

    Result := nil;

end;



function StrFmt(Buffer, Format: PChar; const Args: array of const;

  const FormatSettings: TFormatSettings): PChar;

begin

  if (Buffer <> nil) and (Format <> nil) then

  begin

    Buffer[FormatBuf(Buffer^, MaxInt, Format^, StrLen(Format), Args,

      FormatSettings)] := #0;

    Result := Buffer;

  end

  else

    Result := nil;

end;



function StrLFmt(Buffer: PChar; MaxBufLen: Cardinal; Format: PChar;

  const Args: array of const): PChar;

begin

  if (Buffer <> nil) and (Format <> nil) then

  begin

    Buffer[FormatBuf(Buffer^, MaxBufLen, Format^, StrLen(Format), Args)] := #0;

    Result := Buffer;

  end

  else

    Result := nil;

end;



function StrLFmt(Buffer: PChar; MaxBufLen: Cardinal; Format: PChar;

  const Args: array of const; const FormatSettings: TFormatSettings): PChar;

begin

  if (Buffer <> nil) and (Format <> nil) then

  begin

    Buffer[FormatBuf(Buffer^, MaxBufLen, Format^, StrLen(Format), Args,

      FormatSettings)] := #0;

    Result := Buffer;

  end

  else

    Result := nil;

end;



function Format(const Format: string; const Args: array of const): string;

begin

  FmtStr(Result, Format, Args);

end;



function Format(const Format: string; const Args: array of const;

  const FormatSettings: TFormatSettings): string;

begin

  FmtStr(Result, Format, Args, FormatSettings);

end;



procedure FmtStr(var Result: string; const Format: string;

  const Args: array of const);

var

  Len, BufLen: Integer;

  Buffer: array[0..4095] of Char;

begin

  BufLen := SizeOf(Buffer);

  if Length(Format) < (sizeof(Buffer) - (sizeof(Buffer) div 4)) then

    Len := FormatBuf(Buffer, sizeof(Buffer) - 1, Pointer(Format)^, Length(Format), Args)

  else

  begin

    BufLen := Length(Format);

    Len := BufLen;

  end;

  if Len >= BufLen - 1 then

  begin

    while Len >= BufLen - 1 do

    begin

      Inc(BufLen, BufLen);

      Result := '';          // prevent copying of existing data, for speed

      SetLength(Result, BufLen);

      Len := FormatBuf(Pointer(Result)^, BufLen - 1, Pointer(Format)^,

      Length(Format), Args);

    end;

    SetLength(Result, Len);

  end

  else

    SetString(Result, Buffer, Len);

end;



procedure FmtStr(var Result: string; const Format: string;

  const Args: array of const; const FormatSettings: TFormatSettings);

var

  Len, BufLen: Integer;

  Buffer: array[0..4095] of Char;

begin

  BufLen := SizeOf(Buffer);

  if Length(Format) < (sizeof(Buffer) - (sizeof(Buffer) div 4)) then

    Len := FormatBuf(Buffer, sizeof(Buffer) - 1, Pointer(Format)^, Length(Format),

      Args, FormatSettings)

  else

  begin

    BufLen := Length(Format);

    Len := BufLen;

  end;

  if Len >= BufLen - 1 then

  begin

    while Len >= BufLen - 1 do

    begin

      Inc(BufLen, BufLen);

      Result := '';          // prevent copying of existing data, for speed

      SetLength(Result, BufLen);

      Len := FormatBuf(Pointer(Result)^, BufLen - 1, Pointer(Format)^,

        Length(Format), Args, FormatSettings);

    end;

    SetLength(Result, Len);

  end

  else

    SetString(Result, Buffer, Len);

end;



procedure WideFormatError(ErrorCode: Integer; Format: PWideChar;

  FmtLen: Cardinal);

var

  WideFormat: WideString;

  FormatText: string;

begin

  SetLength(WideFormat, FmtLen);

  SetString(WideFormat, Format, FmtLen);

  FormatText := WideFormat;

  FormatError(ErrorCode, PChar(FormatText), FmtLen);

end;



procedure WideFormatVarToStr(var S: WideString; const V: TVarData);

begin

  {if Assigned(System.VarToWStrProc) then

    System.VarToWStrProc(S, V)

  else

    System.Error(reVarInvalidOp);    }

    S:='Cutted';

end;



function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format;

  FmtLen: Cardinal; const Args: array of const): Cardinal;

var

  ArgIndex, Width, Prec: Integer;

  BufferOrg, FormatOrg, FormatPtr: PWideChar;

  JustFlag: WideChar;

  StrBuf: array[0..64] of WideChar;

  TempWideStr: WideString;

  SaveGOT: Integer;

{ in: eax <-> Buffer }

{ in: edx <-> BufLen }

{ in: ecx <-> Format }



asm

        PUSH    EBX

        PUSH    ESI

        PUSH    EDI

        MOV     EDI,EAX

        MOV     ESI,ECX

{$IFDEF PIC}

        CALL    GetGOT

{$ELSE}

        XOR     EAX,EAX

{$ENDIF}

        MOV     SaveGOT,EAX

        MOV     ECX,FmtLen

        LEA     ECX,[ECX*2+ESI]

        MOV     BufferOrg,EDI

        XOR     EAX,EAX

        MOV     ArgIndex,EAX

        MOV     TempWideStr,EAX



@Loop:

        OR      EDX,EDX

        JE      @Done



@NextChar:

        CMP     ESI,ECX

        JE      @Done

        LODSW

        CMP     AX,'%'

        JE      @Format



@StoreChar:

        STOSW

        DEC     EDX

        JNE     @NextChar



@Done:

        MOV     EAX,EDI

        SUB     EAX,BufferOrg

        SHR     EAX,1

        JMP     @Exit



@Format:

        CMP     ESI,ECX

        JE      @Done

        LODSW

        CMP     AX,'%'

        JE      @StoreChar

        LEA     EBX,[ESI-4]

        MOV     FormatOrg,EBX

@A0:    MOV     JustFlag,AX

        CMP     AX,'-'

        JNE     @A1

        CMP     ESI,ECX

        JE      @Done

        LODSW

@A1:    CALL    @Specifier

        CMP     AX,':'

        JNE     @A2

        MOV     ArgIndex,EBX

        CMP     ESI,ECX

        JE      @Done

        LODSW

        JMP     @A0



@A2:    MOV     Width,EBX

        MOV     EBX,-1

        CMP     AX,'.'

        JNE     @A3

        CMP     ESI,ECX

        JE      @Done

        LODSW

        CALL    @Specifier

@A3:    MOV     Prec,EBX

        MOV     FormatPtr,ESI

        PUSH    ECX

        PUSH    EDX



        CALL    @Convert



        POP     EDX

        MOV     EBX,Width

        SUB     EBX,ECX        //(* ECX <=> number of characters output *)

        JAE     @A4            //(*         jump -> output smaller than width *)

        XOR     EBX,EBX



@A4:    CMP     JustFlag,'-'

        JNE     @A6

        SUB     EDX,ECX

        JAE     @A5

        ADD     ECX,EDX

        XOR     EDX,EDX



@A5:    REP     MOVSW



@A6:    XCHG    EBX,ECX

        SUB     EDX,ECX

        JAE     @A7

        ADD     ECX,EDX

        XOR     EDX,EDX

@A7:    MOV     AX,' '

        REP     STOSW

        XCHG    EBX,ECX

        SUB     EDX,ECX

        JAE     @A8

        ADD     ECX,EDX

        XOR     EDX,EDX

@A8:    REP     MOVSW

        POP     ECX

        MOV     ESI,FormatPtr

        JMP     @Loop



@Specifier:

        XOR     EBX,EBX

        CMP     AX,'*'

        JE      @B3

@B1:    CMP     AX,'0'

        JB      @B5

        CMP     AX,'9'

        JA      @B5

        IMUL    EBX,EBX,10

        SUB     AX,'0'

        MOVZX   EAX,AX

        ADD     EBX,EAX

        CMP     ESI,ECX

        JE      @B2

        LODSW

        JMP     @B1

@B2:    POP     EAX

        JMP     @Done

@B3:    MOV     EAX,ArgIndex

        CMP     EAX,Args.Integer[-4]

        JG      @B4

        INC     ArgIndex

        MOV     EBX,Args

        CMP     [EBX+EAX*8].Byte[4],vtInteger

        MOV     EBX,[EBX+EAX*8]

        JE      @B4

        XOR     EBX,EBX

@B4:    CMP     ESI,ECX

        JE      @B2

        LODSW

@B5:    RET



@Convert:

        AND     AL,0DFH

        MOV     CL,AL

        MOV     EAX,1

        MOV     EBX,ArgIndex

        CMP     EBX,Args.Integer[-4]

        JG      @ErrorExit

        INC     ArgIndex

        MOV     ESI,Args

        LEA     ESI,[ESI+EBX*8]

        MOV     EAX,[ESI].Integer[0]       // TVarRec.data

        MOVZX   EDX,[ESI].Byte[4]          // TVarRec.VType

{$IFDEF PIC}

        MOV     EBX, SaveGOT

        ADD     EBX, offset @CvtVector

        MOV     EBX, [EBX+EDX*4]

        ADD     EBX, SaveGOT

        JMP     EBX

{$ELSE}

        JMP     @CvtVector.Pointer[EDX*4]

{$ENDIF}



@CvtVector:

        DD      @CvtInteger                // vtInteger

        DD      @CvtBoolean                // vtBoolean

        DD      @CvtChar                   // vtChar

        DD      @CvtExtended               // vtExtended

        DD      @CvtShortStr               // vtString

        DD      @CvtPointer                // vtPointer

        DD      @CvtPChar                  // vtPChar

        DD      @CvtObject                 // vtObject

        DD      @CvtClass                  // vtClass

        DD      @CvtWideChar               // vtWideChar

        DD      @CvtPWideChar              // vtPWideChar

        DD      @CvtAnsiStr                // vtAnsiString

        DD      @CvtCurrency               // vtCurrency

        DD      @CvtVariant                // vtVariant

        DD      @CvtInterface              // vtInterface

        DD      @CvtWideString             // vtWideString

        DD      @CvtInt64                  // vtInt64



@CvtBoolean:

@CvtObject:

@CvtClass:

@CvtInterface:

@CvtError:

        XOR     EAX,EAX



@ErrorExit:

        CALL    @ClearTmpWideStr

        MOV     EDX,FormatOrg

        MOV     ECX,FormatPtr

        SUB     ECX,EDX

        SHR     ECX,1

        MOV     EBX, SaveGOT

{$IFDEF PC_MAPPED_EXCEPTIONS}

        //  Because of all the assembly code here, we can't call a routine

        //  that throws an exception if it looks like we're still on the

        //  stack.  The static disassembler cannot give sufficient unwind

        //  frame info to unwind the confusion that is generated from the

        //  assembly code above.  So before we throw the exception, we

        //  go to some lengths to excise ourselves from the stack chain.

        //  We were passed 12 bytes of parameters on the stack, and we have

        //  to make sure that we get rid of those, too.

        MOV     ESP, EBP        // Ditch everthing to the frame

        MOV     EBP, [ESP + 4]  // Get the return addr

        MOV     [ESP + 16], EBP // Move the ret addr up in the stack

        POP     EBP             // Ditch the rest of the frame

        ADD     ESP, 12         // Ditch the space that was taken by params

        JMP     WideFormatError // Off to FormatErr

{$ELSE}

        CALL    WideFormatError

{$ENDIF}

        // The above call raises an exception and does not return



@CvtInt64:

        // CL  <= format character

        // EAX <= address of int64

        // EBX <= TVarRec.VType



        LEA     ESI,StrBuf[64]

        MOV     EDX, Prec

        CMP     EDX, 32

        JBE     @I64_1           // zero padded field width > buffer => no padding

        XOR     EDX, EDX

@I64_1: MOV     EBX, ECX

        SUB     CL, 'D'

        JZ      CvtInt64W         // branch predict backward jump taken

        MOV     ECX, 16

        CMP     BL, 'X'

        JE      CvtInt64W

        MOV     ECX, 10

        CMP     BL, 'U'

        JE      CvtInt64W

        JMP     @CvtError



@CvtInteger:

        LEA     ESI,StrBuf[32]

        MOV     EDX, Prec

        MOV     EBX, ECX

        CMP     EDX, 16

        JBE     @C1             // zero padded field width > buffer => no padding

        XOR     EDX, EDX

@C1:    SUB     CL, 'D'

        JZ      CvtIntW          // branch predict backward jump taken

        MOV     ECX, 16

        CMP     BL, 'X'

        JE      CvtIntW

        MOV     ECX, 10

        CMP     BL, 'U'

        JE      CvtIntW

        JMP     @CvtError



@CvtChar:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     EAX,ESI

        MOV     ECX,1

        JMP     @CvtAnsiThingLen



@CvtWideChar:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ECX,1

        RET



@CvtVariant:

        CMP     CL,'S'

        JNE     @CvtError

        CMP     [EAX].TVarData.VType,varNull

        JBE     @CvtEmptyStr

        MOV     EDX,EAX

        LEA     EAX,TempWideStr

        CALL    WideFormatVarToStr

        MOV     ESI,TempWideStr

        JMP     @CvtWideStrRef



@CvtEmptyStr:

        XOR     ECX,ECX

        RET



@CvtShortStr:

        CMP     CL,'S'

        JNE     @CvtError

        MOVZX   ECX,BYTE PTR [EAX]

        INC     EAX



@CvtAnsiThingLen:

        MOV     ESI,OFFSET System.@WStrFromPCharLen

        JMP     @CvtAnsiThing



@CvtPChar:

        MOV    ESI,OFFSET System.@WStrFromPChar

        JMP    @CvtAnsiThingTest



@CvtAnsiStr:

        MOV    ESI,OFFSET System.@WStrFromLStr



@CvtAnsiThingTest:

        CMP    CL,'S'

        JNE    @CvtError



@CvtAnsiThing:

        ADD    ESI, SaveGOT

{$IFDEF PIC}

        MOV    ESI, [ESI]

{$ENDIF}

        MOV    EDX,EAX

        LEA    EAX,TempWideStr

        PUSH   EBX

        MOV    EBX, SaveGOT

        CALL   ESI

        POP    EBX

        MOV    ESI,TempWideStr

        JMP    @CvtWideStrRef



@CvtWideString:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ESI,EAX



@CvtWideStrRef:

        OR      ESI,ESI

        JE      @CvtEmptyStr

        MOV     ECX,[ESI-4]

        SHR     ECX,1



@CvtWideStrLen:

        CMP     ECX,Prec

        JA      @E1

        RET

@E1:    MOV     ECX,Prec

        RET



@CvtPWideChar:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ESI,EAX

        PUSH    EDI

        MOV     EDI,EAX

        XOR     EAX,EAX

        MOV     ECX,Prec

        JECXZ   @F1

        REPNE   SCASW

        JNE     @F1

        DEC     EDI

        DEC     EDI

@F1:    MOV     ECX,EDI

        SUB     ECX,ESI

        SHR     ECX,1

        POP     EDI

        RET



@CvtPointer:

        CMP     CL,'P'

        JNE     @CvtError

        MOV     EDX,8

        MOV     ECX,16

        LEA     ESI,StrBuf[32]

        JMP     CvtInt



@CvtCurrency:

        MOV     BH,fvCurrency

        JMP     @CvtFloat



@CvtExtended:

        MOV     BH,fvExtended



@CvtFloat:

        MOV     ESI,EAX

        MOV     BL,ffGeneral

        CMP     CL,'G'

        JE      @G2

        MOV     BL,ffExponent

        CMP     CL,'E'

        JE      @G2

        MOV     BL,ffFixed

        CMP     CL,'F'

        JE      @G1

        MOV     BL,ffNumber

        CMP     CL,'N'

        JE      @G1

        CMP     CL,'M'

        JNE     @CvtError

        MOV     BL,ffCurrency

@G1:    MOV     EAX,18

        MOV     EDX,Prec

        CMP     EDX,EAX

        JBE     @G3

        MOV     EDX,2

        CMP     CL,'M'

        JNE     @G3

        MOVZX   EDX,CurrencyDecimals

        JMP     @G3

@G2:    MOV     EAX,Prec

        MOV     EDX,3

        CMP     EAX,18

        JBE     @G3

        MOV     EAX,15

@G3:    PUSH    EBX

        PUSH    EAX

        PUSH    EDX

        LEA     EAX,StrBuf

        MOV     EDX,ESI

        MOVZX   ECX,BH

        MOV     EBX, SaveGOT

        CALL    FloatToText

        MOV     ECX,EAX

        LEA     EDX,StrBuf

        LEA     EAX,TempWideStr

        MOV     EBX, SaveGOT

        CALL    System.@WStrFromPCharLen

        MOV     ESI,TempWideStr

        OR      ESI,ESI

        JE      @CvtEmptyStr

        MOV     ECX,[ESI-4]

        SHR     ECX,1

        RET



@ClearTmpWideStr:

        PUSH    EBX

        PUSH    EAX

        LEA     EAX,TempWideStr

        MOV     EBX, SaveGOT

        CALL    System.@WStrClr

        POP     EAX

        POP     EBX

        RET



@Exit:

        CALL    @ClearTmpWideStr

        POP     EDI

        POP     ESI

        POP     EBX

end;



function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format;

  FmtLen: Cardinal; const Args: array of const;

  const FormatSettings: TFormatSettings): Cardinal;

var

  ArgIndex, Width, Prec: Integer;

  BufferOrg, FormatOrg, FormatPtr: PWideChar;

  JustFlag: WideChar;

  StrBuf: array[0..64] of WideChar;

  TempWideStr: WideString;

  SaveGOT: Integer;

{ in: eax <-> Buffer }

{ in: edx <-> BufLen }

{ in: ecx <-> Format }



asm

        PUSH    EBX

        PUSH    ESI

        PUSH    EDI

        MOV     EDI,EAX

        MOV     ESI,ECX

{$IFDEF PIC}

        CALL    GetGOT

{$ELSE}

        XOR     EAX,EAX

{$ENDIF}

        MOV     SaveGOT,EAX

        MOV     ECX,FmtLen

        LEA     ECX,[ECX*2+ESI]

        MOV     BufferOrg,EDI

        XOR     EAX,EAX

        MOV     ArgIndex,EAX

        MOV     TempWideStr,EAX



@Loop:

        OR      EDX,EDX

        JE      @Done



@NextChar:

        CMP     ESI,ECX

        JE      @Done

        LODSW

        CMP     AX,'%'

        JE      @Format



@StoreChar:

        STOSW

        DEC     EDX

        JNE     @NextChar



@Done:

        MOV     EAX,EDI

        SUB     EAX,BufferOrg

        SHR     EAX,1

        JMP     @Exit



@Format:

        CMP     ESI,ECX

        JE      @Done

        LODSW

        CMP     AX,'%'

        JE      @StoreChar

        LEA     EBX,[ESI-4]

        MOV     FormatOrg,EBX

@A0:    MOV     JustFlag,AX

        CMP     AX,'-'

        JNE     @A1

        CMP     ESI,ECX

        JE      @Done

        LODSW

@A1:    CALL    @Specifier

        CMP     AX,':'

        JNE     @A2

        MOV     ArgIndex,EBX

        CMP     ESI,ECX

        JE      @Done

        LODSW

        JMP     @A0



@A2:    MOV     Width,EBX

        MOV     EBX,-1

        CMP     AX,'.'

        JNE     @A3

        CMP     ESI,ECX

        JE      @Done

        LODSW

        CALL    @Specifier

@A3:    MOV     Prec,EBX

        MOV     FormatPtr,ESI

        PUSH    ECX

        PUSH    EDX



        CALL    @Convert



        POP     EDX

        MOV     EBX,Width

        SUB     EBX,ECX        //(* ECX <=> number of characters output *)

        JAE     @A4            //(*         jump -> output smaller than width *)

        XOR     EBX,EBX



@A4:    CMP     JustFlag,'-'

        JNE     @A6

        SUB     EDX,ECX

        JAE     @A5

        ADD     ECX,EDX

        XOR     EDX,EDX



@A5:    REP     MOVSW



@A6:    XCHG    EBX,ECX

        SUB     EDX,ECX

        JAE     @A7

        ADD     ECX,EDX

        XOR     EDX,EDX

@A7:    MOV     AX,' '

        REP     STOSW

        XCHG    EBX,ECX

        SUB     EDX,ECX

        JAE     @A8

        ADD     ECX,EDX

        XOR     EDX,EDX

@A8:    REP     MOVSW

        POP     ECX

        MOV     ESI,FormatPtr

        JMP     @Loop



@Specifier:

        XOR     EBX,EBX

        CMP     AX,'*'

        JE      @B3

@B1:    CMP     AX,'0'

        JB      @B5

        CMP     AX,'9'

        JA      @B5

        IMUL    EBX,EBX,10

        SUB     AX,'0'

        MOVZX   EAX,AX

        ADD     EBX,EAX

        CMP     ESI,ECX

        JE      @B2

        LODSW

        JMP     @B1

@B2:    POP     EAX

        JMP     @Done

@B3:    MOV     EAX,ArgIndex

        CMP     EAX,Args.Integer[-4]

        JG      @B4

        INC     ArgIndex

        MOV     EBX,Args

        CMP     [EBX+EAX*8].Byte[4],vtInteger

        MOV     EBX,[EBX+EAX*8]

        JE      @B4

        XOR     EBX,EBX

@B4:    CMP     ESI,ECX

        JE      @B2

        LODSW

@B5:    RET



@Convert:

        AND     AL,0DFH

        MOV     CL,AL

        MOV     EAX,1

        MOV     EBX,ArgIndex

        CMP     EBX,Args.Integer[-4]

        JG      @ErrorExit

        INC     ArgIndex

        MOV     ESI,Args

        LEA     ESI,[ESI+EBX*8]

        MOV     EAX,[ESI].Integer[0]       // TVarRec.data

        MOVZX   EDX,[ESI].Byte[4]          // TVarRec.VType

{$IFDEF PIC}

        MOV     EBX, SaveGOT

        ADD     EBX, offset @CvtVector

        MOV     EBX, [EBX+EDX*4]

        ADD     EBX, SaveGOT

        JMP     EBX

{$ELSE}

        JMP     @CvtVector.Pointer[EDX*4]

{$ENDIF}



@CvtVector:

        DD      @CvtInteger                // vtInteger

        DD      @CvtBoolean                // vtBoolean

        DD      @CvtChar                   // vtChar

        DD      @CvtExtended               // vtExtended

        DD      @CvtShortStr               // vtString

        DD      @CvtPointer                // vtPointer

        DD      @CvtPChar                  // vtPChar

        DD      @CvtObject                 // vtObject

        DD      @CvtClass                  // vtClass

        DD      @CvtWideChar               // vtWideChar

        DD      @CvtPWideChar              // vtPWideChar

        DD      @CvtAnsiStr                // vtAnsiString

        DD      @CvtCurrency               // vtCurrency

        DD      @CvtVariant                // vtVariant

        DD      @CvtInterface              // vtInterface

        DD      @CvtWideString             // vtWideString

        DD      @CvtInt64                  // vtInt64



@CvtBoolean:

@CvtObject:

@CvtClass:

@CvtInterface:

@CvtError:

        XOR     EAX,EAX



@ErrorExit:

        CALL    @ClearTmpWideStr

        MOV     EDX,FormatOrg

        MOV     ECX,FormatPtr

        SUB     ECX,EDX

        SHR     ECX,1

        MOV     EBX, SaveGOT

{$IFDEF PC_MAPPED_EXCEPTIONS}

        //  Because of all the assembly code here, we can't call a routine

        //  that throws an exception if it looks like we're still on the

        //  stack.  The static disassembler cannot give sufficient unwind

        //  frame info to unwind the confusion that is generated from the

        //  assembly code above.  So before we throw the exception, we

        //  go to some lengths to excise ourselves from the stack chain.

        //  We were passed 12 bytes of parameters on the stack, and we have

        //  to make sure that we get rid of those, too.

        MOV     ESP, EBP        // Ditch everthing to the frame

        MOV     EBP, [ESP + 4]  // Get the return addr

        MOV     [ESP + 16], EBP // Move the ret addr up in the stack

        POP     EBP             // Ditch the rest of the frame

        ADD     ESP, 12         // Ditch the space that was taken by params

        JMP     WideFormatError // Off to FormatErr

{$ELSE}

        CALL    WideFormatError

{$ENDIF}

        // The above call raises an exception and does not return



@CvtInt64:

        // CL  <= format character

        // EAX <= address of int64

        // EBX <= TVarRec.VType



        LEA     ESI,StrBuf[64]

        MOV     EDX,Prec

        CMP     EDX, 32

        JBE     @I64_1           // zero padded field width > buffer => no padding

        XOR     EDX, EDX

@I64_1: MOV     EBX, ECX

        SUB     CL, 'D'

        JZ      CvtInt64W         // branch predict backward jump taken

        MOV     ECX,16

        CMP     BL, 'X'

        JE      CvtInt64W

        MOV     ECX, 10

        CMP     BL, 'U'

        JE      CvtInt64W

        JMP     @CvtError



@CvtInteger:

        LEA     ESI,StrBuf[32]

        MOV     EDX,Prec

        MOV     EBX, ECX

        CMP     EDX,16

        JBE     @C1             // zero padded field width > buffer => no padding

        XOR     EDX, EDX

@C1:    SUB     CL, 'D'

        JZ      CvtIntW          // branch predict backward jump taken

        MOV     ECX, 16

        CMP     BL, 'X'

        JE      CvtIntW

        MOV     ECX, 10

        CMP     BL, 'U'

        JE      CvtIntW

        JMP     @CvtError



@CvtChar:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     EAX,ESI

        MOV     ECX,1

        JMP     @CvtAnsiThingLen



@CvtWideChar:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ECX,1

        RET



@CvtVariant:

        CMP     CL,'S'

        JNE     @CvtError

        CMP     [EAX].TVarData.VType,varNull

        JBE     @CvtEmptyStr

        MOV     EDX,EAX

        LEA     EAX,TempWideStr

        CALL    WideFormatVarToStr

        MOV     ESI,TempWideStr

        JMP     @CvtWideStrRef



@CvtEmptyStr:

        XOR     ECX,ECX

        RET



@CvtShortStr:

        CMP     CL,'S'

        JNE     @CvtError

        MOVZX   ECX,BYTE PTR [EAX]

        INC     EAX



@CvtAnsiThingLen:

        MOV     ESI,OFFSET System.@WStrFromPCharLen

        JMP     @CvtAnsiThing



@CvtPChar:

        MOV    ESI,OFFSET System.@WStrFromPChar

        JMP    @CvtAnsiThingTest



@CvtAnsiStr:

        MOV    ESI,OFFSET System.@WStrFromLStr



@CvtAnsiThingTest:

        CMP    CL,'S'

        JNE    @CvtError



@CvtAnsiThing:

        ADD    ESI, SaveGOT

{$IFDEF PIC}

        MOV    ESI, [ESI]

{$ENDIF}

        MOV    EDX,EAX

        LEA    EAX,TempWideStr

        PUSH   EBX

        MOV    EBX, SaveGOT

        CALL   ESI

        POP    EBX

        MOV    ESI,TempWideStr

        JMP    @CvtWideStrRef



@CvtWideString:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ESI,EAX



@CvtWideStrRef:

        OR      ESI,ESI

        JE      @CvtEmptyStr

        MOV     ECX,[ESI-4]

        SHR     ECX,1



@CvtWideStrLen:

        CMP     ECX,Prec

        JA      @E1

        RET

@E1:    MOV     ECX,Prec

        RET



@CvtPWideChar:

        CMP     CL,'S'

        JNE     @CvtError

        MOV     ESI,EAX

        PUSH    EDI

        MOV     EDI,EAX

        XOR     EAX,EAX

        MOV     ECX,Prec

        JECXZ   @F1

        REPNE   SCASW

        JNE     @F1

        DEC     EDI

        DEC     EDI

@F1:    MOV     ECX,EDI

        SUB     ECX,ESI

        SHR     ECX,1

        POP     EDI

        RET



@CvtPointer:

        CMP     CL,'P'

        JNE     @CvtError

        MOV     EDX,8

        MOV     ECX,16

        LEA     ESI,StrBuf[32]

        JMP     CvtInt



@CvtCurrency:

        MOV     BH,fvCurrency

        JMP     @CvtFloat



@CvtExtended:

        MOV     BH,fvExtended



@CvtFloat:

        MOV     ESI,EAX

        MOV     BL,ffGeneral

        CMP     CL,'G'

        JE      @G2

        MOV     BL,ffExponent

        CMP     CL,'E'

        JE      @G2

        MOV     BL,ffFixed

        CMP     CL,'F'

        JE      @G1

        MOV     BL,ffNumber

        CMP     CL,'N'

        JE      @G1

        CMP     CL,'M'

        JNE     @CvtError

        MOV     BL,ffCurrency

@G1:    MOV     EAX,18

        MOV     EDX,Prec

        CMP     EDX,EAX

        JBE     @G3

        MOV     EDX,2

        CMP     CL,'M'

        JNE     @G3

        MOV     EDX,FormatSettings

        MOVZX   EDX,[EDX].TFormatSettings.CurrencyDecimals

        JMP     @G3

@G2:    MOV     EAX,Prec

        MOV     EDX,3

        CMP     EAX,18

        JBE     @G3

        MOV     EAX,15

@G3:    PUSH    EBX

        PUSH    EAX

        PUSH    EDX

        MOV     EDX,[FormatSettings]

        PUSH    EDX

        LEA     EAX,StrBuf

        MOV     EDX,ESI

        MOVZX   ECX,BH

        MOV     EBX, SaveGOT

        CALL    FloatToTextEx

        MOV     ECX,EAX

        LEA     EDX,StrBuf

        LEA     EAX,TempWideStr

        MOV     EBX, SaveGOT

        CALL    System.@WStrFromPCharLen

        MOV     ESI,TempWideStr

        OR      ESI,ESI

        JE      @CvtEmptyStr

        MOV     ECX,[ESI-4]

        SHR     ECX,1

        RET



@ClearTmpWideStr:

        PUSH    EBX

        PUSH    EAX

        LEA     EAX,TempWideStr

        MOV     EBX, SaveGOT

        CALL    System.@WStrClr

        POP     EAX

        POP     EBX

        RET



@Exit:

        CALL    @ClearTmpWideStr

        POP     EDI

        POP     ESI

        POP     EBX

end;



procedure WideFmtStr(var Result: WideString; const Format: WideString;

  const Args: array of const);

const

  BufSize = 2048;

var

  Len, BufLen: Integer;

  Buffer: array[0..BufSize-1] of WideChar;

begin

  if Length(Format) < (BufSize - (BufSize div 4)) then

  begin

    BufLen := BufSize;

    Len := WideFormatBuf(Buffer, BufSize - 1, Pointer(Format)^, Length(Format), Args);

    if Len < BufLen - 1 then

    begin

      SetString(Result, Buffer, Len);

      Exit;

    end;

  end

  else

  begin

    BufLen := Length(Format);

    Len := BufLen;

  end;



  while Len >= BufLen - 1 do

  begin

    Inc(BufLen, BufLen);

    Result := '';          // prevent copying of existing data, for speed

    SetLength(Result, BufLen);

    Len := WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(Format)^,

      Length(Format), Args);

  end;

  SetLength(Result, Len);

end;



procedure WideFmtStr(var Result: WideString; const Format: WideString;

  const Args: array of const; const FormatSettings: TFormatSettings);

const

  BufSize = 2048;

var

  Len, BufLen: Integer;

  Buffer: array[0..BufSize-1] of WideChar;

begin

  if Length(Format) < (BufSize - (BufSize div 4)) then

  begin

    BufLen := BufSize;

    Len := WideFormatBuf(Buffer, BufSize - 1, Pointer(Format)^,

      Length(Format), Args, FormatSettings);

    if Len < BufLen - 1 then

    begin

      SetString(Result, Buffer, Len);

      Exit;

    end;

  end

  else

  begin

    BufLen := Length(Format);

    Len := BufLen;

  end;



  while Len >= BufLen - 1 do

  begin

    Inc(BufLen, BufLen);

    Result := '';          // prevent copying of existing data, for speed

    SetLength(Result, BufLen);

    Len := WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(Format)^,

      Length(Format), Args, FormatSettings);

  end;

  SetLength(Result, Len);

end;



function WideFormat(const Format: WideString; const Args: array of const): WideString;

begin

  WideFmtStr(Result, Format, Args);

end;



function WideFormat(const Format: WideString; const Args: array of const;

  const FormatSettings: TFormatSettings): WideString;

begin

  WideFmtStr(Result, Format, Args, FormatSettings);

end;



{ Floating point conversion routines }



const

  // 1E18 as a 64-bit integer

  Const1E18Lo = $0A7640000;

  Const1E18Hi = $00DE0B6B3;

  FCon1E18: Extended = 1E18;

  DCon10: Integer = 10;



procedure PutExponent;

// Store exponent

// In   AL  = Exponent character ('E' or 'e')

//      AH  = Positive sign character ('+' or 0)

//      BL  = Zero indicator

//      ECX = Minimum number of digits (0..4)

//      EDX = Exponent

//      EDI = Destination buffer

asm

        PUSH    ESI

{$IFDEF PIC}

        PUSH    EAX

        PUSH    ECX

        CALL    GetGOT

        MOV     ESI,EAX

        POP     ECX

        POP     EAX

{$ELSE}

        XOR     ESI,ESI

{$ENDIF}

        STOSB

        OR      BL,BL

        JNE     @@0

        XOR     EDX,EDX

        JMP     @@1

@@0:    OR      EDX,EDX

        JGE     @@1

        MOV     AL,'-'

        NEG     EDX

        JMP     @@2

@@1:    OR      AH,AH

        JE      @@3

        MOV     AL,AH

@@2:    STOSB

@@3:    XCHG    EAX,EDX

        PUSH    EAX

        MOV     EBX,ESP

@@4:    XOR     EDX,EDX

        DIV     [ESI].DCon10

        ADD     DL,'0'

        MOV     [EBX],DL

        INC     EBX

        DEC     ECX

        OR      EAX,EAX

        JNE     @@4

        OR      ECX,ECX

        JG      @@4

@@5:    DEC     EBX

        MOV     AL,[EBX]

        STOSB

        CMP     EBX,ESP

        JNE     @@5

        POP     EAX

        POP     ESI

end;



function FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue;

  Format: TFloatFormat; Precision, Digits: Integer): Integer;

var

  Buffer: Cardinal;

  FloatRec: TFloatRec;

  SaveGOT: Integer;

  DecimalSep: Char;

  ThousandSep: Char;

  CurrencyStr: Pointer;

  CurrFmt: Byte;

  NegCurrFmt: Byte;

asm

        PUSH    EDI

        PUSH    ESI

        PUSH    EBX

        MOV     Buffer,EAX

{$IFDEF PIC}

        PUSH    ECX

        CALL    GetGOT

        MOV     SaveGOT,EAX

        MOV     ECX,[EAX].OFFSET DecimalSeparator

        MOV     CL,[ECX]

        MOV     DecimalSep,CL

        MOV     ECX,[EAX].OFFSET ThousandSeparator

        MOV     CL,[ECX].Byte

        MOV     ThousandSep,CL

        MOV     ECX,[EAX].OFFSET CurrencyString

        MOV     ECX,[ECX].Integer

        MOV     CurrencyStr,ECX

        MOV     ECX,[EAX].OFFSET CurrencyFormat

        MOV     CL,[ECX].Byte

        MOV     CurrFmt,CL

        MOV     ECX,[EAX].OFFSET NegCurrFormat

        MOV     CL,[ECX].Byte

        MOV     NegCurrFmt,CL

        POP     ECX

{$ELSE}

        MOV     AL,DecimalSeparator

        MOV     DecimalSep,AL

        MOV     AL,ThousandSeparator

        MOV     ThousandSep,AL

        MOV     EAX,CurrencyString

        MOV     CurrencyStr,EAX

        MOV     AL,CurrencyFormat

        MOV     CurrFmt,AL

        MOV     AL,NegCurrFormat

        MOV     NegCurrFmt,AL

        MOV     SaveGOT,0

{$ENDIF}

        MOV     EAX,19

        CMP     CL,fvExtended

        JNE     @@2

        MOV     EAX,Precision

        CMP     EAX,2

        JGE     @@1

        MOV     EAX,2

@@1:    CMP     EAX,18

        JLE     @@2

        MOV     EAX,18

@@2:    MOV     Precision,EAX

        PUSH    EAX

        MOV     EAX,9999

        CMP     Format,ffFixed

        JB      @@3

        MOV     EAX,Digits

@@3:    PUSH    EAX

        LEA     EAX,FloatRec

        CALL    FloatToDecimal

        MOV     EDI,Buffer

        MOVZX   EAX,FloatRec.Exponent

        SUB     EAX,7FFFH

        CMP     EAX,2

        JAE     @@4

        MOV     ECX, EAX

        CALL    @@PutSign

        LEA     ESI,@@INFNAN[ECX+ECX*2]

        ADD     ESI,SaveGOT

        MOV     ECX,3

        REP     MOVSB

        JMP     @@7

@@4:    LEA     ESI,FloatRec.Digits

        MOVZX   EBX,Format

        CMP     BL,ffExponent

        JE      @@6

        CMP     BL,ffCurrency

        JA      @@5

        MOVSX   EAX,FloatRec.Exponent

        CMP     EAX,Precision

        JLE     @@6

@@5:    MOV     BL,ffGeneral

@@6:    LEA     EBX,@@FormatVector[EBX*4]

        ADD     EBX,SaveGOT

        MOV     EBX,[EBX]

        ADD     EBX,SaveGOT

        CALL    EBX

@@7:    MOV     EAX,EDI

        SUB     EAX,Buffer

        POP     EBX

        POP     ESI

        POP     EDI

        JMP     @@Exit



@@FormatVector:

        DD      @@PutFGeneral

        DD      @@PutFExponent

        DD      @@PutFFixed

        DD      @@PutFNumber

        DD      @@PutFCurrency



@@INFNAN: DB 'INFNAN'



// Get digit or '0' if at end of digit string



@@GetDigit:



        LODSB

        OR      AL,AL

        JNE     @@a1

        MOV     AL,'0'

        DEC     ESI

@@a1:   RET



// Store '-' if number is negative



@@PutSign:



        CMP     FloatRec.Negative,0

        JE      @@b1

        MOV     AL,'-'

        STOSB

@@b1:   RET



// Convert number using ffGeneral format



@@PutFGeneral:



        CALL    @@PutSign

        MOVSX   ECX,FloatRec.Exponent

        XOR     EDX,EDX

        CMP     ECX,Precision

        JG      @@c1

        CMP     ECX,-3

        JL      @@c1

        OR      ECX,ECX

        JG      @@c2

        MOV     AL,'0'

        STOSB

        CMP     BYTE PTR [ESI],0

        JE      @@c6

        MOV     AL,DecimalSep

        STOSB

        NEG     ECX

        MOV     AL,'0'

        REP     STOSB

        JMP     @@c3

@@c1:   MOV     ECX,1

        INC     EDX

@@c2:   LODSB

        OR      AL,AL

        JE      @@c4

        STOSB

        LOOP    @@c2

        LODSB

        OR      AL,AL

        JE      @@c5

        MOV     AH,AL

        MOV     AL,DecimalSep

        STOSW

@@c3:   LODSB

        OR      AL,AL

        JE      @@c5

        STOSB

        JMP     @@c3

@@c4:   MOV     AL,'0'

        REP     STOSB

@@c5:   OR      EDX,EDX

        JE      @@c6

        XOR     EAX,EAX

        JMP     @@PutFloatExpWithDigits

@@c6:   RET



// Convert number using ffExponent format



@@PutFExponent:



        CALL    @@PutSign

        CALL    @@GetDigit

        MOV     AH,DecimalSep

        STOSW

        MOV     ECX,Precision

        DEC     ECX

@@d1:   CALL    @@GetDigit

        STOSB

        LOOP    @@d1

        MOV     AH,'+'



@@PutFloatExpWithDigits:



        MOV     ECX,Digits

        CMP     ECX,4

        JBE     @@PutFloatExp

        XOR     ECX,ECX



// Store exponent

// In   AH  = Positive sign character ('+' or 0)

//      ECX = Minimum number of digits (0..4)



@@PutFloatExp:



        MOV     AL,'E'

        MOV     BL, FloatRec.Digits.Byte

        MOVSX   EDX,FloatRec.Exponent

        DEC     EDX

        CALL    PutExponent

        RET



// Convert number using ffFixed or ffNumber format



@@PutFFixed:

@@PutFNumber:



        CALL    @@PutSign



// Store number in fixed point format



@@PutNumber:



        MOV     EDX,Digits

        CMP     EDX,18

        JB      @@f1

        MOV     EDX,18

@@f1:   MOVSX   ECX,FloatRec.Exponent

        OR      ECX,ECX

        JG      @@f2

        MOV     AL,'0'

        STOSB

        JMP     @@f4

@@f2:   XOR     EBX,EBX

        CMP     Format,ffFixed

        JE      @@f3

        MOV     EAX,ECX

        DEC     EAX

        MOV     BL,3

        DIV     BL

        MOV     BL,AH

        INC     EBX

@@f3:   CALL    @@GetDigit

        STOSB

        DEC     ECX

        JE      @@f4

        DEC     EBX

        JNE     @@f3

        MOV     AL,ThousandSep

        TEST    AL,AL

        JZ      @@f3

        STOSB

        MOV     BL,3

        JMP     @@f3

@@f4:   OR      EDX,EDX

        JE      @@f7

        MOV     AL,DecimalSep

        TEST    AL,AL

        JZ      @@f4b

        STOSB

@@f4b:  JECXZ   @@f6

        MOV     AL,'0'

@@f5:   STOSB

        DEC     EDX

        JE      @@f7

        INC     ECX

        JNE     @@f5

@@f6:   CALL    @@GetDigit

        STOSB

        DEC     EDX

        JNE     @@f6

@@f7:   RET



// Convert number using ffCurrency format



@@PutFCurrency:



        XOR     EBX,EBX

        MOV     BL,CurrFmt.Byte

        MOV     ECX,0003H

        CMP     FloatRec.Negative,0

        JE      @@g1

        MOV     BL,NegCurrFmt.Byte

        MOV     ECX,040FH

@@g1:   CMP     BL,CL

        JBE     @@g2

        MOV     BL,CL

@@g2:   ADD     BL,CH

        LEA     EBX,@@MoneyFormats[EBX+EBX*4]

        ADD     EBX,SaveGOT

        MOV     ECX,5

@@g10:  MOV     AL,[EBX]

        CMP     AL,'@'

        JE      @@g14

        PUSH    ECX

        PUSH    EBX

        CMP     AL,'$'

        JE      @@g11

        CMP     AL,'*'

        JE      @@g12

        STOSB

        JMP     @@g13

@@g11:  CALL    @@PutCurSym

        JMP     @@g13

@@g12:  CALL    @@PutNumber

@@g13:  POP     EBX

        POP     ECX

        INC     EBX

        LOOP    @@g10

@@g14:  RET



// Store currency symbol string



@@PutCurSym:



        PUSH    ESI

        MOV     ESI,CurrencyStr

        TEST    ESI,ESI

        JE      @@h1

        MOV     ECX,[ESI-4]

        REP     MOVSB

@@h1:   POP     ESI

        RET



// Currency formatting templates



@@MoneyFormats:

        DB      '$*@@@'

        DB      '*$@@@'

        DB      '$ *@@'

        DB      '* $@@'

        DB      '($*)@'

        DB      '-$*@@'

        DB      '$-*@@'

        DB      '$*-@@'

        DB      '(*$)@'

        DB      '-*$@@'

        DB      '*-$@@'

        DB      '*$-@@'

        DB      '-* $@'

        DB      '-$ *@'

        DB      '* $-@'

        DB      '$ *-@'

        DB      '$ -*@'

        DB      '*- $@'

        DB      '($ *)'

        DB      '(* $)'



@@Exit:

end;



function FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue;

  Format: TFloatFormat; Precision, Digits: Integer;

  const FormatSettings: TFormatSettings): Integer;

var

  Buffer: Cardinal;

  FloatRec: TFloatRec;

  SaveGOT: Integer;

  DecimalSep: Char;

  ThousandSep: Char;

  CurrencyStr: Pointer;

  CurrFmt: Byte;

  NegCurrFmt: Byte;

asm

        PUSH    EDI

        PUSH    ESI

        PUSH    EBX

        MOV     Buffer,EAX

{$IFDEF PIC}

        PUSH    ECX

        CALL    GetGOT

        MOV     SaveGOT,EAX

        POP     ECX

{$ENDIF}

        MOV     EAX,FormatSettings

        MOV     AL,[EAX].TFormatSettings.DecimalSeparator

        MOV     DecimalSep,AL

        MOV     EAX,FormatSettings

        MOV     AL,[EAX].TFormatSettings.ThousandSeparator

        MOV     ThousandSep,AL

        MOV     EAX,FormatSettings

        MOV     EAX,[EAX].TFormatSettings.CurrencyString

        MOV     CurrencyStr,EAX

        MOV     EAX,FormatSettings

        MOV     AL,[EAX].TFormatSettings.CurrencyFormat

        MOV     CurrFmt,AL

        MOV     EAX,FormatSettings

        MOV     AL,[EAX].TFormatSettings.NegCurrFormat

        MOV     NegCurrFmt,AL

        MOV     SaveGOT,0

        MOV     EAX,19

        CMP     CL,fvExtended

        JNE     @@2

        MOV     EAX,Precision

        CMP     EAX,2

        JGE     @@1

        MOV     EAX,2

@@1:    CMP     EAX,18

        JLE     @@2

        MOV     EAX,18

@@2:    MOV     Precision,EAX

        PUSH    EAX

        MOV     EAX,9999

        CMP     Format,ffFixed

        JB      @@3

        MOV     EAX,Digits

@@3:    PUSH    EAX

        LEA     EAX,FloatRec

        CALL    FloatToDecimal

        MOV     EDI,Buffer

        MOVZX   EAX,FloatRec.Exponent

        SUB     EAX,7FFFH

        CMP     EAX,2

        JAE     @@4

        MOV     ECX, EAX

        CALL    @@PutSign

        LEA     ESI,@@INFNAN[ECX+ECX*2]

        ADD     ESI,SaveGOT

        MOV     ECX,3

        REP     MOVSB

        JMP     @@7

@@4:    LEA     ESI,FloatRec.Digits

        MOVZX   EBX,Format

        CMP     BL,ffExponent

        JE      @@6

        CMP     BL,ffCurrency

        JA      @@5

        MOVSX   EAX,FloatRec.Exponent

        CMP     EAX,Precision

        JLE     @@6

@@5:    MOV     BL,ffGeneral

@@6:    LEA     EBX,@@FormatVector[EBX*4]

        ADD     EBX,SaveGOT

        MOV     EBX,[EBX]

        ADD     EBX,SaveGOT

        CALL    EBX

@@7:    MOV     EAX,EDI

        SUB     EAX,Buffer

        POP     EBX

        POP     ESI

        POP     EDI

        JMP     @@Exit



@@FormatVector:

        DD      @@PutFGeneral

        DD      @@PutFExponent

        DD      @@PutFFixed

        DD      @@PutFNumber

        DD      @@PutFCurrency



@@INFNAN: DB 'INFNAN'



// Get digit or '0' if at end of digit string



@@GetDigit:



        LODSB

        OR      AL,AL

        JNE     @@a1

        MOV     AL,'0'

        DEC     ESI

@@a1:   RET



// Store '-' if number is negative



@@PutSign:



        CMP     FloatRec.Negative,0

        JE      @@b1

        MOV     AL,'-'

        STOSB

@@b1:   RET



// Convert number using ffGeneral format



@@PutFGeneral:



        CALL    @@PutSign

        MOVSX   ECX,FloatRec.Exponent

        XOR     EDX,EDX

        CMP     ECX,Precision

        JG      @@c1

        CMP     ECX,-3

        JL      @@c1

        OR      ECX,ECX

        JG      @@c2

        MOV     AL,'0'

        STOSB

        CMP     BYTE PTR [ESI],0

        JE      @@c6

        MOV     AL,DecimalSep

        STOSB

        NEG     ECX

        MOV     AL,'0'

        REP     STOSB

        JMP     @@c3

@@c1:   MOV     ECX,1

        INC     EDX

@@c2:   LODSB

        OR      AL,AL

        JE      @@c4

        STOSB

        LOOP    @@c2

        LODSB

        OR      AL,AL

        JE      @@c5

        MOV     AH,AL

        MOV     AL,DecimalSep

        STOSW

@@c3:   LODSB

        OR      AL,AL

        JE      @@c5

        STOSB

        JMP     @@c3

@@c4:   MOV     AL,'0'

        REP     STOSB

@@c5:   OR      EDX,EDX

        JE      @@c6

        XOR     EAX,EAX

        JMP     @@PutFloatExpWithDigits

@@c6:   RET



// Convert number using ffExponent format



@@PutFExponent:



        CALL    @@PutSign

        CALL    @@GetDigit

        MOV     AH,DecimalSep

        STOSW

        MOV     ECX,Precision

        DEC     ECX

@@d1:   CALL    @@GetDigit

        STOSB

        LOOP    @@d1

        MOV     AH,'+'



@@PutFloatExpWithDigits:



        MOV     ECX,Digits

        CMP     ECX,4

        JBE     @@PutFloatExp

        XOR     ECX,ECX



// Store exponent

// In   AH  = Positive sign character ('+' or 0)

//      ECX = Minimum number of digits (0..4)



@@PutFloatExp:



        MOV     AL,'E'

        MOV     BL, FloatRec.Digits.Byte

        MOVSX   EDX,FloatRec.Exponent

        DEC     EDX

        CALL    PutExponent

        RET



// Convert number using ffFixed or ffNumber format



@@PutFFixed:

@@PutFNumber:



        CALL    @@PutSign



// Store number in fixed point format



@@PutNumber:



        MOV     EDX,Digits

        CMP     EDX,18

        JB      @@f1

        MOV     EDX,18

@@f1:   MOVSX   ECX,FloatRec.Exponent

        OR      ECX,ECX

        JG      @@f2

        MOV     AL,'0'

        STOSB

        JMP     @@f4

@@f2:   XOR     EBX,EBX

        CMP     Format,ffFixed

        JE      @@f3

        MOV     EAX,ECX

        DEC     EAX

        MOV     BL,3

        DIV     BL

        MOV     BL,AH

        INC     EBX

@@f3:   CALL    @@GetDigit

        STOSB

        DEC     ECX

        JE      @@f4

        DEC     EBX

        JNE     @@f3

        MOV     AL,ThousandSep

        TEST    AL,AL

        JZ      @@f3

        STOSB

        MOV     BL,3

        JMP     @@f3

@@f4:   OR      EDX,EDX

        JE      @@f7

        MOV     AL,DecimalSep

        TEST    AL,AL

        JZ      @@f4b

        STOSB

@@f4b:  JECXZ   @@f6

        MOV     AL,'0'

@@f5:   STOSB

        DEC     EDX

        JE      @@f7

        INC     ECX

        JNE     @@f5

@@f6:   CALL    @@GetDigit

        STOSB

        DEC     EDX

        JNE     @@f6

@@f7:   RET



// Convert number using ffCurrency format



@@PutFCurrency:



        XOR     EBX,EBX

        MOV     BL,CurrFmt.Byte

        MOV     ECX,0003H

        CMP     FloatRec.Negative,0

        JE      @@g1

        MOV     BL,NegCurrFmt.Byte

        MOV     ECX,040FH

@@g1:   CMP     BL,CL

        JBE     @@g2

        MOV     BL,CL

@@g2:   ADD     BL,CH

        LEA     EBX,@@MoneyFormats[EBX+EBX*4]

        ADD     EBX,SaveGOT

        MOV     ECX,5

@@g10:  MOV     AL,[EBX]

        CMP     AL,'@'

        JE      @@g14

        PUSH    ECX

        PUSH    EBX

        CMP     AL,'$'

        JE      @@g11

        CMP     AL,'*'

        JE      @@g12

        STOSB

        JMP     @@g13

@@g11:  CALL    @@PutCurSym

        JMP     @@g13

@@g12:  CALL    @@PutNumber

@@g13:  POP     EBX

        POP     ECX

        INC     EBX

        LOOP    @@g10

@@g14:  RET



// Store currency symbol string



@@PutCurSym:



        PUSH    ESI

        MOV     ESI,CurrencyStr

        TEST    ESI,ESI

        JE      @@h1

        MOV     ECX,[ESI-4]

        REP     MOVSB

@@h1:   POP     ESI

        RET



// Currency formatting templates



@@MoneyFormats:

        DB      '$*@@@'

        DB      '*$@@@'

        DB      '$ *@@'

        DB      '* $@@'

        DB      '($*)@'

        DB      '-$*@@'

        DB      '$-*@@'

        DB      '$*-@@'

        DB      '(*$)@'

        DB      '-*$@@'

        DB      '*-$@@'

        DB      '*$-@@'

        DB      '-* $@'

        DB      '-$ *@'

        DB      '* $-@'

        DB      '$ *-@'

        DB      '$ -*@'

        DB      '*- $@'

        DB      '($ *)'

        DB      '(* $)'



@@Exit:

end;



function FloatToTextFmt(Buf: PChar; const Value; ValueType: TFloatValue;

  Format: PChar): Integer;



var

  Buffer: Pointer;

  ThousandSep: Boolean;

  DecimalSep: Char;

  ThousandsSep: Char;

  Scientific: Boolean;

  Section: Integer;

  DigitCount: Integer;

  DecimalIndex: Integer;

  FirstDigit: Integer;

  LastDigit: Integer;

  DigitPlace: Integer;

  DigitDelta: Integer;

  FloatRec: TFloatRec;

  SaveGOT: Pointer;

asm

        PUSH    EDI

        PUSH    ESI

        PUSH    EBX

        MOV     Buffer,EAX

        MOV     EDI,EDX

        MOV     EBX,ECX

{$IFDEF PIC}

        CALL    GetGOT

        MOV     SaveGOT,EAX

        MOV     ECX,[EAX].OFFSET DecimalSeparator

        MOV     CL,[ECX].Byte

        MOV     DecimalSep,CL

        MOV     ECX,[EAX].OFFSET ThousandSeparator

        MOV     CL,[ECX].Byte

        MOV     ThousandsSep,CL

{$ELSE}

        MOV     SaveGOT,0

        MOV     AL,DecimalSeparator

        MOV     DecimalSep,AL

        MOV     AL,ThousandSeparator

        MOV     ThousandsSep,AL

{$ENDIF}

        MOV     ECX,2

        CMP     BL,fvExtended

        JE      @@1

        MOV     EAX,[EDI].Integer

        OR      EAX,[EDI].Integer[4]

        JE      @@2

        MOV     ECX,[EDI].Integer[4]

        SHR     ECX,31

        JMP     @@2

@@1:    MOVZX   EAX,[EDI].Word[8]

        OR      EAX,[EDI].Integer[0]

        OR      EAX,[EDI].Integer[4]

        JE      @@2

        MOVZX   ECX,[EDI].Word[8]

        SHR     ECX,15

@@2:    CALL    @@FindSection

        JE      @@5

        CALL    @@ScanSection

        MOV     EAX,DigitCount

        MOV     EDX,9999

        CMP     Scientific,0

        JNE     @@3

        SUB     EAX,DecimalIndex

        MOV     EDX,EAX

        MOV     EAX,18

@@3:    PUSH    EAX

        PUSH    EDX

        LEA     EAX,FloatRec

        MOV     EDX,EDI

        MOV     ECX,EBX

        CALL    FloatToDecimal

        MOV     AX,FloatRec.Exponent

        CMP     AX,8000H

        JE      @@5

        CMP     AX,7FFFH

        JE      @@5

        CMP     BL,fvExtended

        JNE     @@6

        CMP     AX,18

        JLE     @@6

        CMP     Scientific,0

        JNE     @@6

@@5:    PUSH    ffGeneral

        PUSH    15

        PUSH    0

        MOV     EAX,Buffer

        MOV     EDX,EDI

        MOV     ECX,EBX

        CALL    FloatToText

        JMP     @@Exit

@@6:    CMP     FloatRec.Digits.Byte,0

        JNE     @@7

        MOV     ECX,2

        CALL    @@FindSection

        JE      @@5

        CMP     ESI,Section

        JE      @@7

        CALL    @@ScanSection

@@7:    CALL    @@ApplyFormat

        JMP     @@Exit



// Find format section

// In   ECX = Section index

// Out  ESI = Section offset

//      ZF  = 1 if section is empty



@@FindSection:

        MOV     ESI,Format

        JECXZ   @@fs2

@@fs1:  LODSB

        CMP     AL,"'"

        JE      @@fs4

        CMP     AL,'"'

        JE      @@fs4

        OR      AL,AL

        JE      @@fs2

        CMP     AL,';'

        JNE     @@fs1

        LOOP    @@fs1

        MOV     AL,byte ptr [ESI]

        OR      AL,AL

        JE      @@fs2

        CMP     AL,';'

        JNE     @@fs3

@@fs2:  MOV     ESI,Format

        MOV     AL,byte ptr [ESI]

        OR      AL,AL

        JE      @@fs3

        CMP     AL,';'

@@fs3:  RET

@@fs4:  MOV     AH,AL

@@fs5:  LODSB

        CMP     AL,AH

        JE      @@fs1

        OR      AL,AL

        JNE     @@fs5

        JMP     @@fs2



// Scan format section



@@ScanSection:

        PUSH    EBX

        MOV     Section,ESI

        MOV     EBX,32767

        XOR     ECX,ECX

        XOR     EDX,EDX

        MOV     DecimalIndex,-1

        MOV     ThousandSep,DL

        MOV     Scientific,DL

@@ss1:  LODSB

@@ss2:  CMP     AL,'#'

        JE      @@ss10

        CMP     AL,'0'

        JE      @@ss11

        CMP     AL,'.'

        JE      @@ss13

        CMP     AL,','

        JE      @@ss14

        CMP     AL,"'"

        JE      @@ss15

        CMP     AL,'"'

        JE      @@ss15

        CMP     AL,'E'

        JE      @@ss20

        CMP     AL,'e'

        JE      @@ss20

        CMP     AL,';'

        JE      @@ss30

        OR      AL,AL

        JNE     @@ss1

        JMP     @@ss30

@@ss10: INC     EDX

        JMP     @@ss1

@@ss11: CMP     EDX,EBX

        JGE     @@ss12

        MOV     EBX,EDX

@@ss12: INC     EDX

        MOV     ECX,EDX

        JMP     @@ss1

@@ss13: CMP     DecimalIndex,-1

        JNE     @@ss1

        MOV     DecimalIndex,EDX

        JMP     @@ss1

@@ss14: MOV     ThousandSep,1

        JMP     @@ss1

@@ss15: MOV     AH,AL

@@ss16: LODSB

        CMP     AL,AH

        JE      @@ss1

        OR      AL,AL

        JNE     @@ss16

        JMP     @@ss30

@@ss20: LODSB

        CMP     AL,'-'

        JE      @@ss21

        CMP     AL,'+'

        JNE     @@ss2

@@ss21: MOV     Scientific,1

@@ss22: LODSB

        CMP     AL,'0'

        JE      @@ss22

        JMP     @@ss2

@@ss30: MOV     DigitCount,EDX

        CMP     DecimalIndex,-1

        JNE     @@ss31

        MOV     DecimalIndex,EDX

@@ss31: MOV     EAX,DecimalIndex

        SUB     EAX,ECX

        JLE     @@ss32

        XOR     EAX,EAX

@@ss32: MOV     LastDigit,EAX

        MOV     EAX,DecimalIndex

        SUB     EAX,EBX

        JGE     @@ss33

        XOR     EAX,EAX

@@ss33: MOV     FirstDigit,EAX

        POP     EBX

        RET



// Apply format string



@@ApplyFormat:

        CMP     Scientific,0

        JE      @@af1

        MOV     EAX,DecimalIndex

        XOR     EDX,EDX

        JMP     @@af3

@@af1:  MOVSX   EAX,FloatRec.Exponent

        CMP     EAX,DecimalIndex

        JG      @@af2

        MOV     EAX,DecimalIndex

@@af2:  MOVSX   EDX,FloatRec.Exponent

        SUB     EDX,DecimalIndex

@@af3:  MOV     DigitPlace,EAX

        MOV     DigitDelta,EDX

        MOV     ESI,Section

        MOV     EDI,Buffer

        LEA     EBX,FloatRec.Digits

        CMP     FloatRec.Negative,0

        JE      @@af10

        CMP     ESI,Format

        JNE     @@af10

        MOV     AL,'-'

        STOSB

@@af10: LODSB

        CMP     AL,'#'

        JE      @@af20

        CMP     AL,'0'

        JE      @@af20

        CMP     AL,'.'

        JE      @@af10

        CMP     AL,','

        JE      @@af10

        CMP     AL,"'"

        JE      @@af25

        CMP     AL,'"'

        JE      @@af25

        CMP     AL,'E'

        JE      @@af30

        CMP     AL,'e'

        JE      @@af30

        CMP     AL,';'

        JE      @@af40

        OR      AL,AL

        JE      @@af40

@@af11: STOSB

        JMP     @@af10

@@af20: CALL    @@PutFmtDigit

        JMP     @@af10

@@af25: MOV     AH,AL

@@af26: LODSB

        CMP     AL,AH

        JE      @@af10

        OR      AL,AL

        JE      @@af40

        STOSB

        JMP     @@af26

@@af30: MOV     AH,[ESI]

        CMP     AH,'+'

        JE      @@af31

        CMP     AH,'-'

        JNE     @@af11

        XOR     AH,AH

@@af31: MOV     ECX,-1

@@af32: INC     ECX

        INC     ESI

        CMP     [ESI].Byte,'0'

        JE      @@af32

        CMP     ECX,4

        JB      @@af33

        MOV     ECX,4

@@af33: PUSH    EBX

        MOV     BL,FloatRec.Digits.Byte

        MOVSX   EDX,FloatRec.Exponent

        SUB     EDX,DecimalIndex

        CALL    PutExponent

        POP     EBX

        JMP     @@af10

@@af40: MOV     EAX,EDI

        SUB     EAX,Buffer

        RET



// Store formatted digit



@@PutFmtDigit:

        CMP     DigitDelta,0

        JE      @@fd3

        JL      @@fd2

@@fd1:  CALL    @@fd3

        DEC     DigitDelta

        JNE     @@fd1

        JMP     @@fd3

@@fd2:  INC     DigitDelta

        MOV     EAX,DigitPlace

        CMP     EAX,FirstDigit

        JLE     @@fd4

        JMP     @@fd7

@@fd3:  MOV     AL,[EBX]

        INC     EBX

        OR      AL,AL

        JNE     @@fd5

        DEC     EBX

        MOV     EAX,DigitPlace

        CMP     EAX,LastDigit

        JLE     @@fd7

@@fd4:  MOV     AL,'0'

@@fd5:  CMP     DigitPlace,0

        JNE     @@fd6

        MOV     AH,AL

        MOV     AL,DecimalSep

        STOSW

        JMP     @@fd7

@@fd6:  STOSB

        CMP     ThousandSep,0

        JE      @@fd7

        MOV     EAX,DigitPlace

        CMP     EAX,1

        JLE     @@fd7

        MOV     DL,3

        DIV     DL

        CMP     AH,1

        JNE     @@fd7

        MOV     AL,ThousandsSep

        TEST    AL,AL

        JZ      @@fd7

        STOSB

@@fd7:  DEC     DigitPlace

        RET



@@exit:

        POP     EBX

        POP     ESI

        POP     EDI

end;



function FloatToTextFmt(Buf: PChar; const Value; ValueType: TFloatValue;

  Format: PChar; const FormatSettings: TFormatSettings): Integer;



var

  Buffer: Pointer;

  ThousandSep: Boolean;

  DecimalSep: Char;

  ThousandsSep: Char;

  Scientific: Boolean;

  Section: Integer;

  DigitCount: Integer;

  DecimalIndex: Integer;

  FirstDigit: Integer;

  LastDigit: Integer;

  DigitPlace: Integer;

  DigitDelta: Integer;

  FloatRec: TFloatRec;

  SaveGOT: Pointer;

asm

        PUSH    EDI

        PUSH    ESI

        PUSH    EBX

        MOV     Buffer,EAX

        MOV     EDI,EDX

        MOV     EBX,ECX

{$IFDEF PIC}

        CALL    GetGOT

        MOV     SaveGOT,EAX

{$ELSE}

        MOV     SaveGOT,0

{$ENDIF}

        MOV     EAX,FormatSettings

        MOV     AL,[EAX].TFormatSettings.DecimalSeparator

        MOV     DecimalSep,AL

        MOV     EAX,FormatSettings

        MOV     AL,[EAX].TFormatSettings.ThousandSeparator

        MOV     ThousandsSep,AL

        MOV     ECX,2

        CMP     BL,fvExtended

        JE      @@1

        MOV     EAX,[EDI].Integer

        OR      EAX,[EDI].Integer[4]

        JE      @@2

        MOV     ECX,[EDI].Integer[4]

        SHR     ECX,31

        JMP     @@2

@@1:    MOVZX   EAX,[EDI].Word[8]

        OR      EAX,[EDI].Integer[0]

        OR      EAX,[EDI].Integer[4]

        JE      @@2

        MOVZX   ECX,[EDI].Word[8]

        SHR     ECX,15

@@2:    CALL    @@FindSection

        JE      @@5

        CALL    @@ScanSection

        MOV     EAX,DigitCount

        MOV     EDX,9999

        CMP     Scientific,0

        JNE     @@3

        SUB     EAX,DecimalIndex

        MOV     EDX,EAX

        MOV     EAX,18

@@3:    PUSH    EAX

        PUSH    EDX

        LEA     EAX,FloatRec

        MOV     EDX,EDI

        MOV     ECX,EBX

        CALL    FloatToDecimal

        MOV     AX,FloatRec.Exponent

        CMP     AX,8000H

        JE      @@5

        CMP     AX,7FFFH

        JE      @@5

        CMP     BL,fvExtended

        JNE     @@6

        CMP     AX,18

        JLE     @@6

        CMP     Scientific,0

        JNE     @@6

@@5:    PUSH    ffGeneral

        PUSH    15

        PUSH    0

        MOV     EAX,[FormatSettings]

        PUSH    EAX

        MOV     EAX,Buffer

        MOV     EDX,EDI

        MOV     ECX,EBX

        CALL    FloatToTextEx

        JMP     @@Exit

@@6:    CMP     FloatRec.Digits.Byte,0

        JNE     @@7

        MOV     ECX,2

        CALL    @@FindSection

        JE      @@5

        CMP     ESI,Section

        JE      @@7

        CALL    @@ScanSection

@@7:    CALL    @@ApplyFormat

        JMP     @@Exit



// Find format section

// In   ECX = Section index

// Out  ESI = Section offset

//      ZF  = 1 if section is empty



@@FindSection:

        MOV     ESI,Format

        JECXZ   @@fs2

@@fs1:  LODSB

        CMP     AL,"'"

        JE      @@fs4

        CMP     AL,'"'

        JE      @@fs4

        OR      AL,AL

        JE      @@fs2

        CMP     AL,';'

        JNE     @@fs1

        LOOP    @@fs1

        MOV     AL,byte ptr [ESI]

        OR      AL,AL

        JE      @@fs2

        CMP     AL,';'

        JNE     @@fs3

@@fs2:  MOV     ESI,Format

        MOV     AL,byte ptr [ESI]

        OR      AL,AL

        JE      @@fs3

        CMP     AL,';'

@@fs3:  RET

@@fs4:  MOV     AH,AL

@@fs5:  LODSB

        CMP     AL,AH

        JE      @@fs1

        OR      AL,AL

        JNE     @@fs5

        JMP     @@fs2



// Scan format section



@@ScanSection:

        PUSH    EBX

        MOV     Section,ESI

        MOV     EBX,32767

        XOR     ECX,ECX

        XOR     EDX,EDX

        MOV     DecimalIndex,-1

        MOV     ThousandSep,DL

        MOV     Scientific,DL

@@ss1:  LODSB

@@ss2:  CMP     AL,'#'

        JE      @@ss10

        CMP     AL,'0'

        JE      @@ss11

        CMP     AL,'.'

        JE      @@ss13

        CMP     AL,','

        JE      @@ss14

        CMP     AL,"'"

        JE      @@ss15

        CMP     AL,'"'

        JE      @@ss15

        CMP     AL,'E'

        JE      @@ss20

        CMP     AL,'e'

        JE      @@ss20

        CMP     AL,';'

        JE      @@ss30

        OR      AL,AL

        JNE     @@ss1

        JMP     @@ss30

@@ss10: INC     EDX

        JMP     @@ss1

@@ss11: CMP     EDX,EBX

        JGE     @@ss12

        MOV     EBX,EDX

@@ss12: INC     EDX

        MOV     ECX,EDX

        JMP     @@ss1

@@ss13: CMP     DecimalIndex,-1

        JNE     @@ss1

        MOV     DecimalIndex,EDX

        JMP     @@ss1

@@ss14: MOV     ThousandSep,1

        JMP     @@ss1

@@ss15: MOV     AH,AL

@@ss16: LODSB

        CMP     AL,AH

        JE      @@ss1

        OR      AL,AL

        JNE     @@ss16

        JMP     @@ss30

@@ss20: LODSB

        CMP     AL,'-'

        JE      @@ss21

        CMP     AL,'+'

        JNE     @@ss2

@@ss21: MOV     Scientific,1

@@ss22: LODSB

        CMP     AL,'0'

        JE      @@ss22

        JMP     @@ss2

@@ss30: MOV     DigitCount,EDX

        CMP     DecimalIndex,-1

        JNE     @@ss31

        MOV     DecimalIndex,EDX

@@ss31: MOV     EAX,DecimalIndex

        SUB     EAX,ECX

        JLE     @@ss32

        XOR     EAX,EAX

@@ss32: MOV     LastDigit,EAX

        MOV     EAX,DecimalIndex

        SUB     EAX,EBX

        JGE     @@ss33

        XOR     EAX,EAX

@@ss33: MOV     FirstDigit,EAX

        POP     EBX

        RET



// Apply format string



@@ApplyFormat:

        CMP     Scientific,0

        JE      @@af1

        MOV     EAX,DecimalIndex

        XOR     EDX,EDX

        JMP     @@af3

@@af1:  MOVSX   EAX,FloatRec.Exponent

        CMP     EAX,DecimalIndex

        JG      @@af2

        MOV     EAX,DecimalIndex

@@af2:  MOVSX   EDX,FloatRec.Exponent

        SUB     EDX,DecimalIndex

@@af3:  MOV     DigitPlace,EAX

        MOV     DigitDelta,EDX

        MOV     ESI,Section

        MOV     EDI,Buffer

        LEA     EBX,FloatRec.Digits

        CMP     FloatRec.Negative,0

        JE      @@af10

        CMP     ESI,Format

        JNE     @@af10

        MOV     AL,'-'

        STOSB

@@af10: LODSB

        CMP     AL,'#'

        JE      @@af20

        CMP     AL,'0'

        JE      @@af20

        CMP     AL,'.'

        JE      @@af10

        CMP     AL,','

        JE      @@af10

        CMP     AL,"'"

        JE      @@af25

        CMP     AL,'"'

        JE      @@af25

        CMP     AL,'E'

        JE      @@af30

        CMP     AL,'e'

        JE      @@af30

        CMP     AL,';'

        JE      @@af40

        OR      AL,AL

        JE      @@af40

@@af11: STOSB

        JMP     @@af10

@@af20: CALL    @@PutFmtDigit

        JMP     @@af10

@@af25: MOV     AH,AL

@@af26: LODSB

        CMP     AL,AH

        JE      @@af10

        OR      AL,AL

        JE      @@af40

        STOSB

        JMP     @@af26

@@af30: MOV     AH,[ESI]

        CMP     AH,'+'

        JE      @@af31

        CMP     AH,'-'

        JNE     @@af11

        XOR     AH,AH

@@af31: MOV     ECX,-1

@@af32: INC     ECX

        INC     ESI

        CMP     [ESI].Byte,'0'

        JE      @@af32

        CMP     ECX,4

        JB      @@af33

        MOV     ECX,4

@@af33: PUSH    EBX

        MOV     BL,FloatRec.Digits.Byte

        MOVSX   EDX,FloatRec.Exponent

        SUB     EDX,DecimalIndex

        CALL    PutExponent

        POP     EBX

        JMP     @@af10

@@af40: MOV     EAX,EDI

        SUB     EAX,Buffer

        RET



// Store formatted digit



@@PutFmtDigit:

        CMP     DigitDelta,0

        JE      @@fd3

        JL      @@fd2

@@fd1:  CALL    @@fd3

        DEC     DigitDelta

        JNE     @@fd1

        JMP     @@fd3

@@fd2:  INC     DigitDelta

        MOV     EAX,DigitPlace

        CMP     EAX,FirstDigit

        JLE     @@fd4

        JMP     @@fd7

@@fd3:  MOV     AL,[EBX]

        INC     EBX

        OR      AL,AL

        JNE     @@fd5

        DEC     EBX

        MOV     EAX,DigitPlace

        CMP     EAX,LastDigit

        JLE     @@fd7

@@fd4:  MOV     AL,'0'

@@fd5:  CMP     DigitPlace,0

        JNE     @@fd6

        MOV     AH,AL

        MOV     AL,DecimalSep

        STOSW

        JMP     @@fd7

@@fd6:  STOSB

        CMP     ThousandSep,0

        JE      @@fd7

        MOV     EAX,DigitPlace

        CMP     EAX,1

        JLE     @@fd7

        MOV     DL,3

        DIV     DL

        CMP     AH,1

        JNE     @@fd7

        MOV     AL,ThousandsSep

        TEST    AL,AL

        JZ      @@fd7

        STOSB

@@fd7:  DEC     DigitPlace

        RET



@@exit:

        POP     EBX

        POP     ESI

        POP     EDI

end;



const

// 8087 status word masks

  mIE = $0001;

  mDE = $0002;

  mZE = $0004;

  mOE = $0008;

  mUE = $0010;

  mPE = $0020;

  mC0 = $0100;

  mC1 = $0200;

  mC2 = $0400;

  mC3 = $4000;



procedure FloatToDecimal(var Result: TFloatRec; const Value;

  ValueType: TFloatValue; Precision, Decimals: Integer);

var

  StatWord: Word;

  Exponent: Integer;

  Temp: Double;

  BCDValue: Extended;

  SaveGOT: Pointer;

asm

        PUSH    EDI

        PUSH    ESI

        PUSH    EBX

        MOV     EBX,EAX

        MOV     ESI,EDX

{$IFDEF PIC}

        PUSH    ECX

        CALL    GetGOT

        POP     ECX

        MOV     SaveGOT,EAX

{$ELSE}

        MOV     SaveGOT,0

{$ENDIF}

        CMP     CL,fvExtended

        JE      @@1

        CALL    @@CurrToDecimal

        JMP     @@Exit

@@1:    CALL    @@ExtToDecimal

        JMP     @@Exit



// Convert Extended to decimal



@@ExtToDecimal:



        MOV     AX,[ESI].Word[8]

        MOV     EDX,EAX

        AND     EAX,7FFFH

        JE      @@ed1

        CMP     EAX,7FFFH

        JNE     @@ed10

// check for special values (INF, NAN)

        TEST    [ESI].Word[6],8000H

        JZ      @@ed2

// any significand bit set = NAN

// all significand bits clear = INF

        CMP     dword ptr [ESI], 0

        JNZ     @@ed0

        CMP     dword ptr [ESI+4], 80000000H

        JZ      @@ed2

@@ed0:  INC     EAX

@@ed1:  XOR     EDX,EDX

@@ed2:  MOV     [EBX].TFloatRec.Digits.Byte,0

        JMP     @@ed31

@@ed10: FLD     TBYTE PTR [ESI]

        SUB     EAX,3FFFH

        IMUL    EAX,19728

        SAR     EAX,16

        INC     EAX

        MOV     Exponent,EAX

        MOV     EAX,18

        SUB     EAX,Exponent

        FABS

        PUSH    EBX

        MOV     EBX,SaveGOT

        CALL    FPower10

        POP     EBX

        FRNDINT

        MOV     EDI,SaveGOT

        FLD     [EDI].FCon1E18

        FCOMP

        FSTSW   StatWord

        FWAIT

        TEST    StatWord,mC0+mC3

        JE      @@ed11

        FIDIV   [EDI].DCon10

        INC     Exponent

@@ed11: FBSTP   BCDValue

        LEA     EDI,[EBX].TFloatRec.Digits

        MOV     EDX,9

        FWAIT

@@ed12: MOV     AL,BCDValue[EDX-1].Byte

        MOV     AH,AL

        SHR     AL,4

        AND     AH,0FH

        ADD     AX,'00'

        STOSW

        DEC     EDX

        JNE     @@ed12

        XOR     AL,AL

        STOSB

@@ed20: MOV     EDI,Exponent

        ADD     EDI,Decimals

        JNS     @@ed21

        XOR     EAX,EAX

        JMP     @@ed1

@@ed21: CMP     EDI,Precision

        JB      @@ed22

        MOV     EDI,Precision

@@ed22: CMP     EDI,18

        JAE     @@ed26

        CMP     [EBX].TFloatRec.Digits.Byte[EDI],'5'

        JB      @@ed25

@@ed23: MOV     [EBX].TFloatRec.Digits.Byte[EDI],0

        DEC     EDI

        JS      @@ed24

        INC     [EBX].TFloatRec.Digits.Byte[EDI]

        CMP     [EBX].TFloatRec.Digits.Byte[EDI],'9'

        JA      @@ed23

        JMP     @@ed30

@@ed24: MOV     [EBX].TFloatRec.Digits.Word,'1'

        INC     Exponent

        JMP     @@ed30

@@ed26: MOV     EDI,18

@@ed25: MOV     [EBX].TFloatRec.Digits.Byte[EDI],0

        DEC     EDI

        JS      @@ed32

        CMP     [EBX].TFloatRec.Digits.Byte[EDI],'0'

        JE      @@ed25

@@ed30: MOV     DX,[ESI].Word[8]

@@ed30a:

        MOV     EAX,Exponent

@@ed31: SHR     DX,15

        MOV     [EBX].TFloatRec.Exponent,AX

        MOV     [EBX].TFloatRec.Negative,DL

        RET

@@ed32: XOR     EDX,EDX

        JMP     @@ed30a



@@DecimalTable:

        DD      10

        DD      100

        DD      1000

        DD      10000



// Convert Currency to decimal



@@CurrToDecimal:



        MOV     EAX,[ESI].Integer[0]

        MOV     EDX,[ESI].Integer[4]

        MOV     ECX,EAX

        OR      ECX,EDX

        JE      @@cd20

        OR      EDX,EDX

        JNS     @@cd1

        NEG     EDX

        NEG     EAX

        SBB     EDX,0

@@cd1:  XOR     ECX,ECX

        MOV     EDI,Decimals

        OR      EDI,EDI

        JGE     @@cd2

        XOR     EDI,EDI

@@cd2:  CMP     EDI,4

        JL      @@cd4

        MOV     EDI,4

@@cd3:  INC     ECX

        SUB     EAX,Const1E18Lo

        SBB     EDX,Const1E18Hi

        JNC     @@cd3

        DEC     ECX

        ADD     EAX,Const1E18Lo

        ADC     EDX,Const1E18Hi

@@cd4:  MOV     Temp.Integer[0],EAX

        MOV     Temp.Integer[4],EDX

        FILD    Temp

        MOV     EDX,EDI

        MOV     EAX,4

        SUB     EAX,EDX

        JE      @@cd5

        MOV     EDI,SaveGOT

        FIDIV   @@DecimalTable.Integer[EDI+EAX*4-4]

@@cd5:  FBSTP   BCDValue

        LEA     EDI,[EBX].TFloatRec.Digits

        FWAIT

        OR      ECX,ECX

        JNE     @@cd11

        MOV     ECX,9

@@cd10: MOV     AL,BCDValue[ECX-1].Byte

        MOV     AH,AL

        SHR     AL,4

        JNE     @@cd13

        MOV     AL,AH

        AND     AL,0FH

        JNE     @@cd14

        DEC     ECX

        JNE     @@cd10

        JMP     @@cd20

@@cd11: MOV     AL,CL

        ADD     AL,'0'

        STOSB

        MOV     ECX,9

@@cd12: MOV     AL,BCDValue[ECX-1].Byte

        MOV     AH,AL

        SHR     AL,4

@@cd13: ADD     AL,'0'

        STOSB

        MOV     AL,AH

        AND     AL,0FH

@@cd14: ADD     AL,'0'

        STOSB

        DEC     ECX

        JNE     @@cd12

        MOV     EAX,EDI

        LEA     ECX,[EBX].TFloatRec.Digits[EDX]

        SUB     EAX,ECX

@@cd15: MOV     BYTE PTR [EDI],0

        DEC     EDI

        CMP     BYTE PTR [EDI],'0'

        JE      @@cd15

        MOV     EDX,[ESI].Integer[4]

        SHR     EDX,31

        JMP     @@cd21

@@cd20: XOR     EAX,EAX

        XOR     EDX,EDX

        MOV     [EBX].TFloatRec.Digits.Byte[0],AL

@@cd21: MOV     [EBX].TFloatRec.Exponent,AX

        MOV     [EBX].TFloatRec.Negative,DL

        RET



@@Exit:

        POP     EBX

        POP     ESI

        POP     EDI

end;



function TextToFloat(Buffer: PChar; var Value;

  ValueType: TFloatValue): Boolean;



const

// 8087 control word

// Infinity control  = 1 Affine

// Rounding Control  = 0 Round to nearest or even

// Precision Control = 3 64 bits

// All interrupts masked

  CWNear: Word = $133F;



var

  Temp: Integer;

  CtrlWord: Word;

  DecimalSep: Char;

  SaveGOT: Integer;

asm

        PUSH    EDI

        PUSH    ESI

        PUSH    EBX

        MOV     ESI,EAX

        MOV     EDI,EDX

{$IFDEF PIC}

        PUSH    ECX

        CALL    GetGOT

        POP     EBX

        MOV     SaveGOT,EAX

        MOV     ECX,[EAX].OFFSET DecimalSeparator

        MOV     CL,[ECX].Byte

        MOV     DecimalSep,CL

{$ELSE}

        MOV     SaveGOT,0

        MOV     AL,DecimalSeparator

        MOV     DecimalSep,AL

        MOV     EBX,ECX

{$ENDIF}

        FSTCW   CtrlWord

        FCLEX

{$IFDEF PIC}

        FLDCW   [EAX].CWNear

{$ELSE}

        FLDCW   CWNear

{$ENDIF}

        FLDZ

        CALL    @@SkipBlanks

        MOV     BH, byte ptr [ESI]

        CMP     BH,'+'

        JE      @@1

        CMP     BH,'-'

        JNE     @@2

@@1:    INC     ESI

@@2:    MOV     ECX,ESI

        CALL    @@GetDigitStr

        XOR     EDX,EDX

        MOV     AL,[ESI]

        CMP     AL,DecimalSep

        JNE     @@3

        INC     ESI

        CALL    @@GetDigitStr

        NEG     EDX

@@3:    CMP     ECX,ESI

        JE      @@9

        MOV     AL, byte ptr [ESI]

        AND     AL,0DFH

        CMP     AL,'E'

        JNE     @@4

        INC     ESI

        PUSH    EDX

        CALL    @@GetExponent

        POP     EAX

        ADD     EDX,EAX

@@4:    CALL    @@SkipBlanks

        CMP     BYTE PTR [ESI],0

        JNE     @@9

        MOV     EAX,EDX

        CMP     BL,fvCurrency

        JNE     @@5

        ADD     EAX,4

@@5:    PUSH    EBX

        MOV     EBX,SaveGOT

        CALL    FPower10

        POP     EBX

        CMP     BH,'-'

        JNE     @@6

        FCHS

@@6:    CMP     BL,fvExtended

        JE      @@7

        FISTP   QWORD PTR [EDI]

        JMP     @@8

@@7:    FSTP    TBYTE PTR [EDI]

@@8:    FSTSW   AX

        TEST    AX,mIE+mOE

        JNE     @@10

        MOV     AL,1

        JMP     @@11

@@9:    FSTP    ST(0)

@@10:   XOR     EAX,EAX

@@11:   FCLEX

        FLDCW   CtrlWord

        FWAIT

        JMP     @@Exit



@@SkipBlanks:



@@21:   LODSB

        OR      AL,AL

        JE      @@22

        CMP     AL,' '

        JE      @@21

@@22:   DEC     ESI

        RET



// Process string of digits

// Out EDX = Digit count



@@GetDigitStr:



        XOR     EAX,EAX

        XOR     EDX,EDX

@@31:   LODSB

        SUB     AL,'0'+10

        ADD     AL,10

        JNC     @@32

{$IFDEF PIC}

        XCHG    SaveGOT,EBX

        FIMUL   [EBX].DCon10

        XCHG    SaveGOT,EBX

{$ELSE}

        FIMUL   DCon10

{$ENDIF}

        MOV     Temp,EAX

        FIADD   Temp

        INC     EDX

        JMP     @@31

@@32:   DEC     ESI

        RET



// Get exponent

// Out EDX = Exponent (-4999..4999)



@@GetExponent:



        XOR     EAX,EAX

        XOR     EDX,EDX

        MOV     CL, byte ptr [ESI]

        CMP     CL,'+'

        JE      @@41

        CMP     CL,'-'

        JNE     @@42

@@41:   INC     ESI

@@42:   MOV     AL, byte ptr [ESI]

        SUB     AL,'0'+10

        ADD     AL,10

        JNC     @@43

        INC     ESI

        IMUL    EDX,10

        ADD     EDX,EAX

        CMP     EDX,500

        JB      @@42

@@43:   CMP     CL,'-'

        JNE     @@44

        NEG     EDX

@@44:   RET



@@Exit:

        POP     EBX

        POP     ESI

        POP     EDI

end;



function TextToFloat(Buffer: PChar; var Value;

  ValueType: TFloatValue; const FormatSettings: TFormatSettings): Boolean;



const

// 8087 control word

// Infinity control  = 1 Affine

// Rounding Control  = 0 Round to nearest or even

// Precision Control = 3 64 bits

// All interrupts masked

  CWNear: Word = $133F;



var

  Temp: Integer;

  CtrlWord: Word;

  DecimalSep: Char;

  SaveGOT: Integer;

asm

        PUSH    EDI

        PUSH    ESI

        PUSH    EBX

        MOV     ESI,EAX

        MOV     EDI,EDX

{$IFDEF PIC}

        PUSH    ECX

        CALL    GetGOT

        POP     EBX

        MOV     SaveGOT,EAX

{$ELSE}

        MOV     SaveGOT,0

        MOV     EBX,ECX

{$ENDIF}

        MOV     EAX,FormatSettings

        MOV     AL,[EAX].TFormatSettings.DecimalSeparator

        MOV     DecimalSep,AL

        FSTCW   CtrlWord

        FCLEX

{$IFDEF PIC}

        FLDCW   [EAX].CWNear

{$ELSE}

        FLDCW   CWNear

{$ENDIF}

        FLDZ

        CALL    @@SkipBlanks

        MOV     BH, byte ptr [ESI]

        CMP     BH,'+'

        JE      @@1

        CMP     BH,'-'

        JNE     @@2

@@1:    INC     ESI

@@2:    MOV     ECX,ESI

        CALL    @@GetDigitStr

        XOR     EDX,EDX

        MOV     AL,[ESI]

        CMP     AL,DecimalSep

        JNE     @@3

        INC     ESI

        CALL    @@GetDigitStr

        NEG     EDX

@@3:    CMP     ECX,ESI

        JE      @@9

        MOV     AL, byte ptr [ESI]

        AND     AL,0DFH

        CMP     AL,'E'

        JNE     @@4

        INC     ESI

        PUSH    EDX

        CALL    @@GetExponent

        POP     EAX

        ADD     EDX,EAX

@@4:    CALL    @@SkipBlanks

        CMP     BYTE PTR [ESI],0

        JNE     @@9

        MOV     EAX,EDX

        CMP     BL,fvCurrency

        JNE     @@5

        ADD     EAX,4

@@5:    PUSH    EBX

        MOV     EBX,SaveGOT

        CALL    FPower10

        POP     EBX

        CMP     BH,'-'

        JNE     @@6

        FCHS

@@6:    CMP     BL,fvExtended

        JE      @@7

        FISTP   QWORD PTR [EDI]

        JMP     @@8

@@7:    FSTP    TBYTE PTR [EDI]

@@8:    FSTSW   AX

        TEST    AX,mIE+mOE

        JNE     @@10

        MOV     AL,1

        JMP     @@11

@@9:    FSTP    ST(0)

@@10:   XOR     EAX,EAX

@@11:   FCLEX

        FLDCW   CtrlWord

        FWAIT

        JMP     @@Exit



@@SkipBlanks:



@@21:   LODSB

        OR      AL,AL

        JE      @@22

        CMP     AL,' '

        JE      @@21

@@22:   DEC     ESI

        RET



// Process string of digits

// Out EDX = Digit count



@@GetDigitStr:



        XOR     EAX,EAX

        XOR     EDX,EDX

@@31:   LODSB

        SUB     AL,'0'+10

        ADD     AL,10

        JNC     @@32

{$IFDEF PIC}

        XCHG    SaveGOT,EBX

        FIMUL   [EBX].DCon10

        XCHG    SaveGOT,EBX

{$ELSE}

        FIMUL   DCon10

{$ENDIF}

        MOV     Temp,EAX

        FIADD   Temp

        INC     EDX

        JMP     @@31

@@32:   DEC     ESI

        RET



// Get exponent

// Out EDX = Exponent (-4999..4999)



@@GetExponent:



        XOR     EAX,EAX

        XOR     EDX,EDX

        MOV     CL, byte ptr [ESI]

        CMP     CL,'+'

        JE      @@41

        CMP     CL,'-'

        JNE     @@42

@@41:   INC     ESI

@@42:   MOV     AL, byte ptr [ESI]

        SUB     AL,'0'+10

        ADD     AL,10

        JNC     @@43

        INC     ESI

        IMUL    EDX,10

        ADD     EDX,EAX

        CMP     EDX,500

        JB      @@42

@@43:   CMP     CL,'-'

        JNE     @@44

        NEG     EDX

@@44:   RET



@@Exit:

        POP     EBX

        POP     ESI

        POP     EDI

end;



function FloatToStr(Value: Extended): string;

var

  Buffer: array[0..63] of Char;

begin

  SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended,

    ffGeneral, 15, 0));

end;



function FloatToStr(Value: Extended;

  const FormatSettings: TFormatSettings): string;

var

  Buffer: array[0..63] of Char;

begin

  SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended,

    ffGeneral, 15, 0, FormatSettings));

end;



function CurrToStr(Value: Currency): string;

var

  Buffer: array[0..63] of Char;

begin

  SetString(Result, Buffer, FloatToText(Buffer, Value, fvCurrency,

    ffGeneral, 0, 0));

end;



function CurrToStr(Value: Currency;

  const FormatSettings: TFormatSettings): string;

var

  Buffer: array[0..63] of Char;

begin

  SetString(Result, Buffer, FloatToText(Buffer, Value, fvCurrency,

    ffGeneral, 0, 0, FormatSettings));

end;



function TryFloatToCurr(const Value: Extended; out AResult: Currency): Boolean;

begin

  Result := (Value >= MinCurrency) and (Value <= MaxCurrency);

  if Result then

    AResult := Value;

end;



function FloatToCurr(const Value: Extended): Currency;

begin

  if not TryFloatToCurr(Value, Result) then

    ConvertErrorFmt(SInvalidCurrency, [FloatToStr(Value)]);

end;



function FloatToStrF(Value: Extended; Format: TFloatFormat;

  Precision, Digits: Integer): string;

var

  Buffer: array[0..63] of Char;

begin

  SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended,

    Format, Precision, Digits));

end;



function FloatToStrF(Value: Extended; Format: TFloatFormat;

  Precision, Digits: Integer; const FormatSettings: TFormatSettings): string;

var

  Buffer: array[0..63] of Char;

begin

  SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended,

    Format, Precision, Digits, FormatSettings));

end;



function CurrToStrF(Value: Currency; Format: TFloatFormat;

  Digits: Integer): string;

var

  Buffer: array[0..63] of Char;

begin

  SetString(Result, Buffer, FloatToText(Buffer, Value, fvCurrency,

    Format, 0, Digits));

end;



function CurrToStrF(Value: Currency; Format: TFloatFormat;

  Digits: Integer; const FormatSettings: TFormatSettings): string;

var

  Buffer: array[0..63] of Char;

begin

  SetString(Result, Buffer, FloatToText(Buffer, Value, fvCurrency,

    Format, 0, Digits, FormatSettings));

end;



function FormatFloat(const Format: string; Value: Extended): string;

var

  Buffer: array[0..255] of Char;

begin

  if Length(Format) > SizeOf(Buffer) - 32 then ConvertError(SFormatTooLong);

  SetString(Result, Buffer, FloatToTextFmt(Buffer, Value, fvExtended,

    PChar(Format)));

end;



function FormatFloat(const Format: string; Value: Extended;

  const FormatSettings: TFormatSettings): string;

var

  Buffer: array[0..255] of Char;

begin

  if Length(Format) > SizeOf(Buffer) - 32 then ConvertError(SFormatTooLong);

  SetString(Result, Buffer, FloatToTextFmt(Buffer, Value, fvExtended,

    PChar(Format), FormatSettings));

end;



function FormatCurr(const Format: string; Value: Currency): string;

var

  Buffer: array[0..255] of Char;

begin

  if Length(Format) > SizeOf(Buffer) - 32 then ConvertError(SFormatTooLong);

  SetString(Result, Buffer, FloatToTextFmt(Buffer, Value, fvCurrency,

    PChar(Format)));

end;



function FormatCurr(const Format: string; Value: Currency;

  const FormatSettings: TFormatSettings): string;

var

  Buffer: array[0..255] of Char;

begin

  if Length(Format) > SizeOf(Buffer) - 32 then ConvertError(SFormatTooLong);

  SetString(Result, Buffer, FloatToTextFmt(Buffer, Value, fvCurrency,

    PChar(Format), FormatSettings));

end;



function StrToFloat(const S: string): Extended;

begin

  if not TextToFloat(PChar(S), Result, fvExtended) then

    ConvertErrorFmt(SInvalidFloat, [S]);

end;



function StrToFloat(const S: string;

  const FormatSettings: TFormatSettings): Extended;

begin

  if not TextToFloat(PChar(S), Result, fvExtended, FormatSettings) then

    ConvertErrorFmt(SInvalidFloat, [S]);

end;



function StrToFloatDef(const S: string; const Default: Extended): Extended;

begin

  if not TextToFloat(PChar(S), Result, fvExtended) then

    Result := Default;

end;



function StrToFloatDef(const S: string; const Default: Extended;

  const FormatSettings: TFormatSettings): Extended;

begin

  if not TextToFloat(PChar(S), Result, fvExtended, FormatSettings) then

    Result := Default;

end;



function TryStrToFloat(const S: string; out Value: Extended): Boolean;

begin

  Result := TextToFloat(PChar(S), Value, fvExtended);

end;



function TryStrToFloat(const S: string; out Value: Extended;

  const FormatSettings: TFormatSettings): Boolean;

begin

  Result := TextToFloat(PChar(S), Value, fvExtended, FormatSettings);

end;



function TryStrToFloat(const S: string; out Value: Double): Boolean;

var

  LValue: Extended;

begin

  Result := TextToFloat(PChar(S), LValue, fvExtended);

  if Result then

    Value := LValue;

end;



function TryStrToFloat(const S: string; out Value: Double;

  const FormatSettings: TFormatSettings): Boolean;

var

  LValue: Extended;

begin

  Result := TextToFloat(PChar(S), LValue, fvExtended, FormatSettings);

  if Result then

    Value := LValue;

end;



function TryStrToFloat(const S: string; out Value: Single): Boolean;

var

  LValue: Extended;

begin

  Result := TextToFloat(PChar(S), LValue, fvExtended);

  if Result then

    Value := LValue;

end;



function TryStrToFloat(const S: string; out Value: Single;

  const FormatSettings: TFormatSettings): Boolean;

var

  LValue: Extended;

begin

  Result := TextToFloat(PChar(S), LValue, fvExtended, FormatSettings);

  if Result then

    Value := LValue;

end;



function StrToCurr(const S: string): Currency;

begin

  if not TextToFloat(PChar(S), Result, fvCurrency) then

    ConvertErrorFmt(SInvalidFloat, [S]);

end;



function StrToCurr(const S: string;

  const FormatSettings: TFormatSettings): Currency;

begin

  if not TextToFloat(PChar(S), Result, fvCurrency, FormatSettings) then

    ConvertErrorFmt(SInvalidFloat, [S]);

end;



function StrToCurrDef(const S: string; const Default: Currency): Currency;

begin

  if not TextToFloat(PChar(S), Result, fvCurrency) then

    Result := Default;

end;



function StrToCurrDef(const S: string; const Default: Currency;

  const FormatSettings: TFormatSettings): Currency;

begin

  if not TextToFloat(PChar(S), Result, fvCurrency, FormatSettings) then

    Result := Default;

end;



function TryStrToCurr(const S: string; out Value: Currency): Boolean;

begin

  Result := TextToFloat(PChar(S), Value, fvCurrency);

end;



function TryStrToCurr(const S: string; out Value: Currency;

  const FormatSettings: TFormatSettings): Boolean;

begin

  Result := TextToFloat(PChar(S), Value, fvCurrency, FormatSettings);

end;



{ Date/time support routines }



const

  FMSecsPerDay: Single = MSecsPerDay;

  IMSecsPerDay: Integer = MSecsPerDay;



function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp;

asm

        PUSH    EBX

{$IFDEF PIC}

        PUSH    EAX

        CALL    GetGOT

        MOV     EBX,EAX

        POP     EAX

{$ELSE}

        XOR     EBX,EBX

{$ENDIF}

        MOV     ECX,EAX

        FLD     DateTime

        FMUL    [EBX].FMSecsPerDay

        SUB     ESP,8

        FISTP   QWORD PTR [ESP]

        FWAIT

        POP     EAX

        POP     EDX

        OR      EDX,EDX

        JNS     @@1

        NEG     EDX

        NEG     EAX

        SBB     EDX,0

        DIV     [EBX].IMSecsPerDay

        NEG     EAX

        JMP     @@2

@@1:    DIV     [EBX].IMSecsPerDay

@@2:    ADD     EAX,DateDelta

        MOV     [ECX].TTimeStamp.Time,EDX

        MOV     [ECX].TTimeStamp.Date,EAX

        POP     EBX

end;



procedure ValidateTimeStamp(const TimeStamp: TTimeStamp);

begin

  if (TimeStamp.Time < 0) or (TimeStamp.Date <= 0) then

    ConvertErrorFmt(SInvalidTimeStamp, [TimeStamp.Date, TimeStamp.Time]);

end;



function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime;

asm

        PUSH    EBX

{$IFDEF PIC}

        PUSH    EAX

        CALL    GetGOT

        MOV     EBX,EAX

        POP     EAX

{$ELSE}

        XOR     EBX,EBX

{$ENDIF}

        PUSH    EAX

        CALL    ValidateTimeStamp

        POP     EAX

        MOV     ECX,[EAX].TTimeStamp.Time

        MOV     EAX,[EAX].TTimeStamp.Date

        SUB     EAX,DateDelta

        IMUL    [EBX].IMSecsPerDay

        OR      EDX,EDX

        JNS     @@1

        SUB     EAX,ECX

        SBB     EDX,0

        JMP     @@2

@@1:    ADD     EAX,ECX

        ADC     EDX,0

@@2:    PUSH    EDX

        PUSH    EAX

        FILD    QWORD PTR [ESP]

        FDIV    [EBX].FMSecsPerDay

        ADD     ESP,8

        POP     EBX

end;



function MSecsToTimeStamp(MSecs: Comp): TTimeStamp;

asm

        PUSH    EBX

{$IFDEF PIC}

        PUSH    EAX

        CALL    GetGOT

        MOV     EBX,EAX

        POP     EAX

{$ELSE}

        XOR     EBX,EBX

{$ENDIF}

        MOV     ECX,EAX

        MOV     EAX,MSecs.Integer[0]

        MOV     EDX,MSecs.Integer[4]

        DIV     [EBX].IMSecsPerDay

        MOV     [ECX].TTimeStamp.Time,EDX

        MOV     [ECX].TTimeStamp.Date,EAX

        POP     EBX

end;



function TimeStampToMSecs(const TimeStamp: TTimeStamp): Comp;

asm

        PUSH    EBX

{$IFDEF PIC}

        PUSH    EAX

        CALL    GetGOT

        MOV     EBX,EAX

        POP     EAX

{$ELSE}

        XOR     EBX,EBX

{$ENDIF}

        PUSH    EAX

        CALL    ValidateTimeStamp

        POP     EAX

        FILD    [EAX].TTimeStamp.Date

        FMUL    [EBX].FMSecsPerDay

        FIADD   [EAX].TTimeStamp.Time

        POP     EBX

end;



{ Time encoding and decoding }



function TryEncodeTime(Hour, Min, Sec, MSec: Word; out Time: TDateTime): Boolean;

begin

  Result := False;

  if (Hour < HoursPerDay) and (Min < MinsPerHour) and (Sec < SecsPerMin) and (MSec < MSecsPerSec) then

  begin

    Time := (Hour * (MinsPerHour * SecsPerMin * MSecsPerSec) +

             Min * (SecsPerMin * MSecsPerSec) +

             Sec * MSecsPerSec +

             MSec) / MSecsPerDay;

    Result := True;

  end;

end;



function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime;

begin

  if not TryEncodeTime(Hour, Min, Sec, MSec, Result) then

    ConvertError(STimeEncodeError);

end;



procedure DecodeTime(const DateTime: TDateTime; var Hour, Min, Sec, MSec: Word);

var

  MinCount, MSecCount: Word;

begin

  DivMod(DateTimeToTimeStamp(DateTime).Time, SecsPerMin * MSecsPerSec, MinCount, MSecCount);

  DivMod(MinCount, MinsPerHour, Hour, Min);

  DivMod(MSecCount, MSecsPerSec, Sec, MSec);

end;



{ Date encoding and decoding }



function IsLeapYear(Year: Word): Boolean;

begin

  Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));

end;



function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean;

var

  I: Integer;

  DayTable: PDayTable;

begin

  Result := False;

  DayTable := @MonthDays[IsLeapYear(Year)];

  if (Year >= 1) and (Year <= 9999) and (Month >= 1) and (Month <= 12) and

    (Day >= 1) and (Day <= DayTable^[Month]) then

  begin

    for I := 1 to Month - 1 do Inc(Day, DayTable^[I]);

    I := Year - 1;

    Date := I * 365 + I div 4 - I div 100 + I div 400 + Day - DateDelta;

    Result := True;

  end;

end;



function EncodeDate(Year, Month, Day: Word): TDateTime;

begin

  if not TryEncodeDate(Year, Month, Day, Result) then

    ConvertError(SDateEncodeError);

end;



function DecodeDateFully(const DateTime: TDateTime; var Year, Month, Day, DOW: Word): Boolean;

const

  D1 = 365;

  D4 = D1 * 4 + 1;

  D100 = D4 * 25 - 1;

  D400 = D100 * 4 + 1;

var

  Y, M, D, I: Word;

  T: Integer;

  DayTable: PDayTable;

begin

  T := DateTimeToTimeStamp(DateTime).Date;

  if T <= 0 then

  begin

    Year := 0;

    Month := 0;

    Day := 0;

    DOW := 0;

    Result := False;

  end else

  begin

    DOW := T mod 7 + 1;

    Dec(T);

    Y := 1;

    while T >= D400 do

    begin

      Dec(T, D400);

      Inc(Y, 400);

    end;

    DivMod(T, D100, I, D);

    if I = 4 then

    begin

      Dec(I);

      Inc(D, D100);

    end;

    Inc(Y, I * 100);

    DivMod(D, D4, I, D);

    Inc(Y, I * 4);

    DivMod(D, D1, I, D);

    if I = 4 then

    begin

      Dec(I);

      Inc(D, D1);

    end;

    Inc(Y, I);

    Result := IsLeapYear(Y);

    DayTable := @MonthDays[Result];

    M := 1;

    while True do

    begin

      I := DayTable^[M];

      if D < I then Break;

      Dec(D, I);

      Inc(M);

    end;

    Year := Y;

    Month := M;

    Day := D + 1;

  end;

end;



function InternalDecodeDate(const DateTime: TDateTime; var Year, Month, Day, DOW: Word): Boolean;

begin

  Result := DecodeDateFully(DateTime, Year, Month, Day, DOW);

  Dec(DOW);

end;



procedure DecodeDate(const DateTime: TDateTime; var Year, Month, Day: Word);

var

  Dummy: Word;

begin

  DecodeDateFully(DateTime, Year, Month, Day, Dummy);

end;



{$IFDEF MSWINDOWS}

procedure DateTimeToSystemTime(const DateTime: TDateTime; var SystemTime: TSystemTime);

begin

  with SystemTime do

  begin

    DecodeDateFully(DateTime, wYear, wMonth, wDay, wDayOfWeek);

    Dec(wDayOfWeek);

    DecodeTime(DateTime, wHour, wMinute, wSecond, wMilliseconds);

  end;

end;



function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime;

begin

  with SystemTime do

  begin

    Result := EncodeDate(wYear, wMonth, wDay);

    if Result >= 0 then

      Result := Result + EncodeTime(wHour, wMinute, wSecond, wMilliSeconds)

    else

      Result := Result - EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);

  end;

end;

{$ENDIF}



function DayOfWeek(const DateTime: TDateTime): Word;

begin

  Result := DateTimeToTimeStamp(DateTime).Date mod 7 + 1;

end;



function Date: TDateTime;

{$IFDEF MSWINDOWS}

var

  SystemTime: TSystemTime;

begin

  GetLocalTime(SystemTime);

  with SystemTime do Result := EncodeDate(wYear, wMonth, wDay);

end;

{$ENDIF}

{$IFDEF LINUX}

var

  T: TTime_T;

  UT: TUnixTime;

begin

  __time(@T);

  localtime_r(@T, UT);

  Result := EncodeDate(UT.tm_year + 1900, UT.tm_mon + 1, UT.tm_mday);

end;

{$ENDIF}



function Time: TDateTime;

{$IFDEF MSWINDOWS}

var

  SystemTime: TSystemTime;

begin

  GetLocalTime(SystemTime);

  with SystemTime do

    Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);

end;

{$ENDIF}

{$IFDEF LINUX}

var

  T: TTime_T;

  TV: TTimeVal;

  UT: TUnixTime;

begin

  gettimeofday(TV, nil);

  T := TV.tv_sec;

  localtime_r(@T, UT);

  Result := EncodeTime(UT.tm_hour, UT.tm_min, UT.tm_sec, TV.tv_usec div 1000);

end;

{$ENDIF}



function GetTime: TDateTime;

begin

  Result := Time;

end;



function Now: TDateTime;

{$IFDEF MSWINDOWS}

var

  SystemTime: TSystemTime;

begin

  GetLocalTime(SystemTime);

  with SystemTime do

    Result := EncodeDate(wYear, wMonth, wDay) +

      EncodeTime(wHour, wMinute, wSecond, wMilliseconds);

end;

{$ENDIF}

{$IFDEF LINUX}

var

  T: TTime_T;

  TV: TTimeVal;

  UT: TUnixTime;

begin

  gettimeofday(TV, nil);

  T := TV.tv_sec;

  localtime_r(@T, UT);

  Result := EncodeDate(UT.tm_year + 1900, UT.tm_mon + 1, UT.tm_mday) +

    EncodeTime(UT.tm_hour, UT.tm_min, UT.tm_sec, TV.tv_usec div 1000);

end;

{$ENDIF}



function IncMonth(const DateTime: TDateTime; NumberOfMonths: Integer): TDateTime;

var

  Year, Month, Day: Word;

begin

  DecodeDate(DateTime, Year, Month, Day);

  IncAMonth(Year, Month, Day, NumberOfMonths);

  Result := EncodeDate(Year, Month, Day);

  ReplaceTime(Result, DateTime);

end;



procedure IncAMonth(var Year, Month, Day: Word; NumberOfMonths: Integer = 1);

var

  DayTable: PDayTable;

  Sign: Integer;

begin

  if NumberOfMonths >= 0 then Sign := 1 else Sign := -1;

  Year := Year + (NumberOfMonths div 12);

  NumberOfMonths := NumberOfMonths mod 12;

  Inc(Month, NumberOfMonths);

  if Word(Month-1) > 11 then    // if Month <= 0, word(Month-1) > 11)

  begin

    Inc(Year, Sign);

    Inc(Month, -12 * Sign);

  end;

  DayTable := @MonthDays[IsLeapYear(Year)];

  if Day > DayTable^[Month] then Day := DayTable^[Month];

end;



procedure ReplaceTime(var DateTime: TDateTime; const NewTime: TDateTime);

begin

  DateTime := Trunc(DateTime);

  if DateTime >= 0 then

    DateTime := DateTime + Abs(Frac(NewTime))

  else

    DateTime := DateTime - Abs(Frac(NewTime));

end;



procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime);

var

  Temp: TDateTime;

begin

  Temp := NewDate;

  ReplaceTime(Temp, DateTime);

  DateTime := Temp;

end;



function CurrentYear: Word;

{$IFDEF MSWINDOWS}

var

  SystemTime: TSystemTime;

begin

  GetLocalTime(SystemTime);

  Result := SystemTime.wYear;

end;

{$ENDIF}

{$IFDEF LINUX}

var

  T: TTime_T;

  UT: TUnixTime;

begin

  __time(@T);

  localtime_r(@T, UT);

  Result := UT.tm_year + 1900;

end;

{$ENDIF}



{ Date/time to string conversions }



procedure DateTimeToString(var Result: string; const Format: string;

  DateTime: TDateTime);

var

  BufPos, AppendLevel: Integer;

  Buffer: array[0..255] of Char;



  procedure AppendChars(P: PChar; Count: Integer);

  var

    N: Integer;

  begin

    N := SizeOf(Buffer) - BufPos;

    if N > Count then N := Count;

    if N <> 0 then Move(P[0], Buffer[BufPos], N);

    Inc(BufPos, N);

  end;



  procedure AppendString(const S: string);

  begin

    AppendChars(Pointer(S), Length(S));

  end;



  procedure AppendNumber(Number, Digits: Integer);

  const

    Format: array[0..3] of Char = '%.*d';

  var

    NumBuf: array[0..15] of Char;

  begin

    AppendChars(NumBuf, FormatBuf(NumBuf, SizeOf(NumBuf), Format,

      SizeOf(Format), [Digits, Number]));

  end;



  procedure AppendFormat(Format: PChar);

  var

    Starter, Token, LastToken: Char;

    DateDecoded, TimeDecoded, Use12HourClock,

    BetweenQuotes: Boolean;

    P: PChar;

    Count: Integer;

    Year, Month, Day, Hour, Min, Sec, MSec, H: Word;



    procedure GetCount;

    var

      P: PChar;

    begin

      P := Format;

      while Format^ = Starter do Inc(Format);

      Count := Format - P + 1;

    end;



    procedure GetDate;

    begin

      if not DateDecoded then

      begin

        DecodeDate(DateTime, Year, Month, Day);

        DateDecoded := True;

      end;

    end;



    procedure GetTime;

    begin

      if not TimeDecoded then

      begin

        DecodeTime(DateTime, Hour, Min, Sec, MSec);

        TimeDecoded := True;

      end;

    end;



{$IFDEF MSWINDOWS}

    function ConvertEraString(const Count: Integer) : string;

    var

      FormatStr: string;

      SystemTime: TSystemTime;

      Buffer: array[Byte] of Char;

      P: PChar;

    begin

      Result := '';

      with SystemTime do

      begin

        wYear  := Year;

        wMonth := Month;

        wDay   := Day;

      end;



      FormatStr := 'gg';

      if GetDateFormat(GetThreadLocale, DATE_USE_ALT_CALENDAR, @SystemTime,

        PChar(FormatStr), Buffer, SizeOf(Buffer)) <> 0 then

      begin

        Result := Buffer;

        if Count = 1 then

        begin

          case SysLocale.PriLangID of

            LANG_JAPANESE:

              Result := Copy(Result, 1, CharToBytelen(Result, 1));

            LANG_CHINESE:

              if (SysLocale.SubLangID = SUBLANG_CHINESE_TRADITIONAL)

                and (ByteToCharLen(Result, Length(Result)) = 4) then

              begin

                P := Buffer + CharToByteIndex(Result, 3) - 1;

                SetString(Result, P, CharToByteLen(P, 2));

              end;

          end;

        end;

      end;

    end;



    function ConvertYearString(const Count: Integer): string;

    var

      FormatStr: string;

      SystemTime: TSystemTime;

      Buffer: array[Byte] of Char;

    begin

      Result := '';

      with SystemTime do

      begin

        wYear  := Year;

        wMonth := Month;

        wDay   := Day;

      end;



      if Count <= 2 then

        FormatStr := 'yy' // avoid Win95 bug.

      else

        FormatStr := 'yyyy';



      if GetDateFormat(GetThreadLocale, DATE_USE_ALT_CALENDAR, @SystemTime,

        PChar(FormatStr), Buffer, SizeOf(Buffer)) <> 0 then

      begin

        Result := Buffer;

        if (Count = 1) and (Result[1] = '0') then

          Result := Copy(Result, 2, Length(Result)-1);

      end;

    end;

{$ENDIF}



{$IFDEF LINUX}

    function FindEra(Date: Integer): Byte;

    var

      I : Byte;

    begin

      Result := 0;

      for I := 1 to EraCount do

      begin

        if (EraRanges[I].StartDate <= Date) and

          (EraRanges[I].EndDate >= Date) then

        begin

          Result := I;

          Exit;

        end;

      end;

    end;



    function ConvertEraString(const Count: Integer) : String;

    var

      I : Byte;

    begin

      Result := '';

      I := FindEra(Trunc(DateTime));

      if I > 0 then

        Result := EraNames[I];

    end;



    function ConvertYearString(const Count: Integer) : String;

    var

      I : Byte;

      S : string;

    begin

      I := FindEra(Trunc(DateTime));

      if I > 0 then

        S := IntToStr(Year - EraYearOffsets[I])

      else

        S := IntToStr(Year);

      while Length(S) < Count do

        S := '0' + S;

      if Length(S) > Count then

        S := Copy(S, Length(S) - (Count - 1), Count);

      Result := S;

    end;

{$ENDIF}



  begin

    if (Format <> nil) and (AppendLevel < 2) then

    begin

      Inc(AppendLevel);

      LastToken := ' ';

      DateDecoded := False;

      TimeDecoded := False;

      Use12HourClock := False;

      while Format^ <> #0 do

      begin

        Starter := Format^;

        if Starter in LeadBytes then

        begin

          AppendChars(Format, StrCharLength(Format));

          Format := StrNextChar(Format);

          LastToken := ' ';

          Continue;

        end;

        Format := StrNextChar(Format);

        Token := Starter;

        if Token in ['a'..'z'] then Dec(Token, 32);

        if Token in ['A'..'Z'] then

        begin

          if (Token = 'M') and (LastToken = 'H') then Token := 'N';

          LastToken := Token;

        end;

        case Token of

          'Y':

            begin

              GetCount;

              GetDate;

              if Count <= 2 then

                AppendNumber(Year mod 100, 2) else

                AppendNumber(Year, 4);

            end;

          'G':

            begin

              GetCount;

              GetDate;

              AppendString(ConvertEraString(Count));

            end;

          'E':

            begin

              GetCount;

              GetDate;

              AppendString(ConvertYearString(Count));

            end;

          'M':

            begin

              GetCount;

              GetDate;

              case Count of

                1, 2: AppendNumber(Month, Count);

                3: AppendString(ShortMonthNames[Month]);

              else

                AppendString(LongMonthNames[Month]);

              end;

            end;

          'D':

            begin

              GetCount;

              case Count of

                1, 2:

                  begin

                    GetDate;

                    AppendNumber(Day, Count);

                  end;

                3: AppendString(ShortDayNames[DayOfWeek(DateTime)]);

                4: AppendString(LongDayNames[DayOfWeek(DateTime)]);

                5: AppendFormat(Pointer(ShortDateFormat));

              else

                AppendFormat(Pointer(LongDateFormat));

              end;

            end;

          'H':

            begin

              GetCount;

              GetTime;

              BetweenQuotes := False;

              P := Format;

              while P^ <> #0 do

              begin

                if P^ in LeadBytes then

                begin

                  P := StrNextChar(P);

                  Continue;

                end;

                case P^ of

                  'A', 'a':

                    if not BetweenQuotes then

                    begin

                      if ( (StrLIComp(P, 'AM/PM', 5) = 0)

                        or (StrLIComp(P, 'A/P',   3) = 0)

                        or (StrLIComp(P, 'AMPM',  4) = 0) ) then

                        Use12HourClock := True;

                      Break;

                    end;

                  'H', 'h':

                    Break;

                  '''', '"': BetweenQuotes := not BetweenQuotes;

                end;

                Inc(P);

              end;

              H := Hour;

              if Use12HourClock then

                if H = 0 then H := 12 else if H > 12 then Dec(H, 12);

              if Count > 2 then Count := 2;

              AppendNumber(H, Count);

            end;

          'N':

            begin

              GetCount;

              GetTime;

              if Count > 2 then Count := 2;

              AppendNumber(Min, Count);

            end;

          'S':

            begin

              GetCount;

              GetTime;

              if Count > 2 then Count := 2;

              AppendNumber(Sec, Count);

            end;

          'T':

            begin

              GetCount;

              if Count = 1 then

                AppendFormat(Pointer(ShortTimeFormat)) else

                AppendFormat(Pointer(LongTimeFormat));

            end;

          'Z':

            begin

              GetCount;

              GetTime;

              if Count > 3 then Count := 3;

              AppendNumber(MSec, Count);

            end;

          'A':

            begin

              GetTime;

              P := Format - 1;

              if StrLIComp(P, 'AM/PM', 5) = 0 then

              begin

                if Hour >= 12 then Inc(P, 3);

                AppendChars(P, 2);

                Inc(Format, 4);

                Use12HourClock := TRUE;

              end else

              if StrLIComp(P, 'A/P', 3) = 0 then

              begin

                if Hour >= 12 then Inc(P, 2);

                AppendChars(P, 1);

                Inc(Format, 2);

                Use12HourClock := TRUE;

              end else

              if StrLIComp(P, 'AMPM', 4) = 0 then

              begin

                if Hour < 12 then

                  AppendString(TimeAMString) else

                  AppendString(TimePMString);

                Inc(Format, 3);

                Use12HourClock := TRUE;

              end else

              if StrLIComp(P, 'AAAA', 4) = 0 then

              begin

                GetDate;

                AppendString(LongDayNames[DayOfWeek(DateTime)]);

                Inc(Format, 3);

              end else

              if StrLIComp(P, 'AAA', 3) = 0 then

              begin

                GetDate;

                AppendString(ShortDayNames[DayOfWeek(DateTime)]);

                Inc(Format, 2);

              end else

              AppendChars(@Starter, 1);

            end;

          'C':

            begin

              GetCount;

              AppendFormat(Pointer(ShortDateFormat));

              GetTime;

              if (Hour <> 0) or (Min <> 0) or (Sec <> 0) then

              begin

                AppendChars(' ', 1);

                AppendFormat(Pointer(LongTimeFormat));

              end;

            end;

          '/':

            if DateSeparator <> #0 then

              AppendChars(@DateSeparator, 1);

          ':':

            if TimeSeparator <> #0 then

              AppendChars(@TimeSeparator, 1);

          '''', '"':

            begin

              P := Format;

              while (Format^ <> #0) and (Format^ <> Starter) do

              begin

                if Format^ in LeadBytes then

                  Format := StrNextChar(Format)

                else

                  Inc(Format);

              end;

              AppendChars(P, Format - P);

              if Format^ <> #0 then Inc(Format);

            end;

        else

          AppendChars(@Starter, 1);

        end;

      end;

      Dec(AppendLevel);

    end;

  end;



begin

  BufPos := 0;

  AppendLevel := 0;

  if Format <> '' then AppendFormat(Pointer(Format)) else AppendFormat('C');

  SetString(Result, Buffer, BufPos);

end;



procedure DateTimeToString(var Result: string; const Format: string;

  DateTime: TDateTime; const FormatSettings: TFormatSettings);

var

  BufPos, AppendLevel: Integer;

  Buffer: array[0..255] of Char;



  procedure AppendChars(P: PChar; Count: Integer);

  var

    N: Integer;

  begin

    N := SizeOf(Buffer) - BufPos;

    if N > Count then N := Count;

    if N <> 0 then Move(P[0], Buffer[BufPos], N);

    Inc(BufPos, N);

  end;



  procedure AppendString(const S: string);

  begin

    AppendChars(Pointer(S), Length(S));

  end;



  procedure AppendNumber(Number, Digits: Integer);

  const

    Format: array[0..3] of Char = '%.*d';

  var

    NumBuf: array[0..15] of Char;

  begin

    AppendChars(NumBuf, FormatBuf(NumBuf, SizeOf(NumBuf), Format,

      SizeOf(Format), [Digits, Number]));

  end;



  procedure AppendFormat(Format: PChar);

  var

    Starter, Token, LastToken: Char;

    DateDecoded, TimeDecoded, Use12HourClock,

    BetweenQuotes: Boolean;

    P: PChar;

    Count: Integer;

    Year, Month, Day, Hour, Min, Sec, MSec, H: Word;



    procedure GetCount;

    var

      P: PChar;

    begin

      P := Format;

      while Format^ = Starter do Inc(Format);

      Count := Format - P + 1;

    end;



    procedure GetDate;

    begin

      if not DateDecoded then

      begin

        DecodeDate(DateTime, Year, Month, Day);

        DateDecoded := True;

      end;

    end;



    procedure GetTime;

    begin

      if not TimeDecoded then

      begin

        DecodeTime(DateTime, Hour, Min, Sec, MSec);

        TimeDecoded := True;

      end;

    end;



{$IFDEF MSWINDOWS}

    function ConvertEraString(const Count: Integer) : string;

    var

      FormatStr: string;

      SystemTime: TSystemTime;

      Buffer: array[Byte] of Char;

      P: PChar;

    begin

      Result := '';

      with SystemTime do

      begin

        wYear  := Year;

        wMonth := Month;

        wDay   := Day;

      end;



      FormatStr := 'gg';

      if GetDateFormat(GetThreadLocale, DATE_USE_ALT_CALENDAR, @SystemTime,

        PChar(FormatStr), Buffer, SizeOf(Buffer)) <> 0 then

      begin

        Result := Buffer;

        if Count = 1 then

        begin

          case SysLocale.PriLangID of

            LANG_JAPANESE:

              Result := Copy(Result, 1, CharToBytelen(Result, 1));

            LANG_CHINESE:

              if (SysLocale.SubLangID = SUBLANG_CHINESE_TRADITIONAL)

                and (ByteToCharLen(Result, Length(Result)) = 4) then

              begin

                P := Buffer + CharToByteIndex(Result, 3) - 1;

                SetString(Result, P, CharToByteLen(P, 2));

              end;

          end;

        end;

      end;

    end;



    function ConvertYearString(const Count: Integer): string;

    var

      FormatStr: string;

      SystemTime: TSystemTime;

      Buffer: array[Byte] of Char;

    begin

      Result := '';

      with SystemTime do

      begin

        wYear  := Year;

        wMonth := Month;

        wDay   := Day;

      end;



      if Count <= 2 then

        FormatStr := 'yy' // avoid Win95 bug.

      else

        FormatStr := 'yyyy';



      if GetDateFormat(GetThreadLocale, DATE_USE_ALT_CALENDAR, @SystemTime,

        PChar(FormatStr), Buffer, SizeOf(Buffer)) <> 0 then

      begin

        Result := Buffer;

        if (Count = 1) and (Result[1] = '0') then

          Result := Copy(Result, 2, Length(Result)-1);

      end;

    end;

{$ENDIF}



{$IFDEF LINUX}

    function FindEra(Date: Integer): Byte;

    var

      I : Byte;

    begin

      Result := 0;

      for I := 1 to EraCount do

      begin

        if (EraRanges[I].StartDate <= Date) and

          (EraRanges[I].EndDate >= Date) then

        begin

          Result := I;

          Exit;

        end;

      end;

    end;



    function ConvertEraString(const Count: Integer) : String;

    var

      I : Byte;

    begin

      Result := '';

      I := FindEra(Trunc(DateTime));

      if I > 0 then

        Result := EraNames[I];

    end;



    function ConvertYearString(const Count: Integer) : String;

    var

      I : Byte;

      S : string;

    begin

      I := FindEra(Trunc(DateTime));

      if I > 0 then

        S := IntToStr(Year - EraYearOffsets[I])

      else

        S := IntToStr(Year);

      while Length(S) < Count do

        S := '0' + S;

      if Length(S) > Count then

        S := Copy(S, Length(S) - (Count - 1), Count);

      Result := S;

    end;

{$ENDIF}



  begin

    if (Format <> nil) and (AppendLevel < 2) then

    begin

      Inc(AppendLevel);

      LastToken := ' ';

      DateDecoded := False;

      TimeDecoded := False;

      Use12HourClock := False;

      while Format^ <> #0 do

      begin

        Starter := Format^;

        if Starter in LeadBytes then

        begin

          AppendChars(Format, StrCharLength(Format));

          Format := StrNextChar(Format);

          LastToken := ' ';

          Continue;

        end;

        Format := StrNextChar(Format);

        Token := Starter;

        if Token in ['a'..'z'] then Dec(Token, 32);

        if Token in ['A'..'Z'] then

        begin

          if (Token = 'M') and (LastToken = 'H') then Token := 'N';

          LastToken := Token;

        end;

        case Token of

          'Y':

            begin

              GetCount;

              GetDate;

              if Count <= 2 then

                AppendNumber(Year mod 100, 2) else

                AppendNumber(Year, 4);

            end;

          'G':

            begin

              GetCount;

              GetDate;

              AppendString(ConvertEraString(Count));

            end;

          'E':

            begin

              GetCount;

              GetDate;

              AppendString(ConvertYearString(Count));

            end;

          'M':

            begin

              GetCount;

              GetDate;

              case Count of

                1, 2: AppendNumber(Month, Count);

                3: AppendString(FormatSettings.ShortMonthNames[Month]);

              else

                AppendString(FormatSettings.LongMonthNames[Month]);

              end;

            end;

          'D':

            begin

              GetCount;

              case Count of

                1, 2:

                  begin

                    GetDate;

                    AppendNumber(Day, Count);

                  end;

                3: AppendString(FormatSettings.ShortDayNames[DayOfWeek(DateTime)]);

                4: AppendString(FormatSettings.LongDayNames[DayOfWeek(DateTime)]);

                5: AppendFormat(Pointer(FormatSettings.ShortDateFormat));

              else

                AppendFormat(Pointer(FormatSettings.LongDateFormat));

              end;

            end;

          'H':

            begin

              GetCount;

              GetTime;

              BetweenQuotes := False;

              P := Format;

              while P^ <> #0 do

              begin

                if P^ in LeadBytes then

                begin

                  P := StrNextChar(P);

                  Continue;

                end;

                case P^ of

                  'A', 'a':

                    if not BetweenQuotes then

                    begin

                      if ( (StrLIComp(P, 'AM/PM', 5) = 0)

                        or (StrLIComp(P, 'A/P',   3) = 0)

                        or (StrLIComp(P, 'AMPM',  4) = 0) ) then

                        Use12HourClock := True;

                      Break;

                    end;

                  'H', 'h':

                    Break;

                  '''', '"': BetweenQuotes := not BetweenQuotes;

                end;

                Inc(P);

              end;

              H := Hour;

              if Use12HourClock then

                if H = 0 then H := 12 else if H > 12 then Dec(H, 12);

              if Count > 2 then Count := 2;

              AppendNumber(H, Count);

            end;

          'N':

            begin

              GetCount;

              GetTime;

              if Count > 2 then Count := 2;

              AppendNumber(Min, Count);

            end;

          'S':

            begin

              GetCount;

              GetTime;

              if Count > 2 then Count := 2;

              AppendNumber(Sec, Count);

            end;

          'T':

            begin

              GetCount;

              if Count = 1 then

                AppendFormat(Pointer(FormatSettings.ShortTimeFormat)) else

                AppendFormat(Pointer(FormatSettings.LongTimeFormat));

            end;

          'Z':

            begin

              GetCount;

              GetTime;

              if Count > 3 then Count := 3;

              AppendNumber(MSec, Count);

            end;

          'A':

            begin

              GetTime;

              P := Format - 1;

              if StrLIComp(P, 'AM/PM', 5) = 0 then

              begin

                if Hour >= 12 then Inc(P, 3);

                AppendChars(P, 2);

                Inc(Format, 4);

                Use12HourClock := TRUE;

              end else

              if StrLIComp(P, 'A/P', 3) = 0 then

              begin

                if Hour >= 12 then Inc(P, 2);

                AppendChars(P, 1);

                Inc(Format, 2);

                Use12HourClock := TRUE;

              end else

              if StrLIComp(P, 'AMPM', 4) = 0 then

              begin

                if Hour < 12 then

                  AppendString(FormatSettings.TimeAMString) else

                  AppendString(FormatSettings.TimePMString);

                Inc(Format, 3);

                Use12HourClock := TRUE;

              end else

              if StrLIComp(P, 'AAAA', 4) = 0 then

              begin

                GetDate;

                AppendString(FormatSettings.LongDayNames[DayOfWeek(DateTime)]);

                Inc(Format, 3);

              end else

              if StrLIComp(P, 'AAA', 3) = 0 then

              begin

                GetDate;

                AppendString(FormatSettings.ShortDayNames[DayOfWeek(DateTime)]);

                Inc(Format, 2);

              end else

              AppendChars(@Starter, 1);

            end;

          'C':

            begin

              GetCount;

              AppendFormat(Pointer(FormatSettings.ShortDateFormat));

              GetTime;

              if (Hour <> 0) or (Min <> 0) or (Sec <> 0) then

              begin

                AppendChars(' ', 1);

                AppendFormat(Pointer(FormatSettings.LongTimeFormat));

              end;

            end;

          '/':

            if DateSeparator <> #0 then

              AppendChars(@FormatSettings.DateSeparator, 1);

          ':':

            if TimeSeparator <> #0 then

              AppendChars(@FormatSettings.TimeSeparator, 1);

          '''', '"':

            begin

              P := Format;

              while (Format^ <> #0) and (Format^ <> Starter) do

              begin

                if Format^ in LeadBytes then

                  Format := StrNextChar(Format)

                else

                  Inc(Format);

              end;

              AppendChars(P, Format - P);

              if Format^ <> #0 then Inc(Format);

            end;

        else

          AppendChars(@Starter, 1);

        end;

      end;

      Dec(AppendLevel);

    end;

  end;



begin

  BufPos := 0;

  AppendLevel := 0;

  if Format <> '' then AppendFormat(Pointer(Format)) else AppendFormat('C');

  SetString(Result, Buffer, BufPos);

end;



function TryFloatToDateTime(const Value: Extended; out AResult: TDateTime): Boolean;

begin

  Result := not ((Value < MinDateTime) or (Value >= Int(MaxDateTime) + 1.0));

  if Result then

    AResult := Value;

end;



function FloatToDateTime(const Value: Extended): TDateTime;

begin

  if not TryFloatToDateTime(Value, Result) then

    ConvertErrorFmt(SInvalidDateTimeFloat, [Value]);

end;



function DateToStr(const DateTime: TDateTime): string;

begin

  DateTimeToString(Result, ShortDateFormat, DateTime);

end;



function DateToStr(const DateTime: TDateTime;

  const FormatSettings: TFormatSettings): string;

begin

  DateTimeToString(Result, FormatSettings.ShortDateFormat, DateTime,

    FormatSettings);

end;



function TimeToStr(const DateTime: TDateTime): string;

begin

  DateTimeToString(Result, LongTimeFormat, DateTime);

end;



function TimeToStr(const DateTime: TDateTime;

  const FormatSettings: TFormatSettings): string;

begin

  DateTimeToString(Result, FormatSettings.LongTimeFormat, DateTime,

    FormatSettings);

end;



function DateTimeToStr(const DateTime: TDateTime): string;

begin

  DateTimeToString(Result, '', DateTime);

end;



function DateTimeToStr(const DateTime: TDateTime;

  const FormatSettings: TFormatSettings): string;

begin

  DateTimeToString(Result, '', DateTime, FormatSettings);

end;



function FormatDateTime(const Format: string; DateTime: TDateTime): string;

begin

  DateTimeToString(Result, Format, DateTime);

end;



function FormatDateTime(const Format: string; DateTime: TDateTime;

  const FormatSettings: TFormatSettings): string;

begin

  DateTimeToString(Result, Format, DateTime, FormatSettings);

end;



{ String to date/time conversions }



type

  TDateOrder = (doMDY, doDMY, doYMD);



procedure ScanBlanks(const S: string; var Pos: Integer);

var

  I: Integer;

begin

  I := Pos;

  while (I <= Length(S)) and (S[I] = ' ') do Inc(I);

  Pos := I;

end;



function ScanNumber(const S: string; var Pos: Integer;

  var Number: Word; var CharCount: Byte): Boolean;

var

  I: Integer;

  N: Word;

begin

  Result := False;

  CharCount := 0;

  ScanBlanks(S, Pos);

  I := Pos;

  N := 0;

  while (I <= Length(S)) and (S[I] in ['0'..'9']) and (N < 1000) do

  begin

    N := N * 10 + (Ord(S[I]) - Ord('0'));

    Inc(I);

  end;

  if I > Pos then

  begin

    CharCount := I - Pos;

    Pos := I;

    Number := N;

    Result := True;

  end;

end;



function ScanString(const S: string; var Pos: Integer;

  const Symbol: string): Boolean;

begin

  Result := False;

  if Symbol <> '' then

  begin

    ScanBlanks(S, Pos);

    if AnsiCompareText(Symbol, Copy(S, Pos, Length(Symbol))) = 0 then

    begin

      Inc(Pos, Length(Symbol));

      Result := True;

    end;

  end;

end;



function ScanChar(const S: string; var Pos: Integer; Ch: Char): Boolean;

begin

  Result := False;

  ScanBlanks(S, Pos);

  if (Pos <= Length(S)) and (S[Pos] = Ch) then

  begin

    Inc(Pos);

    Result := True;

  end;

end;



function GetDateOrder(const DateFormat: string): TDateOrder;

var

  I: Integer;

begin

  Result := doMDY;

  I := 1;

  while I <= Length(DateFormat) do

  begin

    case Chr(Ord(DateFormat[I]) and $DF) of

      'E': Result := doYMD;

      'Y': Result := doYMD;

      'M': Result := doMDY;

      'D': Result := doDMY;

    else

      Inc(I);

      Continue;

    end;

    Exit;

  end;

  Result := doMDY;

end;



procedure ScanToNumber(const S: string; var Pos: Integer);

begin

  while (Pos <= Length(S)) and not (S[Pos] in ['0'..'9']) do

  begin

    if S[Pos] in LeadBytes then

      Pos := NextCharIndex(S, Pos)

    else

      Inc(Pos);

  end;

end;



function GetEraYearOffset(const Name: string): Integer;

var

  I: Integer;

begin

  Result := 0;

  for I := Low(EraNames) to High(EraNames) do

  begin

    if EraNames[I] = '' then Break;

    if AnsiStrPos(PChar(EraNames[I]), PChar(Name)) <> nil then

    begin

      Result := EraYearOffsets[I];

      Exit;

    end;

  end;

end;



function ScanDate(const S: string; var Pos: Integer;

  var Date: TDateTime): Boolean; overload;

var

  DateOrder: TDateOrder;

  N1, N2, N3, Y, M, D: Word;

  L1, L2, L3, YearLen: Byte;

  CenturyBase: Integer;

  EraName : string;

  EraYearOffset: Integer;



  function EraToYear(Year: Integer): Integer;

  begin

{$IFDEF MSWINDOWS}

    if SysLocale.PriLangID = LANG_KOREAN then

    begin

      if Year <= 99 then

        Inc(Year, (CurrentYear + Abs(EraYearOffset)) div 100 * 100);

      if EraYearOffset > 0 then

        EraYearOffset := -EraYearOffset;

    end

    else

      Dec(EraYearOffset);

{$ENDIF}

    Result := Year + EraYearOffset;

  end;



begin

  Y := 0;

  M := 0;

  D := 0;

  YearLen := 0;

  Result := False;

  DateOrder := GetDateOrder(ShortDateFormat);

  EraYearOffset := 0;

  if ShortDateFormat[1] = 'g' then  // skip over prefix text

  begin

    ScanToNumber(S, Pos);

    EraName := Trim(Copy(S, 1, Pos-1));

    EraYearOffset := GetEraYearOffset(EraName);

  end

  else

    if AnsiPos('e', ShortDateFormat) > 0 then

      EraYearOffset := EraYearOffsets[1];

  if not (ScanNumber(S, Pos, N1, L1) and ScanChar(S, Pos, DateSeparator) and

    ScanNumber(S, Pos, N2, L2)) then Exit;

  if ScanChar(S, Pos, DateSeparator) then

  begin

    if not ScanNumber(S, Pos, N3, L3) then Exit;

    case DateOrder of

      doMDY: begin Y := N3; YearLen := L3; M := N1; D := N2; end;

      doDMY: begin Y := N3; YearLen := L3; M := N2; D := N1; end;

      doYMD: begin Y := N1; YearLen := L1; M := N2; D := N3; end;

    end;

    if EraYearOffset > 0 then

      Y := EraToYear(Y)

    else

    if (YearLen <= 2) then

    begin

      CenturyBase := CurrentYear - TwoDigitYearCenturyWindow;

      Inc(Y, CenturyBase div 100 * 100);

      if (TwoDigitYearCenturyWindow > 0) and (Y < CenturyBase) then

        Inc(Y, 100);

    end;

  end else

  begin

    Y := CurrentYear;

    if DateOrder = doDMY then

    begin

      D := N1; M := N2;

    end else

    begin

      M := N1; D := N2;

    end;

  end;

  ScanChar(S, Pos, DateSeparator);

  ScanBlanks(S, Pos);

  if SysLocale.FarEast and (System.Pos('ddd', ShortDateFormat) <> 0) then

  begin     // ignore trailing text

    if ShortTimeFormat[1] in ['0'..'9'] then  // stop at time digit

      ScanToNumber(S, Pos)

    else  // stop at time prefix

      repeat

        while (Pos <= Length(S)) and (S[Pos] <> ' ') do Inc(Pos);

        ScanBlanks(S, Pos);

      until (Pos > Length(S)) or

        (AnsiCompareText(TimeAMString, Copy(S, Pos, Length(TimeAMString))) = 0) or

        (AnsiCompareText(TimePMString, Copy(S, Pos, Length(TimePMString))) = 0);

  end;

  Result := TryEncodeDate(Y, M, D, Date);

end;



function ScanDate(const S: string; var Pos: Integer; var Date: TDateTime;

  const FormatSettings: TFormatSettings): Boolean; overload;

var

  DateOrder: TDateOrder;

  N1, N2, N3, Y, M, D: Word;

  L1, L2, L3, YearLen: Byte;

  CenturyBase: Integer;

  EraName : string;

  EraYearOffset: Integer;



  function EraToYear(Year: Integer): Integer;

  begin

{$IFDEF MSWINDOWS}

    if SysLocale.PriLangID = LANG_KOREAN then

    begin

      if Year <= 99 then

        Inc(Year, (CurrentYear + Abs(EraYearOffset)) div 100 * 100);

      if EraYearOffset > 0 then

        EraYearOffset := -EraYearOffset;

    end

    else

      Dec(EraYearOffset);

{$ENDIF}

    Result := Year + EraYearOffset;

  end;



begin

  Y := 0;

  M := 0;

  D := 0;

  YearLen := 0;

  Result := False;

  DateOrder := GetDateOrder(FormatSettings.ShortDateFormat);

  EraYearOffset := 0;

  if FormatSettings.ShortDateFormat[1] = 'g' then  // skip over prefix text

  begin

    ScanToNumber(S, Pos);

    EraName := Trim(Copy(S, 1, Pos-1));

    EraYearOffset := GetEraYearOffset(EraName);

  end

  else

    if AnsiPos('e', FormatSettings.ShortDateFormat) > 0 then

      EraYearOffset := EraYearOffsets[1];

  if not (ScanNumber(S, Pos, N1, L1) and ScanChar(S, Pos, FormatSettings.DateSeparator) and

    ScanNumber(S, Pos, N2, L2)) then Exit;

  if ScanChar(S, Pos, FormatSettings.DateSeparator) then

  begin

    if not ScanNumber(S, Pos, N3, L3) then Exit;

    case DateOrder of

      doMDY: begin Y := N3; YearLen := L3; M := N1; D := N2; end;

      doDMY: begin Y := N3; YearLen := L3; M := N2; D := N1; end;

      doYMD: begin Y := N1; YearLen := L1; M := N2; D := N3; end;

    end;

    if EraYearOffset > 0 then

      Y := EraToYear(Y)

    else

    if (YearLen <= 2) then

    begin

      CenturyBase := CurrentYear - FormatSettings.TwoDigitYearCenturyWindow;

      Inc(Y, CenturyBase div 100 * 100);

      if (FormatSettings.TwoDigitYearCenturyWindow > 0) and (Y < CenturyBase) then

        Inc(Y, 100);

    end;

  end else

  begin

    Y := CurrentYear;

    if DateOrder = doDMY then

    begin

      D := N1; M := N2;

    end else

    begin

      M := N1; D := N2;

    end;

  end;

  ScanChar(S, Pos, FormatSettings.DateSeparator);

  ScanBlanks(S, Pos);

  if SysLocale.FarEast and (System.Pos('ddd', FormatSettings.ShortDateFormat) <> 0) then

  begin     // ignore trailing text

    if FormatSettings.ShortTimeFormat[1] in ['0'..'9'] then  // stop at time digit

      ScanToNumber(S, Pos)

    else  // stop at time prefix

      repeat

        while (Pos <= Length(S)) and (S[Pos] <> ' ') do Inc(Pos);

        ScanBlanks(S, Pos);

      until (Pos > Length(S)) or

        (AnsiCompareText(FormatSettings.TimeAMString,

         Copy(S, Pos, Length(FormatSettings.TimeAMString))) = 0) or

        (AnsiCompareText(FormatSettings.TimePMString,

         Copy(S, Pos, Length(FormatSettings.TimePMString))) = 0);

  end;

  Result := TryEncodeDate(Y, M, D, Date);

end;



function ScanTime(const S: string; var Pos: Integer;

  var Time: TDateTime): Boolean; overload;

var

  BaseHour: Integer;

  Hour, Min, Sec, MSec: Word;

  Junk: Byte;

begin

  Result := False;

  BaseHour := -1;

  if ScanString(S, Pos, TimeAMString) or ScanString(S, Pos, 'AM') then

    BaseHour := 0

  else if ScanString(S, Pos, TimePMString) or ScanString(S, Pos, 'PM') then

    BaseHour := 12;

  if BaseHour >= 0 then ScanBlanks(S, Pos);

  if not ScanNumber(S, Pos, Hour, Junk) then Exit;

  Min := 0;

  Sec := 0;

  MSec := 0;

  if ScanChar(S, Pos, TimeSeparator) then

  begin

    if not ScanNumber(S, Pos, Min, Junk) then Exit;

    if ScanChar(S, Pos, TimeSeparator) then

    begin

      if not ScanNumber(S, Pos, Sec, Junk) then Exit;

      if ScanChar(S, Pos, DecimalSeparator) then

        if not ScanNumber(S, Pos, MSec, Junk) then Exit;

    end;

  end;

  if BaseHour < 0 then

    if ScanString(S, Pos, TimeAMString) or ScanString(S, Pos, 'AM') then

      BaseHour := 0

    else

      if ScanString(S, Pos, TimePMString) or ScanString(S, Pos, 'PM') then

        BaseHour := 12;

  if BaseHour >= 0 then

  begin

    if (Hour = 0) or (Hour > 12) then Exit;

    if Hour = 12 then Hour := 0;

    Inc(Hour, BaseHour);

  end;

  ScanBlanks(S, Pos);

  Result := TryEncodeTime(Hour, Min, Sec, MSec, Time);

end;



function ScanTime(const S: string; var Pos: Integer; var Time: TDateTime;

  const FormatSettings: TFormatSettings): Boolean; overload;

var

  BaseHour: Integer;

  Hour, Min, Sec, MSec: Word;

  Junk: Byte;

begin

  Result := False;

  BaseHour := -1;

  if ScanString(S, Pos, FormatSettings.TimeAMString) or ScanString(S, Pos, 'AM') then

    BaseHour := 0

  else if ScanString(S, Pos, FormatSettings.TimePMString) or ScanString(S, Pos, 'PM') then

    BaseHour := 12;

  if BaseHour >= 0 then ScanBlanks(S, Pos);

  if not ScanNumber(S, Pos, Hour, Junk) then Exit;

  Min := 0;

  Sec := 0;

  MSec := 0;

  if ScanChar(S, Pos, FormatSettings.TimeSeparator) then

  begin

    if not ScanNumber(S, Pos, Min, Junk) then Exit;

    if ScanChar(S, Pos, FormatSettings.TimeSeparator) then

    begin

      if not ScanNumber(S, Pos, Sec, Junk) then Exit;

      if ScanChar(S, Pos, FormatSettings.DecimalSeparator) then

        if not ScanNumber(S, Pos, MSec, Junk) then Exit;

    end;

  end;

  if BaseHour < 0 then

    if ScanString(S, Pos, FormatSettings.TimeAMString) or ScanString(S, Pos, 'AM') then

      BaseHour := 0

    else

      if ScanString(S, Pos, FormatSettings.TimePMString) or ScanString(S, Pos, 'PM') then

        BaseHour := 12;

  if BaseHour >= 0 then

  begin

    if (Hour = 0) or (Hour > 12) then Exit;

    if Hour = 12 then Hour := 0;

    Inc(Hour, BaseHour);

  end;

  ScanBlanks(S, Pos);

  Result := TryEncodeTime(Hour, Min, Sec, MSec, Time);

end;



function StrToDate(const S: string): TDateTime;

begin

  if not TryStrToDate(S, Result) then

    ConvertErrorFmt(SInvalidDate, [S]);

end;



function StrToDate(const S: string;

  const FormatSettings: TFormatSettings): TDateTime;

begin

  if not TryStrToDate(S, Result, FormatSettings) then

    ConvertErrorFmt(SInvalidDate, [S]);

end;



function StrToDateDef(const S: string; const Default: TDateTime): TDateTime;

begin

  if not TryStrToDate(S, Result) then

    Result := Default;

end;



function StrToDateDef(const S: string; const Default: TDateTime;

  const FormatSettings: TFormatSettings): TDateTime;

begin

  if not TryStrToDate(S, Result, FormatSettings) then

    Result := Default;

end;



function TryStrToDate(const S: string; out Value: TDateTime): Boolean;

var

  Pos: Integer;

begin

  Pos := 1;

  Result := ScanDate(S, Pos, Value) and (Pos > Length(S));

end;



function TryStrToDate(const S: string; out Value: TDateTime;

  const FormatSettings: TFormatSettings): Boolean;

var

  Pos: Integer;

begin

  Pos := 1;

  Result := ScanDate(S, Pos, Value, FormatSettings) and (Pos > Length(S));

end;



function StrToTime(const S: string): TDateTime;

begin

  if not TryStrToTime(S, Result) then

    ConvertErrorFmt(SInvalidTime, [S]);

end;



function StrToTime(const S: string;

  const FormatSettings: TFormatSettings): TDateTime;

begin

  if not TryStrToTime(S, Result, FormatSettings) then

    ConvertErrorFmt(SInvalidTime, [S]);

end;



function StrToTimeDef(const S: string; const Default: TDateTime): TDateTime;

begin

  if not TryStrToTime(S, Result) then

    Result := Default;

end;



function StrToTimeDef(const S: string; const Default: TDateTime;

  const FormatSettings: TFormatSettings): TDateTime;

begin

  if not TryStrToTime(S, Result, FormatSettings) then

    Result := Default;

end;



function TryStrToTime(const S: string; out Value: TDateTime): Boolean;

var

  Pos: Integer;

begin

  Pos := 1;

  Result := ScanTime(S, Pos, Value) and (Pos > Length(S));

end;



function TryStrToTime(const S: string; out Value: TDateTime;

  const FormatSettings: TFormatSettings): Boolean;

var

  Pos: Integer;

begin

  Pos := 1;

  Result := ScanTime(S, Pos, Value, FormatSettings) and (Pos > Length(S));

end;



function StrToDateTime(const S: string): TDateTime;

begin

  if not TryStrToDateTime(S, Result) then

    ConvertErrorFmt(SInvalidDateTime, [S]);

end;



function StrToDateTime(const S: string;

  const FormatSettings: TFormatSettings): TDateTime;

begin

  if not TryStrToDateTime(S, Result, FormatSettings) then

    ConvertErrorFmt(SInvalidDateTime, [S]);

end;



function StrToDateTimeDef(const S: string; const Default: TDateTime): TDateTime;

begin

  if not TryStrToDateTime(S, Result) then

    Result := Default;

end;



function StrToDateTimeDef(const S: string; const Default: TDateTime;

  const FormatSettings: TFormatSettings): TDateTime;

begin

  if not TryStrToDateTime(S, Result, FormatSettings) then

    Result := Default;

end;



function TryStrToDateTime(const S: string; out Value: TDateTime): Boolean;

var

  Pos: Integer;

  Date, Time: TDateTime;

begin

  Result := True;

  Pos := 1;

  Time := 0;

  if not ScanDate(S, Pos, Date) or

     not ((Pos > Length(S)) or ScanTime(S, Pos, Time)) then



    // Try time only

    Result := TryStrToTime(S, Value)

  else

    if Date >= 0 then

      Value := Date + Time

    else

      Value := Date - Time;

end;



function TryStrToDateTime(const S: string; out Value: TDateTime;

  const FormatSettings: TFormatSettings): Boolean;

var

  Pos: Integer;

  Date, Time: TDateTime;

begin

  Result := True;

  Pos := 1;

  Time := 0;

  if not ScanDate(S, Pos, Date, FormatSettings) or

     not ((Pos > Length(S)) or ScanTime(S, Pos, Time, FormatSettings)) then



    // Try time only

    Result := TryStrToTime(S, Value, FormatSettings)

  else

    if Date >= 0 then

      Value := Date + Time

    else

      Value := Date - Time;

end;



{ System error messages }



function SysErrorMessage(ErrorCode: Integer): string;

var

  Buffer: array[0..255] of Char;

{$IFDEF MSWINDOWS}

var

  Len: Integer;

begin

  Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or

    FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,

    SizeOf(Buffer), nil);

  while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len);

  SetString(Result, Buffer, Len);

end;

{$ENDIF}

{$IFDEF LINUX}

begin

  //Result := Format('System error: %4x',[ErrorCode]);

  Result := strerror_r(ErrorCode, Buffer, sizeof(Buffer));

end;

{$ENDIF}



{ Initialization file support }



function GetLocaleStr(Locale, LocaleType: Integer; const Default: string): string;

{$IFDEF MSWINDOWS}

var

  L: Integer;

  Buffer: array[0..255] of Char;

begin

  L := GetLocaleInfo(Locale, LocaleType, Buffer, SizeOf(Buffer));

  if L > 0 then SetString(Result, Buffer, L - 1) else Result := Default;

end;

{$ENDIF}

{$IFDEF LINUX}

begin

  Result := Default;

end;

{$ENDIF}



function GetLocaleChar(Locale, LocaleType: Integer; Default: Char): Char;

{$IFDEF MSWINDOWS}

var

  Buffer: array[0..1] of Char;

begin

  if GetLocaleInfo(Locale, LocaleType, Buffer, 2) > 0 then

    Result := Buffer[0] else

    Result := Default;

end;

{$ENDIF}

{$IFDEF LINUX}

begin

  Result := Default;

end;

{$ENDIF}



{var

  DefShortMonthNames: array[1..12] of Pointer = (@SShortMonthNameJan,

    @SShortMonthNameFeb, @SShortMonthNameMar, @SShortMonthNameApr,

    @SShortMonthNameMay, @SShortMonthNameJun, @SShortMonthNameJul,

    @SShortMonthNameAug, @SShortMonthNameSep, @SShortMonthNameOct,

    @SShortMonthNameNov, @SShortMonthNameDec);



  DefLongMonthNames: array[1..12] of Pointer = (@SLongMonthNameJan,

    @SLongMonthNameFeb, @SLongMonthNameMar, @SLongMonthNameApr,

    @SLongMonthNameMay, @SLongMonthNameJun, @SLongMonthNameJul,

    @SLongMonthNameAug, @SLongMonthNameSep, @SLongMonthNameOct,

    @SLongMonthNameNov, @SLongMonthNameDec);



  DefShortDayNames: array[1..7] of Pointer = (@SShortDayNameSun,

    @SShortDayNameMon, @SShortDayNameTue, @SShortDayNameWed,

    @SShortDayNameThu, @SShortDayNameFri, @SShortDayNameSat);



  DefLongDayNames: array[1..7] of Pointer = (@SLongDayNameSun,

    @SLongDayNameMon, @SLongDayNameTue, @SLongDayNameWed,

    @SLongDayNameThu, @SLongDayNameFri, @SLongDayNameSat);

                                                                }

procedure GetMonthDayNames;

{$IFDEF MSWINDOWS}

var

  I, Day: Integer;

  DefaultLCID: LCID;



  function LocalGetLocaleStr(LocaleType: Integer): string;

  begin

    Result := GetLocaleStr(DefaultLCID, LocaleType, '');

    if Result = '' then Result := GetLocaleStr($409, LocaleType, '');

    //Result := LoadResString(DefValues[Index]);

  end;



begin

  DefaultLCID := GetThreadLocale;

  for I := 1 to 12 do

  begin

    ShortMonthNames[I] := LocalGetLocaleStr(LOCALE_SABBREVMONTHNAME1 + I - 1);

    LongMonthNames[I] := LocalGetLocaleStr(LOCALE_SMONTHNAME1 + I - 1);

  end;

  for I := 1 to 7 do

  begin

    Day := (I + 5) mod 7;

    ShortDayNames[I] := LocalGetLocaleStr(LOCALE_SABBREVDAYNAME1 + Day);

    LongDayNames[I] := LocalGetLocaleStr(LOCALE_SDAYNAME1 + Day);

  end;

end;

{$ELSE}

{$IFDEF LINUX}

  function GetLocaleStr(LocaleIndex, Index: Integer;

    const DefValues: array of Pointer): string;

  var

    temp: PChar;

  begin

    temp := nl_langinfo(LocaleIndex);

    if (temp = nil) or (temp^ = #0) then

      Result := LoadResString(DefValues[Index])

    else

      Result := temp;

  end;



var

  I: Integer;

begin

  for I := 1 to 12 do

  begin

    ShortMonthNames[I] := GetLocaleStr(ABMON_1 + I - 1,

      I - Low(DefShortMonthNames), DefShortMonthNames);

    LongMonthNames[I] := GetLocaleStr(MON_1 + I - 1,

      I - Low(DefLongMonthNames), DefLongMonthNames);

  end;

  for I := 1 to 7 do

  begin

    ShortDayNames[I] := GetLocaleStr(ABDAY_1 + I - 1,

      I - Low(DefShortDayNames), DefShortDayNames);

    LongDayNames[I] := GetLocaleStr(DAY_1 + I - 1,

      I - Low(DefLongDayNames), DefLongDayNames);

  end;

end;

{$ELSE}

var

  I: Integer;

begin

  for I := 1 to 12 do

  begin

    ShortMonthNames[I] := LoadResString(DefShortMonthNames[I]);

    LongMonthNames[I] := LoadResString(DefLongMonthNames[I]);

  end;

  for I := 1 to 7 do

  begin

    ShortDayNames[I] := LoadResString(DefShortDayNames[I]);

    LongDayNames[I] := LoadResString(DefLongDayNames[I]);

  end;

end;

{$ENDIF}

{$ENDIF}



{$IFDEF MSWINDOWS}

procedure GetLocaleMonthDayNames(DefaultLCID: Integer;

  var FormatSettings: TFormatSettings);

var

  I, Day: Integer;



  function LocalGetLocaleStr(LocaleType: Integer): string;

  begin

    Result := GetLocaleStr(DefaultLCID, LocaleType, '');

    if Result = '' then Result := GetLocaleStr($409, LocaleType, '');

  end;



begin

  for I := 1 to 12 do

  begin

    FormatSettings.ShortMonthNames[I] := LocalGetLocaleStr(LOCALE_SABBREVMONTHNAME1 + I - 1);

    FormatSettings.LongMonthNames[I] := LocalGetLocaleStr(LOCALE_SMONTHNAME1 + I - 1);

  end;

  for I := 1 to 7 do

  begin

    Day := (I + 5) mod 7;

    FormatSettings.ShortDayNames[I] := LocalGetLocaleStr(LOCALE_SABBREVDAYNAME1 + Day);

    FormatSettings.LongDayNames[I] := LocalGetLocaleStr(LOCALE_SDAYNAME1 + Day);

  end;

end;

{$ENDIF}



{$IFDEF MSWINDOWS}

function EnumEraNames(Names: PChar): Integer; stdcall;

var

  I: Integer;

begin

  Result := 0;

  I := Low(EraNames);

  while EraNames[I] <> '' do

    if (I = High(EraNames)) then

      Exit

    else Inc(I);

  EraNames[I] := Names;

  Result := 1;

end;



function EnumEraYearOffsets(YearOffsets: PChar): Integer; stdcall;

var

  I: Integer;

begin

  Result := 0;

  I := Low(EraYearOffsets);

  while EraYearOffsets[I] <> -1 do

    if (I = High(EraYearOffsets)) then

      Exit

    else Inc(I);

  EraYearOffsets[I] := StrToIntDef(YearOffsets, 0);

  Result := 1;

end;



procedure GetEraNamesAndYearOffsets;

var

  J: Integer;

  CalendarType: CALTYPE;

begin

  CalendarType := StrToIntDef(GetLocaleStr(GetThreadLocale,

    LOCALE_IOPTIONALCALENDAR, '1'), 1);

  if CalendarType in [CAL_JAPAN, CAL_TAIWAN, CAL_KOREA] then

  begin

    EnumCalendarInfoA(@EnumEraNames, GetThreadLocale, CalendarType,

      CAL_SERASTRING);

    for J := Low(EraYearOffsets) to High(EraYearOffsets) do

      EraYearOffsets[J] := -1;

    EnumCalendarInfoA(@EnumEraYearOffsets, GetThreadLocale, CalendarType,

      CAL_IYEAROFFSETRANGE);

  end;

end;



function TranslateDateFormat(const FormatStr: string): string;

var

  I: Integer;

  L: Integer;

  CalendarType: CALTYPE;

  RemoveEra: Boolean;

begin

  I := 1;

  Result := '';

  CalendarType := StrToIntDef(GetLocaleStr(GetThreadLocale,

    LOCALE_ICALENDARTYPE, '1'), 1);

  if not (CalendarType in [CAL_JAPAN, CAL_TAIWAN, CAL_KOREA]) then

  begin

    RemoveEra := SysLocale.PriLangID in [LANG_JAPANESE, LANG_CHINESE, LANG_KOREAN];

    if RemoveEra then

    begin

      While I <= Length(FormatStr) do

      begin

        if not (FormatStr[I] in ['g', 'G']) then

          Result := Result + FormatStr[I];

        Inc(I);

      end;

    end

    else

      Result := FormatStr;

    Exit;

  end;



  while I <= Length(FormatStr) do

  begin

    if FormatStr[I] in LeadBytes then

    begin

      L := CharLength(FormatStr, I);

      Result := Result + Copy(FormatStr, I, L);

      Inc(I, L);

    end else

    begin

      if StrLIComp(@FormatStr[I], 'gg', 2) = 0 then

      begin

        Result := Result + 'ggg';

        Inc(I, 1);

      end

      else if StrLIComp(@FormatStr[I], 'yyyy', 4) = 0 then

      begin

        Result := Result + 'eeee';

        Inc(I, 4-1);

      end

      else if StrLIComp(@FormatStr[I], 'yy', 2) = 0 then

      begin

        Result := Result + 'ee';

        Inc(I, 2-1);

      end

      else if FormatStr[I] in ['y', 'Y'] then

        Result := Result + 'e'

      else

        Result := Result + FormatStr[I];

      Inc(I);

    end;

  end;

end;

{$ENDIF}



{$IFDEF LINUX}

procedure InitEras;

var

  Count : Byte;

  I, J, Pos : Integer;

  Number : Word;

  S : string;

  Year, Month, Day: Word;

begin

  EraCount := 0;

  S := nl_langinfo(ERA);

  if S = '' then

    S := LoadResString(@SEraEntries);



  Pos := 1;

  for I := 1 to MaxEraCount do

  begin

    if Pos > Length(S) then Break;

    if not(ScanChar(S, Pos, '+') or ScanChar(S, Pos, '-')) then Break;

    // Eras in which year increases with negative time (eg Christian BC era)

    // are not currently supported.

//    EraRanges[I].Direction := S[Pos - 1];



    // Era offset, in years from Gregorian calendar year

    if not ScanChar(S, Pos, ':') then Break;

    if ScanChar(S, Pos, '-') then

      J := -1

    else

      J := 1;

    if not ScanNumber(S, Pos, Number, Count) then Break;

    EraYearOffsets[I] := J * Number;   // apply sign to Number



    // Era start date, in Gregorian year/month/day format

    if not ScanChar(S, Pos, ':') then Break;

    if not ScanNumber(S, Pos, Year, Count) then Break;

    if not ScanChar(S, Pos, '/') then Break;

    if not ScanNumber(S, Pos, Month, Count) then Break;

    if not ScanChar(S, Pos, '/') then Break;

    if not ScanNumber(S, Pos, Day, Count) then Break;

    EraRanges[I].StartDate := Trunc(EncodeDate(Year, Month, Day));

    EraYearOffsets[I] := Year - EraYearOffsets[I];



    // Era end date, in Gregorian year/month/day format

    if not ScanChar(S, Pos, ':') then Break;

    if ScanString(S, Pos, '+*') then       // positive infinity

      EraRanges[I].EndDate := High(EraRanges[I].EndDate)

    else if ScanString(S, Pos, '-*') then  // negative infinity

      EraRanges[I].EndDate := Low(EraRanges[I].EndDate)

    else if not ScanNumber(S, Pos, Year, Count) then

      Break

    else

    begin

      if not ScanChar(S, Pos, '/') then Break;

      if not ScanNumber(S, Pos, Month, Count) then Break;

      if not ScanChar(S, Pos, '/') then Break;

      if not ScanNumber(S, Pos, Day, Count) then Break;

      EraRanges[I].EndDate := Trunc(EncodeDate(Year, Month, Day));

    end;



    // Era name, in locale charset

    if not ScanChar(S, Pos, ':') then Break;

    J := AnsiPos(':', Copy(S, Pos, Length(S) + 1 - Pos));

    if J = 0 then Break;

    EraNames[I] := Copy(S, Pos, J - 1);

    Inc(Pos, J - 1);



    // Optional Era format string for era year, in locale charset

    if not ScanChar(S, Pos, ':') then Break;

    J := AnsiPos(';', Copy(S, Pos, Length(S) + 1 - Pos));

    if J = 0 then

      J := 1 + Length(S) + 1 - Pos;

    {if J = 0 then Break;}

    EraYearFormats[I] := Copy(S, Pos, J - 1);

    Inc(Pos, J - 1);

    Inc(EraCount);

    if not((Pos > Length(S)) or ScanChar(S, Pos, ';')) then Break;

  end;



  // Clear the rest of the era slots, including partial entry from failed parse

  for I := EraCount+1 to MaxEraCount do

  begin

    EraNames[I] := '';

    EraYearOffsets[I] := -1;

    EraRanges[I].StartDate := High(EraRanges[I].StartDate);

    EraRanges[I].EndDate := High(EraRanges[I].EndDate);

    EraYearFormats[I] := '';

  end;

end;

{$ENDIF}



{ Exception handling routines }



var

  OutOfMemory: EOutOfMemory;

  InvalidPointer: EInvalidPointer;



{ Convert physical address to logical address }



{ Format and return an exception error message }



function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;

  Buffer: PChar; Size: Integer): Integer;

{$IFDEF MSWINDOWS}



  function ConvertAddr(Address: Pointer): Pointer; assembler;

  asm

          TEST    EAX,EAX         { Always convert nil to nil }

          JE      @@1

          SUB     EAX, $1000      { offset from code start; code start set by linker to $1000 }

  @@1:

  end;



var

  MsgPtr: PChar;

  MsgEnd: PChar;

  MsgLen: Integer;

  ModuleName: array[0..MAX_PATH] of Char;

  Temp: array[0..MAX_PATH] of Char;

  //Format: array[0..255] of Char;

  Info: TMemoryBasicInformation;

  ConvertedAddress: Pointer;

begin

  VirtualQuery(ExceptAddr, Info, sizeof(Info));

  if (Info.State <> MEM_COMMIT) or

    (GetModuleFilename(THandle(Info.AllocationBase), Temp, SizeOf(Temp)) = 0) then

  begin

    GetModuleFileName(HInstance, Temp, SizeOf(Temp));

    ConvertedAddress := ConvertAddr(ExceptAddr);

  end

  else

    Integer(ConvertedAddress) := Integer(ExceptAddr) - Integer(Info.AllocationBase);

  StrLCopy(ModuleName, AnsiStrRScan(Temp, '\') + 1, SizeOf(ModuleName) - 1);

  MsgPtr := '';

  MsgEnd := '';

  if ExceptObject is Exception then

  begin

    MsgPtr := PChar(Exception(ExceptObject).Message);

    MsgLen := StrLen(MsgPtr);

    if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then MsgEnd := '.';

  end;

  {LoadString(FindResourceHInstance(HInstance),

    PResStringRec(@SException).Identifier, Format, SizeOf(Format));

  StrLFmt(Buffer, Size, Format, [ExceptObject.ClassName, ModuleName,

    ConvertedAddress, MsgPtr, MsgEnd]);        }

    StrPCopy(Buffer, kol.Format(SException, [ExceptObject.ClassName, ModuleName,

                                  ConvertedAddress, MsgPtr, MsgEnd]) );

  Result := StrLen(Buffer);

end;

{$ENDIF}

{$IFDEF LINUX}

const

  UnknownModuleName = '<unknown>';

var

  MsgPtr: PChar;

  MsgEnd: PChar;

  MsgLen: Integer;

  ModuleName: array[0..MAX_PATH] of Char;

  Info: TDLInfo;

begin

  MsgPtr := '';

  MsgEnd := '';

  if ExceptObject is Exception then

  begin

    MsgPtr := PChar(Exception(ExceptObject).Message);

    MsgLen := StrLen(MsgPtr);

    if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then MsgEnd := '.';

  end;

  if (dladdr(ExceptAddr, Info) <> 0) and (Info.dli_fname <> nil) then

    StrLCopy(ModuleName, AnsiStrRScan(Info.dli_fname, PathDelim) + 1, SizeOf(ModuleName) - 1)

  else

    StrLCopy(ModuleName, UnknownModuleName, SizeOf(ModuleName) - 1);

  StrLFmt(Buffer, Size, PChar(SException), [ExceptObject.ClassName, ModuleName,

    ExceptAddr, MsgPtr, MsgEnd]);

  Result := StrLen(Buffer);

end;

{$ENDIF}



{ Display exception message box }



procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);

{$IFDEF MSWINDOWS}

var

  //Title: array[0..63] of Char;

  Buffer: array[0..1023] of Char;

  Dummy: Cardinal;

begin

  ExceptionErrorMessage(ExceptObject, ExceptAddr, Buffer, SizeOf(Buffer));

  if IsConsole then

  begin

    Flush(Output);

    CharToOemA(Buffer, Buffer);

    WriteFile(GetStdHandle(STD_ERROR_HANDLE), Buffer, StrLen(Buffer), Dummy, nil);

    WriteFile(GetStdHandle(STD_ERROR_HANDLE), sLineBreak, 2, Dummy, nil);

  end

  else

  begin

  {  LoadString(FindResourceHInstance(HInstance), PResStringRec(@SExceptTitle).Identifier,

      Title, SizeOf(Title));

    MessageBox(0, Buffer, Title, MB_OK or MB_ICONSTOP or MB_TASKMODAL); }

    MessageBox(0, Buffer, PChar(SExceptTitle), MB_OK or MB_ICONSTOP or MB_TASKMODAL);

  end;

end;

{$ENDIF}

{$IFDEF LINUX}

var

  Buffer: array[0..1023] of Char;

begin

  ExceptionErrorMessage(ExceptObject, ExceptAddr, Buffer, Sizeof(Buffer));

  if TTextRec(ErrOutput).Mode = fmOutput then

    Flush(ErrOutput);

  __write(STDERR_FILENO, Buffer, StrLen(Buffer));

end;

{$ENDIF}



{ Raise abort exception }



procedure Abort;



  function ReturnAddr: Pointer;

  asm

          MOV     EAX,[EBP + 4]

  end;



begin

  raise EAbort.CreateRes(SOperationAborted) at ReturnAddr;

end;



{ Raise out of memory exception }



procedure OutOfMemoryError;

begin

  raise OutOfMemory;

end;



{ Exception class }



constructor Exception.Create(const Msg: string);

begin

  FMessage := Msg;

end;



constructor Exception.CreateFmt(const Msg: string;

  const Args: array of const);

begin

  FMessage := Format(Msg, Args);

end;



constructor Exception.CreateRes(Ident: Integer);

begin

  FMessage := LoadStr(Ident);

end;



constructor Exception.CreateRes(const ResStringRec: string);

begin

  FMessage := ResStringRec;

end;



constructor Exception.CreateResFmt(Ident: Integer;

  const Args: array of const);

begin

  FMessage := Format(LoadStr(Ident), Args);

end;



constructor Exception.CreateResFmt(const ResStringRec: string;

  const Args: array of const);

begin

  FMessage := Format(ResStringRec, Args);

end;



constructor Exception.CreateHelp(const Msg: string; AHelpContext: Integer);

begin

  FMessage := Msg;

  FHelpContext := AHelpContext;

end;



constructor Exception.CreateFmtHelp(const Msg: string; const Args: array of const;

  AHelpContext: Integer);

begin

  FMessage := Format(Msg, Args);

  FHelpContext := AHelpContext;

end;



constructor Exception.CreateResHelp(Ident: Integer; AHelpContext: Integer);

begin

  FMessage := LoadStr(Ident);

  FHelpContext := AHelpContext;

end;



constructor Exception.CreateResHelp(ResStringRec: PResStringRec;

  AHelpContext: Integer);

begin

  FMessage := LoadResString(ResStringRec);

  FHelpContext := AHelpContext;

end;



constructor Exception.CreateResFmtHelp(Ident: Integer;

  const Args: array of const;

  AHelpContext: Integer);

begin

  FMessage := Format(LoadStr(Ident), Args);

  FHelpContext := AHelpContext;

end;



constructor Exception.CreateResFmtHelp(ResStringRec: PResStringRec;

  const Args: array of const;

  AHelpContext: Integer);

begin

  FMessage := Format(LoadResString(ResStringRec), Args);

  FHelpContext := AHelpContext;

end;



{ EHeapException class }



procedure EHeapException.FreeInstance;

begin

  if AllowFree then

    inherited FreeInstance;

end;



{ Create I/O exception }



function CreateInOutError: EInOutError;

type

  TErrorRec = record

    Code: Integer;

    Ident: string;

  end;

const

  ErrorMap: array[0..6] of TErrorRec = (

    (Code: 2; Ident: SFileNotFound),

    (Code: 3; Ident: SInvalidFilename),

    (Code: 4; Ident: STooManyOpenFiles),

    (Code: 5; Ident: SAccessDenied),

    (Code: 100; Ident: SEndOfFile),

    (Code: 101; Ident: SDiskFull),

    (Code: 106; Ident: SInvalidInput));

var

  I: Integer;

  InOutRes: Integer;

begin

  I := Low(ErrorMap);

  InOutRes := IOResult;  // resets IOResult to zero

  while (I <= High(ErrorMap)) and (ErrorMap[I].Code <> InOutRes) do Inc(I);

  if I <= High(ErrorMap) then

    Result := EInOutError.Create(ErrorMap[I].Ident) else

    Result := EInOutError.CreateResFmt(SInOutError, [InOutRes]);

  Result.ErrorCode := InOutRes;

end;



{ RTL error handler }



type

  TExceptRec = record

    EClass: ExceptClass;

    EIdent: string;

  end;



const

  ExceptMap: array[Ord(reDivByZero)..Ord(High(TRuntimeError))] of TExceptRec = (

    (EClass: EDivByZero; EIdent: SDivByZero),

    (EClass: ERangeError; EIdent: SRangeError),

    (EClass: EIntOverflow; EIdent: SIntOverflow),

    (EClass: EInvalidOp; EIdent: SInvalidOp),

    (EClass: EZeroDivide; EIdent: SZeroDivide),

    (EClass: EOverflow; EIdent: SOverflow),

    (EClass: EUnderflow; EIdent: SUnderflow),

    (EClass: EInvalidCast; EIdent: SInvalidCast),

    (EClass: EAccessViolation; EIdent: SAccessViolationNoArg),

    (EClass: EPrivilege; EIdent: SPrivilege),

    (EClass: EControlC; EIdent: SControlC),

    (EClass: EStackOverflow; EIdent: SStackOverflow),

    (EClass: EVariantError; EIdent: SInvalidVarCast),

    (EClass: EVariantError; EIdent: SInvalidVarOp),

    (EClass: EVariantError; EIdent: SDispatchError),

    (EClass: EVariantError; EIdent: SVarArrayCreate),

    (EClass: EVariantError; EIdent: SVarInvalid),

    (EClass: EVariantError; EIdent: SVarArrayBounds),

    (EClass: EAssertionFailed; EIdent: SAssertionFailed),

    (EClass: EExternalException; EIdent: SExternalException),

    (EClass: EIntfCastError; EIdent: SIntfCastError),

    (EClass: ESafecallException; EIdent: SSafecallException)

  {$IFDEF LINUX}

    ,

    (EClass: EQuit; EIdent: SQuit),

    (EClass: ECodesetConversion; EIdent: SCodesetConversionError)

  {$ENDIF}

    );



procedure ErrorHandler(ErrorCode: Byte; ErrorAddr: Pointer); export;

var

  E: Exception;

begin

  case ErrorCode of

    Ord(reOutOfMemory):

      E := OutOfMemory;

    Ord(reInvalidPtr):

      E := InvalidPointer;

    Ord(reDivByZero)..Ord(High(TRuntimeError)):

      begin

        with ExceptMap[ErrorCode] do

          E := EClass.Create(EIdent);

      end;

  else

    E := CreateInOutError;

  end;

  raise E at ErrorAddr;

end;



{ Assertion error handler }



{ This is complicated by the desire to make it look like the exception     }

{ happened in the user routine, so the debugger can give a decent stack    }

{ trace. To make that feasible, AssertErrorHandler calls a helper function }

{ to create the exception object, so that AssertErrorHandler itself does   }

{ not need any temps. After the exception object is created, the asm       }

{ routine RaiseAssertException sets up the registers just as if the user   }

{ code itself had raised the exception.                                    }



function CreateAssertException(const Message, Filename: string;

  LineNumber: Integer): Exception;

var

  S: string;

begin

  if Message <> '' then S := Message else S := SAssertionFailed;

  Result := EAssertionFailed.CreateFmt(SAssertError,

    [S, Filename, LineNumber]);

end;



{ This code is based on the following assumptions:                         }

{  - Our direct caller (AssertErrorHandler) has an EBP frame               }

{  - ErrorStack points to where the return address would be if the         }

{    user program had called System.@RaiseExcept directly                  }

procedure RaiseAssertException(const E: Exception; const ErrorAddr, ErrorStack: Pointer);

asm

        MOV     ESP,ECX

        MOV     [ESP],EDX

        MOV     EBP,[EBP]

        JMP     System.@RaiseExcept

end;



{ If you change this procedure, make sure it does not have any local variables }

{ or temps that need cleanup - they won't get cleaned up due to the way        }

{ RaiseAssertException frame works. Also, it can not have an exception frame.  }

procedure AssertErrorHandler(const Message, Filename: string;

  LineNumber: Integer; ErrorAddr: Pointer);

var

  E: Exception;

begin

   E := CreateAssertException(Message, Filename, LineNumber);

{$IF Defined(LINUX)}

   RaiseAssertException(E, ErrorAddr, PChar(@ErrorAddr)+8);

{$ELSEIF Defined(MSWINDOWS)}

   RaiseAssertException(E, ErrorAddr, PChar(@ErrorAddr)+4);

{$ELSE}

   {$MESSAGE ERROR 'AssertErrorHandler not implemented'}

{$IFEND}

end;



{$IFNDEF PC_MAPPED_EXCEPTIONS}



{ Abstract method invoke error handler }



procedure AbstractErrorHandler;

begin

  raise EAbstractError.CreateRes(SAbstractError);

end;

{$ENDIF}



{$IFDEF LINUX}

const

  TRAP_ZERODIVIDE    = 0;

  TRAP_SINGLESTEP    = 1;

  TRAP_NMI           = 2;

  TRAP_BREAKPOINT    = 3;

  TRAP_OVERFLOW      = 4;

  TRAP_BOUND         = 5;

  TRAP_INVINSTR      = 6;

  TRAP_DEVICENA      = 7;

  TRAP_DOUBLEFAULT   = 8;

  TRAP_FPOVERRUN     = 9;

  TRAP_BADTSS        = 10;

  TRAP_SEGMENTNP     = 11;

  TRAP_STACKFAULT    = 12;

  TRAP_GPFAULT       = 13;

  TRAP_PAGEFAULT     = 14;

  TRAP_RESERVED      = 15;

  TRAP_FPE           = 16;

  TRAP_ALIGNMENT     = 17;

  TRAP_MACHINECHECK  = 18;

  TRAP_CACHEFAULT    = 19;

  TRAP_UNKNOWN       = -1;



function MapFPUStatus(Status: LongWord): TRuntimeError;

begin

  if (Status and 1) = 1 then Result := System.reInvalidOp           // STACK_CHECK or INVALID_OPERATION

  else if (Status and 2) = 2 then Result := System.reInvalidOp      // DENORMAL_OPERAND

  else if (Status and 4) = 4 then Result := System.reZeroDivide     // DIVIDE_BY_ZERO

  else if (Status and 8) = 8 then Result := System.reOverflow       // OVERFLOW

  else if (Status and $10) = $10 then Result := System.reUnderflow  // UNDERFLOW

  else if (Status and $20) = $20 then Result := System.reInvalidOp  // INEXACT_RESULT

  else Result := System.reInvalidOp;

end;



function MapFPE(Context: PSigContext): TRuntimeError;

begin

  case Context^.trapno of

    TRAP_ZERODIVIDE:

      Result := System.reDivByZero;

    TRAP_FPOVERRUN:

      Result := System.reInvalidOp;

    TRAP_FPE:

      Result := MapFPUStatus(Context^.fpstate^.sw);

  else

    Result := System.reInvalidOp;

  end;

end;



function MapFault(Context: PSigContext): TRuntimeError;

begin

  case Context^.trapno of

    TRAP_OVERFLOW:

      Result := System.reIntOverflow;

    TRAP_BOUND:

      Result := System.reRangeError;

    TRAP_INVINSTR:

      Result := System.rePrivInstruction; // This doesn't seem right, but we don't

                                          // have an external exception to match!

    TRAP_STACKFAULT:

      Result := System.reStackOverflow;

    TRAP_SEGMENTNP,

    TRAP_GPFAULT:

      Result := System.reAccessViolation;

    TRAP_PAGEFAULT:

      Result := System.reAccessViolation;

  else

    Result := System.reAccessViolation;

  end;

end;



function MapSignal(SigNum: Integer; Context: PSigContext): LongWord;

var

  Err: TRuntimeError;

begin

  case SigNum of

    SIGINT:       { Control-C }

      Err := System.reControlBreak;

    SIGQUIT:       { Quit key (Control-\) }

      Err := System.reQuit;

    SIGFPE:       { Floating Point Error }

      Err := MapFPE(Context);

    SIGSEGV:      { Segmentation Violation }

      Err := MapFault(Context);

    SIGILL:       { Illegal Instruction }

      Err := MapFault(Context);

    SIGBUS:       { Bus Error }

      Err := MapFault(Context);

  else

    Err := System.reExternalException;

  end;

  Result := LongWord(Err) or (LongWord(SigNum) shl 16);

end;

{$ENDIF}



{$IFDEF MSWINDOWS}

function MapException(P: PExceptionRecord): TRuntimeError;

begin

  case P.ExceptionCode of

    STATUS_INTEGER_DIVIDE_BY_ZERO:

      Result := System.reDivByZero;

    STATUS_ARRAY_BOUNDS_EXCEEDED:

      Result := System.reRangeError;

    STATUS_INTEGER_OVERFLOW:

      Result := System.reIntOverflow;

    STATUS_FLOAT_INEXACT_RESULT,

    STATUS_FLOAT_INVALID_OPERATION,

    STATUS_FLOAT_STACK_CHECK:

      Result := System.reInvalidOp;

    STATUS_FLOAT_DIVIDE_BY_ZERO:

      Result := System.reZeroDivide;

    STATUS_FLOAT_OVERFLOW:

      Result := System.reOverflow;

    STATUS_FLOAT_UNDERFLOW,

    STATUS_FLOAT_DENORMAL_OPERAND:

      Result := System.reUnderflow;

    STATUS_ACCESS_VIOLATION:

      Result := System.reAccessViolation;

    STATUS_PRIVILEGED_INSTRUCTION:

      Result := System.rePrivInstruction;

    STATUS_CONTROL_C_EXIT:

      Result := System.reControlBreak;

    STATUS_STACK_OVERFLOW:

      Result := System.reStackOverflow;

    else

      Result := System.reExternalException;

  end;

end;



function GetExceptionClass(P: PExceptionRecord): ExceptClass;

var

  ErrorCode: Byte;

begin

  ErrorCode := Byte(MapException(P));

  Result := ExceptMap[ErrorCode].EClass;

end;



function GetExceptionObject(P: PExceptionRecord): Exception;

var

  ErrorCode: Integer;



  function CreateAVObject: Exception;

  var

    AccessOp: string; // string ID indicating the access type READ or WRITE

    AccessAddress: Pointer;

    MemInfo: TMemoryBasicInformation;

    ModName: array[0..MAX_PATH] of Char;

  begin

    with P^ do

    begin

      if ExceptionInformation[0] = 0 then

        AccessOp := SReadAccess

      else

        AccessOp := SWriteAccess;

      AccessAddress := Pointer(ExceptionInformation[1]);

      VirtualQuery(ExceptionAddress, MemInfo, SizeOf(MemInfo));

      if (MemInfo.State = MEM_COMMIT) and

         (GetModuleFileName(THandle(MemInfo.AllocationBase), ModName, SizeOf(ModName)) <> 0) then

        Result := EAccessViolation.CreateFmt(sModuleAccessViolation,

          [ExceptionAddress, ExtractFileName(ModName), AccessOp,

          AccessAddress])

      else

        Result := EAccessViolation.CreateFmt(SAccessViolationArg3,

          [ExceptionAddress, AccessOp, AccessAddress]);

    end;

  end;



begin

  ErrorCode := Byte(MapException(P));

  case ErrorCode of

    3..10, 12..21:

      with ExceptMap[ErrorCode] do Result := EClass.Create(EIdent);

    11: Result := CreateAVObject;

  else

    Result := EExternalException.CreateFmt(SExternalException, [P.ExceptionCode]);

  end;

  if Result is EExternal then EExternal(Result).ExceptionRecord := P;

end;

{$ENDIF} { WIN32 }



{$IFDEF LINUX}

{

  The ErrorCode has the translated error code in the low byte and the

  original signal number in the high word.

}

function GetExceptionObject(ExceptionAddress: LongWord; AccessAddress: LongWord; ErrorCode: LongWord): Exception;

begin

  case (ErrorCode and $ff) of

    3..10, 12..21, 25:

      begin

        with ExceptMap[ErrorCode and $ff] do

          Result := EClass.Create(EIdent);

      end;

    11:

      Result := EAccessViolation.CreateFmt(SAccessViolationArg2, [Pointer(ExceptionAddress), Pointer(AccessAddress)]);

  else

//    Result := EExternalException.CreateFmt(SExternalException, [P.ExceptionCode]);

{ Not quite right - we need the original trap code, but that's lost }

    Result := EExternalException.CreateFmt(SExternalException, [ErrorCode and $ff]);

  end;



  EExternal(Result).ExceptionAddress := ExceptionAddress;

  EExternal(Result).AccessAddress := AccessAddress;

  EExternal(Result).SignalNumber := ErrorCode shr 16;

end;

{$ENDIF}



{ RTL exception handler }



procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer); far;

begin

  ShowException(ExceptObject, ExceptAddr);

  Halt(1);

end;



{$IFDEF LINUX}

{$IFDEF DEBUG}

{

  Used for debugging the signal handlers.

}

procedure DumpContext(SigNum: Integer; context : PSigContext);

var

   Buff: array [0..128] of char;

begin

   StrFmt(Buff, 'Context for signal: %d', [SigNum]);

   Writeln(Buff);

   StrFmt(Buff, 'CS = %04X  DS = %04X  ES = %04X  FS = %04X  GS = %04X  SS = %04X',

          [context^.cs, context^.ds, context^.es, context^.fs, context^.gs, context^.ss]);

   WriteLn(Buff);

   StrFmt(Buff, 'EAX = %08X  EBX = %08X  ECX = %08X  EDX = %08X',

          [context^.eax, context^.ebx, context^.ecx, context^.edx]);

   WriteLn(Buff);

   StrFmt(Buff, 'EDI = %08X  ESI = %08X  EBP = %08X  ESP = %08X',

          [context^.edi, context^.esi, context^.ebp, context^.esp]);

   WriteLn(Buff);

   StrFmt(Buff, 'EIP = %08X  EFLAGS = %08X  ESP(signal) = %08X  CR2 = %08X',

          [context^.eip, context^.eflags, context^.esp_at_signal, context^.cr2]);

   WriteLn(Buff);

   StrFmt(Buff, 'trapno = %d, err = %08x', [context^.trapno, context^.err]);

   WriteLn(Buff);

end;

{$ENDIF}





{

  RaiseSignalException is called from SignalConverter, once we've made things look

  like there's a legitimate stack frame above us.  Now we will just create

  an exception object, and raise it via a software raise.

}

procedure RaiseSignalException(ExceptionEIP: LongWord; FaultAddr: LongWord; ErrorCode: LongWord);

begin

  raise GetExceptionObject(ExceptionEIP, FaultAddr, ErrorCode);

end;



{

  SignalConverter is where we come when a signal is raised that we want to convert

  to an exception.  This function stands the best chance of being called with a

  useable stack frame behind it for the purpose of stack unwinding.  We can't

  guarantee that, though.  The stack was modified by the baseline signal handler

  to make it look as though we were called by the faulting instruction.  That way

  the unwinder stands a chance of being able to clean things up.

}

procedure SignalConverter(ExceptionEIP: LongWord; FaultAddr: LongWord; ErrorCode: LongWord);

asm

        {

          Here's the tricky part.  We arrived here directly by virtue of our

          signal handler tweaking the execution context with our address.  That

          means there's no return address on the stack.  The unwinder needs to

          have a return address so that it can unwind past this function when

          we raise the Delphi exception.  We will use the faulting instruction

          pointer as a fake return address.  Because of the fencepost conditions

          in the Delphi unwinder, we need to have an address that is strictly

          greater than the actual faulting instruction, so we increment that

          address by one.  This may be in the middle of an instruction, but we

          don't care, because we will never be returning to that address.

          Finally, the way that we get this address onto the stack is important.

          The compiler will generate unwind information for SignalConverter that

          will attempt to undo any stack modifications that are made by this

          function when unwinding past it.  In this particular case, we don't want

          that to happen, so we use some assembly language tricks to get around

          the compiler noticing the stack modification.

        }

        MOV EBX, ESP      // Get the current stack pointer

        SUB EBX, 4        // Effectively decrement the stack by 4

        MOV ESP, EBX      //   by doing a move to ESP with a register value

        MOV [ESP], EAX    // Store the instruction pointer into the new stack loc

        INC [ESP]         // Increment by one to keep the unwinder happy



        { Reset the FPU, or things can go south down the line from here }

        FNINIT

        FWAIT

{$IFDEF PIC}

        PUSH    EAX

        PUSH    ECX

        CALL    GetGOT

        MOV     EAX, [EAX].offset Default8087CW

        FLDCW   [EAX]

        POP     ECX

        POP     EAX

{$ELSE}

        FLDCW   Default8087CW

{$ENDIF}

        PUSH    EBP

        MOV     EBP, ESP

        CALL    RaiseSignalException

end;



function TlsGetValue(Key: Integer): Pointer; cdecl;

  external libpthreadmodulename name 'pthread_getspecific';



{

  Under Linux, we crawl out from underneath the OS signal handler before

  we attempt to do anything with the signal.  This is because the stack

  has a bunch of OS frames on there that we cannot possibly unwind from.

  So we use this routine to accomplish the dispatch, and then another

  routine to handle the language level of the exception handling.

}

procedure SignalDispatcher(SigNum: Integer; SigInfo: PSigInfo; UContext: PUserContext); cdecl;

type

  PGeneralRegisters = ^gregset_t;

var

  GeneralRegisters: PGeneralRegisters;

begin

//DumpContext(SigNum, @context);



  {

    Some of the ways that we get here are can lead us to big trouble.  For

    example, if the signal is SIGINT or SIGQUIT, these will commonly be raised

    to all threads in the process if the user generated them from the

    keyboard.  This is handled well by the Delphi threads, but if a non-Delphi

    thread lets one of these get by unhandled, terrible things will happen.

    So we look for that case, and eat SIGINT and SIGQUIT that have been issued

    on threads that are not Delphi threads.  If the signal is a SIGSEGV, or

    other fatal sort of signal, and the thread that we're running on is not

    a Delphi thread, then we are completely without options.  We have no

    recovery means, and we have to take the app down hard, right away.

  }

  if TlsGetValue(TlsIndex) = nil then

  begin

    if (SigNum = SIGINT) or (SigNum = SIGQUIT) then

      Exit;

    RunError(232);

  end;



  {

    If we are processing another exception right now, we definitely do not

    want to be dispatching any exceptions that are async, like SIGINT and

    SIGQUIT.  So we have check to see if OS signals are blocked.  If they are,

    we have to eat this signal right now.

  }

  if AreOSExceptionsBlocked and ((SigNum = SIGINT) or (SigNum = SIGQUIT)) then

    Exit;



  {

    If someone wants to delay the handling of SIGINT or SIGQUIT until such

    time as it's safe to handle it, they set DeferUserInterrupts to True.

    Then we just set a global variable saying that a SIGINT or SIGQUIT was

    issued.  It is the responsibility of some other body of code at this

    point to poll for changes to SIG(INT/QUIT)Issued

  }

  if DeferUserInterrupts then

  begin

    if SigNum = SIGINT then

    begin

      SIGINTIssued := True;

      Exit;

    end;

    if SigNum = SIGQUIT then

    begin

      SIGQUITIssued := True;

      Exit;

    end;

  end;



  BlockOSExceptions;



  GeneralRegisters := @UContext^.uc_mcontext.gregs;



  GeneralRegisters^[REG_EAX] := GeneralRegisters^[REG_EIP];

  GeneralRegisters^[REG_EDX] := UContext^.uc_mcontext.cr2;

  GeneralRegisters^[REG_ECX] := MapSignal(SigNum, PSigContext(GeneralRegisters));



  GeneralRegisters^[REG_EIP] := LongWord(@SignalConverter);

end;



type

  TSignalMap = packed record

    SigNum: Integer;

    Abandon: Boolean;

    OldAction: TSigAction;

    Hooked: Boolean;

  end;



var

  Signals: array [0..RTL_SIGLAST] of TSignalMap =

    ( (SigNum: SIGINT;),

      (SigNum: SIGFPE;),

      (SigNum: SIGSEGV;),

      (SigNum: SIGILL;),

      (SigNum: SIGBUS;),

      (SigNum: SIGQUIT;) );



function InquireSignal(RtlSigNum: Integer): TSignalState;

var

  Action: TSigAction;

begin

  if sigaction(Signals[RtlSigNum].SigNum, nil, @Action) = -1 then

    raise Exception.CreateRes(@SSigactionFailed);

  if (@Action.__sigaction_handler <> @SignalDispatcher) then

  begin

    if Signals[RtlSigNum].Hooked then

      Result := ssOverridden

    else

      Result := ssNotHooked;

  end

  else

    Result := ssHooked;

end;



procedure AbandonSignalHandler(RtlSigNum: Integer);

var

  I: Integer;

begin

  if RtlSigNum = RTL_SIGDEFAULT then

  begin

    for I := 0 to RTL_SIGLAST do

      AbandonSignalHandler(I);

    Exit;

  end;

  Signals[RtlSigNum].Abandon := True;

end;



procedure HookSignal(RtlSigNum: Integer);

var

  Action: TSigAction;

  I: Integer;

begin

  if RtlSigNum = RTL_SIGDEFAULT then

  begin

    for I := 0 to RTL_SIGLAST do

      HookSignal(I);

    Exit;

  end;



  FillChar(Action, SizeOf(Action), 0);

  Action.__sigaction_handler := @SignalDispatcher;

  Action.sa_flags := SA_SIGINFO;

  sigaddset(Action.sa_mask, SIGINT);

  sigaddset(Action.sa_mask, SIGQUIT);

  if sigaction(Signals[RtlSigNum].SigNum, @Action, @Signals[RtlSigNum].OldAction) = -1 then

    raise Exception.CreateRes(@SSigactionFailed);

  Signals[RtlSigNum].Hooked := True;

end;



procedure UnhookSignal(RtlSigNum: Integer; OnlyIfHooked: Boolean);

var

  I: Integer;

begin

  if RtlSigNum = RTL_SIGDEFAULT then

  begin

    for I := 0 to RTL_SIGLAST do

      UnhookSignal(I, OnlyIfHooked);

    Exit;

  end;

  if not Signals[RtlSigNum].Abandon then

  begin

    if OnlyIfHooked and (InquireSignal(RtlSigNum) <> ssHooked) then

      Exit;

    if sigaction(Signals[RtlSigNum].SigNum, @Signals[RtlSigNum].OldAction, Nil) = -1 then

      raise Exception.CreateRes(@SSigactionFailed);

    Signals[RtlSigNum].Hooked := False;

  end;

end;



procedure UnhookOSExceptions;

begin

  if not Assigned(HookOSExceptionsProc) then

    UnhookSignal(RTL_SIGDEFAULT, True);

end;



procedure HookOSExceptions;

begin

  if Assigned(HookOSExceptionsProc) then

    HookOSExceptionsProc

  else

  begin

    HookSignal(RTL_SIGDEFAULT);

  end;

end;

{$ENDIF} // LINUX



procedure InitExceptions;

begin

  OutOfMemory := EOutOfMemory.CreateRes(SOutOfMemory);

  InvalidPointer := EInvalidPointer.CreateRes(SInvalidPointer);

  ErrorProc := ErrorHandler;

  ExceptProc := @ExceptHandler;

  ExceptionClass := Exception;



{$IFDEF MSWINDOWS}

  ExceptClsProc := @GetExceptionClass;

  ExceptObjProc := @GetExceptionObject;

{$ENDIF}



  AssertErrorProc := @AssertErrorHandler;



{$IFNDEF PC_MAPPED_EXCEPTIONS}

  // We don't hook this under PC mapped exceptions, because

  // we have no idea what the parameters were to the procedure

  // in question.  Hence we cannot hope to unwind the stack in

  // our handler.  Since we just throw an exception from our

  // handler, that pretty much rules out using this without

  // exorbitant compiler support.  If you do hook AbstractErrorProc,

  // you must make sure that you never throw an exception from

  // your handler if PC_MAPPED_EXCEPTIONS is defined.

  AbstractErrorProc := @AbstractErrorHandler;

{$ENDIF}



{$IFDEF LINUX}

  if not IsLibrary then

    HookOSExceptions;

{$ENDIF}

end;



procedure DoneExceptions;

begin

  if Assigned(OutOfMemory) then

  begin

    OutOfMemory.AllowFree := True;

    OutOfMemory.FreeInstance;

    OutOfMemory := nil;

  end;

  if Assigned(InvalidPointer) then

  begin

    InvalidPointer.AllowFree := True;

    InvalidPointer.Free;

    InvalidPointer := nil;

  end;

  ErrorProc := nil;

  ExceptProc := nil;

  ExceptionClass := nil;

{$IFDEF MSWINDOWS}

  ExceptClsProc := nil;

  ExceptObjProc := nil;

{$ENDIF}

  AssertErrorProc := nil;

{$IFDEF LINUX}

  if not IsLibrary then

    UnhookOSExceptions;

{$ENDIF}

end;



{$IFDEF MSWINDOWS}

procedure InitPlatformId;

var

  OSVersionInfo: TOSVersionInfo;

begin

  OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);

  if GetVersionEx(OSVersionInfo) then

    with OSVersionInfo do

    begin

      Win32Platform := dwPlatformId;

      Win32MajorVersion := dwMajorVersion;

      Win32MinorVersion := dwMinorVersion;

      if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then

        Win32BuildNumber := dwBuildNumber and $FFFF

      else

        Win32BuildNumber := dwBuildNumber;

      Win32CSDVersion := szCSDVersion;

    end;

end;



function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean;

begin

  Result := (Win32MajorVersion > AMajor) or

            ((Win32MajorVersion = AMajor) and

             (Win32MinorVersion >= AMinor));

end;



function GetFileVersion(const AFileName: string): Cardinal;

var

  FileName: string;

  InfoSize, Wnd: DWORD;

  VerBuf: Pointer;

  FI: PVSFixedFileInfo;

  VerSize: DWORD;

begin

  Result := Cardinal(-1);

  // GetFileVersionInfo modifies the filename parameter data while parsing.

  // Copy the string const into a local variable to create a writeable copy.

  FileName := AFileName;

  UniqueString(FileName);

  InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);

  if InfoSize <> 0 then

  begin

    GetMem(VerBuf, InfoSize);

    try

      if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then

        if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then

          Result:= FI.dwFileVersionMS;

    finally

      FreeMem(VerBuf);

    end;

  end;

end;



procedure Beep;

begin

  MessageBeep(0);

end;

{$ENDIF}

{$IFDEF LINUX}

procedure Beep;

var

  ch: Char;

  FileDes: Integer;

begin

  if isatty(STDERR_FILENO) = 1 then

    FileDes := STDERR_FILENO

  else

  if isatty(STDOUT_FILENO) = 1 then

    FileDes := STDOUT_FILENO

  else

  begin

    // Neither STDERR_FILENO nor STDOUT_FILENO are open

    // terminals (TTYs). It is not possible to safely

    // write the beep character.

    Exit;

  end;



  ch := #7;

  __write(FileDes, ch, 1);

end;

{$ENDIF}



{ MBCS functions }



function ByteTypeTest(P: PChar; Index: Integer): TMbcsByteType;

{$IFDEF MSWINDOWS}

var

  I: Integer;

begin

  Result := mbSingleByte;

  if (P = nil) or (P[Index] = #$0) then Exit;

  if (Index = 0) then

  begin

    if P[0] in LeadBytes then Result := mbLeadByte;

  end

  else

  begin

    I := Index - 1;

    while (I >= 0) and (P[I] in LeadBytes) do Dec(I);

    if ((Index - I) mod 2) = 0 then Result := mbTrailByte

    else if P[Index] in LeadBytes then Result := mbLeadByte;

  end;

end;

{$ENDIF}

{$IFDEF LINUX}

var

  I, L: Integer;

begin

  Result := mbSingleByte;

  if (P = nil) or (P[Index] = #$0) then Exit;



  I := 0;

  repeat

    if P[I] in LeadBytes then

      L := StrCharLength(P + I)

    else

      L := 1;

    Inc(I, L);

  until (I > Index);



  if (L <> 1) then

    if (I - L = Index) then

      Result := mbLeadByte

    else

      Result := mbTrailByte;

end;

{$ENDIF}



function ByteType(const S: string; Index: Integer): TMbcsByteType;

begin

  Result := mbSingleByte;

  if SysLocale.FarEast then

    Result := ByteTypeTest(PChar(S), Index-1);

end;



function StrByteType(Str: PChar; Index: Cardinal): TMbcsByteType;

begin

  Result := mbSingleByte;

  if SysLocale.FarEast then

    Result := ByteTypeTest(Str, Index);

end;



function ByteToCharLen(const S: string; MaxLen: Integer): Integer;

begin

  if Length(S) < MaxLen then MaxLen := Length(S);

  Result := ByteToCharIndex(S, MaxLen);

end;



function ByteToCharIndex(const S: string; Index: Integer): Integer;

var

  I: Integer;

begin

  Result := 0;

  if (Index <= 0) or (Index > Length(S)) then Exit;

  Result := Index;

  if not SysLocale.FarEast then Exit;

  I := 1;

  Result := 0;

  while I <= Index do

  begin

    if S[I] in LeadBytes then

      I := NextCharIndex(S, I)

    else

      Inc(I);

    Inc(Result);

  end;

end;



procedure CountChars(const S: string; MaxChars: Integer; var CharCount, ByteCount: Integer);

var

  C, L, B: Integer;

begin

  L := Length(S);

  C := 1;

  B := 1;

  while (B < L) and (C < MaxChars) do

  begin

    Inc(C);

    if S[B] in LeadBytes then

      B := NextCharIndex(S, B)

    else

      Inc(B);

  end;

  if (C = MaxChars) and (B < L) and (S[B] in LeadBytes) then

    B := NextCharIndex(S, B) - 1;

  CharCount := C;

  ByteCount := B;

end;



function CharToByteIndex(const S: string; Index: Integer): Integer;

var

  Chars: Integer;

begin

  Result := 0;

  if (Index <= 0) or (Index > Length(S)) then Exit;

  if (Index > 1) and SysLocale.FarEast then

  begin

    CountChars(S, Index-1, Chars, Result);

    if (Chars < (Index-1)) or (Result >= Length(S)) then

      Result := 0  // Char index out of range

    else

      Inc(Result);

  end

  else

    Result := Index;

end;



function CharToByteLen(const S: string; MaxLen: Integer): Integer;

var

  Chars: Integer;

begin

  Result := 0;

  if MaxLen <= 0 then Exit;

  if MaxLen > Length(S) then MaxLen := Length(S);

  if SysLocale.FarEast then

  begin

    CountChars(S, MaxLen, Chars, Result);

    if Result > Length(S) then

      Result := Length(S);

  end

  else

    Result := MaxLen;

end;



{ MBCS Helper functions }



function StrCharLength(const Str: PChar): Integer;

begin

{$IFDEF LINUX}

  Result := mblen(Str, MB_CUR_MAX);

  if (Result = -1) then Result := 1;

{$ENDIF}

{$IFDEF MSWINDOWS}

  if SysLocale.FarEast then

    Result := Integer(CharNext(Str)) - Integer(Str)

  else

    Result := 1;

{$ENDIF}

end;



function StrNextChar(const Str: PChar): PChar;

begin

{$IFDEF LINUX}

  Result := Str + StrCharLength(Str);

{$ENDIF}

{$IFDEF MSWINDOWS}

  Result := CharNext(Str);

{$ENDIF}

end;



function CharLength(const S: string; Index: Integer): Integer;

begin

  Result := 1;

  assert((Index > 0) and (Index <= Length(S)));

  if SysLocale.FarEast and (S[Index] in LeadBytes) then

    Result := StrCharLength(PChar(S) + Index - 1);

end;



function NextCharIndex(const S: string; Index: Integer): Integer;

begin

  Result := Index + 1;

  assert((Index > 0) and (Index <= Length(S)));

  if SysLocale.FarEast and (S[Index] in LeadBytes) then

    Result := Index + StrCharLength(PChar(S) + Index - 1);

end;



function IsPathDelimiter(const S: string; Index: Integer): Boolean;

begin

  Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = PathDelim)

    and (ByteType(S, Index) = mbSingleByte);

end;



function IsDelimiter(const Delimiters, S: string; Index: Integer): Boolean;

begin

  Result := False;

  if (Index <= 0) or (Index > Length(S)) or (ByteType(S, Index) <> mbSingleByte) then exit;

  Result := StrScan(PChar(Delimiters), S[Index]) <> nil;

end;



function IncludeTrailingBackslash(const S: string): string;

begin

  Result := IncludeTrailingPathDelimiter(S);

end;



function IncludeTrailingPathDelimiter(const S: string): string;

begin

  Result := S;

  if not IsPathDelimiter(Result, Length(Result)) then

    Result := Result + PathDelim;

end;



function ExcludeTrailingBackslash(const S: string): string;

begin

  Result := ExcludeTrailingPathDelimiter(S);

end;



function ExcludeTrailingPathDelimiter(const S: string): string;

begin

  Result := S;

  if IsPathDelimiter(Result, Length(Result)) then

    SetLength(Result, Length(Result)-1);

end;



function AnsiPos(const Substr, S: string): Integer;

var

  P: PChar;

begin

  Result := 0;

  P := AnsiStrPos(PChar(S), PChar(SubStr));

  if P <> nil then

    Result := Integer(P) - Integer(PChar(S)) + 1;

end;



function AnsiCompareFileName(const S1, S2: string): Integer;

begin

{$IFDEF MSWINDOWS}

  Result := AnsiCompareStr(AnsiLowerCaseFileName(S1), AnsiLowerCaseFileName(S2));

{$ENDIF}

{$IFDEF LINUX}

  Result := AnsiCompareStr(S1, S2);

{$ENDIF}

end;



function SameFileName(const S1, S2: string): Boolean;

begin

  Result := AnsiCompareFileName(S1, S2) = 0;

end;



function AnsiLowerCaseFileName(const S: string): string;

{$IFDEF MSWINDOWS}

var

  I,L: Integer;

begin

  if SysLocale.FarEast then

  begin

    L := Length(S);

    SetLength(Result, L);

    I := 1;

    while I <= L do

    begin

      Result[I] := S[I];

      if S[I] in LeadBytes then

      begin

        Inc(I);

        Result[I] := S[I];

      end

      else

        if Result[I] in ['A'..'Z'] then Inc(Byte(Result[I]), 32);

      Inc(I);

    end;

  end

  else

    Result := AnsiLowerCase(S);

end;

{$ENDIF}

{$IFDEF LINUX}

begin

  Result := AnsiLowerCase(S);

end;

{$ENDIF}



function AnsiUpperCaseFileName(const S: string): string;

{$IFDEF MSWINDOWS}

var

  I,L: Integer;

begin

  if SysLocale.FarEast then

  begin

    L := Length(S);

    SetLength(Result, L);

    I := 1;

    while I <= L do

    begin

      Result[I] := S[I];

      if S[I] in LeadBytes then

      begin

        Inc(I);

        Result[I] := S[I];

      end

      else

        if Result[I] in ['a'..'z'] then Dec(Byte(Result[I]), 32);

      Inc(I);

    end;

  end

  else

    Result := AnsiUpperCase(S);

end;

{$ENDIF}

{$IFDEF LINUX}

begin

  Result := AnsiUpperCase(S);

end;

{$ENDIF}



function AnsiStrPos(Str, SubStr: PChar): PChar;

var

  L1, L2: Cardinal;

  ByteType : TMbcsByteType;

begin

  Result := nil;

  if (Str = nil) or (Str^ = #0) or (SubStr = nil) or (SubStr^ = #0) then Exit;

  L1 := StrLen(Str);

  L2 := StrLen(SubStr);

  Result := StrPos(Str, SubStr);

  while (Result <> nil) and ((L1 - Cardinal(Result - Str)) >= L2) do

  begin

    ByteType := StrByteType(Str, Integer(Result-Str));

{$IFDEF MSWINDOWS}

    if (ByteType <> mbTrailByte) and

      (CompareString(LOCALE_USER_DEFAULT, 0, Result, L2, SubStr, L2) = CSTR_EQUAL) then Exit;

    if (ByteType = mbLeadByte) then Inc(Result);

{$ENDIF}

{$IFDEF LINUX}

    if (ByteType <> mbTrailByte) and

      (strncmp(Result, SubStr, L2) = 0) then Exit;

{$ENDIF}

    Inc(Result);

    Result := StrPos(Result, SubStr);

  end;

  Result := nil;

end;



function AnsiStrRScan(Str: PChar; Chr: Char): PChar;

begin

  Str := AnsiStrScan(Str, Chr);

  Result := Str;

  if Chr <> #$0 then

  begin

    while Str <> nil do

    begin

      Result := Str;

      Inc(Str);

      Str := AnsiStrScan(Str, Chr);

    end;

  end

end;



function AnsiStrScan(Str: PChar; Chr: Char): PChar;

begin

  Result := StrScan(Str, Chr);

  while Result <> nil do

  begin

{$IFDEF MSWINDOWS}

    case StrByteType(Str, Integer(Result-Str)) of

      mbSingleByte: Exit;

      mbLeadByte: Inc(Result);

    end;

{$ENDIF}

{$IFDEF LINUX}

    if StrByteType(Str, Integer(Result-Str)) = mbSingleByte then Exit;

{$ENDIF}

    Inc(Result);

    Result := StrScan(Result, Chr);

  end;

end;



{$IFDEF MSWINDOWS}

function LCIDToCodePage(ALcid: LCID): Integer;

var

  Buffer: array [0..6] of Char;

begin

  GetLocaleInfo(ALcid, LOCALE_IDEFAULTANSICODEPAGE, Buffer, SizeOf(Buffer));

  Result:= StrToIntDef(Buffer, GetACP);

end;

{$ENDIF}



procedure InitSysLocale;

{$IFDEF MSWINDOWS}

var

  DefaultLCID: LCID;

  DefaultLangID: LANGID;

  AnsiCPInfo: TCPInfo;

//  I: Integer;

//  BufferA: array [128..255] of Char;

 // BufferW: array [128..256] of Word;

 // PCharA: PChar;



  procedure InitLeadBytes;

  var

    I: Integer;

    J: Byte;

  begin

    GetCPInfo(CP_ACP, AnsiCPInfo);

    with AnsiCPInfo do

    begin

      I := 0;

      while (I < MAX_LEADBYTES) and ((LeadByte[I] or LeadByte[I + 1]) <> 0) do

      begin

        for J := LeadByte[I] to LeadByte[I + 1] do

          Include(LeadBytes, Char(J));

        Inc(I, 2);

      end;

    end;

  end;



begin

  { Set default to English (US). }

  SysLocale.DefaultLCID := $0409;

  SysLocale.PriLangID := LANG_ENGLISH;

  SysLocale.SubLangID := SUBLANG_ENGLISH_US;



  DefaultLCID := GetThreadLocale;

  if DefaultLCID <> 0 then SysLocale.DefaultLCID := DefaultLCID;



  DefaultLangID := Word(DefaultLCID);

  if DefaultLangID <> 0 then

  begin

    SysLocale.PriLangID := DefaultLangID and $3ff;

    SysLocale.SubLangID := DefaultLangID shr 10;

  end;



  LeadBytes := [];

  if (Win32MajorVersion > 4) and (Win32Platform = VER_PLATFORM_WIN32_NT) then

    SysLocale.MiddleEast := True

  else

    SysLocale.MiddleEast := GetSystemMetrics(SM_MIDEASTENABLED) <> 0;

  SysLocale.FarEast    := GetSystemMetrics(SM_DBCSENABLED) <> 0;

  if SysLocale.FarEast then

    InitLeadBytes;

end;

{$ENDIF}

{$IFDEF LINUX}

var

  I: Integer;

  buf: array [0..3] of char;

begin

  FillChar(SysLocale, sizeof(SysLocale), 0);

  SysLocale.FarEast := MB_CUR_MAX <> 1;

  if not SysLocale.FarEast then Exit;



  buf[1] := #0;

  for I := 1 to 255 do

  begin

    buf[0] := Chr(I);

    if mblen(buf, 1) <> 1 then Include(LeadBytes, Char(I));

  end;

end;

{$ENDIF}



procedure GetFormatSettings;

{$IFDEF MSWINDOWS}

var

  HourFormat, TimePrefix, TimePostfix: string;

  DefaultLCID: Integer;

begin

  InitSysLocale;

  GetMonthDayNames;

  if SysLocale.FarEast then GetEraNamesAndYearOffsets;

  DefaultLCID := GetThreadLocale;

  CurrencyString := GetLocaleStr(DefaultLCID, LOCALE_SCURRENCY, '');

  CurrencyFormat := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRENCY, '0'), 0);

  NegCurrFormat := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_INEGCURR, '0'), 0);

  ThousandSeparator := GetLocaleChar(DefaultLCID, LOCALE_STHOUSAND, ',');

  DecimalSeparator := GetLocaleChar(DefaultLCID, LOCALE_SDECIMAL, '.');

  CurrencyDecimals := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRDIGITS, '0'), 0);

  DateSeparator := GetLocaleChar(DefaultLCID, LOCALE_SDATE, '/');

  ShortDateFormat := TranslateDateFormat(GetLocaleStr(DefaultLCID, LOCALE_SSHORTDATE, 'm/d/yy'));

  LongDateFormat := TranslateDateFormat(GetLocaleStr(DefaultLCID, LOCALE_SLONGDATE, 'mmmm d, yyyy'));

  TimeSeparator := GetLocaleChar(DefaultLCID, LOCALE_STIME, ':');

  TimeAMString := GetLocaleStr(DefaultLCID, LOCALE_S1159, 'am');

  TimePMString := GetLocaleStr(DefaultLCID, LOCALE_S2359, 'pm');

  TimePrefix := '';

  TimePostfix := '';

  if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITLZERO, '0'), 0) = 0 then

    HourFormat := 'h' else

    HourFormat := 'hh';

  if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIME, '0'), 0) = 0 then

    if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIMEMARKPOSN, '0'), 0) = 0 then

      TimePostfix := ' AMPM'

    else

      TimePrefix := 'AMPM ';

  ShortTimeFormat := TimePrefix + HourFormat + ':mm' + TimePostfix;

  LongTimeFormat := TimePrefix + HourFormat + ':mm:ss' + TimePostfix;

  ListSeparator := GetLocaleChar(DefaultLCID, LOCALE_SLIST, ',');

end;

{$ELSE}

{$IFDEF LINUX}

const

  //first boolean is p_cs_precedes, second is p_sep_by_space

  CurrencyFormats: array[boolean, boolean] of byte = ((1, 3),(0, 2));

  //first boolean is n_cs_precedes, second is n_sep_by_space and finally n_sign_posn

  NegCurrFormats: array[boolean, boolean, 0..4] of byte =

    (((4,5,7,6,7),(15,8,10,13,10)),((0,1,3,1,2),(14,9,11,9,12)));



  function TranslateFormat(s: PChar; const Default: string): string;

  begin

    Result := '';

    while s^ <> #0 do

    begin

      if s^ = '%' then

      begin

        inc(s);

        case s^ of

          'a': Result := Result + 'ddd';

          'A': Result := Result + 'dddd';

          'b': Result := Result + 'MMM';

          'B': Result := Result + 'MMMM';

          'c': Result := Result + 'c';

//        'C':  year / 100 not supported

          'd': Result := Result + 'dd';

          'D': Result := Result + 'MM/dd/yy';

          'e': Result := Result + 'd';

//        'E': alternate format not supported

          'g': Result := Result + 'yy';

          'G': Result := Result + 'yyyy';

          'h': Result := Result + 'MMM';

          'H': Result := Result + 'HH';

          'I': Result := Result + 'hh';

//        'j': day of year not supported

          'k': Result := Result + 'H';

          'l': Result := Result + 'h';

          'm': Result := Result + 'MM';

          'M': Result := Result + 'nn';  // minutes! not months!

          'n': Result := Result + sLineBreak;  // line break

//        'O': alternate format not supported

          'P',   // P's implied lowercasing of locale string is not supported

          'p': Result := Result + 'AMPM';

          'r': Result := Result + TranslateFormat(nl_langInfo(T_FMT_AMPM),'');

          'R': Result := Result + 'HH:mm';

//        's': number of seconds since Epoch not supported

          'S': Result := Result + 'ss';

          't': Result := Result + #9;  // tab char

          'T': Result := Result + 'HH:mm:ss';

//        'u': day of week 1..7 not supported

//        'U': week number of the year not supported

//        'V': week number of the year not supported

//        'w': day of week 0..6 not supported

//        'W': week number of the year not supported

          'x': Result := Result + TranslateFormat(nl_langInfo(D_FMT),'');

          'X': Result := Result + TranslateFormat(nl_langinfo(T_FMT),'');

          'y': Result := Result + 'yy';

          'Y': Result := Result + 'yyyy';

//        'z': GMT offset is not supported

          '%': Result := Result + '%';

        end;

      end

      else

        Result := Result + s^;

      Inc(s);

    end;

    if Result = '' then

      Result := Default;

  end;



  function GetFirstCharacter(const SrcString, match: string): char;

  var

    i, p: integer;

  begin

    result := match[1];

    for i := 1 to length(SrcString) do begin

      p := Pos(SrcString[i], match);

      if p > 0 then

      begin

        result := match[p];

        break;

      end;

    end;

  end;



var

  P: PLConv;

begin

  InitSysLocale;

  GetMonthDayNames;

  if SysLocale.FarEast then InitEras;



  CurrencyString := '';

  CurrencyFormat := 0;

  NegCurrFormat := 0;

  ThousandSeparator := ',';

  DecimalSeparator := '.';

  CurrencyDecimals := 0;



  P := localeconv;

  if P <> nil then

  begin

    if P^.currency_symbol <> nil then

      CurrencyString := P^.currency_symbol;



    if (Byte(P^.p_cs_precedes) in [0..1]) and

       (Byte(P^.p_sep_by_space) in [0..1]) then

    begin

      CurrencyFormat := CurrencyFormats[P^.p_cs_precedes, P^.p_sep_by_space];

      if P^.p_sign_posn in [0..4] then

        NegCurrFormat := NegCurrFormats[P^.n_cs_precedes, P^.n_sep_by_space,

                                        P^.n_sign_posn];

    end;



    // #0 is valid for ThousandSeparator.  Indicates no thousand separator.

    ThousandSeparator := P^.thousands_sep^;



    // #0 is not valid for DecimalSeparator.

    if P^.decimal_point <> #0 then

      DecimalSeparator := P^.decimal_point^;

    CurrencyDecimals := P^.frac_digits;

  end;



  ShortDateFormat := TranslateFormat(nl_langinfo(D_FMT),'m/d/yy');

  LongDateFormat := TranslateFormat(nl_langinfo(D_T_FMT), ShortDateFormat);

  ShortTimeFormat := TranslateFormat(nl_langinfo(T_FMT), 'hh:mm AMPM');

  LongTimeFormat := TranslateFormat(nl_langinfo(T_FMT_AMPM), ShortTimeFormat);



  DateSeparator := GetFirstCharacter(ShortDateFormat, '/.-');

  TimeSeparator := GetFirstCharacter(ShortTimeFormat, ':.');



  TimeAMString := nl_langinfo(AM_STR);

  TimePMString := nl_langinfo(PM_STR);

  ListSeparator := ',';

end;

{$ELSE}

var

  HourFormat, TimePrefix, TimePostfix: string;

begin

  InitSysLocale;

  GetMonthDayNames;

  CurrencyString := '';

  CurrencyFormat := 0;

  NegCurrFormat := 0;

  ThousandSeparator := ',';

  DecimalSeparator := '.';

  CurrencyDecimals := 0;

  DateSeparator := '/';

  ShortDateFormat := 'm/d/yy';

  LongDateFormat := 'mmmm d, yyyy';

  TimeSeparator := ':';

  TimeAMString := 'am';

  TimePMString := 'pm';

  TimePrefix := '';

  TimePostfix := '';

  HourFormat := 'h';

  TimePostfix := ' AMPM';

  ShortTimeFormat := TimePrefix + HourFormat + ':mm' + TimePostfix;

  LongTimeFormat := TimePrefix + HourFormat + ':mm:ss' + TimePostfix;

  ListSeparator := ',';

end;

{$ENDIF}

{$ENDIF}



{$IFDEF MSWINDOWS}

procedure GetLocaleFormatSettings(LCID: Integer;

  var FormatSettings: TFormatSettings);

var

  HourFormat, TimePrefix, TimePostfix: string;

  DefaultLCID: Integer;

begin

  if IsValidLocale(LCID, LCID_INSTALLED) then

    DefaultLCID := LCID

  else

    DefaultLCID := GetThreadLocale;



  GetLocaleMonthDayNames(LCID, FormatSettings);

  with FormatSettings do

  begin

    CurrencyString := GetLocaleStr(DefaultLCID, LOCALE_SCURRENCY, '');

    CurrencyFormat := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRENCY, '0'), 0);

    NegCurrFormat := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_INEGCURR, '0'), 0);

    ThousandSeparator := GetLocaleChar(DefaultLCID, LOCALE_STHOUSAND, ',');

    DecimalSeparator := GetLocaleChar(DefaultLCID, LOCALE_SDECIMAL, '.');

    CurrencyDecimals := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRDIGITS, '0'), 0);

    DateSeparator := GetLocaleChar(DefaultLCID, LOCALE_SDATE, '/');

    ShortDateFormat := TranslateDateFormat(GetLocaleStr(DefaultLCID, LOCALE_SSHORTDATE, 'm/d/yy'));

    LongDateFormat := TranslateDateFormat(GetLocaleStr(DefaultLCID, LOCALE_SLONGDATE, 'mmmm d, yyyy'));

    TimeSeparator := GetLocaleChar(DefaultLCID, LOCALE_STIME, ':');

    TimeAMString := GetLocaleStr(DefaultLCID, LOCALE_S1159, 'am');

    TimePMString := GetLocaleStr(DefaultLCID, LOCALE_S2359, 'pm');

    TimePrefix := '';

    TimePostfix := '';

    if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITLZERO, '0'), 0) = 0 then

      HourFormat := 'h' else

      HourFormat := 'hh';

    if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIME, '0'), 0) = 0 then

      if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIMEMARKPOSN, '0'), 0) = 0 then

        TimePostfix := ' AMPM'

      else

        TimePrefix := 'AMPM ';

    ShortTimeFormat := TimePrefix + HourFormat + ':mm' + TimePostfix;

    LongTimeFormat := TimePrefix + HourFormat + ':mm:ss' + TimePostfix;

    ListSeparator := GetLocaleChar(DefaultLCID, LOCALE_SLIST, ',');

  end;

end;

{$ENDIF}



function StringReplace(const S, OldPattern, NewPattern: string;

  Flags: TReplaceFlags): string;

var

  SearchStr, Patt, NewStr: string;

  Offset: Integer;

begin

  if rfIgnoreCase in Flags then

  begin

    SearchStr := AnsiUpperCase(S);

    Patt := AnsiUpperCase(OldPattern);

  end else

  begin

    SearchStr := S;

    Patt := OldPattern;

  end;

  NewStr := S;

  Result := '';

  while SearchStr <> '' do

  begin

    Offset := AnsiPos(Patt, SearchStr);

    if Offset = 0 then

    begin

      Result := Result + NewStr;

      Break;

    end;

    Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;

    NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);

    if not (rfReplaceAll in Flags) then

    begin

      Result := Result + NewStr;

      Break;

    end;

    SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);

  end;

end;



function WrapText(const Line, BreakStr: string; const BreakChars: TSysCharSet;

  MaxCol: Integer): string;

const

  QuoteChars = ['''', '"'];

var

  Col, Pos: Integer;

  LinePos, LineLen: Integer;

  BreakLen, BreakPos: Integer;

  QuoteChar, CurChar: Char;

  ExistingBreak: Boolean;

  L: Integer;

begin

  Col := 1;

  Pos := 1;

  LinePos := 1;

  BreakPos := 0;

  QuoteChar := #0;

  ExistingBreak := False;

  LineLen := Length(Line);

  BreakLen := Length(BreakStr);

  Result := '';

  while Pos <= LineLen do

  begin

    CurChar := Line[Pos];

    if CurChar in LeadBytes then

    begin

      L := CharLength(Line, Pos) - 1;

      Inc(Pos, L);

      Inc(Col, L);

    end

    else

    begin

      if CurChar in QuoteChars then

        if QuoteChar = #0 then

          QuoteChar := CurChar

        else if CurChar = QuoteChar then

          QuoteChar := #0;

      if QuoteChar = #0 then

      begin

        if CurChar = BreakStr[1] then

        begin

          ExistingBreak := StrLComp(Pointer(BreakStr), Pointer(@Line[Pos]), BreakLen) = 0;

          if ExistingBreak then

          begin

            Inc(Pos, BreakLen-1);

            BreakPos := Pos;

          end;

        end;



        if not ExistingBreak then

          if CurChar in BreakChars then

            BreakPos := Pos;

      end;

    end;



    Inc(Pos);

    Inc(Col);



    if not (QuoteChar in QuoteChars) and (ExistingBreak or

      ((Col > MaxCol) and (BreakPos > LinePos))) then

    begin

      Col := 1;

      Result := Result + Copy(Line, LinePos, BreakPos - LinePos + 1);

      if not (CurChar in QuoteChars) then

      begin

        while Pos <= LineLen do

        begin

          if Line[Pos] in BreakChars then

          begin

            Inc(Pos);

            ExistingBreak := False;

          end

          else

          begin

            if StrLComp(Pointer(@Line[Pos]), sLineBreak, Length(sLineBreak)) = 0 then

            begin

              Inc(Pos, Length(sLineBreak));

              ExistingBreak := True;

            end

            else

              Break;

          end;

        end;

      end;

      if (Pos <= LineLen) and not ExistingBreak then

        Result := Result + BreakStr;



      Inc(BreakPos);

      LinePos := BreakPos;

      Pos := LinePos;

      ExistingBreak := False;

    end;

  end;

  Result := Result + Copy(Line, LinePos, MaxInt);

end;



function WrapText(const Line: string; MaxCol: Integer): string;

begin

  Result := WrapText(Line, sLineBreak, [' ', '-', #9], MaxCol); { do not localize }

end;



function FindCmdLineSwitch(const Switch: string; const Chars: TSysCharSet;

  IgnoreCase: Boolean): Boolean;

var

  I: Integer;

  S: string;

begin

  for I := 1 to ParamCount do

  begin

    S := ParamStr(I);

    if (Chars = []) or (S[1] in Chars) then

      if IgnoreCase then

      begin

        if (AnsiCompareText(Copy(S, 2, Maxint), Switch) = 0) then

        begin

          Result := True;

          Exit;

        end;

      end

      else begin

        if (AnsiCompareStr(Copy(S, 2, Maxint), Switch) = 0) then

        begin

          Result := True;

          Exit;

        end;

      end;

  end;

  Result := False;

end;



function FindCmdLineSwitch(const Switch: string): Boolean;

begin

  Result := FindCmdLineSwitch(Switch, SwitchChars, True);

end;



function FindCmdLineSwitch(const Switch: string; IgnoreCase: Boolean): Boolean;

begin

  Result := FindCmdLineSwitch(Switch, SwitchChars, IgnoreCase);

end;



{ Package info structures }



type

  PPkgName = ^TPkgName;

  TPkgName = packed record

    HashCode: Byte;

    Name: array[0..255] of Char;

  end;



  { PackageUnitFlags:

    bit      meaning

    -----------------------------------------------------------------------------------------

    0      | main unit

    1      | package unit (dpk source)

    2      | $WEAKPACKAGEUNIT unit

    3      | original containment of $WEAKPACKAGEUNIT (package into which it was compiled)

    4      | implicitly imported

    5..7   | reserved

  }

  PUnitName = ^TUnitName;

  TUnitName = packed record

    Flags : Byte;

    HashCode: Byte;

    Name: array[0..255] of Char;

  end;



  { Package flags:

    bit     meaning

    -----------------------------------------------------------------------------------------

    0     | 1: never-build                  0: always build

    1     | 1: design-time only             0: not design-time only      on => bit 2 = off

    2     | 1: run-time only                0: not run-time only         on => bit 1 = off

    3     | 1: do not check for dup units   0: perform normal dup unit check

    4..25 | reserved

    26..27| (producer) 0: pre-V4, 1: undefined, 2: c++, 3: Pascal

    28..29| reserved

    30..31| 0: EXE, 1: Package DLL, 2: Library DLL, 3: undefined

  }

  PPackageInfoHeader = ^TPackageInfoHeader;

  TPackageInfoHeader = packed record

    Flags: Cardinal;

    RequiresCount: Integer;

    {Requires: array[0..9999] of TPkgName;

    ContainsCount: Integer;

    Contains: array[0..9999] of TUnitName;}

  end;



function PackageInfoTable(Module: HMODULE): PPackageInfoHeader;

var

  ResInfo: HRSRC;

  Data: THandle;

begin

  Result := nil;

  ResInfo := FindResource(Module, 'PACKAGEINFO', RT_RCDATA);

  if ResInfo <> 0 then

  begin

    Data := LoadResource(Module, ResInfo);

    if Data <> 0 then

    try

      Result := LockResource(Data);

      UnlockResource(Data);

    finally

      FreeResource(Data);

    end;

  end;

end;



function GetModuleName(Module: HMODULE): string;

var

  ModName: array[0..MAX_PATH] of Char;

begin

  SetString(Result, ModName, GetModuleFileName(Module, ModName, SizeOf(ModName)));

end;



var

  Reserved: Integer;



procedure CheckForDuplicateUnits(Module: HMODULE);

var

  ModuleFlags: Cardinal;



  function IsUnitPresent(HC: Byte; UnitName: PChar; Module: HMODULE;

    const ModuleName: string; var UnitPackage: string): Boolean;

  var

    I: Integer;

    InfoTable: PPackageInfoHeader;

    LibModule: PLibModule;

    PkgName: PPkgName;

    UName : PUnitName;

    Count: Integer;

  begin

    Result := True;

    if (StrIComp(UnitName, 'SysInit') <> 0) and

      (StrIComp(UnitName, PChar(ModuleName)) <> 0) then

    begin

      LibModule := LibModuleList;

      while LibModule <> nil do

      begin

        if LibModule.Instance <> Cardinal(Module) then

        begin

          InfoTable := PackageInfoTable(HMODULE(LibModule.Instance));

          if (InfoTable <> nil) and (InfoTable.Flags and pfModuleTypeMask = pfPackageModule) and

            ((InfoTable.Flags and pfIgnoreDupUnits) = (ModuleFlags and pfIgnoreDupUnits)) then

          begin

            PkgName := PPkgName(Integer(InfoTable) + SizeOf(InfoTable^));

            Count := InfoTable.RequiresCount;

            { Skip the Requires list }

            for I := 0 to Count - 1 do Inc(Integer(PkgName), StrLen(PkgName.Name) + 2);

            Count := Integer(Pointer(PkgName)^);

            UName := PUnitName(Integer(PkgName) + 4);

            for I := 0 to Count - 1 do

            begin

              with UName^ do

                // Test Flags to ignore weak package units

                if ((HashCode = HC) or (HashCode = 0) or (HC = 0)) and

                  ((Flags and $06) = 0) and (StrIComp(UnitName, Name) = 0) then

                begin

                  UnitPackage := ChangeFileExt(ExtractFileName(

                    GetModuleName(HMODULE(LibModule.Instance))), '');

                  Exit;

                end;

              Inc(Integer(UName), StrLen(UName.Name) + 3);

            end;

          end;

        end;

        LibModule := LibModule.Next;

      end;

    end;

    Result := False;

  end;



  function FindLibModule(Module: HModule): PLibModule;

  begin

    Result := LibModuleList;

    while Result <> nil do

    begin

      if Result.Instance = Cardinal(Module) then Exit;

      Result := Result.Next;

    end;

  end;



  procedure InternalUnitCheck(Module: HModule);

  var

    I: Integer;

    InfoTable: PPackageInfoHeader;

    UnitPackage: string;

    ModuleName: string;

    PkgName: PPkgName;

    UName: PUnitName;

    Count: Integer;

    LibModule: PLibModule;

  begin

    InfoTable := PackageInfoTable(Module);

    if (InfoTable <> nil) and (InfoTable.Flags and pfModuleTypeMask = pfPackageModule) then

    begin

      if ModuleFlags = 0 then ModuleFlags := InfoTable.Flags;

      ModuleName := ChangeFileExt(ExtractFileName(GetModuleName(Module)), '');

      PkgName := PPkgName(Integer(InfoTable) + SizeOf(InfoTable^));

      Count := InfoTable.RequiresCount;

      for I := 0 to Count - 1 do

      begin

        with PkgName^ do

{$IFDEF MSWINDOWS}

          InternalUnitCheck(GetModuleHandle(PChar(ChangeFileExt(Name, '.bpl'))));

{$ENDIF}

{$IFDEF LINUX}

          InternalUnitCheck(GetModuleHandle(Name));

{$ENDIF}

          Inc(Integer(PkgName), StrLen(PkgName.Name) + 2);

      end;

      LibModule := FindLibModule(Module);

      if (LibModule = nil) or ((LibModule <> nil) and (LibModule.Reserved <> Reserved)) then

      begin

        if LibModule <> nil then LibModule.Reserved := Reserved;

        Count := Integer(Pointer(PkgName)^);

        UName := PUnitName(Integer(PkgName) + 4);

        for I := 0 to Count - 1 do

        begin

          with UName^ do

            // Test Flags to ignore weak package units

            if ((Flags and ufWeakPackageUnit) = 0 ) and

              IsUnitPresent(HashCode, Name, Module, ModuleName, UnitPackage) then

              raise EPackageError.CreateResFmt(SDuplicatePackageUnit,

                [ModuleName, Name, UnitPackage]);

          Inc(Integer(UName), StrLen(UName.Name) + 3);

        end;

      end;

    end;

  end;



begin

  Inc(Reserved);

  ModuleFlags := 0;

  InternalUnitCheck(Module);

end;



{$IFDEF LINUX}

function LoadLibrary(ModuleName: PChar): HMODULE;

begin

  Result := HMODULE(dlopen(ModuleName, RTLD_LAZY));

end;



function FreeLibrary(Module: HMODULE): LongBool;

begin

  Result := LongBool(dlclose(Pointer(Module)));

end;



function GetProcAddress(Module: HMODULE; Proc: PChar): Pointer;

var

  Info: TDLInfo;

  Error: PChar;

  ModHandle: HMODULE;

begin

  // dlsym doesn't clear the error state when the function succeeds

  dlerror;

  Result := dlsym(Pointer(Module), Proc);

  Error := dlerror;

  if Error <> nil then

    Result := nil

  else if dladdr(Result, Info) <> 0 then

  begin

{   In glibc 2.1.3 and earlier, dladdr returns a nil dli_fname

    for addresses in the main program file.  In glibc 2.1.91 and

    later, dladdr fills in the dli_fname for addresses in the

    main program file, but dlopen will segfault when given

    the main program file name.

    Workaround:  Check the symbol base address against the main

    program file's base address, and only call dlopen with a nil

    filename to get the module name of the main program.  }



    if Info.dli_fbase = ExeBaseAddress then

      Info.dli_fname := nil;



    ModHandle := HMODULE(dlopen(Info.dli_fname, RTLD_LAZY));

    if ModHandle <> 0 then

    begin

      dlclose(Pointer(ModHandle));

      if ModHandle <> Module then

        Result := nil;

    end;

  end else Result := nil;

end;



type

  plink_map = ^link_map;

  link_map = record

    l_addr: Pointer;

    l_name: PChar;

    l_ld: Pointer;

    l_next, l_prev: plink_map;

  end;



  pr_debug = ^r_debug;

  r_debug = record

    r_version: Integer;

    r_map: plink_map;

    r_brk: Pointer;

    r_state: Integer;

    r_ldbase: Pointer;

  end;



var

  _r_debug: pr_debug = nil;



function ScanLinkMap(Func: Pointer): plink_map;

var

  linkmap: plink_map;



  function Eval(linkmap: plink_map; Func: Pointer): Boolean;

  asm

//        MOV    ECX,[EBP]

        PUSH   EBP

        CALL   EDX

        POP    ECX

  end;



begin

  if _r_debug = nil then

    _r_debug := dlsym(RTLD_DEFAULT, '_r_debug');

  if _r_debug = nil then

  begin

    Assert(False, 'Unable to locate ''_r_debug'' symbol'); // do not localize

    Result := nil;

    Exit;

  end;

  linkmap := _r_debug.r_map;

  while linkmap <> nil do

  begin

    if not Eval(linkmap, Func) then Break;

    linkmap := linkmap.l_next;

  end;

  Result := linkmap;

end;



function InitModule(linkmap: plink_map): HMODULE;

begin

  if linkmap <> nil then

  begin

    Result := HMODULE(dlopen(linkmap.l_name, RTLD_LAZY));

    if Result <> 0 then

      dlclose(Pointer(Result));

  end else Result := 0;

end;



function GetModuleHandle(ModuleName: PChar): HMODULE;



  function CheckModuleName(linkmap: plink_map): Boolean;

  var

    BaseName: PChar;

  begin

    Result := True;

    if ((ModuleName = nil) and ((linkmap.l_name = nil) or (linkmap.l_name[0] = #0))) or

      ((ModuleName[0] = PathDelim) and (StrComp(ModuleName, linkmap.l_name) = 0)) then

    begin

      Result := False;

      Exit;

    end else

    begin

      // Locate the start of the actual filename

      BaseName := StrRScan(linkmap.l_name, PathDelim);

      if BaseName = nil then

        BaseName := linkmap.l_name

      else Inc(BaseName); // The filename is actually located at BaseName+1

      if StrComp(ModuleName, BaseName) = 0 then

      begin

        Result := False;

        Exit;

      end;

    end;

  end;



begin

  Result := InitModule(ScanLinkMap(@CheckModuleName));

end;



function GetPackageModuleHandle(PackageName: PChar): HMODULE;

var

  PkgName: array[0..MAX_PATH] of Char;



  function CheckPackageName(linkmap: plink_map): Boolean;

  var

    BaseName: PChar;

  begin

    Result := True;

    if linkmap.l_name <> nil then

    begin

      // Locate the start of the actual filename

      BaseName := StrRScan(linkmap.l_name, PathDelim);

      if BaseName = nil then

        BaseName := linkmap.l_name  // If there is no path info, just use the whole name

      else Inc(BaseName); // The filename is actually located at BaseName+1

      Result := StrPos(BaseName, PkgName) = nil;

    end;

  end;



  procedure MakePkgName(Prefix, Name: PChar);

  begin

    StrCopy(PkgName, Prefix);

    StrLCat(PkgName, Name, sizeof(PkgName)-1);

    PkgName[High(PkgName)] := #0;

  end;



begin

  if (PackageName = nil) or (StrScan(PackageName, PathDelim) <> nil) then

    Result := 0

  else

  begin

    MakePkgName('bpl', PackageName); // First check the default prefix

    Result := InitModule(ScanLinkMap(@CheckPackageName));

    if Result = 0 then

    begin

      MakePkgName('dcl', PackageName); // Next check the design-time prefix

      Result := InitModule(ScanLinkMap(@CheckPackageName));

      if Result = 0 then

      begin

        MakePkgName('', PackageName);  // finally check without a prefix

        Result := InitModule(ScanLinkMap(@CheckPackageName));

      end;

    end;

  end;

end;



{$ENDIF}



{$IFDEF MSWINDOWS}

procedure Sleep; external kernel32 name 'Sleep'; stdcall;

{$ENDIF}

{$IFDEF LINUX}

procedure Sleep(milliseconds: Cardinal);

begin

  usleep(milliseconds * 1000);  // usleep is in microseconds

end;

{$ENDIF}



{ InitializePackage }



procedure InitializePackage(Module: HMODULE);

type

  TPackageLoad = procedure;

var

  PackageLoad: TPackageLoad;

begin

  CheckForDuplicateUnits(Module);

  @PackageLoad := GetProcAddress(Module, 'Initialize'); //Do not localize

  if Assigned(PackageLoad) then

    PackageLoad

  else

    raise EPackageError.CreateFmt(sInvalidPackageFile, [GetModuleName(Module)]);

end;



{ FinalizePackage }



procedure FinalizePackage(Module: HMODULE);

type

  TPackageUnload = procedure;

var

  PackageUnload: TPackageUnload;

begin

  @PackageUnload := GetProcAddress(Module, 'Finalize'); //Do not localize

  if Assigned(PackageUnload) then

    PackageUnload

  else

    raise EPackageError.CreateRes(sInvalidPackageHandle);

end;



{ LoadPackage }



function LoadPackage(const Name: string): HMODULE;

{$IFDEF LINUX}

var

  DLErrorMsg: string;

{$ENDIF}

begin

{$IFDEF MSWINDOWS}

  Result := SafeLoadLibrary(Name);

{$ENDIF}

{$IFDEF LINUX}

  Result := HMODULE(dlOpen(PChar(Name), PkgLoadingMode));

{$ENDIF}

  if Result = 0 then

  begin

{$IFDEF LINUX}

    DLErrorMsg := dlerror;

{$ENDIF}

    raise EPackageError.CreateResFmt(sErrorLoadingPackage,

      [Name,

       {$IFDEF MSWINDOWS}SysErrorMessage(GetLastError){$ENDIF}

       {$IFDEF LINUX}DLErrorMsg{$ENDIF}]);

  end;

  try

    InitializePackage(Result);

  except

{$IFDEF MSWINDOWS}

    FreeLibrary(Result);

{$ENDIF}

{$IFDEF LINUX}

    dlclose(Pointer(Result));

{$ENDIF}

    raise;

  end;

end;



{ UnloadPackage }



procedure UnloadPackage(Module: HMODULE);

begin

  FinalizePackage(Module);

{$IFDEF MSWINDOWS}

  FreeLibrary(Module);

{$ENDIF}

{$IFDEF LINUX}

  dlclose(Pointer(Module));

  InvalidateModuleCache;

{$ENDIF}

end;



{ GetPackageInfo }



procedure GetPackageInfo(Module: HMODULE; Param: Pointer; var Flags: Integer;

  InfoProc: TPackageInfoProc);

var

  InfoTable: PPackageInfoHeader;

  I: Integer;

  PkgName: PPkgName;

  UName: PUnitName;

  Count: Integer;

begin

  InfoTable := PackageInfoTable(Module);

  if not Assigned(InfoTable) then

    raise EPackageError.CreateFmt(SCannotReadPackageInfo,

      [ExtractFileName(GetModuleName(Module))]);

  Flags := InfoTable.Flags;

  with InfoTable^ do

  begin

    PkgName := PPkgName(Integer(InfoTable) + SizeOf(InfoTable^));

    Count := RequiresCount;

    for I := 0 to Count - 1 do

    begin

      InfoProc(PkgName.Name, ntRequiresPackage, 0, Param);

      Inc(Integer(PkgName), StrLen(PkgName.Name) + 2);

    end;

    Count := Integer(Pointer(PkgName)^);

    UName := PUnitName(Integer(PkgName) + 4);

    for I := 0 to Count - 1 do

    begin

      InfoProc(UName.Name, ntContainsUnit, UName.Flags, Param);

      Inc(Integer(UName), StrLen(UName.Name) + 3);

    end;

    if Flags and pfPackageModule <> 0 then

    begin

      PkgName := PPkgName(UName);

      InfoProc(PkgName.Name, ntDcpBpiName, 0, Param);

    end;

  end;

end;



function GetPackageDescription(ModuleName: PChar): string;

var

  ResModule: HMODULE;

  ResInfo: HRSRC;

  ResData: HGLOBAL;

{$IFDEF LINUX}

  DLErrorMsg: string;

{$ENDIF}

begin

  Result := '';

  ResModule := LoadResourceModule(ModuleName);

  if ResModule = 0 then

  begin

{$IFDEF MSWINDOWS}

    ResModule := LoadLibraryEx(ModuleName, 0, LOAD_LIBRARY_AS_DATAFILE);

{$ENDIF}

{$IFDEF LINUX}

    ResModule := HMODULE(dlopen(ModuleName, RTLD_LAZY));

{$ENDIF}

    if ResModule = 0 then

    begin

{$IFDEF LINUX}

      DLErrorMsg := dlerror;

{$ENDIF}

      raise EPackageError.CreateResFmt(sErrorLoadingPackage,

        [ModuleName,

         {$IFDEF MSWINDOWS}SysErrorMessage(GetLastError){$ENDIF}

         {$IFDEF LINUX}DLErrorMsg{$ENDIF}]);

    end;

  end;

  try

    ResInfo := FindResource(ResModule, 'DESCRIPTION', RT_RCDATA);

    if ResInfo <> 0 then

    begin

      ResData := LoadResource(ResModule, ResInfo);

      if ResData <> 0 then

      try

        Result := PWideChar(LockResource(ResData));

        UnlockResource(ResData);

      finally

        FreeResource(ResData);

      end;

    end;

  finally

{$IFDEF MSWINDOWS}

    FreeLibrary(ResModule);

{$ENDIF}

{$IFDEF LINUX}

    dlclose(Pointer(ResModule));

{$ENDIF}

  end;

end;



procedure RaiseLastOSError;

begin

  RaiseLastOSError(GetLastError);

end;



procedure RaiseLastOSError(LastError: Integer);

var

  Error: EOSError;

begin

  if LastError <> 0 then

    Error := EOSError.CreateResFmt(SOSError, [LastError,

      SysErrorMessage(LastError)])

  else

    Error := EOSError.CreateRes(SUnkOSError);

  Error.ErrorCode := LastError;

  raise Error;

end;



{$IFDEF MSWINDOWS}

{ RaiseLastWin32Error }



procedure RaiseLastWin32Error;

begin

  RaiseLastOSError;

end;



{ Win32Check }



function Win32Check(RetVal: BOOL): BOOL;

begin

  if not RetVal then RaiseLastOSError;

  Result := RetVal;

end;

{$ENDIF}



type

  PTerminateProcInfo = ^TTerminateProcInfo;

  TTerminateProcInfo = record

    Next: PTerminateProcInfo;

    Proc: TTerminateProc;

  end;



var

  TerminateProcList: PTerminateProcInfo = nil;



procedure AddTerminateProc(TermProc: TTerminateProc);

var

  P: PTerminateProcInfo;

begin

  New(P);

  P^.Next := TerminateProcList;

  P^.Proc := TermProc;

  TerminateProcList := P;

end;



function CallTerminateProcs: Boolean;

var

  PI: PTerminateProcInfo;

begin

  Result := True;

  PI := TerminateProcList;

  while Result and (PI <> nil) do

  begin

    Result := PI^.Proc;

    PI := PI^.Next;

  end;

end;



procedure FreeTerminateProcs;

var

  PI: PTerminateProcInfo;

begin

  while TerminateProcList <> nil do

  begin

    PI := TerminateProcList;

    TerminateProcList := PI^.Next;

    Dispose(PI);

  end;

end;



{ --- }

function AL1(const P): LongWord;

asm

        MOV     EDX,DWORD PTR [P]

        XOR     EDX,DWORD PTR [P+4]

        XOR     EDX,DWORD PTR [P+8]

        XOR     EDX,DWORD PTR [P+12]

        MOV     EAX,EDX

end;



function AL2(const P): LongWord;

asm

        MOV     EDX,DWORD PTR [P]

        ROR     EDX,5

        XOR     EDX,DWORD PTR [P+4]

        ROR     EDX,5

        XOR     EDX,DWORD PTR [P+8]

        ROR     EDX,5

        XOR     EDX,DWORD PTR [P+12]

        MOV     EAX,EDX

end;



const

  AL1s: array[0..3] of LongWord = ($FFFFFFF0, $FFFFEBF0, 0, $FFFFFFFF);

  AL2s: array[0..3] of LongWord = ($42C3ECEF, $20F7AEB6, $D1C2F74E, $3F6574DE);



procedure ALV;

begin

  raise Exception.CreateRes(SNL);

end;



function ALR: Pointer;

var

  LibModule: PLibModule;

begin

  if MainInstance <> 0 then

    Result := Pointer(LoadResource(MainInstance, FindResource(MainInstance, 'DVCLAL',

      RT_RCDATA)))

  else

  begin

    Result := nil;

    LibModule := LibModuleList;

    while LibModule <> nil do

    begin

      with LibModule^ do

      begin

        Result := Pointer(LoadResource(Instance, FindResource(Instance, 'DVCLAL',

          RT_RCDATA)));

        if Result <> nil then Break;

      end;

      LibModule := LibModule.Next;

    end;

  end;

end;



function GDAL: LongWord;

type

  TDVCLAL = array[0..3] of LongWord;

  PDVCLAL = ^TDVCLAL;

var

  P: Pointer;

  A1, A2: LongWord;

  PAL1s, PAL2s: PDVCLAL;

  ALOK: Boolean;

begin

  P := ALR;

  if P <> nil then

  begin

    A1 := AL1(P^);

    A2 := AL2(P^);

    Result := A1;

    PAL1s := @AL1s;

    PAL2s := @AL2s;

    ALOK := ((A1 = PAL1s[0]) and (A2 = PAL2s[0])) or

            ((A1 = PAL1s[1]) and (A2 = PAL2s[1])) or

            ((A1 = PAL1s[2]) and (A2 = PAL2s[2]));

    FreeResource(Integer(P));

    if not ALOK then ALV;

  end else Result := AL1s[3];

end;



procedure RCS;

var

  P: Pointer;

  ALOK: Boolean;

begin

  P := ALR;

  if P <> nil then

  begin

    ALOK := (AL1(P^) = AL1s[2]) and (AL2(P^) = AL2s[2]);

    FreeResource(Integer(P));

  end else ALOK := False;

  if not ALOK then ALV;

end;



procedure RPR;

var

  AL: LongWord;

begin

  AL := GDAL;

  if (AL <> AL1s[1]) and (AL <> AL1s[2]) then ALV;

end;



{$IFDEF MSWINDOWS}

procedure InitDriveSpacePtr;

var

  Kernel: THandle;

begin

  Kernel := GetModuleHandle(Windows.Kernel32);

  if Kernel <> 0 then

    @GetDiskFreeSpaceEx := GetProcAddress(Kernel, 'GetDiskFreeSpaceExA');

  if not Assigned(GetDiskFreeSpaceEx) then

    GetDiskFreeSpaceEx := @BackfillGetDiskFreeSpaceEx;

end;

{$ENDIF}



// Win95 does not return the actual value of the result.

// These implementations are consistent on all platforms.

function InterlockedIncrement(var I: Integer): Integer;

asm

        MOV     EDX,1

        XCHG    EAX,EDX

  LOCK  XADD    [EDX],EAX

        INC     EAX

end;



function InterlockedDecrement(var I: Integer): Integer;

asm

        MOV     EDX,-1

        XCHG    EAX,EDX

  LOCK  XADD    [EDX],EAX

        DEC     EAX

end;



function InterlockedExchange(var A: Integer; B: Integer): Integer;

asm

        XCHG    [EAX],EDX

        MOV     EAX,EDX

end;



// The InterlockedExchangeAdd Win32 API is not available on Win95.

function InterlockedExchangeAdd(var A: Integer; B: Integer): Integer;

asm

        XCHG    EAX,EDX

  LOCK  XADD    [EDX],EAX

end;





{ TSimpleRWSync }



constructor TSimpleRWSync.Create;

begin

  inherited Create;

  InitializeCriticalSection(FLock);

end;



destructor TSimpleRWSync.Destroy;

begin

  inherited Destroy;

  DeleteCriticalSection(FLock);

end;



function TSimpleRWSync.BeginWrite: Boolean;

begin

  EnterCriticalSection(FLock);

  Result := True;

end;



procedure TSimpleRWSync.EndWrite;

begin

  LeaveCriticalSection(FLock);

end;



procedure TSimpleRWSync.BeginRead;

begin

  EnterCriticalSection(FLock);

end;



procedure TSimpleRWSync.EndRead;

begin

  LeaveCriticalSection(FLock);

end;



{ TThreadLocalCounter }



const

  Alive = High(Integer);



destructor TThreadLocalCounter.Destroy;

var

  P, Q: PThreadInfo;

  I: Integer;

begin

  for I := 0 to High(FHashTable) do

  begin

    P := FHashTable[I];

    FHashTable[I] := nil;

    while P <> nil do

    begin

      Q := P;

      P := P^.Next;

      FreeMem(Q);

    end;

  end;

  inherited Destroy;

end;



function TThreadLocalCounter.HashIndex: Byte;

var

  H: Word;

begin

  H := Word(GetCurrentThreadID);

  Result := (WordRec(H).Lo xor WordRec(H).Hi) and 15;

end;



procedure TThreadLocalCounter.Open(var Thread: PThreadInfo);

var

  P: PThreadInfo;

  CurThread: Cardinal;

  H: Byte;

begin

  H := HashIndex;

  CurThread := GetCurrentThreadID;



  P := FHashTable[H];

  while (P <> nil) and (P.ThreadID <> CurThread) do

    P := P.Next;



  if P = nil then

  begin

    P := Recycle;



    if P = nil then

    begin

      P := PThreadInfo(AllocMem(sizeof(TThreadInfo)));

      P.ThreadID := CurThread;

      P.Active := Alive;



      // Another thread could start traversing the list between when we set the

      // head to P and when we assign to P.Next.  Initializing P.Next to point

      // to itself will make others spin until we assign the tail to P.Next.

      P.Next := P;

      P.Next := PThreadInfo(InterlockedExchange(Integer(FHashTable[H]), Integer(P)));

    end;

  end;

  Thread := P;

end;



procedure TThreadLocalCounter.Close(var Thread: PThreadInfo);

begin

  Thread := nil;

end;



procedure TThreadLocalCounter.Delete(var Thread: PThreadInfo);

begin

  Thread.ThreadID := 0;

  Thread.Active := 0;

end;



function TThreadLocalCounter.Recycle: PThreadInfo;

var

  Gen: Integer;

begin

  Result := FHashTable[HashIndex];

  while (Result <> nil) do

  begin

    Gen := InterlockedExchange(Result.Active, Alive);

    if Gen <> Alive then

    begin

      Result.ThreadID := GetCurrentThreadID;

      Exit;

    end

    else

      Result := Result.Next;

  end;

end;





{$IFDEF MSWINDOWS}

{ TMultiReadExclusiveWriteSynchronizer }

const

  mrWriteRequest = $FFFF; // 65535 concurrent read requests (threads)

                          // 32768 concurrent write requests (threads)

                          // only one write lock at a time

                          // 2^32 lock recursions per thread (read and write combined)



constructor TMultiReadExclusiveWriteSynchronizer.Create;

begin

  inherited Create;

  FSentinel := mrWriteRequest;

  FReadSignal := CreateEvent(nil, True, True, nil);  // manual reset, start signaled

  FWriteSignal := CreateEvent(nil, False, False, nil); // auto reset, start blocked

  FWaitRecycle := INFINITE;

  tls := TThreadLocalCounter.Create;

end;



destructor TMultiReadExclusiveWriteSynchronizer.Destroy;

begin

  BeginWrite;

  inherited Destroy;

  CloseHandle(FReadSignal);

  CloseHandle(FWriteSignal);

  tls.Free;

end;



procedure TMultiReadExclusiveWriteSynchronizer.BlockReaders;

begin

  ResetEvent(FReadSignal);

end;



procedure TMultiReadExclusiveWriteSynchronizer.UnblockReaders;

begin

  SetEvent(FReadSignal);

end;



procedure TMultiReadExclusiveWriteSynchronizer.UnblockOneWriter;

begin

  SetEvent(FWriteSignal);

end;



procedure TMultiReadExclusiveWriteSynchronizer.WaitForReadSignal;

begin

  WaitForSingleObject(FReadSignal, FWaitRecycle);

end;



procedure TMultiReadExclusiveWriteSynchronizer.WaitForWriteSignal;

begin

  WaitForSingleObject(FWriteSignal, FWaitRecycle);

end;



{$IFDEF DEBUG_MREWS}

var

  x: Integer;



procedure TMultiReadExclusiveWriteSynchronizer.Debug(const Msg: string);

begin

  OutputDebugString(PChar(Format('%d %s Thread=%x Sentinel=%d, FWriterID=%x',

    [InterlockedIncrement(x), Msg, GetCurrentThreadID, FSentinel, FWriterID])));

end;

{$ENDIF}



function TMultiReadExclusiveWriteSynchronizer.BeginWrite: Boolean;

var

  Thread: PThreadInfo;

  HasReadLock: Boolean;

  ThreadID: Cardinal;

  Test: Integer;

  OldRevisionLevel: Cardinal;

begin

  {

    States of FSentinel (roughly - during inc/dec's, the states may not be exactly what is said here):

    mrWriteRequest:         A reader or a writer can get the lock

    1 - (mrWriteRequest-1): A reader (possibly more than one) has the lock

    0:                      A writer (possibly) just got the lock, if returned from the main write While loop

    < 0, but not a multiple of mrWriteRequest: Writer(s) want the lock, but reader(s) have it.

          New readers should be blocked, but current readers should be able to call BeginRead

    < 0, but a multiple of mrWriteRequest: Writer(s) waiting for a writer to finish

  }





{$IFDEF DEBUG_MREWS}

  Debug('Write enter------------------------------------');

{$ENDIF}

  Result := True;

  ThreadID := GetCurrentThreadID;

  if FWriterID <> ThreadID then  // somebody or nobody has a write lock

  begin

    // Prevent new readers from entering while we wait for the existing readers

    // to exit.

    BlockReaders;



    OldRevisionLevel := FRevisionLevel;



    tls.Open(Thread);

    // We have another lock already. It must be a read lock, because if it

    // were a write lock, FWriterID would be our threadid.

    HasReadLock := Thread.RecursionCount > 0;



    if HasReadLock then    // acquiring a write lock requires releasing read locks

      InterlockedIncrement(FSentinel);



{$IFDEF DEBUG_MREWS}

    Debug('Write before loop');

{$ENDIF}

    // InterlockedExchangeAdd returns prev value

    while InterlockedExchangeAdd(FSentinel, -mrWriteRequest) <> mrWriteRequest do

    begin

{$IFDEF DEBUG_MREWS}

      Debug('Write loop');

      Sleep(1000); // sleep to force / debug race condition

      Debug('Write loop2a');

{$ENDIF}



      // Undo what we did, since we didn't get the lock

      Test := InterlockedExchangeAdd(FSentinel, mrWriteRequest);

      // If the old value (in Test) was 0, then we may be able to

      // get the lock (because it will now be mrWriteRequest). So,

      // we continue the loop to find out. Otherwise, we go to sleep,

      // waiting for a reader or writer to signal us.



      if Test <> 0 then

      begin

        {$IFDEF DEBUG_MREWS}

        Debug('Write starting to wait');

        {$ENDIF}

        WaitForWriteSignal;

      end

      {$IFDEF DEBUG_MREWS}

      else

        Debug('Write continue')

      {$ENDIF}

    end;



    // At the EndWrite, first Writers are awoken, and then Readers are awoken.

    // If a Writer got the lock, we don't want the readers to do busy

    // waiting. This Block resets the event in case the situation happened.

    BlockReaders;



    // Put our read lock marker back before we lose track of it

    if HasReadLock then

      InterlockedDecrement(FSentinel);



    FWriterID := ThreadID;



    Result := Integer(OldRevisionLevel) = (InterlockedIncrement(Integer(FRevisionLevel)) - 1);

  end;



  Inc(FWriteRecursionCount);

{$IFDEF DEBUG_MREWS}

  Debug('Write lock-----------------------------------');

{$ENDIF}

end;



procedure TMultiReadExclusiveWriteSynchronizer.EndWrite;

var

  Thread: PThreadInfo;

begin

{$IFDEF DEBUG_MREWS}

  Debug('Write end');

{$ENDIF}

  assert(FWriterID = GetCurrentThreadID);

  tls.Open(Thread);

  Dec(FWriteRecursionCount);

  if FWriteRecursionCount = 0 then

  begin

    FWriterID := 0;

    InterlockedExchangeAdd(FSentinel, mrWriteRequest);

    {$IFDEF DEBUG_MREWS}

    Debug('Write about to UnblockOneWriter');

    {$ENDIF}

    UnblockOneWriter;

    {$IFDEF DEBUG_MREWS}

    Debug('Write about to UnblockReaders');

    {$ENDIF}

    UnblockReaders;

  end;

  if Thread.RecursionCount = 0 then

    tls.Delete(Thread);

{$IFDEF DEBUG_MREWS}

  Debug('Write unlock');

{$ENDIF}

end;



procedure TMultiReadExclusiveWriteSynchronizer.BeginRead;

var

  Thread: PThreadInfo;

  WasRecursive: Boolean;

  SentValue: Integer;

begin

{$IFDEF DEBUG_MREWS}

  Debug('Read enter');

{$ENDIF}



  tls.Open(Thread);

  Inc(Thread.RecursionCount);

  WasRecursive := Thread.RecursionCount > 1;



  if FWriterID <> GetCurrentThreadID then

  begin

{$IFDEF DEBUG_MREWS}

    Debug('Trying to get the ReadLock (we did not have a write lock)');

{$ENDIF}

    // In order to prevent recursive Reads from causing deadlock,

    // we need to always WaitForReadSignal if not recursive.

    // This prevents unnecessarily decrementing the FSentinel, and

    // then immediately incrementing it again.

    if not WasRecursive then

    begin

      // Make sure we don't starve writers. A writer will

      // always set the read signal when it is done, and it is initially on.

      WaitForReadSignal;

      while (InterlockedDecrement(FSentinel) <= 0) do

      begin

  {$IFDEF DEBUG_MREWS}

        Debug('Read loop');

  {$ENDIF}

        // Because the InterlockedDecrement happened, it is possible that

        // other threads "think" we have the read lock,

        // even though we really don't. If we are the last reader to do this,

        // then SentValue will become mrWriteRequest

        SentValue := InterlockedIncrement(FSentinel);

        // So, if we did inc it to mrWriteRequest at this point,

        // we need to signal the writer.

        if SentValue = mrWriteRequest then

          UnblockOneWriter;



        // This sleep below prevents starvation of writers

        Sleep(0);



  {$IFDEF DEBUG_MREWS}

        Debug('Read loop2 - waiting to be signaled');

  {$ENDIF}

        WaitForReadSignal;

  {$IFDEF DEBUG_MREWS}

        Debug('Read signaled');

  {$ENDIF}

      end;

    end;

  end;

{$IFDEF DEBUG_MREWS}

  Debug('Read lock');

{$ENDIF}

end;



procedure TMultiReadExclusiveWriteSynchronizer.EndRead;

var

  Thread: PThreadInfo;

  Test: Integer;

begin

{$IFDEF DEBUG_MREWS}

  Debug('Read end');

{$ENDIF}

  tls.Open(Thread);

  Dec(Thread.RecursionCount);

  if (Thread.RecursionCount = 0) then

  begin

     tls.Delete(Thread);



    // original code below commented out

    if (FWriterID <> GetCurrentThreadID) then

    begin

      Test := InterlockedIncrement(FSentinel);

      // It is possible for Test to be mrWriteRequest

      // or, it can be = 0, if the write loops:

      // Test := InterlockedExchangeAdd(FSentinel, mrWriteRequest) + mrWriteRequest;

      // Did not get executed before this has called (the sleep debug makes it happen faster)

      {$IFDEF DEBUG_MREWS}

      Debug(Format('Read UnblockOneWriter may be called. Test=%d', [Test]));

      {$ENDIF}

      if Test = mrWriteRequest then

        UnblockOneWriter

      else if Test <= 0 then // We may have some writers waiting

      begin

        if (Test mod mrWriteRequest) = 0 then

          UnblockOneWriter; // No more readers left (only writers) so signal one of them

      end;

    end;

  end;

{$IFDEF DEBUG_MREWS}

  Debug('Read unlock');

{$ENDIF}

end;

{$ENDIF} //MSWINDOWS for TMultiReadExclusiveWriteSynchronizer



procedure FreeAndNil(var Obj);

var

  Temp: TObject;

begin

  Temp := TObject(Obj);

  Pointer(Obj) := nil;

  Temp.Free;

end;



{ Interface support routines }



function Supports(const Instance: IInterface; const IID: TGUID; out Intf): Boolean;

begin

  Result := (Instance <> nil) and (Instance.QueryInterface(IID, Intf) = 0);

end;



function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean;

var

  LUnknown: IUnknown;

begin

  Result := (Instance <> nil) and

            ((Instance.GetInterface(IUnknown, LUnknown) and Supports(LUnknown, IID, Intf)) or

             Instance.GetInterface(IID, Intf));

end;



function Supports(const Instance: IInterface; const IID: TGUID): Boolean;

var

  Temp: IInterface;

begin

  Result := Supports(Instance, IID, Temp);

end;



function Supports(const Instance: TObject; const IID: TGUID): Boolean;

var

  Temp: IInterface;

begin

  Result := Supports(Instance, IID, Temp);

end;



function Supports(const AClass: TClass; const IID: TGUID): Boolean;

begin

  Result := AClass.GetInterfaceEntry(IID) <> nil;

end;



{$IFDEF MSWINDOWS}

{ TLanguages }



var

  FTempLanguages: TLanguages;



function EnumLocalesCallback(LocaleID: PChar): Integer; stdcall;

begin

  Result := FTempLanguages.LocalesCallback(LocaleID);

end;



{ Query the OS for information for a specified locale. Unicode version. Works correctly on Asian WinNT. }

function GetLocaleDataW(ID: LCID; Flag: DWORD): string;

var

  Buffer: array[0..1023] of WideChar;

begin

  Buffer[0] := #0;

  GetLocaleInfoW(ID, Flag, Buffer, SizeOf(Buffer) div 2);

  Result := Buffer;

end;



{ Query the OS for information for a specified locale. ANSI Version. Works correctly on Asian Win95. }

function GetLocaleDataA(ID: LCID; Flag: DWORD): string;

var

  Buffer: array[0..1023] of Char;

begin

  Buffer[0] := #0;

  SetString(Result, Buffer, GetLocaleInfoA(ID, Flag, Buffer, SizeOf(Buffer)) - 1);

end;



{ Called for each supported locale. }

function TLanguages.LocalesCallback(LocaleID: PChar): Integer; stdcall;

var

  AID: LCID;

  ShortLangName: string;

  GetLocaleDataProc: function (ID: LCID; Flag: DWORD): string;

begin

  if Win32Platform = VER_PLATFORM_WIN32_NT then

    GetLocaleDataProc := @GetLocaleDataW

  else

    GetLocaleDataProc := @GetLocaleDataA;

  AID := StrToInt('$' + Copy(LocaleID, 5, 4));

  ShortLangName := GetLocaleDataProc(AID, LOCALE_SABBREVLANGNAME);

  if ShortLangName <> '' then

  begin

    SetLength(FSysLangs, Length(FSysLangs) + 1);

    with FSysLangs[High(FSysLangs)] do

    begin

      FName := GetLocaleDataProc(AID, LOCALE_SLANGUAGE);

      FLCID := AID;

      FExt := ShortLangName;

    end;

  end;

  Result := 1;

end;



constructor TLanguages.Create;

begin

  inherited Create;

  FTempLanguages := Self;

  EnumSystemLocales(@EnumLocalesCallback, LCID_SUPPORTED);

end;



function TLanguages.GetCount: Integer;

begin

  Result := High(FSysLangs) + 1;

end;



function TLanguages.GetExt(Index: Integer): string;

begin

  Result := FSysLangs[Index].FExt;

end;



function TLanguages.GetID(Index: Integer): string;

begin

  Result := HexDisplayPrefix + IntToHex(FSysLangs[Index].FLCID, 8);

end;



function TLanguages.GetLCID(Index: Integer): LCID;

begin

  Result := FSysLangs[Index].FLCID;

end;



function TLanguages.GetName(Index: Integer): string;

begin

  Result := FSysLangs[Index].FName;

end;



function TLanguages.GetNameFromLocaleID(ID: LCID): string;

var

  Index: Integer;

begin

  Result := sUnknown;

  Index := IndexOf(ID);

  if Index <> - 1 then Result := Name[Index];

  if Result = '' then Result := sUnknown;

end;



function TLanguages.GetNameFromLCID(const ID: string): string;

begin

  Result := NameFromLocaleID[StrToIntDef(ID, 0)];

end;



function TLanguages.IndexOf(ID: LCID): Integer;

begin

  for Result := Low(FSysLangs) to High(FSysLangs) do

    if FSysLangs[Result].FLCID = ID then Exit;

  Result := -1;

end;



var

  FLanguages: TLanguages;



function Languages: TLanguages;

begin

  if FLanguages = nil then

    FLanguages := TLanguages.Create;

  Result := FLanguages;

end;



function SafeLoadLibrary(const Filename: string; ErrorMode: UINT): HMODULE;

var

  OldMode: UINT;

  FPUControlWord: Word;

begin

  OldMode := SetErrorMode(ErrorMode);

  try

    asm

      FNSTCW  FPUControlWord

    end;

    try

      Result := LoadLibrary(PChar(Filename));

    finally

      asm

        FNCLEX

        FLDCW FPUControlWord

      end;

    end;

  finally

    SetErrorMode(OldMode);

  end;

end;

{$ENDIF}

{$IFDEF LINUX}

function SafeLoadLibrary(const FileName: string; Dummy: LongWord): HMODULE;

var

  FPUControlWord: Word;

begin

  asm

    FNSTCW  FPUControlWord

  end;

  try

    Result := LoadLibrary(PChar(Filename));

  finally

    asm

      FNCLEX

      FLDCW FPUControlWord

    end;

  end;

end;

{$ENDIF}



{$IFDEF MSWINDOWS}

function GetEnvironmentVariable(const Name: string): string;

const

  BufSize = 1024;

var

  Len: Integer;

  Buffer: array[0..BufSize - 1] of Char;

begin

  Result := '';

  Len := Windows.GetEnvironmentVariable(PChar(Name), @Buffer, BufSize);

  if Len < BufSize then

    SetString(Result, PChar(@Buffer), Len)

  else

  begin

    SetLength(Result, Len - 1);

    Windows.GetEnvironmentVariable(PChar(Name), PChar(Result), Len);

  end;

end;

{$ENDIF}

{$IFDEF LINUX}

function GetEnvironmentVariable(const Name: string): string;

begin

  Result := getenv(PChar(Name));

end;

{$ENDIF}



{$IFDEF LINUX}

procedure CheckLocale;

var

  P,Q: PChar;

begin

  P := gnu_get_libc_version();

  Q := getenv('LC_ALL');

  if (Q = nil) or (Q[0] = #0) then

    Q := getenv('LANG');



  //  2.1.3 <= current version < 2.1.91

  if (strverscmp('2.1.3', P) <= 0) and

     (strverscmp(P, '2.1.91') < 0) and

     ((Q = nil) or (Q[0] = #0)) then

  begin

    // GNU libc 2.1.3 will segfault in towupper() if environment variables don't

    // specify a locale.  This can happen when Apache launches CGI subprocesses.

    // Solution: set a locale if the environment variable is missing.

    // Works in 2.1.2, fixed in glibc 2.1.91 and later

    setlocale(LC_ALL, 'POSIX');

  end

  else

    // Configure the process locale settings according to

    // the system environment variables (LC_CTYPE, LC_COLLATE, etc)

    setlocale(LC_ALL, '');



  // Note:

  // POSIX/C is the default locale on many Unix systems, but its 7-bit charset

  // causes char to widechar conversions to fail on any high-ascii

  // character.  To support high-ascii charset conversions, set the

  // LC_CTYPE environment variable to something else or call setlocale to set

  // the LC_CTYPE information for this process.  It doesn't matter what

  // you set it to, as long as it's not POSIX.

  if StrComp(nl_langinfo(_NL_CTYPE_CODESET_NAME), 'ANSI_X3.4-1968') = 0 then

    setlocale(LC_CTYPE, 'en_US');  // selects codepage ISO-8859-1

end;



procedure PropagateSignals;

var

  Exc: TObject;

begin

  {

    If there is a current exception pending, then we're shutting down because

    it went unhandled.  If that exception is the result of a signal, then we

    need to propagate that back out to the world as a real signal death.  See

    the discussion at http://www2.cons.org/cracauer/sigint.html for more info.

  }

  Exc := ExceptObject;

  if (Exc <> nil) and (Exc is EExternal) then

     kill(getpid, EExternal(Exc).SignalNumber);

end;



{

    Under Win32, SafeCallError is implemented in ComObj.  Under Linux, we

    don't have ComObj, so we've substituted a similar mechanism here.

}

procedure SafeCallError(ErrorCode: Integer; ErrorAddr: Pointer);

var

  ExcMsg: String;

begin

  ExcMsg := GetSafeCallExceptionMsg;

  SetSafeCallExceptionMsg('');

  if ExcMsg <> '' then

  begin

    raise ESafeCallException.Create(ExcMsg) at GetSafeCallExceptionAddr;

  end

  else

    raise ESafeCallException.CreateRes(@SSafecallException);

end;

{$ENDIF}



initialization

  if ModuleIsCpp then HexDisplayPrefix := '0x';

  InitExceptions;



{$IFDEF LINUX}

  SafeCallErrorProc := @SafeCallError;

  ExitProcessProc := PropagateSignals;



  CheckLocale;

{$ENDIF}



{$IFDEF MSWINDOWS}

  InitPlatformId;

  InitDriveSpacePtr;

{$ENDIF}

  GetFormatSettings; { Win implementation uses platform id }



finalization

{$IFDEF MSWINDOWS}

  FreeAndNil(FLanguages);

{$ENDIF}

{$IFDEF LINUX}

  if libuuidHandle <> nil then

    dlclose(libuuidHandle);

{$ENDIF}

  FreeTerminateProcs;

  DoneExceptions;



end.