tntsysutils.pas

TNT Components Source

begin
  Result := _IntStrToDateTime(Str, 0, SInvalidDateTime);
end;

function TntStrToDate(Str: WideString): TDateTime;
begin
  Result := _IntStrToDateTime(Str, VAR_DATEVALUEONLY, SInvalidDate);
end;

function TntStrToTime(Str: WideString): TDateTime;
begin
  Result := _IntStrToDateTime(Str, VAR_TIMEVALUEONLY, SInvalidTime);
end;

//=============================================================================================
//==  CURRENCY STRING PARSING =================================================================
//=============================================================================================

function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString;
const
  MAX_BUFF_SIZE = 64; // can a currency string actually be larger?
var
  ValueStr: WideString;
begin
  // format lpValue using ENG-US settings
  ValueStr := ENG_US_FloatToStr(Value);
  // get currency format
  SetLength(Result, MAX_BUFF_SIZE);
  if 0 = Tnt_GetCurrencyFormatW(GetThreadLocale, 0, PWideChar(ValueStr),
    lpFormat, PWideChar(Result), Length(Result))
  then begin
    RaiseLastOSError;
  end;
  Result := PWideChar(Result);
end;

function TntStrToCurr(const S: WideString): Currency;
begin
  try
    OleCheck(VarCyFromStr(S, GetThreadLocale, 0, Result));
  except
    on E: Exception do begin
      E.Message := E.Message + CRLF + WideFormat(SInvalidCurrency, [S]);
      raise EConvertError.Create(E.Message);
    end;
  end;
end;

function ValidCurrencyStr(const S: WideString): Boolean;
var
  Dummy: Currency;
begin
  Result := Succeeded(VarCyFromStr(S, GetThreadLocale, 0, Dummy));
end;

function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency;
begin
  if not Succeeded(VarCyFromStr(S, GetThreadLocale, 0, Result)) then
    Result := Default;
end;

threadvar
  Currency_DecimalSep: WideString;
  Currency_ThousandSep: WideString;
  Currency_CurrencySymbol: WideString;

function GetDefaultCurrencyFmt: TCurrencyFmtW;
begin
  ZeroMemory(@Result, SizeOf(Result));
  Result.NumDigits := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRDIGITS, '2'), 2);
  Result.LeadingZero := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ILZERO, '1'), 1);
  Result.Grouping := StrToIntDef(Copy(WideGetLocaleStr(GetThreadLocale, LOCALE_SMONGROUPING, '3;0'), 1, 1), 3);
  Currency_DecimalSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONDECIMALSEP, '.');
  Result.lpDecimalSep := PWideChar(Currency_DecimalSep);
  Currency_ThousandSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONTHOUSANDSEP, ',');
  Result.lpThousandSep := PWideChar(Currency_ThousandSep);
  Result.NegativeOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_INEGCURR, '0'), 0);
  Result.PositiveOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRENCY, '0'), 0);
  Currency_CurrencySymbol := WideGetLocaleStr(GetThreadLocale, LOCALE_SCURRENCY, '');
  Result.lpCurrencySymbol := PWideChar(Currency_CurrencySymbol);
end;

//=============================================================================================

function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString;
var
  L: Integer;
begin
  if (not Win32PlatformIsUnicode) then
    Result := GetLocaleStr{TNT-ALLOW GetLocaleStr}(LocaleID, LocaleType, Default)
  else begin
    SetLength(Result, 255);
    L := GetLocaleInfoW(LocaleID, LocaleType, PWideChar(Result), Length(Result));
    if L > 0 then
      SetLength(Result, L - 1)
    else
      Result := Default;
  end;
end;

function WideSysErrorMessage(ErrorCode: Integer): WideString;
begin
  Result := WideLibraryErrorMessage('system', 0, ErrorCode);
end;

function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString;
var
  Len: Integer;
  AnsiResult: AnsiString;
  Flags: Cardinal;
begin
  Flags := FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY;
  if Dll <> 0 then
    Flags := Flags or FORMAT_MESSAGE_FROM_HMODULE;
  if Win32PlatformIsUnicode then begin
    SetLength(Result, 256);
    Len := FormatMessageW(Flags, Pointer(Dll), ErrorCode, 0, PWideChar(Result), Length(Result), nil);
    SetLength(Result, Len);
  end else begin
    SetLength(AnsiResult, 256);
    Len := FormatMessageA(Flags, Pointer(Dll), ErrorCode, 0, PAnsiChar(AnsiResult), Length(AnsiResult), nil);
    SetLength(AnsiResult, Len);
    Result := AnsiResult;
  end;
  if Trim(Result) = '' then
    Result := WideFormat('Unspecified error (%d) from %s.', [ErrorCode, LibName]);
