jclwideformat.pas

East make Tray Icon in delphi

{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is FormatW.pas.                                                                }
{                                                                                                  }
{ The Initial Developer of the Original Code is Rob Kennedy, rkennedy att cs dott wisc dott edu.   }
{ Portions created by Rob Kennedy are Copyright Rob Kennedy. All rights reserved.                  }
{                                                                                                  }
{ Contributors (in alphabetical order):                                                            }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Comments by Rob Kennedy:                                                                         }
{                                                                                                  }
{ This unit provides a Unicode version of the SysUtils.Format function for                         }
{ Delphi 5. Later Delphi versions already have such a function. To the best of                     }
{ my knowledge, this function is bug-free. (Famous last words?) If there are any                   }
{ questions regarding the workings of the format parser's state machine, please                    }
{ do not hesitate to contact me. I understand all the state transitions, but                       }
{ find it hard to document en masse.                                                               }
{                                                                                                  }
{**************************************************************************************************}

// Last modified: $Date: 2005/03/08 16:10:10 $
// For history see end of file

{ TODO : Replacing the calls to MultiBytetoWideChar is all what's needed to make this crossplatform }
{ TODO : Fix Internal Error DBG1384 in BCB 6 compilation }

unit JclWideFormat;

{$I jcl.inc}
{$I windowsonly.inc}

{$IFDEF COMPILER9}
{ Delphi 2005 compiler fails with "Fatal: F2084 Internal error: C6662" if
  optimization is off. }
{$O+}
{$ENDIF COMPILER9}

interface

{ With FORMAT_EXTENSIONS defined, WideFormat will accept more argument types
  than Borland's Format function. In particular, it will accept Variant
  arguments for the D, E, F, G, M, N, U, and X format types, it will accept
  Boolean and TClass arguments for the S format type, and it will accept PChar,
  PWideChar, interface, and object arguments for the P format type.
  In addition, WideFormat can use Int64 and Variant arguments for index, width,
  and precision specifiers used by the asterisk character. }
{$DEFINE FORMAT_EXTENSIONS}

{ If the format type is D, U, or X, and if the format string contains a
  precision specifier greater than 16, then the precision specifier is ignored.
  This is consistent with observed Format behavior, although it is not so
  documented. Likewise, if the format type is E, F, G, M, or N and the precision
  specifier is greater than 18, then it too will be ignored.

  There is one known difference between the behaviors of Format and WideFormat.
  WideFormat interprets a width specifier as a signed 32-bit integer. If it is
  negative, then it will be treated as 0. Format interprets it as a very large
  unsigned integer, which can lead to an access violation or buffer overrun.

  WideFormat detects the same errors as Format, but it reports them differently.
  Because of differences in the parsers, WideFormat is unable to provide the
  entire format string in the error message every time. When the full string is
  not available, it will provide the offending character index instead. In the
  case of an invalid argument type, WideFormat will include the allowed types
  and the argument index in the error message. Despite the different error
  messages, the exception class is still EConvertError. }
function WideFormat(const Format: WideString; const Args: array of const): WideString;

implementation

uses
  Windows,              // for MultiBytetoWideChar
  {$IFDEF HAS_UNIT_VARIANTS}
  Variants,
  {$ENDIF ~HAS_UNIT_VARIANTS}
  SysUtils,             // for exceptions and FloatToText
  Classes,              // for TStrings, in error-reporting code
  JclBase,              // for PByte and PCardinal
  JclMath,              // for TDelphiSet
  JclResources,         // for resourcestrings
  JclStrings,           // for BooleanToStr, StrLen
  JclWideStrings;       // for StrLenW, MoveWideChar

type
  { WideFormat uses a finite-state machine to do its parsing. The states are
    represented by the TState type below. The progression from one state to the
    next is determined by the StateTable constant, which combines the previous
    state with the class of the current character (represented by the TCharClass
    type).

    Some anomolies: It's possible to go directly from stDot to one of the
    specifier states, which according to the documentation should be a syntax
    error, but SysUtils.Format accepts it and uses the default -1 for Prec.
    Therefore, there are special stPrecDigit and stPrecStar modes that differ
    from stDigit and stStar by checking for and overriding the default Prec
    value when necessary. }
  TState = (stError, stBeginAcc, stAcc, stPercent, stDigit, stPrecDigit, stStar, stPrecStar, stColon, stDash, stDot, stFloat, stInt, stPointer, stString);
  TCharClass = (ccOther, ccPercent, ccDigit, ccStar, ccColon, ccDash, ccDot, ccSpecF, ccSpecI, ccSpecP, ccSpecS);

const
  WidePercent = WideChar('%');
  WideLittleX = WideChar('x');
  WideSpace = WideChar(' '); // Also defined in JclUnicode

  { This array classifies characters within the range of characters considered
    special to the format syntax. Characters outside the range are all
    classified as ccOther. The value from this table combines with the current
    state to yield the next state, as determined by StateTable below. }
  CharClassTable: array [WidePercent..WideLittleX] of TCharClass = (
    {%}ccPercent, {&}ccOther, {'}ccOther, {(}ccOther, {)}ccOther, {*}ccStar,
    {+}ccOther,   {,}ccOther, {-}ccDash,  {.}ccDot,   {/}ccOther, {0}ccDigit,
    {1}ccDigit,   {2}ccDigit, {3}ccDigit, {4}ccDigit, {5}ccDigit, {6}ccDigit,
    {7}ccDigit,   {8}ccDigit, {9}ccDigit, {:}ccColon, {;}ccOther, {<}ccOther,
    {=}ccOther,   {>}ccOther, {?}ccOther, {@}ccOther, {A}ccOther, {B}ccOther,
    {C}ccOther,   {D}ccSpecI, {E}ccSpecF, {F}ccSpecF, {G}ccSpecF, {H}ccOther,
    {I}ccOther,   {J}ccOther, {K}ccOther, {L}ccOther, {M}ccSpecF, {N}ccSpecF,
    {O}ccOther,   {P}ccSpecP, {Q}ccOther, {R}ccOther, {S}ccSpecS, {T}ccOther,
    {U}ccSpecI,   {V}ccOther, {W}ccOther, {X}ccSpecI, {Y}ccOther, {Z}ccOther,
    {[}ccOther,   {\}ccOther, {]}ccOther, {^}ccOther, {_}ccOther, {`}ccOther,
    {a}ccOther,   {b}ccOther, {c}ccOther, {d}ccSpecI, {e}ccSpecF, {f}ccSpecF,
    {g}ccSpecF,   {h}ccOther, {i}ccOther, {j}ccOther, {k}ccOther, {l}ccOther,
    {m}ccSpecF,   {n}ccSpecF, {o}ccOther, {p}ccSpecP, {q}ccOther, {r}ccOther,
    {s}ccSpecS,   {t}ccOther, {u}ccSpecI, {v}ccOther, {w}ccOther, {x}ccSpecI
  );
  { Given the previous state and the class of the current character, this table
    determines what the next state should be. }
  StateTable: array [TState{old state}, TCharClass{new char}] of TState {new state}= (
    {             ccOther,    ccPercent,  ccDigit,     ccStar,     ccColon,    ccDash,     ccDot,      ccSpecF,    ccSpecI,    ccSpecP,    ccSpecS }
    {stError}    (stBeginAcc, stPercent,  stBeginAcc,  stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc),
    {stBeginAcc} (stAcc,      stPercent,  stAcc,       stAcc,      stAcc,      stAcc,      stAcc,      stAcc,      stAcc,      stAcc,      stAcc),
    {stAcc}      (stAcc,      stPercent,  stAcc,       stAcc,      stAcc,      stAcc,      stAcc,      stAcc,      stAcc,      stAcc,      stAcc),
    {stPercent}  (stError,    stBeginAcc, stDigit,     stStar,     stError,    stDash,     stDot,      stFloat,    stInt,      stPointer,  stString),
    {stDigit}    (stError,    stError,    stDigit,     stError,    stColon,    stError,    stDot,      stFloat,    stInt,      stPointer,  stString),
    {stPrecDigit}(stError,    stError,    stPrecDigit, stError,    stError,    stError,    stError,    stFloat,    stInt,      stPointer,  stString),
    {stStar}     (stError,    stError,    stError,     stError,    stColon,    stError,    stDot,      stFloat,    stInt,      stPointer,  stString),
    {stPrecStar} (stError,    stError,    stError,     stError,    stError,    stError,    stError,    stFloat,    stInt,      stPointer,  stString),
    {stColon}    (stError,    stError,    stDigit,     stStar,     stError,    stDash,     stDot,      stFloat,    stInt,      stPointer,  stString),
    {stDash}     (stError,    stError,    stDigit,     stStar,     stError,    stError,    stDot,      stFloat,    stInt,      stPointer,  stString),
    {stDot}      (stError,    stError,    stPrecDigit, stPrecStar, stError,    stError,    stError,    stFloat,    stInt,      stPointer,  stString),
    {stFloat}    (stBeginAcc, stPercent,  stBeginAcc,  stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc),
    {stInt}      (stBeginAcc, stPercent,  stBeginAcc,  stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc),
    {stPointer}  (stBeginAcc, stPercent,  stBeginAcc,  stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc),
    {stString}   (stBeginAcc, stPercent,  stBeginAcc,  stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc, stBeginAcc)
  );
  { This table is used in converting an ordinal value to a string in either
    decimal or hexadecimal format. }
  ConvertChars: array [0..15] of WideChar =
    ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F');

function FillWideChar(var X; Count: Cardinal; const Value: WideChar): Cardinal; forward;
function GetPClassName(const Cls: TClass): Pointer; forward;
function ConvertInt32(Value: Cardinal; const Base: Cardinal; var Buffer: PWideChar): Cardinal; forward;
function ConvertInt64(Value: Int64; const Base: Cardinal; var Buffer: PWideChar): Cardinal; forward;
procedure SafeNegate32(var Int: Integer); forward;
procedure SafeNegate64(var Int: Int64); forward;

{ Using separate functions for creating exceptions helps to streamline the
  WideFormat code. The stack is not cluttered with space for temporary strings
  and open arrays needed for calling the exceptions' constructors, and the
  function's prologue and epilogue don't execute code for initializing and
  finalizing those hidden stack variables. The extra stack space is thus only
  used in the case when WideFormat actually needs to raise an exception. }
function FormatNoArgumentError(const ArgIndex: Cardinal): Exception; forward;
function FormatNoArgumentErrorEx(const Format: WideString; const FormatStart, FormatEnd, ArgIndex: Cardinal): Exception; forward;
function FormatSyntaxError(const CharIndex: Cardinal): Exception; forward;
function FormatBadArgumentTypeError(const VType: Byte; const ArgIndex: Cardinal; const Allowed: TDelphiSet): Exception; forward;
function FormatBadArgumentTypeErrorEx(const Format: WideString; const FormatStart, FormatEnd: Cardinal; const VType: Byte; const ArgIndex: Cardinal; const Allowed: TDelphiSet): Exception; forward;

function WideFormat(const Format: WideString; const Args: array of const): WideString;
const
  NoPrecision = $ffffffff;
  // For converting strings
  DefaultCodePage = cp_ACP;
  // For converting integers
  MaxIntPrecision = 16;
  // For converting floats
  DefaultGeneralPrecision = 15;
  GeneralDigits = 3;
  DefaultFixedDigits = 2;
  FixedPrecision = 18;
  MaxFloatPrecision = 18;
  // Mostly used for error reporting
  AllowedFloatTypes: TDelphiSet = [vtExtended, vtCurrency {$IFDEF FORMAT_EXTENSIONS}, vtVariant {$ENDIF}];
  AllowedIntegerTypes: TDelphiSet = [vtInteger, vtInt64 {$IFDEF FORMAT_EXTENSIONS}, vtVariant {$ENDIF}];
  AllowedStarTypes: TDelphiSet = [vtInteger {$IFDEF FORMAT_EXTENSIONS}, vtInt64, vtVariant {$ENDIF}];
  AllowedPointerTypes: TDelphiSet = [vtPointer
    {$IFDEF FORMAT_EXTENSIONS}, vtInterface, vtObject, vtPChar, vtPWideChar {$ENDIF}];
  AllowedStringTypes: TDelphiSet = [vtChar, vtWideChar, vtString, vtPChar, vtPWideChar,
    vtVariant, vtAnsiString, vtWideString {$IFDEF FORMAT_EXTENSIONS}, vtBoolean, vtClass {$ENDIF}];
var
  // Basic parsing values
  State: TState; // Maintain the finite-state machine
  C: WideChar;               // Cache value of Format[Src]
  Src, Dest: Cardinal;       // Indices into Format and Result
  FormatLen: Cardinal;       // Alias for Length(Format)
  ResultLen: Cardinal;       // Alias for Length(Result)
  // Formatting variables
  ArgIndex: Cardinal; // Which argument to read from the Args array
  Arg: PVarRec; // Pointer to current argument
  LeftAlign: Boolean; // Whether the "-" character is present
  Width: Cardinal;
  Prec: Cardinal; // Precision specifier
  PrecWidth: PCardinal; // Reading Prec and Width are similar; this helps consolidate some code.

  FormatStart: Cardinal; // First character of a format string; for error reporting

  P: Pointer; // Pointer to character buffer. Either Wide or Ansi.
  Wide: Boolean; // Tells whether P is PWideChar or PAnsiChar
  CharCount: Cardinal; // How many characters are pointed to by P
  AnsiCount: Cardinal; //
  Buffer: array [0..63] of Byte; // Buffer for numerical conversions
  TempWS: WideString;
  MinWidth, SpacesNeeded: Cardinal;
  // Integer-conversion variables
  Base: Cardinal; // For decimal or hexadecimal
  Neg: Boolean;
  Temp32: Cardinal;
  Temp64: Int64;
  // Float-conversion variables
  ValueType: TFloatValue;
  FloatVal: Pointer;
  FloatFormat: TFloatFormat;
  {$IFDEF FORMAT_EXTENSIONS}
  TempExt: Extended;
  TempCurr: Currency;
  {$ENDIF FORMAT_EXTENSIONS}

  procedure EnsureResultLen(const NeededLen: Cardinal; var AResultLen: Cardinal);
  begin
    if NeededLen > AResultLen then
    begin
      repeat
        AResultLen := AResultLen * 2;
      until NeededLen <= AResultLen;
      SetLength(Result, AResultLen);
    end;
  end;

begin
  FormatLen := Length(Format);
  // Start with an estimated result length
  ResultLen := FormatLen * 4;
  SetLength(Result, ResultLen);
  if FormatLen = 0 then
    Exit;

  Dest := 1;
  State := stError;
  ArgIndex := 0;
  CharCount := 0;

  // Avoid compiler warnings
  LeftAlign := False;
  AnsiCount := 0;
  FormatStart := 0;

  for Src := 1 to FormatLen do
  begin
    C := Format[Src];