jclwideformat.pas

East make Tray Icon in delphi

                    CharCount := PByte(P)^;
                    Inc(PAnsiChar(P));
                  end;
                {$ENDIF FORMAT_EXTENSIONS}
                vtAnsiString, vtWideString:
                  begin
                    P := Arg^.VAnsiString;
                    if Wide then
                      CharCount := Length(WideString(P))
                    else
                      CharCount := Length(AnsiString(P));
                  end;
              else
                raise FormatBadArgumentTypeErrorEx(Format, FormatStart, Src, Arg.VType, ArgIndex, AllowedStringTypes);
              end;
              // We want the length in WideChars, not AnsiChars; they aren't
              // necessarily the same.
              if (not Wide) and (CharCount > 0) then
              begin
                AnsiCount := CharCount;
                CharCount := MultiByteToWideChar(DefaultCodePage, 0, P, AnsiCount, nil, 0);
              end;
              // For strings, Prec can only truncate, never lengthen.
              if Prec < CharCount then
                CharCount := Prec;
            end; // stString case
          end; // case State

          Inc(ArgIndex);
          if Integer(Width) < 0 then
            Width := 0;

          // This code prepares for the buffer-copying code.
          MinWidth := CharCount;
          if Width > MinWidth then
            SpacesNeeded := Width - MinWidth
          else
            SpacesNeeded := 0;
          EnsureResultLen(Dest - 1 + MinWidth + SpacesNeeded, ResultLen);

          // This code fills the resultant buffer.
          if (SpacesNeeded > 0) and not LeftAlign then
            Inc(Dest, FillWideChar(Result[Dest], SpacesNeeded, WideSpace));
          if Wide then
            MoveWideChar(P^, Result[Dest], CharCount)
          else
            MultiByteToWideChar(DefaultCodePage, 0, P, AnsiCount, @Result[Dest], CharCount);
          Inc(Dest, CharCount);
          CharCount := 0;
          if (SpacesNeeded > 0) and LeftAlign then
            Inc(Dest, FillWideChar(Result[Dest], SpacesNeeded, WideSpace));
        end; // case stFloat, stInt, stPointer, stString
    end; // case
  end; // for
  if CharCount > 0 then
  begin
    // Copy accumulated characters into result
    SetLength(Result, Dest + CharCount - 1);
    MoveWideChar(P^, Result[Dest], CharCount);
  end
  else
    if ResultLen >= Dest then
      SetLength(Result, Dest - 1);
end;

function FillWideChar(var X; Count: Cardinal; const Value: WideChar): Cardinal;
var
  PW: PWideChar;
begin
  Result := Count;
  PW := @X;
  for Count := Count downto 1 do
  begin
    PW^ := Value;
    Inc(PW);
  end;
end;

{ GetPClassName is similar to calling Cls.ClassName, but avoids the necessary
  memory copy inherent in the function call. It also avoids a conversion from
  ShortString to AnsiString, which would happen when the function's result got
  type cast to PChar. Since all we really need is a pointer to the first byte
  of the string, the bytes in the VMT are just as good as the bytes in a normal
  AnsiString. }
function GetPClassName(const Cls: TClass): Pointer;
asm
        MOV     EAX, [EAX].vmtClassName
  // Result := JclSysUtils.GetVirtualMethod(Cls, vmtClassName div SizeOf(Pointer));
end;

function ModDiv32(const Dividend, Divisor: Cardinal; out Quotient: Cardinal): Cardinal;
// Returns the quotient and modulus of the two inputs
// Quotient := Dividend div Divisor;
// Result := Dividend mod Divisor;
asm
        PUSH    ECX
        MOV     ECX, EDX
        XOR     EDX, EDX
        DIV     ECX
        POP     ECX
        MOV     [ECX], EAX
        MOV     EAX, EDX
end;

function ConvertInt32(Value: Cardinal; const Base: Cardinal; var Buffer: PWideChar): Cardinal;
// Buffer: Pointer to the END of the buffer to be filled. Upon return, Buffer
//  will point to the first character in the string. The buffer will NOT be
//  null-terminated.
// Result: Number of characters filled in buffer
begin
  Result := 0;
  repeat
    Inc(Result);
    Dec(Buffer);
    Buffer^ := ConvertChars[ModDiv32(Value, Base, Value)];
  until Value = 0;
end;

function ModDiv64(var Dividend: Int64; const Divisor: Cardinal; out Quotient: Int64): Int64;
{ Returns the quotient and modulus of the two inputs using unsigned division
  Unsigned 64-bit division is not available in Delphi 5, but the System unit
  does provide division and modulus functions.
  Quotient := Dividend div Divisor;
  Result := Dividend mod Divisor; }
asm
        PUSH    0 // prepare for second division
        PUSH    EDX

        PUSH    DWORD PTR [EAX] // save dividend
        PUSH    DWORD PTR [EAX+4]

        PUSH    ECX // save quotient

        PUSH    0 // prepare for first division
        PUSH    EDX
        MOV     EDX, [EAX+4]
        MOV     EAX, [EAX]
        CALL    System.@_lludiv
        POP     ECX // restore quotient
        MOV     [ECX], EAX // store quotient
        MOV     [ECX+4], EDX

        POP     EDX // restore dividend
        POP     EAX
        CALL    System.@_llumod