end;

{$IFNDEF COMPILER_7_UP}
function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean;
begin
  Result := (Win32MajorVersion > AMajor) or
            ((Win32MajorVersion = AMajor) and
             (Win32MinorVersion >= AMinor));
end;
{$ENDIF}

function WinCheckH(RetVal: Cardinal): Cardinal;
begin
  if RetVal = 0 then RaiseLastOSError;
  Result := RetVal;
end;

function WinCheckFileH(RetVal: Cardinal): Cardinal;
begin
  if RetVal = INVALID_HANDLE_VALUE then RaiseLastOSError;
  Result := RetVal;
end;

function WinCheckP(RetVal: Pointer): Pointer;
begin
  if RetVal = nil then RaiseLastOSError;
  Result := RetVal;
end;

function WideGetModuleFileName(Instance: HModule): WideString;
begin
  SetLength(Result, MAX_PATH);
  WinCheckH(Tnt_GetModuleFileNameW(Instance, PWideChar(Result), Length(Result)));
  Result := PWideChar(Result)
end;

function WideSafeLoadLibrary(const Filename: Widestring; ErrorMode: UINT): HMODULE;
var
  OldMode: UINT;
  FPUControlWord: Word;
begin
  OldMode := SetErrorMode(ErrorMode);
  try
    asm
      FNSTCW  FPUControlWord
    end;
    try
      Result := Tnt_LoadLibraryW(PWideChar(Filename));
    finally
      asm
        FNCLEX
        FLDCW FPUControlWord
      end;
    end;
  finally
    SetErrorMode(OldMode);
  end;
end;

function WideLoadPackage(const Name: Widestring): HMODULE;
begin
  Result := WideSafeLoadLibrary(Name);
  if Result = 0 then
  begin
    raise EPackageError.CreateFmt(sErrorLoadingPackage, [Name, WideSysErrorMessage(GetLastError)]);
  end;
  try
    InitializePackage(Result);
  except
    FreeLibrary(Result);
    raise;
  end;
end;

function _WideCharType(WC: WideChar; dwInfoType: Cardinal): Word;
begin
  Win32Check(Tnt_GetStringTypeExW(GetThreadLocale, dwInfoType, PWideChar(@WC), 1, Result))
end;

function IsWideCharUpper(WC: WideChar): Boolean;
begin
  Result := (_WideCharType(WC, CT_CTYPE1) and C1_UPPER) <> 0;
end;

function IsWideCharLower(WC: WideChar): Boolean;
begin
  Result := (_WideCharType(WC, CT_CTYPE1) and C1_LOWER) <> 0;
end;

function IsWideCharDigit(WC: WideChar): Boolean;
begin
  Result := (_WideCharType(WC, CT_CTYPE1) and C1_DIGIT) <> 0;
end;

function IsWideCharSpace(WC: WideChar): Boolean;
begin
  Result := (_WideCharType(WC, CT_CTYPE1) and C1_SPACE) <> 0;
end;

function IsWideCharPunct(WC: WideChar): Boolean;
begin
  Result := (_WideCharType(WC, CT_CTYPE1) and C1_PUNCT) <> 0;
end;

function IsWideCharCntrl(WC: WideChar): Boolean;
begin
  Result := (_WideCharType(WC, CT_CTYPE1) and C1_CNTRL) <> 0;
end;

function IsWideCharBlank(WC: WideChar): Boolean;
begin
  Result := (_WideCharType(WC, CT_CTYPE1) and C1_BLANK) <> 0;
end;

function IsWideCharXDigit(WC: WideChar): Boolean;
begin
  Result := (_WideCharType(WC, CT_CTYPE1) and C1_XDIGIT) <> 0;
end;

function IsWideCharAlpha(WC: WideChar): Boolean;
begin
  Result := (_WideCharType(WC, CT_CTYPE1) and C1_ALPHA) <> 0;
end;

function IsWideCharAlphaNumeric(WC: WideChar): Boolean;
begin
  Result := (_WideCharType(WC, CT_CTYPE1) and (C1_ALPHA + C1_DIGIT)) <> 0;
end;

function WideTextPos(const SubStr, S: WideString): Integer;
begin
  Result := Pos(Tnt_WideUpperCase(SubStr), Tnt_WideUpperCase(S));
end;

