aboutsummaryrefslogtreecommitdiffstats
path: root/src/lib/TntUnicodeControls/TntSysUtils.pas
diff options
context:
space:
mode:
Diffstat (limited to 'src/lib/TntUnicodeControls/TntSysUtils.pas')
-rw-r--r--src/lib/TntUnicodeControls/TntSysUtils.pas1753
1 files changed, 0 insertions, 1753 deletions
diff --git a/src/lib/TntUnicodeControls/TntSysUtils.pas b/src/lib/TntUnicodeControls/TntSysUtils.pas
deleted file mode 100644
index b7cf2467..00000000
--- a/src/lib/TntUnicodeControls/TntSysUtils.pas
+++ /dev/null
@@ -1,1753 +0,0 @@
-
-{*****************************************************************************}
-{ }
-{ Tnt Delphi Unicode Controls }
-{ http://www.tntware.com/delphicontrols/unicode/ }
-{ Version: 2.3.0 }
-{ }
-{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) }
-{ }
-{*****************************************************************************}
-
-unit TntSysUtils;
-
-{$IFDEF FPC}
- {$MODE Delphi}
-{$ENDIF}
-
-{$INCLUDE TntCompilers.inc}
-
-interface
-
-{ TODO: Consider: more filename functions from SysUtils }
-{ TODO: Consider: string functions from StrUtils. }
-
-uses
- Types, SysUtils, Windows, TntWindows;
-
-//---------------------------------------------------------------------------------------------
-// Tnt - Types
-//---------------------------------------------------------------------------------------------
-
-// ......... introduced .........
-type
- // The user of the application did something plainly wrong.
- ETntUserError = class(Exception);
- // A general error occured. (ie. file didn't exist, server didn't return data, etc.)
- ETntGeneralError = class(Exception);
- // Like Assert(). An error occured that should never have happened, send me a bug report now!
- ETntInternalError = class(Exception);
-
-{$IFNDEF FPC}
-type
- PtrInt = LongInt;
- PtrUInt = LongWord;
-{$ENDIF}
-
-//---------------------------------------------------------------------------------------------
-// Tnt - SysUtils
-//---------------------------------------------------------------------------------------------
-
-// ......... SBCS and MBCS functions with WideString replacements in SysUtils.pas .........
-
-{TNT-WARN CompareStr} {TNT-WARN AnsiCompareStr}
-{TNT-WARN SameStr} {TNT-WARN AnsiSameStr}
-{TNT-WARN SameText} {TNT-WARN AnsiSameText}
-{TNT-WARN CompareText} {TNT-WARN AnsiCompareText}
-{TNT-WARN UpperCase} {TNT-WARN AnsiUpperCase}
-{TNT-WARN LowerCase} {TNT-WARN AnsiLowerCase}
-
-{TNT-WARN AnsiPos} { --> Pos() supports WideString. }
-{TNT-WARN FmtStr}
-{TNT-WARN Format}
-{TNT-WARN FormatBuf}
-
-// ......... MBCS Byte Type Procs .........
-
-{TNT-WARN ByteType}
-{TNT-WARN StrByteType}
-{TNT-WARN ByteToCharIndex}
-{TNT-WARN ByteToCharLen}
-{TNT-WARN CharToByteIndex}
-{TNT-WARN CharToByteLen}
-
-// ........ null-terminated string functions .........
-
-{TNT-WARN StrEnd}
-{TNT-WARN StrLen}
-{TNT-WARN StrLCopy}
-{TNT-WARN StrCopy}
-{TNT-WARN StrECopy}
-{TNT-WARN StrPLCopy}
-{TNT-WARN StrPCopy}
-{TNT-WARN StrLComp}
-{TNT-WARN AnsiStrLComp}
-{TNT-WARN StrComp}
-{TNT-WARN AnsiStrComp}
-{TNT-WARN StrLIComp}
-{TNT-WARN AnsiStrLIComp}
-{TNT-WARN StrIComp}
-{TNT-WARN AnsiStrIComp}
-{TNT-WARN StrLower}
-{TNT-WARN AnsiStrLower}
-{TNT-WARN StrUpper}
-{TNT-WARN AnsiStrUpper}
-{TNT-WARN StrPos}
-{TNT-WARN AnsiStrPos}
-{TNT-WARN StrScan}
-{TNT-WARN AnsiStrScan}
-{TNT-WARN StrRScan}
-{TNT-WARN AnsiStrRScan}
-{TNT-WARN StrLCat}
-{TNT-WARN StrCat}
-{TNT-WARN StrMove}
-{TNT-WARN StrPas}
-{TNT-WARN StrAlloc}
-{TNT-WARN StrBufSize}
-{TNT-WARN StrNew}
-{TNT-WARN StrDispose}
-
-{TNT-WARN AnsiExtractQuotedStr}
-{TNT-WARN AnsiLastChar}
-{TNT-WARN AnsiStrLastChar}
-{TNT-WARN QuotedStr}
-{TNT-WARN AnsiQuotedStr}
-{TNT-WARN AnsiDequotedStr}
-
-// ........ string functions .........
-
-{$IFNDEF FPC}
-{$IFNDEF COMPILER_9_UP}
- //
- // pre-Delphi 9 issues w/ WideFormatBuf, WideFmtStr and WideFormat
- //
-
- {$IFDEF COMPILER_7_UP}
- type
- PFormatSettings = ^TFormatSettings;
- {$ENDIF}
-
- // SysUtils.WideFormatBuf doesn't correctly handle numeric specifiers.
- function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr;
- FmtLen: Cardinal; const Args: array of const): Cardinal; {$IFDEF COMPILER_7_UP} overload; {$ENDIF}
-
- {$IFDEF COMPILER_7_UP}
- function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr;
- FmtLen: Cardinal; const Args: array of const;
- const FormatSettings: TFormatSettings): Cardinal; overload;
- {$ENDIF}
-
- // SysUtils.WideFmtStr doesn't handle string lengths > 4096.
- procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString;
- const Args: array of const); {$IFDEF COMPILER_7_UP} overload; {$ENDIF}
-
- {$IFDEF COMPILER_7_UP}
- procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString;
- const Args: array of const; const FormatSettings: TFormatSettings); overload;
- {$ENDIF}
-
- {----------------------------------------------------------------------------------------
- Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary...
- TntSystem.InstallTntSystemUpdates([tsFixWideFormat]);
- will fix WideFormat as well as WideFmtStr.
- ----------------------------------------------------------------------------------------}
- function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString; {$IFDEF COMPILER_7_UP} overload; {$ENDIF}
-
- {$IFDEF COMPILER_7_UP}
- function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const;
- const FormatSettings: TFormatSettings): WideString; overload;
- {$ENDIF}
-
-{$ENDIF}
-{$ENDIF}
-
-{TNT-WARN WideUpperCase} // SysUtils.WideUpperCase is broken on Win9x for D6, D7, D9.
-function Tnt_WideUpperCase(const S: WideString): WideString;
-{TNT-WARN WideLowerCase} // SysUtils.WideLowerCase is broken on Win9x for D6, D7, D9.
-function Tnt_WideLowerCase(const S: WideString): WideString;
-
-function TntWideLastChar(const S: WideString): WideChar;
-
-{TNT-WARN StringReplace}
-{TNT-WARN WideStringReplace} // <-- WideStrUtils.WideStringReplace uses SysUtils.WideUpperCase which is broken on Win9x.
-function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString;
- Flags: TReplaceFlags; WholeWord: Boolean = False): WideString;
-
-{TNT-WARN AdjustLineBreaks}
-type TTntTextLineBreakStyle = (tlbsLF, tlbsCRLF, tlbsCR);
-function TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer;
-function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString;
-
-{TNT-WARN WrapText}
-function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet;
- MaxCol: Integer): WideString; overload;
-function WideWrapText(const Line: WideString; MaxCol: Integer): WideString; overload;
-
-// ........ filename manipulation .........
-
-{TNT-WARN SameFileName} // doesn't apply to Unicode filenames, use WideSameText
-{TNT-WARN AnsiCompareFileName} // doesn't apply to Unicode filenames, use WideCompareText
-{TNT-WARN AnsiLowerCaseFileName} // doesn't apply to Unicode filenames, use WideLowerCase
-{TNT-WARN AnsiUpperCaseFileName} // doesn't apply to Unicode filenames, use WideUpperCase
-
-{TNT-WARN IncludeTrailingBackslash}
-function WideIncludeTrailingBackslash(const S: WideString): WideString;
-{TNT-WARN IncludeTrailingPathDelimiter}
-function WideIncludeTrailingPathDelimiter(const S: WideString): WideString;
-{TNT-WARN ExcludeTrailingBackslash}
-function WideExcludeTrailingBackslash(const S: WideString): WideString;
-{TNT-WARN ExcludeTrailingPathDelimiter}
-function WideExcludeTrailingPathDelimiter(const S: WideString): WideString;
-{TNT-WARN IsDelimiter}
-function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean;
-{TNT-WARN IsPathDelimiter}
-function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean;
-{TNT-WARN LastDelimiter}
-function WideLastDelimiter(const Delimiters, S: WideString): Integer;
-{TNT-WARN ChangeFileExt}
-function WideChangeFileExt(const FileName, Extension: WideString): WideString;
-{TNT-WARN ExtractFilePath}
-function WideExtractFilePath(const FileName: WideString): WideString;
-{TNT-WARN ExtractFileDir}
-function WideExtractFileDir(const FileName: WideString): WideString;
-{TNT-WARN ExtractFileDrive}
-function WideExtractFileDrive(const FileName: WideString): WideString;
-{TNT-WARN ExtractFileName}
-function WideExtractFileName(const FileName: WideString): WideString;
-{TNT-WARN ExtractFileExt}
-function WideExtractFileExt(const FileName: WideString): WideString;
-{TNT-WARN ExtractRelativePath}
-function WideExtractRelativePath(const BaseName, DestName: WideString): WideString;
-
-// ........ file management routines .........
-
-{TNT-WARN ExpandFileName}
-function WideExpandFileName(const FileName: WideString): WideString;
-{TNT-WARN ExtractShortPathName}
-function WideExtractShortPathName(const FileName: WideString): WideString;
-{TNT-WARN FileCreate}
-function WideFileCreate(const FileName: WideString): Integer;
-{TNT-WARN FileOpen}
-function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer;
-{TNT-WARN FileAge}
-function WideFileAge(const FileName: WideString): Integer; overload;
-function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean; overload;
-{TNT-WARN DirectoryExists}
-function WideDirectoryExists(const Name: WideString): Boolean;
-{TNT-WARN FileExists}
-function WideFileExists(const Name: WideString): Boolean;
-{TNT-WARN FileGetAttr}
-function WideFileGetAttr(const FileName: WideString): Cardinal;
-{TNT-WARN FileSetAttr}
-function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean;
-{TNT-WARN FileIsReadOnly}
-function WideFileIsReadOnly(const FileName: WideString): Boolean;
-{TNT-WARN FileSetReadOnly}
-function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean;
-{TNT-WARN ForceDirectories}
-function WideForceDirectories(Dir: WideString): Boolean;
-{TNT-WARN FileSearch}
-function WideFileSearch(const Name, DirList: WideString): WideString;
-{TNT-WARN RenameFile}
-function WideRenameFile(const OldName, NewName: WideString): Boolean;
-{TNT-WARN DeleteFile}
-function WideDeleteFile(const FileName: WideString): Boolean;
-{TNT-WARN CopyFile}
-function WideCopyFile(const FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean;
-
-
-{TNT-WARN TFileName}
-type
- TWideFileName = type WideString;
-
-{TNT-WARN TSearchRec} // <-- FindFile - warning on TSearchRec is all that is necessary
-type
- TSearchRecW = record
- Time: Integer;
- Size: Int64;
- Attr: Integer;
- Name: TWideFileName;
- ExcludeAttr: Integer;
- FindHandle: THandle;
- FindData: TWin32FindDataW;
- end;
-function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer;
-function WideFindNext(var F: TSearchRecW): Integer;
-procedure WideFindClose(var F: TSearchRecW);
-
-{TNT-WARN CreateDir}
-function WideCreateDir(const Dir: WideString): Boolean;
-{TNT-WARN RemoveDir}
-function WideRemoveDir(const Dir: WideString): Boolean;
-{TNT-WARN GetCurrentDir}
-function WideGetCurrentDir: WideString;
-{TNT-WARN SetCurrentDir}
-function WideSetCurrentDir(const Dir: WideString): Boolean;
-
-
-// ........ date/time functions .........
-
-{TNT-WARN TryStrToDateTime}
-function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean;
-{TNT-WARN TryStrToDate}
-function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean;
-{TNT-WARN TryStrToTime}
-function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean;
-
-{ introduced }
-function ValidDateTimeStr(Str: WideString): Boolean;
-function ValidDateStr(Str: WideString): Boolean;
-function ValidTimeStr(Str: WideString): Boolean;
-
-{TNT-WARN StrToDateTime}
-function TntStrToDateTime(Str: WideString): TDateTime;
-{TNT-WARN StrToDate}
-function TntStrToDate(Str: WideString): TDateTime;
-{TNT-WARN StrToTime}
-function TntStrToTime(Str: WideString): TDateTime;
-{TNT-WARN StrToDateTimeDef}
-function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime;
-{TNT-WARN StrToDateDef}
-function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime;
-{TNT-WARN StrToTimeDef}
-function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime;
-
-{TNT-WARN CurrToStr}
-{TNT-WARN CurrToStrF}
-function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString;
-{TNT-WARN StrToCurr}
-function TntStrToCurr(const S: WideString): Currency;
-{TNT-WARN StrToCurrDef}
-function ValidCurrencyStr(const S: WideString): Boolean;
-function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency;
-function GetDefaultCurrencyFmt: TCurrencyFmtW;
-
-// ........ misc functions .........
-
-{TNT-WARN GetLocaleStr}
-function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString;
-{TNT-WARN SysErrorMessage}
-function WideSysErrorMessage(ErrorCode: Integer): WideString;
-
-// ......... introduced .........
-
-function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString;
-
-const
- CR = WideChar(#13);
- LF = WideChar(#10);
- CRLF = WideString(#13#10);
- WideLineSeparator = WideChar($2028);
-
-var
- Win32PlatformIsUnicode: Boolean;
- Win32PlatformIsXP: Boolean;
- Win32PlatformIs2003: Boolean;
- Win32PlatformIsVista: Boolean;
-
-{$IFNDEF FPC}
-{$IFNDEF COMPILER_7_UP}
-function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean;
-{$ENDIF}
-{$ENDIF}
-function WinCheckH(RetVal: Cardinal): Cardinal;
-function WinCheckFileH(RetVal: Cardinal): Cardinal;
-function WinCheckP(RetVal: Pointer): Pointer;
-
-function WideGetModuleFileName(Instance: HModule): WideString;
-function WideSafeLoadLibrary(const Filename: Widestring;
- ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE;
-{$IFNDEF FPC}
-function WideLoadPackage(const Name: Widestring): HMODULE;
-{$ENDIF}
-
-function IsWideCharUpper(WC: WideChar): Boolean;
-function IsWideCharLower(WC: WideChar): Boolean;
-function IsWideCharDigit(WC: WideChar): Boolean;
-function IsWideCharSpace(WC: WideChar): Boolean;
-function IsWideCharPunct(WC: WideChar): Boolean;
-function IsWideCharCntrl(WC: WideChar): Boolean;
-function IsWideCharBlank(WC: WideChar): Boolean;
-function IsWideCharXDigit(WC: WideChar): Boolean;
-function IsWideCharAlpha(WC: WideChar): Boolean;
-function IsWideCharAlphaNumeric(WC: WideChar): Boolean;
-
-function WideTextPos(const SubStr, S: WideString): Integer;
-
-function ExtractStringArrayStr(P: PWideChar): WideString;
-function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString;
-function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray;
-
-function IsWideCharMappableToAnsi(const WC: WideChar): Boolean;
-function IsWideStringMappableToAnsi(const WS: WideString): Boolean;
-function IsRTF(const Value: WideString): Boolean;
-
-function ENG_US_FloatToStr(Value: Extended): WideString;
-function ENG_US_StrToFloat(const S: WideString): Extended;
-
-//---------------------------------------------------------------------------------------------
-// Tnt - Variants
-//---------------------------------------------------------------------------------------------
-
-// ........ Variants.pas has WideString versions of these functions .........
-{TNT-WARN VarToStr}
-{TNT-WARN VarToStrDef}
-
-var
- _SettingChangeTime: Cardinal;
-
-implementation
-
-uses
- ActiveX, ComObj, SysConst,
- {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils,
- TntSystem, TntFormatStrUtils;
-
-//---------------------------------------------------------------------------------------------
-// Tnt - SysUtils
-//---------------------------------------------------------------------------------------------
-
-{$IFNDEF FPC}
-{$IFNDEF COMPILER_9_UP}
-
- function _Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr;
- FmtLen: Cardinal; const Args: array of const
- {$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings {$ENDIF}): Cardinal;
- var
- OldFormat: WideString;
- NewFormat: WideString;
- begin
- SetString(OldFormat, PWideChar(@FormatStr), FmtLen);
- { The reason for this is that WideFormat doesn't correctly format floating point specifiers.
- See QC#4254. }
- NewFormat := ReplaceFloatingArgumentsInFormatString(OldFormat, Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF});
- {$IFDEF COMPILER_7_UP}
- if FormatSettings <> nil then
- Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^,
- Length(NewFormat), Args, FormatSettings^)
- else
- {$ENDIF}
- Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^,
- Length(NewFormat), Args);
- end;
-
- function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr;
- FmtLen: Cardinal; const Args: array of const): Cardinal;
- begin
- Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF});
- end;
-
- {$IFDEF COMPILER_7_UP}
- function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr;
- FmtLen: Cardinal; const Args: array of const; const FormatSettings: TFormatSettings): Cardinal;
- begin
- Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args, @FormatSettings);
- end;
- {$ENDIF}
-
- procedure _Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString;
- const Args: array of const{$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings{$ENDIF});
- var
- Len, BufLen: Integer;
- Buffer: array[0..4095] of WideChar;
- begin
- BufLen := Length(Buffer); // Fixes buffer overwrite issue. (See QC #4703, #4744)
- if Length(FormatStr) < (Length(Buffer) - (Length(Buffer) div 4)) then
- Len := _Tnt_WideFormatBuf(Buffer, Length(Buffer) - 1, Pointer(FormatStr)^,
- Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF})
- else
- begin
- BufLen := Length(FormatStr);
- 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 := _Tnt_WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(FormatStr)^,
- Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF});
- end;
- SetLength(Result, Len);
- end
- else
- SetString(Result, Buffer, Len);
- end;
-
- procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString;
- const Args: array of const);
- begin
- _Tnt_WideFmtStr(Result, FormatStr, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF});
- end;
-
- {$IFDEF COMPILER_7_UP}
- procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString;
- const Args: array of const; const FormatSettings: TFormatSettings);
- begin
- _Tnt_WideFmtStr(Result, FormatStr, Args, @FormatSettings);
- end;
- {$ENDIF}
-
- {----------------------------------------------------------------------------------------
- Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary...
- TntSystem.InstallTntSystemUpdates([tsFixWideFormat]);
- will fix WideFormat as well as WideFmtStr.
- ----------------------------------------------------------------------------------------}
- function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString;
- begin
- Tnt_WideFmtStr(Result, FormatStr, Args);
- end;
-
- {$IFDEF COMPILER_7_UP}
- function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const;
- const FormatSettings: TFormatSettings): WideString;
- begin
- Tnt_WideFmtStr(Result, FormatStr, Args, FormatSettings);
- end;
- {$ENDIF}
-
-{$ENDIF}
-{$ENDIF FPC}
-
-function Tnt_WideUpperCase(const S: WideString): WideString;
-begin
- {$IFNDEF FPC}
- {$IFNDEF COMPILER_10_UP}
- {$DEFINE WIDEUPPERCASE_BROKEN}
- {$ENDIF}
- {$ENDIF}
- {$IFDEF WIDEUPPERCASE_BROKEN}
- { SysUtils.WideUpperCase is broken for Win9x. }
- Result := S;
- if Length(Result) > 0 then
- Tnt_CharUpperBuffW(PWideChar(Result), Length(Result));
- {$ELSE}
- Result := SysUtils.WideUpperCase{TNT-ALLOW WideUpperCase}(S);
- {$ENDIF}
-end;
-
-function Tnt_WideLowerCase(const S: WideString): WideString;
-begin
- {$IFNDEF FPC}
- {$IFNDEF COMPILER_10_UP}
- {$DEFINE WIDELOWERCASE_BROKEN}
- {$ENDIF}
- {$ENDIF}
- {$IFDEF WIDELOWERCASE_BROKEN}
- { SysUtils.WideLowerCase is broken for Win9x. }
- Result := S;
- if Length(Result) > 0 then
- Tnt_CharLowerBuffW(PWideChar(Result), Length(Result));
- {$ELSE}
- Result := SysUtils.WideLowerCase{TNT-ALLOW WideLowerCase}(S);
- {$ENDIF}
-end;
-
-function TntWideLastChar(const S: WideString): WideChar;
-var
- P: PWideChar;
-begin
- P := WideLastChar(S);
- if P = nil then
- Result := #0
- else
- Result := P^;
-end;
-
-function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString;
- Flags: TReplaceFlags; WholeWord: Boolean = False): WideString;
-
- function IsWordSeparator(WC: WideChar): Boolean;
- begin
- Result := (WC = WideChar(#0))
- or IsWideCharSpace(WC)
- or IsWideCharPunct(WC);
- end;
-
-var
- SearchStr, Patt, NewStr: WideString;
- Offset: Integer;
- PrevChar, NextChar: WideChar;
-begin
- if rfIgnoreCase in Flags then
- begin
- SearchStr := Tnt_WideUpperCase(S);
- Patt := Tnt_WideUpperCase(OldPattern);
- end else
- begin
- SearchStr := S;
- Patt := OldPattern;
- end;
- NewStr := S;
- Result := '';
- while SearchStr <> '' do
- begin
- Offset := Pos(Patt, SearchStr);
- if Offset = 0 then
- begin
- Result := Result + NewStr;
- Break;
- end; // done
-
- if (WholeWord) then
- begin
- if (Offset = 1) then
- PrevChar := TntWideLastChar(Result)
- else
- PrevChar := NewStr[Offset - 1];
-
- if Offset + Length(OldPattern) <= Length(NewStr) then
- NextChar := NewStr[Offset + Length(OldPattern)]
- else
- NextChar := WideChar(#0);
-
- if (not IsWordSeparator(PrevChar))
- or (not IsWordSeparator(NextChar)) then
- begin
- Result := Result + Copy(NewStr, 1, Offset + Length(OldPattern) - 1);
- NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
- SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
- continue;
- end;
- 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 TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer;
-var
- Source, SourceEnd: PWideChar;
-begin
- Source := Pointer(S);
- SourceEnd := Source + Length(S);
- Result := Length(S);
- while Source < SourceEnd do
- begin
- case Source^ of
- #10, WideLineSeparator:
- if Style = tlbsCRLF then
- Inc(Result);
- #13:
- if Style = tlbsCRLF then
- if Source[1] = #10 then
- Inc(Source)
- else
- Inc(Result)
- else
- if Source[1] = #10 then
- Dec(Result);
- end;
- Inc(Source);
- end;
-end;
-
-function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString;
-var
- Source, SourceEnd, Dest: PWideChar;
- DestLen: Integer;
-begin
- Source := Pointer(S);
- SourceEnd := Source + Length(S);
- DestLen := TntAdjustLineBreaksLength(S, Style);
- SetString(Result, nil, DestLen);
- Dest := Pointer(Result);
- while Source < SourceEnd do begin
- case Source^ of
- #10, WideLineSeparator:
- begin
- if Style in [tlbsCRLF, tlbsCR] then
- begin
- Dest^ := #13;
- Inc(Dest);
- end;
- if Style in [tlbsCRLF, tlbsLF] then
- begin
- Dest^ := #10;
- Inc(Dest);
- end;
- Inc(Source);
- end;
- #13:
- begin
- if Style in [tlbsCRLF, tlbsCR] then
- begin
- Dest^ := #13;
- Inc(Dest);
- end;
- if Style in [tlbsCRLF, tlbsLF] then
- begin
- Dest^ := #10;
- Inc(Dest);
- end;
- Inc(Source);
- if Source^ = #10 then Inc(Source);
- end;
- else
- Dest^ := Source^;
- Inc(Dest);
- Inc(Source);
- end;
- end;
-end;
-
-function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet;
- MaxCol: Integer): WideString;
-
- function WideCharIn(C: WideChar; SysCharSet: TSysCharSet): Boolean;
- begin
- Result := (C <= High(AnsiChar)) and (AnsiChar(C) in SysCharSet);
- end;
-
-const
- QuoteChars = ['''', '"'];
-var
- Col, Pos: Integer;
- LinePos, LineLen: Integer;
- BreakLen, BreakPos: Integer;
- QuoteChar, CurChar: WideChar;
- ExistingBreak: Boolean;
-begin
- Col := 1;
- Pos := 1;
- LinePos := 1;
- BreakPos := 0;
- QuoteChar := ' ';
- ExistingBreak := False;
- LineLen := Length(Line);
- BreakLen := Length(BreakStr);
- Result := '';
- while Pos <= LineLen do
- begin
- CurChar := Line[Pos];
- if CurChar = BreakStr[1] then
- begin
- if QuoteChar = ' ' then
- begin
- ExistingBreak := WideSameText(BreakStr, Copy(Line, Pos, BreakLen));
- if ExistingBreak then
- begin
- Inc(Pos, BreakLen-1);
- BreakPos := Pos;
- end;
- end
- end
- else if WideCharIn(CurChar, BreakChars) then
- begin
- if QuoteChar = ' ' then BreakPos := Pos
- end
- else if WideCharIn(CurChar, QuoteChars) then
- begin
- if CurChar = QuoteChar then
- QuoteChar := ' '
- else if QuoteChar = ' ' then
- QuoteChar := CurChar;
- end;
- Inc(Pos);
- Inc(Col);
- if not (WideCharIn(QuoteChar, QuoteChars)) and (ExistingBreak or
- ((Col > MaxCol) and (BreakPos > LinePos))) then
- begin
- Col := Pos - BreakPos;
- Result := Result + Copy(Line, LinePos, BreakPos - LinePos + 1);
- if not (WideCharIn(CurChar, QuoteChars)) then
- while Pos <= LineLen do
- begin
- if WideCharIn(Line[Pos], BreakChars) then
- Inc(Pos)
- else if Copy(Line, Pos, Length(sLineBreak)) = sLineBreak then
- Inc(Pos, Length(sLineBreak))
- else
- break;
- end;
- if not ExistingBreak and (Pos < LineLen) then
- Result := Result + BreakStr;
- Inc(BreakPos);
- LinePos := BreakPos;
- ExistingBreak := False;
- end;
- end;
- Result := Result + Copy(Line, LinePos, MaxInt);
-end;
-
-function WideWrapText(const Line: WideString; MaxCol: Integer): WideString;
-begin
- Result := WideWrapText(Line, sLineBreak, [' ', '-', #9], MaxCol); { do not localize }
-end;
-
-function WideIncludeTrailingBackslash(const S: WideString): WideString;
-begin
- Result := WideIncludeTrailingPathDelimiter(S);
-end;
-
-function WideIncludeTrailingPathDelimiter(const S: WideString): WideString;
-begin
- Result := S;
- if not WideIsPathDelimiter(Result, Length(Result)) then Result := Result + PathDelim;
-end;
-
-function WideExcludeTrailingBackslash(const S: WideString): WideString;
-begin
- Result := WideExcludeTrailingPathDelimiter(S);
-end;
-
-function WideExcludeTrailingPathDelimiter(const S: WideString): WideString;
-begin
- Result := S;
- if WideIsPathDelimiter(Result, Length(Result)) then
- SetLength(Result, Length(Result)-1);
-end;
-
-function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean;
-begin
- Result := False;
- if (Index <= 0) or (Index > Length(S)) then exit;
- Result := WStrScan(PWideChar(Delimiters), S[Index]) <> nil;
-end;
-
-function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean;
-begin
- Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = PathDelim);
-end;
-
-function WideLastDelimiter(const Delimiters, S: WideString): Integer;
-var
- P: PWideChar;
-begin
- Result := Length(S);
- P := PWideChar(Delimiters);
- while Result > 0 do
- begin
- if (S[Result] <> #0) and (WStrScan(P, S[Result]) <> nil) then
- Exit;
- Dec(Result);
- end;
-end;
-
-function WideChangeFileExt(const FileName, Extension: WideString): WideString;
-var
- I: Integer;
-begin
- I := WideLastDelimiter('.\:',Filename);
- if (I = 0) or (FileName[I] <> '.') then I := MaxInt;
- Result := Copy(FileName, 1, I - 1) + Extension;
-end;
-
-function WideExtractFilePath(const FileName: WideString): WideString;
-var
- I: Integer;
-begin
- I := WideLastDelimiter('\:', FileName);
- Result := Copy(FileName, 1, I);
-end;
-
-function WideExtractFileDir(const FileName: WideString): WideString;
-var
- I: Integer;
-begin
- I := WideLastDelimiter(DriveDelim + PathDelim,Filename);
- if (I > 1) and (FileName[I] = PathDelim) and
- (not (FileName[I - 1] in [WideChar(PathDelim), WideChar(DriveDelim)])) then Dec(I);
- Result := Copy(FileName, 1, I);
-end;
-
-function WideExtractFileDrive(const FileName: WideString): WideString;
-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;
-
-function WideExtractFileName(const FileName: WideString): WideString;
-var
- I: Integer;
-begin
- I := WideLastDelimiter('\:', FileName);
- Result := Copy(FileName, I + 1, MaxInt);
-end;
-
-function WideExtractFileExt(const FileName: WideString): WideString;
-var
- I: Integer;
-begin
- I := WideLastDelimiter('.\:', FileName);
- if (I > 0) and (FileName[I] = '.') then
- Result := Copy(FileName, I, MaxInt) else
- Result := '';
-end;
-
-function WideExtractRelativePath(const BaseName, DestName: WideString): WideString;
-var
- BasePath, DestPath: WideString;
- BaseLead, DestLead: PWideChar;
- BasePtr, DestPtr: PWideChar;
-
- function WideExtractFilePathNoDrive(const FileName: WideString): WideString;
- begin
- Result := WideExtractFilePath(FileName);
- Delete(Result, 1, Length(WideExtractFileDrive(FileName)));
- end;
-
- function Next(var Lead: PWideChar): PWideChar;
- begin
- Result := Lead;
- if Result = nil then Exit;
- Lead := WStrScan(Lead, PathDelim);
- if Lead <> nil then
- begin
- Lead^ := #0;
- Inc(Lead);
- end;
- end;
-
-begin
- if WideSameText(WideExtractFileDrive(BaseName), WideExtractFileDrive(DestName)) then
- begin
- BasePath := WideExtractFilePathNoDrive(BaseName);
- DestPath := WideExtractFilePathNoDrive(DestName);
- BaseLead := Pointer(BasePath);
- BasePtr := Next(BaseLead);
- DestLead := Pointer(DestPath);
- DestPtr := Next(DestLead);
- while (BasePtr <> nil) and (DestPtr <> nil) and WideSameText(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 + WideExtractFileName(DestName);
- end
- else
- Result := DestName;
-end;
-
-function WideExpandFileName(const FileName: WideString): WideString;
-var
- FName: PWideChar;
- Buffer: array[0..MAX_PATH - 1] of WideChar;
-begin
- SetString(Result, Buffer, Tnt_GetFullPathNameW(PWideChar(FileName), MAX_PATH, Buffer, FName));
-end;
-
-function WideExtractShortPathName(const FileName: WideString): WideString;
-var
- Buffer: array[0..MAX_PATH - 1] of WideChar;
-begin
- SetString(Result, Buffer, Tnt_GetShortPathNameW(PWideChar(FileName), Buffer, MAX_PATH));
-end;
-
-function WideFileCreate(const FileName: WideString): Integer;
-begin
- Result := Integer(Tnt_CreateFileW(PWideChar(FileName), GENERIC_READ or GENERIC_WRITE,
- 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0))
-end;
-
-function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer;
-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 := Integer(Tnt_CreateFileW(PWideChar(FileName), AccessMode[Mode and 3],
- ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING,
- FILE_ATTRIBUTE_NORMAL, 0));
-end;
-
-function WideFileAge(const FileName: WideString): Integer;
-var
- Handle: THandle;
- FindData: TWin32FindDataW;
- LocalFileTime: TFileTime;
-begin
- Handle := Tnt_FindFirstFileW(PWideChar(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;
-
-function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean;
-var
- Handle: THandle;
- FindData: TWin32FindDataW;
- LSystemTime: TSystemTime;
- LocalFileTime: TFileTime;
-begin
- Result := False;
- Handle := Tnt_FindFirstFileW(PWideChar(FileName), FindData);
- if Handle <> INVALID_HANDLE_VALUE then
- begin
- Windows.FindClose(Handle);
- if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
- begin
- Result := True;
- FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
- FileTimeToSystemTime(LocalFileTime, LSystemTime);
- with LSystemTime do
- FileDateTime := EncodeDate(wYear, wMonth, wDay) +
- EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);
- end;
- end;
-end;
-
-function WideDirectoryExists(const Name: WideString): Boolean;
-var
- Code: Cardinal;
-begin
- Code := WideFileGetAttr(Name);
- Result := (Code <> INVALID_FILE_ATTRIBUTES) and ((FILE_ATTRIBUTE_DIRECTORY and Code) <> 0);
-end;
-
-function WideFileExists(const Name: WideString): Boolean;
-var
- Code: Cardinal;
-begin
- Code := WideFileGetAttr(Name);
- Result := (Code <> INVALID_FILE_ATTRIBUTES) and ((FILE_ATTRIBUTE_DIRECTORY and Code) = 0);
-end;
-
-function WideFileGetAttr(const FileName: WideString): Cardinal;
-begin
- Result := Tnt_GetFileAttributesW(PWideChar(FileName));
-end;
-
-function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean;
-begin
- Result := Tnt_SetFileAttributesW(PWideChar(FileName), Attr)
-end;
-
-function WideFileIsReadOnly(const FileName: WideString): Boolean;
-begin
- Result := (Tnt_GetFileAttributesW(PWideChar(FileName)) and faReadOnly) <> 0;
-end;
-
-function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean;
-var
- Flags: Integer;
-begin
- Result := False;
- Flags := Tnt_GetFileAttributesW(PWideChar(FileName));
- if Flags = -1 then Exit;
- if ReadOnly then
- Flags := Flags or faReadOnly
- else
- Flags := Flags and not faReadOnly;
- Result := Tnt_SetFileAttributesW(PWideChar(FileName), Flags);
-end;
-
-function WideForceDirectories(Dir: WideString): Boolean;
-begin
- Result := True;
- if Length(Dir) = 0 then
- raise ETntGeneralError.Create(
- {$IFNDEF FPC} SCannotCreateDir {$ELSE} SCannotCreateEmptyDir {$ENDIF});
- Dir := WideExcludeTrailingBackslash(Dir);
- if (Length(Dir) < 3) or WideDirectoryExists(Dir)
- or (WideExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
- Result := WideForceDirectories(WideExtractFilePath(Dir));
- if Result then
- Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil)
-end;
-
-function WideFileSearch(const Name, DirList: WideString): WideString;
-var
- I, P, L: Integer;
- C: WideChar;
-begin
- Result := Name;
- P := 1;
- L := Length(DirList);
- while True do
- begin
- if WideFileExists(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
- Inc(P);
- Result := Copy(DirList, I, P - I);
- C := TntWideLastChar(Result);
- if (C <> DriveDelim) and (C <> PathDelim) then
- Result := Result + PathDelim;
- Result := Result + Name;
- end;
- Result := '';
-end;
-
-function WideRenameFile(const OldName, NewName: WideString): Boolean;
-begin
- Result := Tnt_MoveFileW(PWideChar(OldName), PWideChar(NewName))
-end;
-
-function WideDeleteFile(const FileName: WideString): Boolean;
-begin
- Result := Tnt_DeleteFileW(PWideChar(FileName))
-end;
-
-function WideCopyFile(const FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean;
-begin
- Result := Tnt_CopyFileW(PWideChar(FromFile), PWideChar(ToFile), FailIfExists)
-end;
-
-function _WideFindMatchingFile(var F: TSearchRecW): Integer;
-var
- LocalFileTime: TFileTime;
-begin
- with F do
- begin
- while FindData.dwFileAttributes and ExcludeAttr <> 0 do
- if not Tnt_FindNextFileW(FindHandle, FindData) then
- begin
- Result := GetLastError;
- Exit;
- end;
- FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
- FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo);
- Size := (Int64(FindData.nFileSizeHigh) shl 32) + FindData.nFileSizeLow;
- Attr := FindData.dwFileAttributes;
- Name := FindData.cFileName;
- end;
- Result := 0;
-end;
-
-function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer;
-const
- faSpecial = faHidden or faSysFile {$IFNDEF COMPILER_9_UP} or faVolumeID {$ENDIF} or faDirectory;
-begin
- F.ExcludeAttr := not Attr and faSpecial;
- F.FindHandle := Tnt_FindFirstFileW(PWideChar(Path), F.FindData);
- if F.FindHandle <> INVALID_HANDLE_VALUE then
- begin
- Result := _WideFindMatchingFile(F);
- if Result <> 0 then WideFindClose(F);
- end else
- Result := GetLastError;
-end;
-
-function WideFindNext(var F: TSearchRecW): Integer;
-begin
- if Tnt_FindNextFileW(F.FindHandle, F.FindData) then
- Result := _WideFindMatchingFile(F) else
- Result := GetLastError;
-end;
-
-procedure WideFindClose(var F: TSearchRecW);
-begin
- if F.FindHandle <> INVALID_HANDLE_VALUE then
- begin
- Windows.FindClose(F.FindHandle);
- F.FindHandle := INVALID_HANDLE_VALUE;
- end;
-end;
-
-function WideCreateDir(const Dir: WideString): Boolean;
-begin
- Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil);
-end;
-
-function WideRemoveDir(const Dir: WideString): Boolean;
-begin
- Result := Tnt_RemoveDirectoryW(PWideChar(Dir));
-end;
-
-function WideGetCurrentDir: WideString;
-begin
- SetLength(Result, MAX_PATH);
- Tnt_GetCurrentDirectoryW(MAX_PATH, PWideChar(Result));
- Result := PWideChar(Result);
-end;
-
-function WideSetCurrentDir(const Dir: WideString): Boolean;
-begin
- Result := Tnt_SetCurrentDirectoryW(PWideChar(Dir));
-end;
-
-//=============================================================================================
-//== DATE/TIME STRING PARSING ================================================================
-//=============================================================================================
-
-{$IFDEF FPC}
-const
- VAR_TIMEVALUEONLY = 1;
- VAR_DATEVALUEONLY = 2;
-{$ENDIF}
-
-function _IntTryStrToDateTime(Str: WideString; Flags: Integer; out DateTime: TDateTime): HResult;
-begin
- Result := VarDateFromStr(
- {$IFDEF FPC} POLECHAR(Str) {$ELSE} Str {$ENDIF},
- GetThreadLocale, Flags, Double(DateTime));
- if (not Succeeded(Result)) then begin
- if (Flags = VAR_TIMEVALUEONLY)
- and SysUtils.TryStrToTime{TNT-ALLOW TryStrToTime}(Str, DateTime) then
- Result := S_OK // SysUtils seems confident (works for date = "dd.MM.yy" and time = "H.mm.ss")
- else if (Flags = VAR_DATEVALUEONLY)
- and SysUtils.TryStrToDate{TNT-ALLOW TryStrToDate}(Str, DateTime) then
- Result := S_OK // SysUtils seems confident
- else if (Flags = 0)
- and SysUtils.TryStrToDateTime{TNT-ALLOW TryStrToDateTime}(Str, DateTime) then
- Result := S_OK // SysUtils seems confident
- end;
-end;
-
-function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean;
-begin
- Result := Succeeded(_IntTryStrToDateTime(Str, 0, DateTime));
-end;
-
-function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean;
-begin
- Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, DateTime));
-end;
-
-function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean;
-begin
- Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, DateTime));
-end;
-
-function ValidDateTimeStr(Str: WideString): Boolean;
-var
- Temp: TDateTime;
-begin
- Result := Succeeded(_IntTryStrToDateTime(Str, 0, Temp));
-end;
-
-function ValidDateStr(Str: WideString): Boolean;
-var
- Temp: TDateTime;
-begin
- Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, Temp));
-end;
-
-function ValidTimeStr(Str: WideString): Boolean;
-var
- Temp: TDateTime;
-begin
- Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, Temp));
-end;
-
-function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime;
-begin
- if not TntTryStrToDateTime(Str, Result) then
- Result := Default;
-end;
-
-function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime;
-begin
- if not TntTryStrToDate(Str, Result) then
- Result := Default;
-end;
-
-function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime;
-begin
- if not TntTryStrToTime(Str, Result) then
- Result := Default;
-end;
-
-function _IntStrToDateTime(Str: WideString; Flags: Integer; ErrorFormatStr: WideString): TDateTime;
-begin
- try
- OleCheck(_IntTryStrToDateTime(Str, Flags, Result));
- except
- on E: Exception do begin
- E.Message := E.Message + CRLF + WideFormat(ErrorFormatStr, [Str]);
- raise EConvertError.Create(E.Message);
- end;
- end;
-end;
-
-function TntStrToDateTime(Str: WideString): TDateTime;
-begin
- Result := _IntStrToDateTime(Str, 0, SInvalidDateTime);
-end;
-
-function TntStrToDate(Str: WideString): TDateTime;
-begin
- Result := _IntStrToDateTime(Str, VAR_DATEVALUEONLY,
- {$IFNDEF FPC} SInvalidDate {$ELSE} SInvalidDateTime {$ENDIF});
-end;
-
-function TntStrToTime(Str: WideString): TDateTime;
-begin
- Result := _IntStrToDateTime(Str, VAR_TIMEVALUEONLY,
- {$IFNDEF FPC} SInvalidTime {$ELSE} SInvalidDateTime {$ENDIF});
-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(
- {$IFDEF FPC} POLECHAR(S) {$ELSE} S {$ENDIF},
- 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(
- {$IFDEF FPC} POLECHAR(S) {$ELSE} S {$ENDIF},
- GetThreadLocale, 0, Dummy));
-end;
-
-function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency;
-begin
- if not Succeeded(VarCyFromStr(
- {$IFDEF FPC} POLECHAR(S) {$ELSE} S {$ENDIF},
- 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 := {$IFNDEF FPC} PWideChar(Currency_DecimalSep)
- {$ELSE} LPTSTR(PWideChar(Currency_DecimalSep)) {$ENDIF};
- Currency_ThousandSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONTHOUSANDSEP, ',');
- Result.lpThousandSep := {$IFNDEF FPC} PWideChar(Currency_ThousandSep)
- {$ELSE} LPTSTR(PWideChar(Currency_ThousandSep)) {$ENDIF};
- 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 := {$IFNDEF FPC} PWideChar(Currency_CurrencySymbol)
- {$ELSE} LPTSTR(PWideChar(Currency_CurrencySymbol)) {$ENDIF};
-end;
-
-//=============================================================================================
-
-{$IFDEF FPC}
-function GetLocaleStr(Locale, LocaleType: Integer; const Default: string): string;
-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}
-
-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;
-
-{$IFNDEF FPC}
-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;
-{$ENDIF}
-
-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.
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-21 00:12:30 +0000