end;

function ConvertInt64(Value: Int64; const Base: Cardinal; var Buffer: PWideChar): Cardinal;
{ Result: Number of characters filled in buffer
  Buffer: Pointer to first valid character in buffer
  Written in assembler to use unsigned division instead of signed. Otherwise,
  the code would be exactly the same as for ConvertInt32. }
begin
  Result := 0;
  repeat
    Inc(Result);
    Dec(Buffer);
    Buffer^ := ConvertChars[ModDiv64(Value, Base, Value)];
  until Value = 0;
end;

{ The compiler's overflow checking must be disabled for the following two
  procedures. These compiler directives temporarily disable overflow checking
  for just these two routines. For the rest of the code in this unit, overflow
  isn't relevant. }

{$Q-}

// These functions negate integers without the danger of overflow errors.
procedure SafeNegate32(var Int: Integer);
begin
  Int := -Int;
end;

procedure SafeNegate64(var Int: Int64);
begin
  Int := -Int;
end;

{$IFDEF OVERFLOWCHECKS_ON}
{$Q+}
{$ENDIF OVERFLOWCHECKS_ON}

function FormatNoArgumentError(const ArgIndex: Cardinal): Exception;
begin
  Result := EConvertError.CreateResFmt(PResStringRec(@RsFormatNoArgument), [ArgIndex]);
end;

function FormatNoArgumentErrorEx(const Format: WideString; const FormatStart, FormatEnd, ArgIndex: Cardinal): Exception;
begin
  Result := EConvertError.CreateResFmt(PResStringRec(@RsFormatNoArgumentEx), [ArgIndex, Copy(Format, FormatStart, FormatStart - FormatEnd + 1)]);
end;

function FormatSyntaxError(const CharIndex: Cardinal): Exception;
begin
  Result := EConvertError.CreateResFmt(PResStringRec(@RsFormatSyntaxError), [CharIndex]);
end;

const
  VarRecTypes: array [vtInteger..vtInt64] of PChar = (
    'Integer', 'Boolean', 'Char', 'Extended', 'ShortString', 'Pointer', 'PChar',
    'TObject', 'TClass', 'WideChar', 'PWideChar', 'AnsiString', 'Currency',
    'Variant', 'IUnknown', 'WideString', 'Int64'
  );

function GetTypeList(const Types: TDelphiSet): string;
var
  T: Byte;
  List: TStrings;
begin
  List := TStringList.Create;
  try
    for T := Low(VarRecTypes) to High(VarRecTypes) do
    begin
      if T in Types then
        List.Add(VarRecTypes[T]);
    end;
    Result := List.CommaText;
  finally
    List.Free;
  end;
end;

function FormatBadArgumentTypeError(const VType: Byte; const ArgIndex: Cardinal; const Allowed: TDelphiSet): Exception;
var
  FoundType, AllowedTypes: string;
begin
  FoundType := VarRecTypes[VType];
  AllowedTypes := GetTypeList(Allowed);
  Result := EConvertError.CreateResFmt(PResStringRec(@RsFormatBadArgumentType), [FoundType, ArgIndex, AllowedTypes]);
end;

function FormatBadArgumentTypeErrorEx(const Format: WideString; const FormatStart, FormatEnd: Cardinal; const VType: Byte; const ArgIndex: Cardinal; const Allowed: TDelphiSet): Exception;
var
  FoundType, AllowedTypes: string;
begin
  FoundType := VarRecTypes[VType];
  AllowedTypes := GetTypeList(Allowed);
  Result := EConvertError.CreateResFmt(PResStringRec(@RsFormatBadArgumentTypeEx), [FoundType, ArgIndex, Copy(Format, FormatStart, FormatEnd - FormatStart + 1), AllowedTypes]);
end;

// History:

// $Log: JclWideFormat.pas,v $
// Revision 1.8  2005/03/08 16:10:10  marquardt
// standard char sets extended and used, some optimizations for string literals
//
// Revision 1.7  2005/03/08 08:33:23  marquardt
// overhaul of exceptions and resourcestrings, minor style cleaning
//
// Revision 1.6  2005/03/01 00:55:50  ahuser
// Delphi 2005 compiler bug workaround
//
// Revision 1.5  2005/02/27 07:27:47  marquardt
// changed interface names from I to IJcl, moved resourcestrings to JclResource.pas
//
// Revision 1.4  2005/02/25 07:20:16  marquardt
// add section lines
//
// Revision 1.3  2005/02/24 07:36:25  marquardt
// resolved the compiler warnings, style cleanup, removed code from JclContainerIntf.pas
//
// Revision 1.2  2005/02/22 07:55:18  rrossmair
// - issue #2662 fixed (internal error C6662 when compiling with D2005)
//
// Revision 1.1  2005/02/14 00:45:50  rrossmair
// - initial check-in
//

end.