function FindDoubleTerminator(P: PWideChar): PWideChar;
begin
  Result := P;
  while True do begin
    Result := WStrScan(Result, #0);
    Inc(Result);
    if Result^ = #0 then begin
      Dec(Result);
      break;
    end;
  end;
end;

function ExtractStringArrayStr(P: PWideChar): WideString;
var
  PEnd: PWideChar;
begin
  PEnd := FindDoubleTerminator(P);
  Inc(PEnd, 2); // move past #0#0
  SetString(Result, P, PEnd - P);
end;

function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString;
var
  Start: PWideChar;
begin
  Start := P;
  P := WStrScan(Start, Separator);
  if P = nil then begin
    Result := Start;
    P := WStrEnd(Start);
  end else begin
    SetString(Result, Start, P - Start);
    Inc(P);
  end;
end;

function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray;
const
  GROW_COUNT = 256;
var
  Count: Integer;
  Item: WideString;
begin
  Count := 0;
  SetLength(Result, GROW_COUNT);
  Item := ExtractStringFromStringArray(P, Separator);
  While Item <> '' do begin
    if Count > High(Result) then
      SetLength(Result, Length(Result) + GROW_COUNT);
    Result[Count] := Item;
    Inc(Count);
    Item := ExtractStringFromStringArray(P, Separator);
  end;
  SetLength(Result, Count);
end;

function IsWideCharMappableToAnsi(const WC: WideChar): Boolean;
var
  UsedDefaultChar: BOOL;
begin
  WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(@WC), 1, nil, 0, nil, @UsedDefaultChar);
  Result := not UsedDefaultChar;
end;

function IsWideStringMappableToAnsi(const WS: WideString): Boolean;
var
  UsedDefaultChar: BOOL;
begin
  WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(WS), Length(WS), nil, 0, nil, @UsedDefaultChar);
  Result := not UsedDefaultChar;
end;

function IsRTF(const Value: WideString): Boolean;
const
  RTF_BEGIN_1  = WideString('{\RTF');
  RTF_BEGIN_2  = WideString('{URTF');
begin
  Result := (WideTextPos(RTF_BEGIN_1, Value) = 1)
         or (WideTextPos(RTF_BEGIN_2, Value) = 1);
end;

{$IFDEF COMPILER_7_UP}
var
  Cached_ENG_US_FormatSettings: TFormatSettings;
  Cached_ENG_US_FormatSettings_Time: Cardinal;

function ENG_US_FormatSettings: TFormatSettings;
begin
  if Cached_ENG_US_FormatSettings_Time = _SettingChangeTime then
    Result := Cached_ENG_US_FormatSettings
  else begin
    GetLocaleFormatSettings(MAKELCID(MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US)), Result);
    Result.DecimalSeparator := '.'; // ignore overrides
    Cached_ENG_US_FormatSettings := Result;
    Cached_ENG_US_FormatSettings_Time := _SettingChangeTime;
  end;
 end;

function ENG_US_FloatToStr(Value: Extended): WideString;
begin
  Result := FloatToStr(Value, ENG_US_FormatSettings);
end;

function ENG_US_StrToFloat(const S: WideString): Extended;
begin
  if not TextToFloat(PAnsiChar(AnsiString(S)), Result, fvExtended, ENG_US_FormatSettings) then
    Result := StrToFloat(S); // try using native format
end;

{$ELSE}

function ENG_US_FloatToStr(Value: Extended): WideString;
var
  SaveDecimalSep: AnsiChar;
begin
  SaveDecimalSep := SysUtils.DecimalSeparator;
  try
    SysUtils.DecimalSeparator := '.';
    Result := FloatToStr(Value);
  finally
    SysUtils.DecimalSeparator := SaveDecimalSep;
  end;
end;

function ENG_US_StrToFloat(const S: WideString): Extended;
var
  SaveDecimalSep: AnsiChar;
begin
  try
    SaveDecimalSep := SysUtils.DecimalSeparator;
    try
      SysUtils.DecimalSeparator := '.';
      Result := StrToFloat(S);
    finally
      SysUtils.DecimalSeparator := SaveDecimalSep;
    end;
  except
    if SysUtils.DecimalSeparator <> '.' then
      Result := StrToFloat(S) // try using native format
    else
      raise;
  end;
end;
{$ENDIF}

//---------------------------------------------------------------------------------------------
//                                 Tnt - Variants
//---------------------------------------------------------------------------------------------

initialization
  Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT);
  Win32PlatformIsXP := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1))
                    or  (Win32MajorVersion > 5);
  Win32PlatformIs2003 := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 2))
                    or  (Win32MajorVersion > 5);
  Win32PlatformIsVista := (Win32MajorVersion >= 6);

finalization
  Currency_DecimalSep := ''; {make memory sleuth happy}
  Currency_ThousandSep := ''; {make memory sleuth happy}
  Currency_CurrencySymbol := ''; {make memory sleuth happy}

end.