source: cprs/branches/tmg-cprs/TMG_Extra/tntUniCode/Source/TntSysUtils.pas@ 745

Last change on this file since 745 was 672, checked in by Kevin Toppenberg, 15 years ago

Adding source to tntControls for compilation
File size: 53.9 KB
Line 
1
2{*****************************************************************************}
3{ }
4{ Tnt Delphi Unicode Controls }
5{ http://www.tntware.com/delphicontrols/unicode/ }
6{ Version: 2.3.0 }
7{ }
8{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) }
9{ }
10{*****************************************************************************}
11
12unit TntSysUtils;
13
14{$INCLUDE TntCompilers.inc}
15
16interface
17
18{ TODO: Consider: more filename functions from SysUtils }
19{ TODO: Consider: string functions from StrUtils. }
20
21uses
22 Types, SysUtils, Windows;
23
24//---------------------------------------------------------------------------------------------
25// Tnt - Types
26//---------------------------------------------------------------------------------------------
27
28// ......... introduced .........
29type
30 // The user of the application did something plainly wrong.
31 ETntUserError = class(Exception);
32 // A general error occured. (ie. file didn't exist, server didn't return data, etc.)
33 ETntGeneralError = class(Exception);
34 // Like Assert(). An error occured that should never have happened, send me a bug report now!
35 ETntInternalError = class(Exception);
36
37//---------------------------------------------------------------------------------------------
38// Tnt - SysUtils
39//---------------------------------------------------------------------------------------------
40
41// ......... SBCS and MBCS functions with WideString replacements in SysUtils.pas .........
42
43{TNT-WARN CompareStr} {TNT-WARN AnsiCompareStr}
44{TNT-WARN SameStr} {TNT-WARN AnsiSameStr}
45{TNT-WARN SameText} {TNT-WARN AnsiSameText}
46{TNT-WARN CompareText} {TNT-WARN AnsiCompareText}
47{TNT-WARN UpperCase} {TNT-WARN AnsiUpperCase}
48{TNT-WARN LowerCase} {TNT-WARN AnsiLowerCase}
49
50{TNT-WARN AnsiPos} { --> Pos() supports WideString. }
51{TNT-WARN FmtStr}
52{TNT-WARN Format}
53{TNT-WARN FormatBuf}
54
55// ......... MBCS Byte Type Procs .........
56
57{TNT-WARN ByteType}
58{TNT-WARN StrByteType}
59{TNT-WARN ByteToCharIndex}
60{TNT-WARN ByteToCharLen}
61{TNT-WARN CharToByteIndex}
62{TNT-WARN CharToByteLen}
63
64// ........ null-terminated string functions .........
65
66{TNT-WARN StrEnd}
67{TNT-WARN StrLen}
68{TNT-WARN StrLCopy}
69{TNT-WARN StrCopy}
70{TNT-WARN StrECopy}
71{TNT-WARN StrPLCopy}
72{TNT-WARN StrPCopy}
73{TNT-WARN StrLComp}
74{TNT-WARN AnsiStrLComp}
75{TNT-WARN StrComp}
76{TNT-WARN AnsiStrComp}
77{TNT-WARN StrLIComp}
78{TNT-WARN AnsiStrLIComp}
79{TNT-WARN StrIComp}
80{TNT-WARN AnsiStrIComp}
81{TNT-WARN StrLower}
82{TNT-WARN AnsiStrLower}
83{TNT-WARN StrUpper}
84{TNT-WARN AnsiStrUpper}
85{TNT-WARN StrPos}
86{TNT-WARN AnsiStrPos}
87{TNT-WARN StrScan}
88{TNT-WARN AnsiStrScan}
89{TNT-WARN StrRScan}
90{TNT-WARN AnsiStrRScan}
91{TNT-WARN StrLCat}
92{TNT-WARN StrCat}
93{TNT-WARN StrMove}
94{TNT-WARN StrPas}
95{TNT-WARN StrAlloc}
96{TNT-WARN StrBufSize}
97{TNT-WARN StrNew}
98{TNT-WARN StrDispose}
99
100{TNT-WARN AnsiExtractQuotedStr}
101{TNT-WARN AnsiLastChar}
102{TNT-WARN AnsiStrLastChar}
103{TNT-WARN QuotedStr}
104{TNT-WARN AnsiQuotedStr}
105{TNT-WARN AnsiDequotedStr}
106
107// ........ string functions .........
108
109{$IFNDEF COMPILER_9_UP}
110 //
111 // pre-Delphi 9 issues w/ WideFormatBuf, WideFmtStr and WideFormat
112 //
113
114 {$IFDEF COMPILER_7_UP}
115 type
116 PFormatSettings = ^TFormatSettings;
117 {$ENDIF}
118
119 // SysUtils.WideFormatBuf doesn't correctly handle numeric specifiers.
120 function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr;
121 FmtLen: Cardinal; const Args: array of const): Cardinal; {$IFDEF COMPILER_7_UP} overload; {$ENDIF}
122
123 {$IFDEF COMPILER_7_UP}
124 function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr;
125 FmtLen: Cardinal; const Args: array of const;
126 const FormatSettings: TFormatSettings): Cardinal; overload;
127 {$ENDIF}
128
129 // SysUtils.WideFmtStr doesn't handle string lengths > 4096.
130 procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString;
131 const Args: array of const); {$IFDEF COMPILER_7_UP} overload; {$ENDIF}
132
133 {$IFDEF COMPILER_7_UP}
134 procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString;
135 const Args: array of const; const FormatSettings: TFormatSettings); overload;
136 {$ENDIF}
137
138 {----------------------------------------------------------------------------------------
139 Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary...
140 TntSystem.InstallTntSystemUpdates([tsFixWideFormat]);
141 will fix WideFormat as well as WideFmtStr.
142 ----------------------------------------------------------------------------------------}
143 function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString; {$IFDEF COMPILER_7_UP} overload; {$ENDIF}
144
145 {$IFDEF COMPILER_7_UP}
146 function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const;
147 const FormatSettings: TFormatSettings): WideString; overload;
148 {$ENDIF}
149
150{$ENDIF}
151
152{TNT-WARN WideUpperCase} // SysUtils.WideUpperCase is broken on Win9x for D6, D7, D9.
153function Tnt_WideUpperCase(const S: WideString): WideString;
154{TNT-WARN WideLowerCase} // SysUtils.WideLowerCase is broken on Win9x for D6, D7, D9.
155function Tnt_WideLowerCase(const S: WideString): WideString;
156
157function TntWideLastChar(const S: WideString): WideChar;
158
159{TNT-WARN StringReplace}
160{TNT-WARN WideStringReplace} // <-- WideStrUtils.WideStringReplace uses SysUtils.WideUpperCase which is broken on Win9x.
161function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString;
162 Flags: TReplaceFlags; WholeWord: Boolean = False): WideString;
163
164{TNT-WARN AdjustLineBreaks}
165type TTntTextLineBreakStyle = (tlbsLF, tlbsCRLF, tlbsCR);
166function TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer;
167function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString;
168
169{TNT-WARN WrapText}
170function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet;
171 MaxCol: Integer): WideString; overload;
172function WideWrapText(const Line: WideString; MaxCol: Integer): WideString; overload;
173
174// ........ filename manipulation .........
175
176{TNT-WARN SameFileName} // doesn't apply to Unicode filenames, use WideSameText
177{TNT-WARN AnsiCompareFileName} // doesn't apply to Unicode filenames, use WideCompareText
178{TNT-WARN AnsiLowerCaseFileName} // doesn't apply to Unicode filenames, use WideLowerCase
179{TNT-WARN AnsiUpperCaseFileName} // doesn't apply to Unicode filenames, use WideUpperCase
180
181{TNT-WARN IncludeTrailingBackslash}
182function WideIncludeTrailingBackslash(const S: WideString): WideString;
183{TNT-WARN IncludeTrailingPathDelimiter}
184function WideIncludeTrailingPathDelimiter(const S: WideString): WideString;
185{TNT-WARN ExcludeTrailingBackslash}
186function WideExcludeTrailingBackslash(const S: WideString): WideString;
187{TNT-WARN ExcludeTrailingPathDelimiter}
188function WideExcludeTrailingPathDelimiter(const S: WideString): WideString;
189{TNT-WARN IsDelimiter}
190function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean;
191{TNT-WARN IsPathDelimiter}
192function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean;
193{TNT-WARN LastDelimiter}
194function WideLastDelimiter(const Delimiters, S: WideString): Integer;
195{TNT-WARN ChangeFileExt}
196function WideChangeFileExt(const FileName, Extension: WideString): WideString;
197{TNT-WARN ExtractFilePath}
198function WideExtractFilePath(const FileName: WideString): WideString;
199{TNT-WARN ExtractFileDir}
200function WideExtractFileDir(const FileName: WideString): WideString;
201{TNT-WARN ExtractFileDrive}
202function WideExtractFileDrive(const FileName: WideString): WideString;
203{TNT-WARN ExtractFileName}
204function WideExtractFileName(const FileName: WideString): WideString;
205{TNT-WARN ExtractFileExt}
206function WideExtractFileExt(const FileName: WideString): WideString;
207{TNT-WARN ExtractRelativePath}
208function WideExtractRelativePath(const BaseName, DestName: WideString): WideString;
209
210// ........ file management routines .........
211
212{TNT-WARN ExpandFileName}
213function WideExpandFileName(const FileName: WideString): WideString;
214{TNT-WARN ExtractShortPathName}
215function WideExtractShortPathName(const FileName: WideString): WideString;
216{TNT-WARN FileCreate}
217function WideFileCreate(const FileName: WideString): Integer;
218{TNT-WARN FileOpen}
219function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer;
220{TNT-WARN FileAge}
221function WideFileAge(const FileName: WideString): Integer; overload;
222function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean; overload;
223{TNT-WARN DirectoryExists}
224function WideDirectoryExists(const Name: WideString): Boolean;
225{TNT-WARN FileExists}
226function WideFileExists(const Name: WideString): Boolean;
227{TNT-WARN FileGetAttr}
228function WideFileGetAttr(const FileName: WideString): Cardinal;
229{TNT-WARN FileSetAttr}
230function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean;
231{TNT-WARN FileIsReadOnly}
232function WideFileIsReadOnly(const FileName: WideString): Boolean;
233{TNT-WARN FileSetReadOnly}
234function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean;
235{TNT-WARN ForceDirectories}
236function WideForceDirectories(Dir: WideString): Boolean;
237{TNT-WARN FileSearch}
238function WideFileSearch(const Name, DirList: WideString): WideString;
239{TNT-WARN RenameFile}
240function WideRenameFile(const OldName, NewName: WideString): Boolean;
241{TNT-WARN DeleteFile}
242function WideDeleteFile(const FileName: WideString): Boolean;
243{TNT-WARN CopyFile}
244function WideCopyFile(FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean;
245
246
247{TNT-WARN TFileName}
248type
249 TWideFileName = type WideString;
250
251{TNT-WARN TSearchRec} // <-- FindFile - warning on TSearchRec is all that is necessary
252type
253 TSearchRecW = record
254 Time: Integer;
255 Size: Int64;
256 Attr: Integer;
257 Name: TWideFileName;
258 ExcludeAttr: Integer;
259 FindHandle: THandle;
260 FindData: TWin32FindDataW;
261 end;
262function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer;
263function WideFindNext(var F: TSearchRecW): Integer;
264procedure WideFindClose(var F: TSearchRecW);
265
266{TNT-WARN CreateDir}
267function WideCreateDir(const Dir: WideString): Boolean;
268{TNT-WARN RemoveDir}
269function WideRemoveDir(const Dir: WideString): Boolean;
270{TNT-WARN GetCurrentDir}
271function WideGetCurrentDir: WideString;
272{TNT-WARN SetCurrentDir}
273function WideSetCurrentDir(const Dir: WideString): Boolean;
274
275
276// ........ date/time functions .........
277
278{TNT-WARN TryStrToDateTime}
279function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean;
280{TNT-WARN TryStrToDate}
281function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean;
282{TNT-WARN TryStrToTime}
283function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean;
284
285{ introduced }
286function ValidDateTimeStr(Str: WideString): Boolean;
287function ValidDateStr(Str: WideString): Boolean;
288function ValidTimeStr(Str: WideString): Boolean;
289
290{TNT-WARN StrToDateTime}
291function TntStrToDateTime(Str: WideString): TDateTime;
292{TNT-WARN StrToDate}
293function TntStrToDate(Str: WideString): TDateTime;
294{TNT-WARN StrToTime}
295function TntStrToTime(Str: WideString): TDateTime;
296{TNT-WARN StrToDateTimeDef}
297function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime;
298{TNT-WARN StrToDateDef}
299function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime;
300{TNT-WARN StrToTimeDef}
301function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime;
302
303{TNT-WARN CurrToStr}
304{TNT-WARN CurrToStrF}
305function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString;
306{TNT-WARN StrToCurr}
307function TntStrToCurr(const S: WideString): Currency;
308{TNT-WARN StrToCurrDef}
309function ValidCurrencyStr(const S: WideString): Boolean;
310function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency;
311function GetDefaultCurrencyFmt: TCurrencyFmtW;
312
313// ........ misc functions .........
314
315{TNT-WARN GetLocaleStr}
316function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString;
317{TNT-WARN SysErrorMessage}
318function WideSysErrorMessage(ErrorCode: Integer): WideString;
319
320// ......... introduced .........
321
322function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString;
323
324const
325 CR = WideChar(#13);
326 LF = WideChar(#10);
327 CRLF = WideString(#13#10);
328 WideLineSeparator = WideChar($2028);
329
330var
331 Win32PlatformIsUnicode: Boolean;
332 Win32PlatformIsXP: Boolean;
333 Win32PlatformIs2003: Boolean;
334 Win32PlatformIsVista: Boolean;
335
336{$IFNDEF COMPILER_7_UP}
337function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean;
338{$ENDIF}
339function WinCheckH(RetVal: Cardinal): Cardinal;
340function WinCheckFileH(RetVal: Cardinal): Cardinal;
341function WinCheckP(RetVal: Pointer): Pointer;
342
343function WideGetModuleFileName(Instance: HModule): WideString;
344function WideSafeLoadLibrary(const Filename: Widestring;
345 ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE;
346function WideLoadPackage(const Name: Widestring): HMODULE;
347
348function IsWideCharUpper(WC: WideChar): Boolean;
349function IsWideCharLower(WC: WideChar): Boolean;
350function IsWideCharDigit(WC: WideChar): Boolean;
351function IsWideCharSpace(WC: WideChar): Boolean;
352function IsWideCharPunct(WC: WideChar): Boolean;
353function IsWideCharCntrl(WC: WideChar): Boolean;
354function IsWideCharBlank(WC: WideChar): Boolean;
355function IsWideCharXDigit(WC: WideChar): Boolean;
356function IsWideCharAlpha(WC: WideChar): Boolean;
357function IsWideCharAlphaNumeric(WC: WideChar): Boolean;
358
359function WideTextPos(const SubStr, S: WideString): Integer;
360
361function ExtractStringArrayStr(P: PWideChar): WideString;
362function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString;
363function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray;
364
365function IsWideCharMappableToAnsi(const WC: WideChar): Boolean;
366function IsWideStringMappableToAnsi(const WS: WideString): Boolean;
367function IsRTF(const Value: WideString): Boolean;
368
369function ENG_US_FloatToStr(Value: Extended): WideString;
370function ENG_US_StrToFloat(const S: WideString): Extended;
371
372//---------------------------------------------------------------------------------------------
373// Tnt - Variants
374//---------------------------------------------------------------------------------------------
375
376// ........ Variants.pas has WideString versions of these functions .........
377{TNT-WARN VarToStr}
378{TNT-WARN VarToStrDef}
379
380var
381 _SettingChangeTime: Cardinal;
382
383implementation
384
385uses
386 ActiveX, ComObj, SysConst,
387 {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils,
388 TntSystem, TntWindows, TntFormatStrUtils;
389
390//---------------------------------------------------------------------------------------------
391// Tnt - SysUtils
392//---------------------------------------------------------------------------------------------
393
394{$IFNDEF COMPILER_9_UP}
395
396 function _Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr;
397 FmtLen: Cardinal; const Args: array of const
398 {$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings {$ENDIF}): Cardinal;
399 var
400 OldFormat: WideString;
401 NewFormat: WideString;
402 begin
403 SetString(OldFormat, PWideChar(@FormatStr), FmtLen);
404 { The reason for this is that WideFormat doesn't correctly format floating point specifiers.
405 See QC#4254. }
406 NewFormat := ReplaceFloatingArgumentsInFormatString(OldFormat, Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF});
407 {$IFDEF COMPILER_7_UP}
408 if FormatSettings <> nil then
409 Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^,
410 Length(NewFormat), Args, FormatSettings^)
411 else
412 {$ENDIF}
413 Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^,
414 Length(NewFormat), Args);
415 end;
416
417 function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr;
418 FmtLen: Cardinal; const Args: array of const): Cardinal;
419 begin
420 Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF});
421 end;
422
423 {$IFDEF COMPILER_7_UP}
424 function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr;
425 FmtLen: Cardinal; const Args: array of const; const FormatSettings: TFormatSettings): Cardinal;
426 begin
427 Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args, @FormatSettings);
428 end;
429 {$ENDIF}
430
431 procedure _Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString;
432 const Args: array of const{$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings{$ENDIF});
433 var
434 Len, BufLen: Integer;
435 Buffer: array[0..4095] of WideChar;
436 begin
437 BufLen := Length(Buffer); // Fixes buffer overwrite issue. (See QC #4703, #4744)
438 if Length(FormatStr) < (Length(Buffer) - (Length(Buffer) div 4)) then
439 Len := _Tnt_WideFormatBuf(Buffer, Length(Buffer) - 1, Pointer(FormatStr)^,
440 Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF})
441 else
442 begin
443 BufLen := Length(FormatStr);
444 Len := BufLen;
445 end;
446 if Len >= BufLen - 1 then
447 begin
448 while Len >= BufLen - 1 do
449 begin
450 Inc(BufLen, BufLen);
451 Result := ''; // prevent copying of existing data, for speed
452 SetLength(Result, BufLen);
453 Len := _Tnt_WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(FormatStr)^,
454 Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF});
455 end;
456 SetLength(Result, Len);
457 end
458 else
459 SetString(Result, Buffer, Len);
460 end;
461
462 procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString;
463 const Args: array of const);
464 begin
465 _Tnt_WideFmtStr(Result, FormatStr, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF});
466 end;
467
468 {$IFDEF COMPILER_7_UP}
469 procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString;
470 const Args: array of const; const FormatSettings: TFormatSettings);
471 begin
472 _Tnt_WideFmtStr(Result, FormatStr, Args, @FormatSettings);
473 end;
474 {$ENDIF}
475
476 {----------------------------------------------------------------------------------------
477 Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary...
478 TntSystem.InstallTntSystemUpdates([tsFixWideFormat]);
479 will fix WideFormat as well as WideFmtStr.
480 ----------------------------------------------------------------------------------------}
481 function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString;
482 begin
483 Tnt_WideFmtStr(Result, FormatStr, Args);
484 end;
485
486 {$IFDEF COMPILER_7_UP}
487 function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const;
488 const FormatSettings: TFormatSettings): WideString;
489 begin
490 Tnt_WideFmtStr(Result, FormatStr, Args, FormatSettings);
491 end;
492 {$ENDIF}
493
494{$ENDIF}
495
496function Tnt_WideUpperCase(const S: WideString): WideString;
497begin
498 {$IFNDEF COMPILER_10_UP}
499 { SysUtils.WideUpperCase is broken for Win9x. }
500 Result := S;
501 if Length(Result) > 0 then
502 Tnt_CharUpperBuffW(PWideChar(Result), Length(Result));
503 {$ELSE}
504 Result := SysUtils.WideUpperCase{TNT-ALLOW WideUpperCase}(S);
505 {$ENDIF}
506end;
507
508function Tnt_WideLowerCase(const S: WideString): WideString;
509begin
510 {$IFNDEF COMPILER_10_UP}
511 { SysUtils.WideLowerCase is broken for Win9x. }
512 Result := S;
513 if Length(Result) > 0 then
514 Tnt_CharLowerBuffW(PWideChar(Result), Length(Result));
515 {$ELSE}
516 Result := SysUtils.WideLowerCase{TNT-ALLOW WideLowerCase}(S);
517 {$ENDIF}
518end;
519
520function TntWideLastChar(const S: WideString): WideChar;
521var
522 P: PWideChar;
523begin
524 P := WideLastChar(S);
525 if P = nil then
526 Result := #0
527 else
528 Result := P^;
529end;
530
531function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString;
532 Flags: TReplaceFlags; WholeWord: Boolean = False): WideString;
533
534 function IsWordSeparator(WC: WideChar): Boolean;
535 begin
536 Result := (WC = WideChar(#0))
537 or IsWideCharSpace(WC)
538 or IsWideCharPunct(WC);
539 end;
540
541var
542 SearchStr, Patt, NewStr: WideString;
543 Offset: Integer;
544 PrevChar, NextChar: WideChar;
545begin
546 if rfIgnoreCase in Flags then
547 begin
548 SearchStr := Tnt_WideUpperCase(S);
549 Patt := Tnt_WideUpperCase(OldPattern);
550 end else
551 begin
552 SearchStr := S;
553 Patt := OldPattern;
554 end;
555 NewStr := S;
556 Result := '';
557 while SearchStr <> '' do
558 begin
559 Offset := Pos(Patt, SearchStr);
560 if Offset = 0 then
561 begin
562 Result := Result + NewStr;
563 Break;
564 end; // done
565
566 if (WholeWord) then
567 begin
568 if (Offset = 1) then
569 PrevChar := TntWideLastChar(Result)
570 else
571 PrevChar := NewStr[Offset - 1];
572
573 if Offset + Length(OldPattern) <= Length(NewStr) then
574 NextChar := NewStr[Offset + Length(OldPattern)]
575 else
576 NextChar := WideChar(#0);
577
578 if (not IsWordSeparator(PrevChar))
579 or (not IsWordSeparator(NextChar)) then
580 begin
581 Result := Result + Copy(NewStr, 1, Offset + Length(OldPattern) - 1);
582 NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
583 SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
584 continue;
585 end;
586 end;
587
588 Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;
589 NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
590 if not (rfReplaceAll in Flags) then
591 begin
592 Result := Result + NewStr;
593 Break;
594 end;
595 SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
596 end;
597end;
598
599function TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer;
600var
601 Source, SourceEnd: PWideChar;
602begin
603 Source := Pointer(S);
604 SourceEnd := Source + Length(S);
605 Result := Length(S);
606 while Source < SourceEnd do
607 begin
608 case Source^ of
609 #10, WideLineSeparator:
610 if Style = tlbsCRLF then
611 Inc(Result);
612 #13:
613 if Style = tlbsCRLF then
614 if Source[1] = #10 then
615 Inc(Source)
616 else
617 Inc(Result)
618 else
619 if Source[1] = #10 then
620 Dec(Result);
621 end;
622 Inc(Source);
623 end;
624end;
625
626function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString;
627var
628 Source, SourceEnd, Dest: PWideChar;
629 DestLen: Integer;
630begin
631 Source := Pointer(S);
632 SourceEnd := Source + Length(S);
633 DestLen := TntAdjustLineBreaksLength(S, Style);
634 SetString(Result, nil, DestLen);
635 Dest := Pointer(Result);
636 while Source < SourceEnd do begin
637 case Source^ of
638 #10, WideLineSeparator:
639 begin
640 if Style in [tlbsCRLF, tlbsCR] then
641 begin
642 Dest^ := #13;
643 Inc(Dest);
644 end;
645 if Style in [tlbsCRLF, tlbsLF] then
646 begin
647 Dest^ := #10;
648 Inc(Dest);
649 end;
650 Inc(Source);
651 end;
652 #13:
653 begin
654 if Style in [tlbsCRLF, tlbsCR] then
655 begin
656 Dest^ := #13;
657 Inc(Dest);
658 end;
659 if Style in [tlbsCRLF, tlbsLF] then
660 begin
661 Dest^ := #10;
662 Inc(Dest);
663 end;
664 Inc(Source);
665 if Source^ = #10 then Inc(Source);
666 end;
667 else
668 Dest^ := Source^;
669 Inc(Dest);
670 Inc(Source);
671 end;
672 end;
673end;
674
675function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet;
676 MaxCol: Integer): WideString;
677
678 function WideCharIn(C: WideChar; SysCharSet: TSysCharSet): Boolean;
679 begin
680 Result := (C <= High(AnsiChar)) and (AnsiChar(C) in SysCharSet);
681 end;
682
683const
684 QuoteChars = ['''', '"'];
685var
686 Col, Pos: Integer;
687 LinePos, LineLen: Integer;
688 BreakLen, BreakPos: Integer;
689 QuoteChar, CurChar: WideChar;
690 ExistingBreak: Boolean;
691begin
692 Col := 1;
693 Pos := 1;
694 LinePos := 1;
695 BreakPos := 0;
696 QuoteChar := ' ';
697 ExistingBreak := False;
698 LineLen := Length(Line);
699 BreakLen := Length(BreakStr);
700 Result := '';
701 while Pos <= LineLen do
702 begin
703 CurChar := Line[Pos];
704 if CurChar = BreakStr[1] then
705 begin
706 if QuoteChar = ' ' then
707 begin
708 ExistingBreak := WideSameText(BreakStr, Copy(Line, Pos, BreakLen));
709 if ExistingBreak then
710 begin
711 Inc(Pos, BreakLen-1);
712 BreakPos := Pos;
713 end;
714 end
715 end
716 else if WideCharIn(CurChar, BreakChars) then
717 begin
718 if QuoteChar = ' ' then BreakPos := Pos
719 end
720 else if WideCharIn(CurChar, QuoteChars) then
721 begin
722 if CurChar = QuoteChar then
723 QuoteChar := ' '
724 else if QuoteChar = ' ' then
725 QuoteChar := CurChar;
726 end;
727 Inc(Pos);
728 Inc(Col);
729 if not (WideCharIn(QuoteChar, QuoteChars)) and (ExistingBreak or
730 ((Col > MaxCol) and (BreakPos > LinePos))) then
731 begin
732 Col := Pos - BreakPos;
733 Result := Result + Copy(Line, LinePos, BreakPos - LinePos + 1);
734 if not (WideCharIn(CurChar, QuoteChars)) then
735 while Pos <= LineLen do
736 begin
737 if WideCharIn(Line[Pos], BreakChars) then
738 Inc(Pos)
739 else if Copy(Line, Pos, Length(sLineBreak)) = sLineBreak then
740 Inc(Pos, Length(sLineBreak))
741 else
742 break;
743 end;
744 if not ExistingBreak and (Pos < LineLen) then
745 Result := Result + BreakStr;
746 Inc(BreakPos);
747 LinePos := BreakPos;
748 ExistingBreak := False;
749 end;
750 end;
751 Result := Result + Copy(Line, LinePos, MaxInt);
752end;
753
754function WideWrapText(const Line: WideString; MaxCol: Integer): WideString;
755begin
756 Result := WideWrapText(Line, sLineBreak, [' ', '-', #9], MaxCol); { do not localize }
757end;
758
759function WideIncludeTrailingBackslash(const S: WideString): WideString;
760begin
761 Result := WideIncludeTrailingPathDelimiter(S);
762end;
763
764function WideIncludeTrailingPathDelimiter(const S: WideString): WideString;
765begin
766 Result := S;
767 if not WideIsPathDelimiter(Result, Length(Result)) then Result := Result + PathDelim;
768end;
769
770function WideExcludeTrailingBackslash(const S: WideString): WideString;
771begin
772 Result := WideExcludeTrailingPathDelimiter(S);
773end;
774
775function WideExcludeTrailingPathDelimiter(const S: WideString): WideString;
776begin
777 Result := S;
778 if WideIsPathDelimiter(Result, Length(Result)) then
779 SetLength(Result, Length(Result)-1);
780end;
781
782function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean;
783begin
784 Result := False;
785 if (Index <= 0) or (Index > Length(S)) then exit;
786 Result := WStrScan(PWideChar(Delimiters), S[Index]) <> nil;
787end;
788
789function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean;
790begin
791 Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = PathDelim);
792end;
793
794function WideLastDelimiter(const Delimiters, S: WideString): Integer;
795var
796 P: PWideChar;
797begin
798 Result := Length(S);
799 P := PWideChar(Delimiters);
800 while Result > 0 do
801 begin
802 if (S[Result] <> #0) and (WStrScan(P, S[Result]) <> nil) then
803 Exit;
804 Dec(Result);
805 end;
806end;
807
808function WideChangeFileExt(const FileName, Extension: WideString): WideString;
809var
810 I: Integer;
811begin
812 I := WideLastDelimiter('.\:',Filename);
813 if (I = 0) or (FileName[I] <> '.') then I := MaxInt;
814 Result := Copy(FileName, 1, I - 1) + Extension;
815end;
816
817function WideExtractFilePath(const FileName: WideString): WideString;
818var
819 I: Integer;
820begin
821 I := WideLastDelimiter('\:', FileName);
822 Result := Copy(FileName, 1, I);
823end;
824
825function WideExtractFileDir(const FileName: WideString): WideString;
826var
827 I: Integer;
828begin
829 I := WideLastDelimiter(DriveDelim + PathDelim,Filename);
830 if (I > 1) and (FileName[I] = PathDelim) and
831 (not (FileName[I - 1] in [WideChar(PathDelim), WideChar(DriveDelim)])) then Dec(I);
832 Result := Copy(FileName, 1, I);
833end;
834
835function WideExtractFileDrive(const FileName: WideString): WideString;
836var
837 I, J: Integer;
838begin
839 if (Length(FileName) >= 2) and (FileName[2] = DriveDelim) then
840 Result := Copy(FileName, 1, 2)
841 else if (Length(FileName) >= 2) and (FileName[1] = PathDelim) and
842 (FileName[2] = PathDelim) then
843 begin
844 J := 0;
845 I := 3;
846 While (I < Length(FileName)) and (J < 2) do
847 begin
848 if FileName[I] = PathDelim then Inc(J);
849 if J < 2 then Inc(I);
850 end;
851 if FileName[I] = PathDelim then Dec(I);
852 Result := Copy(FileName, 1, I);
853 end else Result := '';
854end;
855
856function WideExtractFileName(const FileName: WideString): WideString;
857var
858 I: Integer;
859begin
860 I := WideLastDelimiter('\:', FileName);
861 Result := Copy(FileName, I + 1, MaxInt);
862end;
863
864function WideExtractFileExt(const FileName: WideString): WideString;
865var
866 I: Integer;
867begin
868 I := WideLastDelimiter('.\:', FileName);
869 if (I > 0) and (FileName[I] = '.') then
870 Result := Copy(FileName, I, MaxInt) else
871 Result := '';
872end;
873
874function WideExtractRelativePath(const BaseName, DestName: WideString): WideString;
875var
876 BasePath, DestPath: WideString;
877 BaseLead, DestLead: PWideChar;
878 BasePtr, DestPtr: PWideChar;
879
880 function WideExtractFilePathNoDrive(const FileName: WideString): WideString;
881 begin
882 Result := WideExtractFilePath(FileName);
883 Delete(Result, 1, Length(WideExtractFileDrive(FileName)));
884 end;
885
886 function Next(var Lead: PWideChar): PWideChar;
887 begin
888 Result := Lead;
889 if Result = nil then Exit;
890 Lead := WStrScan(Lead, PathDelim);
891 if Lead <> nil then
892 begin
893 Lead^ := #0;
894 Inc(Lead);
895 end;
896 end;
897
898begin
899 if WideSameText(WideExtractFileDrive(BaseName), WideExtractFileDrive(DestName)) then
900 begin
901 BasePath := WideExtractFilePathNoDrive(BaseName);
902 DestPath := WideExtractFilePathNoDrive(DestName);
903 BaseLead := Pointer(BasePath);
904 BasePtr := Next(BaseLead);
905 DestLead := Pointer(DestPath);
906 DestPtr := Next(DestLead);
907 while (BasePtr <> nil) and (DestPtr <> nil) and WideSameText(BasePtr, DestPtr) do
908 begin
909 BasePtr := Next(BaseLead);
910 DestPtr := Next(DestLead);
911 end;
912 Result := '';
913 while BaseLead <> nil do
914 begin
915 Result := Result + '..' + PathDelim; { Do not localize }
916 Next(BaseLead);
917 end;
918 if (DestPtr <> nil) and (DestPtr^ <> #0) then
919 Result := Result + DestPtr + PathDelim;
920 if DestLead <> nil then
921 Result := Result + DestLead; // destlead already has a trailing backslash
922 Result := Result + WideExtractFileName(DestName);
923 end
924 else
925 Result := DestName;
926end;
927
928function WideExpandFileName(const FileName: WideString): WideString;
929var
930 FName: PWideChar;
931 Buffer: array[0..MAX_PATH - 1] of WideChar;
932begin
933 SetString(Result, Buffer, Tnt_GetFullPathNameW(PWideChar(FileName), MAX_PATH, Buffer, FName));
934end;
935
936function WideExtractShortPathName(const FileName: WideString): WideString;
937var
938 Buffer: array[0..MAX_PATH - 1] of WideChar;
939begin
940 SetString(Result, Buffer, Tnt_GetShortPathNameW(PWideChar(FileName), Buffer, MAX_PATH));
941end;
942
943function WideFileCreate(const FileName: WideString): Integer;
944begin
945 Result := Integer(Tnt_CreateFileW(PWideChar(FileName), GENERIC_READ or GENERIC_WRITE,
946 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0))
947end;
948
949function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer;
950const
951 AccessMode: array[0..2] of LongWord = (
952 GENERIC_READ,
953 GENERIC_WRITE,
954 GENERIC_READ or GENERIC_WRITE);
955 ShareMode: array[0..4] of LongWord = (
956 0,
957 0,
958 FILE_SHARE_READ,
959 FILE_SHARE_WRITE,
960 FILE_SHARE_READ or FILE_SHARE_WRITE);
961begin
962 Result := Integer(Tnt_CreateFileW(PWideChar(FileName), AccessMode[Mode and 3],
963 ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING,
964 FILE_ATTRIBUTE_NORMAL, 0));
965end;
966
967function WideFileAge(const FileName: WideString): Integer;
968var
969 Handle: THandle;
970 FindData: TWin32FindDataW;
971 LocalFileTime: TFileTime;
972begin
973 Handle := Tnt_FindFirstFileW(PWideChar(FileName), FindData);
974 if Handle <> INVALID_HANDLE_VALUE then
975 begin
976 Windows.FindClose(Handle);
977 if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
978 begin
979 FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
980 if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi, LongRec(Result).Lo) then
981 Exit
982 end;
983 end;
984 Result := -1;
985end;
986
987function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean;
988var
989 Handle: THandle;
990 FindData: TWin32FindDataW;
991 LSystemTime: TSystemTime;
992 LocalFileTime: TFileTime;
993begin
994 Result := False;
995 Handle := Tnt_FindFirstFileW(PWideChar(FileName), FindData);
996 if Handle <> INVALID_HANDLE_VALUE then
997 begin
998 Windows.FindClose(Handle);
999 if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
1000 begin
1001 Result := True;
1002 FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
1003 FileTimeToSystemTime(LocalFileTime, LSystemTime);
1004 with LSystemTime do
1005 FileDateTime := EncodeDate(wYear, wMonth, wDay) +
1006 EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);
1007 end;
1008 end;
1009end;
1010
1011function WideDirectoryExists(const Name: WideString): Boolean;
1012var
1013 Code: Cardinal;
1014begin
1015 Code := WideFileGetAttr(Name);
1016 Result := (Code <> INVALID_FILE_ATTRIBUTES) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
1017end;
1018
1019function WideFileExists(const Name: WideString): Boolean;
1020var
1021 Handle: THandle;
1022 FindData: TWin32FindDataW;
1023begin
1024 Result := False;
1025 Handle := Tnt_FindFirstFileW(PWideChar(Name), FindData);
1026 if Handle <> INVALID_HANDLE_VALUE then
1027 begin
1028 Windows.FindClose(Handle);
1029 if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
1030 Result := True;
1031 end;
1032end;
1033
1034function WideFileGetAttr(const FileName: WideString): Cardinal;
1035begin
1036 Result := Tnt_GetFileAttributesW(PWideChar(FileName));
1037end;
1038
1039function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean;
1040begin
1041 Result := Tnt_SetFileAttributesW(PWideChar(FileName), Attr)
1042end;
1043
1044function WideFileIsReadOnly(const FileName: WideString): Boolean;
1045begin
1046 Result := (Tnt_GetFileAttributesW(PWideChar(FileName)) and faReadOnly) <> 0;
1047end;
1048
1049function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean;
1050var
1051 Flags: Integer;
1052begin
1053 Result := False;
1054 Flags := Tnt_GetFileAttributesW(PWideChar(FileName));
1055 if Flags = -1 then Exit;
1056 if ReadOnly then
1057 Flags := Flags or faReadOnly
1058 else
1059 Flags := Flags and not faReadOnly;
1060 Result := Tnt_SetFileAttributesW(PWideChar(FileName), Flags);
1061end;
1062
1063function WideForceDirectories(Dir: WideString): Boolean;
1064begin
1065 Result := True;
1066 if Length(Dir) = 0 then
1067 raise ETntGeneralError.Create(SCannotCreateDir);
1068 Dir := WideExcludeTrailingBackslash(Dir);
1069 if (Length(Dir) < 3) or WideDirectoryExists(Dir)
1070 or (WideExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
1071 Result := WideForceDirectories(WideExtractFilePath(Dir));
1072 if Result then
1073 Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil)
1074end;
1075
1076function WideFileSearch(const Name, DirList: WideString): WideString;
1077var
1078 I, P, L: Integer;
1079 C: WideChar;
1080begin
1081 Result := Name;
1082 P := 1;
1083 L := Length(DirList);
1084 while True do
1085 begin
1086 if WideFileExists(Result) then Exit;
1087 while (P <= L) and (DirList[P] = PathSep) do Inc(P);
1088 if P > L then Break;
1089 I := P;
1090 while (P <= L) and (DirList[P] <> PathSep) do
1091 Inc(P);
1092 Result := Copy(DirList, I, P - I);
1093 C := TntWideLastChar(Result);
1094 if (C <> DriveDelim) and (C <> PathDelim) then
1095 Result := Result + PathDelim;
1096 Result := Result + Name;
1097 end;
1098 Result := '';
1099end;
1100
1101function WideRenameFile(const OldName, NewName: WideString): Boolean;
1102begin
1103 Result := Tnt_MoveFileW(PWideChar(OldName), PWideChar(NewName))
1104end;
1105
1106function WideDeleteFile(const FileName: WideString): Boolean;
1107begin
1108 Result := Tnt_DeleteFileW(PWideChar(FileName))
1109end;
1110
1111function WideCopyFile(FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean;
1112begin
1113 Result := Tnt_CopyFileW(PWideChar(FromFile), PWideChar(ToFile), FailIfExists)
1114end;
1115
1116function _WideFindMatchingFile(var F: TSearchRecW): Integer;
1117var
1118 LocalFileTime: TFileTime;
1119begin
1120 with F do
1121 begin
1122 while FindData.dwFileAttributes and ExcludeAttr <> 0 do
1123 if not Tnt_FindNextFileW(FindHandle, FindData) then
1124 begin
1125 Result := GetLastError;
1126 Exit;
1127 end;
1128 FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
1129 FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo);
1130 Size := (Int64(FindData.nFileSizeHigh) shl 32) + FindData.nFileSizeLow;
1131 Attr := FindData.dwFileAttributes;
1132 Name := FindData.cFileName;
1133 end;
1134 Result := 0;
1135end;
1136
1137function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer;
1138const
1139 faSpecial = faHidden or faSysFile {$IFNDEF COMPILER_9_UP} or faVolumeID {$ENDIF} or faDirectory;
1140begin
1141 F.ExcludeAttr := not Attr and faSpecial;
1142 F.FindHandle := Tnt_FindFirstFileW(PWideChar(Path), F.FindData);
1143 if F.FindHandle <> INVALID_HANDLE_VALUE then
1144 begin
1145 Result := _WideFindMatchingFile(F);
1146 if Result <> 0 then WideFindClose(F);
1147 end else
1148 Result := GetLastError;
1149end;
1150
1151function WideFindNext(var F: TSearchRecW): Integer;
1152begin
1153 if Tnt_FindNextFileW(F.FindHandle, F.FindData) then
1154 Result := _WideFindMatchingFile(F) else
1155 Result := GetLastError;
1156end;
1157
1158procedure WideFindClose(var F: TSearchRecW);
1159begin
1160 if F.FindHandle <> INVALID_HANDLE_VALUE then
1161 begin
1162 Windows.FindClose(F.FindHandle);
1163 F.FindHandle := INVALID_HANDLE_VALUE;
1164 end;
1165end;
1166
1167function WideCreateDir(const Dir: WideString): Boolean;
1168begin
1169 Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil);
1170end;
1171
1172function WideRemoveDir(const Dir: WideString): Boolean;
1173begin
1174 Result := Tnt_RemoveDirectoryW(PWideChar(Dir));
1175end;
1176
1177function WideGetCurrentDir: WideString;
1178begin
1179 SetLength(Result, MAX_PATH);
1180 Tnt_GetCurrentDirectoryW(MAX_PATH, PWideChar(Result));
1181 Result := PWideChar(Result);
1182end;
1183
1184function WideSetCurrentDir(const Dir: WideString): Boolean;
1185begin
1186 Result := Tnt_SetCurrentDirectoryW(PWideChar(Dir));
1187end;
1188
1189//=============================================================================================
1190//== DATE/TIME STRING PARSING ================================================================
1191//=============================================================================================
1192
1193function _IntTryStrToDateTime(Str: WideString; Flags: Integer; out DateTime: TDateTime): HResult;
1194begin
1195 Result := VarDateFromStr(Str, GetThreadLocale, Flags, Double(DateTime));
1196 if (not Succeeded(Result)) then begin
1197 if (Flags = VAR_TIMEVALUEONLY)
1198 and SysUtils.TryStrToTime{TNT-ALLOW TryStrToTime}(Str, DateTime) then
1199 Result := S_OK // SysUtils seems confident (works for date = "dd.MM.yy" and time = "H.mm.ss")
1200 else if (Flags = VAR_DATEVALUEONLY)
1201 and SysUtils.TryStrToDate{TNT-ALLOW TryStrToDate}(Str, DateTime) then
1202 Result := S_OK // SysUtils seems confident
1203 else if (Flags = 0)
1204 and SysUtils.TryStrToDateTime{TNT-ALLOW TryStrToDateTime}(Str, DateTime) then
1205 Result := S_OK // SysUtils seems confident
1206 end;
1207end;
1208
1209function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean;
1210begin
1211 Result := Succeeded(_IntTryStrToDateTime(Str, 0, DateTime));
1212end;
1213
1214function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean;
1215begin
1216 Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, DateTime));
1217end;
1218
1219function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean;
1220begin
1221 Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, DateTime));
1222end;
1223
1224function ValidDateTimeStr(Str: WideString): Boolean;
1225var
1226 Temp: TDateTime;
1227begin
1228 Result := Succeeded(_IntTryStrToDateTime(Str, 0, Temp));
1229end;
1230
1231function ValidDateStr(Str: WideString): Boolean;
1232var
1233 Temp: TDateTime;
1234begin
1235 Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, Temp));
1236end;
1237
1238function ValidTimeStr(Str: WideString): Boolean;
1239var
1240 Temp: TDateTime;
1241begin
1242 Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, Temp));
1243end;
1244
1245function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime;
1246begin
1247 if not TntTryStrToDateTime(Str, Result) then
1248 Result := Default;
1249end;
1250
1251function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime;
1252begin
1253 if not TntTryStrToDate(Str, Result) then
1254 Result := Default;
1255end;
1256
1257function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime;
1258begin
1259 if not TntTryStrToTime(Str, Result) then
1260 Result := Default;
1261end;
1262
1263function _IntStrToDateTime(Str: WideString; Flags: Integer; ErrorFormatStr: WideString): TDateTime;
1264begin
1265 try
1266 OleCheck(_IntTryStrToDateTime(Str, Flags, Result));
1267 except
1268 on E: Exception do begin
1269 E.Message := E.Message + CRLF + WideFormat(ErrorFormatStr, [Str]);
1270 raise EConvertError.Create(E.Message);
1271 end;
1272 end;
1273end;
1274
1275function TntStrToDateTime(Str: WideString): TDateTime;
1276begin
1277 Result := _IntStrToDateTime(Str, 0, SInvalidDateTime);
1278end;
1279
1280function TntStrToDate(Str: WideString): TDateTime;
1281begin
1282 Result := _IntStrToDateTime(Str, VAR_DATEVALUEONLY, SInvalidDate);
1283end;
1284
1285function TntStrToTime(Str: WideString): TDateTime;
1286begin
1287 Result := _IntStrToDateTime(Str, VAR_TIMEVALUEONLY, SInvalidTime);
1288end;
1289
1290//=============================================================================================
1291//== CURRENCY STRING PARSING =================================================================
1292//=============================================================================================
1293
1294function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString;
1295const
1296 MAX_BUFF_SIZE = 64; // can a currency string actually be larger?
1297var
1298 ValueStr: WideString;
1299begin
1300 // format lpValue using ENG-US settings
1301 ValueStr := ENG_US_FloatToStr(Value);
1302 // get currency format
1303 SetLength(Result, MAX_BUFF_SIZE);
1304 if 0 = Tnt_GetCurrencyFormatW(GetThreadLocale, 0, PWideChar(ValueStr),
1305 lpFormat, PWideChar(Result), Length(Result))
1306 then begin
1307 RaiseLastOSError;
1308 end;
1309 Result := PWideChar(Result);
1310end;
1311
1312function TntStrToCurr(const S: WideString): Currency;
1313begin
1314 try
1315 OleCheck(VarCyFromStr(S, GetThreadLocale, 0, Result));
1316 except
1317 on E: Exception do begin
1318 E.Message := E.Message + CRLF + WideFormat(SInvalidCurrency, [S]);
1319 raise EConvertError.Create(E.Message);
1320 end;
1321 end;
1322end;
1323
1324function ValidCurrencyStr(const S: WideString): Boolean;
1325var
1326 Dummy: Currency;
1327begin
1328 Result := Succeeded(VarCyFromStr(S, GetThreadLocale, 0, Dummy));
1329end;
1330
1331function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency;
1332begin
1333 if not Succeeded(VarCyFromStr(S, GetThreadLocale, 0, Result)) then
1334 Result := Default;
1335end;
1336
1337threadvar
1338 Currency_DecimalSep: WideString;
1339 Currency_ThousandSep: WideString;
1340 Currency_CurrencySymbol: WideString;
1341
1342function GetDefaultCurrencyFmt: TCurrencyFmtW;
1343begin
1344 ZeroMemory(@Result, SizeOf(Result));
1345 Result.NumDigits := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRDIGITS, '2'), 2);
1346 Result.LeadingZero := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ILZERO, '1'), 1);
1347 Result.Grouping := StrToIntDef(Copy(WideGetLocaleStr(GetThreadLocale, LOCALE_SMONGROUPING, '3;0'), 1, 1), 3);
1348 Currency_DecimalSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONDECIMALSEP, '.');
1349 Result.lpDecimalSep := PWideChar(Currency_DecimalSep);
1350 Currency_ThousandSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONTHOUSANDSEP, ',');
1351 Result.lpThousandSep := PWideChar(Currency_ThousandSep);
1352 Result.NegativeOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_INEGCURR, '0'), 0);
1353 Result.PositiveOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRENCY, '0'), 0);
1354 Currency_CurrencySymbol := WideGetLocaleStr(GetThreadLocale, LOCALE_SCURRENCY, '');
1355 Result.lpCurrencySymbol := PWideChar(Currency_CurrencySymbol);
1356end;
1357
1358//=============================================================================================
1359
1360function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString;
1361var
1362 L: Integer;
1363begin
1364 if (not Win32PlatformIsUnicode) then
1365 Result := GetLocaleStr{TNT-ALLOW GetLocaleStr}(LocaleID, LocaleType, Default)
1366 else begin
1367 SetLength(Result, 255);
1368 L := GetLocaleInfoW(LocaleID, LocaleType, PWideChar(Result), Length(Result));
1369 if L > 0 then
1370 SetLength(Result, L - 1)
1371 else
1372 Result := Default;
1373 end;
1374end;
1375
1376function WideSysErrorMessage(ErrorCode: Integer): WideString;
1377begin
1378 Result := WideLibraryErrorMessage('system', 0, ErrorCode);
1379end;
1380
1381function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString;
1382var
1383 Len: Integer;
1384 AnsiResult: AnsiString;
1385 Flags: Cardinal;
1386begin
1387 Flags := FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY;
1388 if Dll <> 0 then
1389 Flags := Flags or FORMAT_MESSAGE_FROM_HMODULE;
1390 if Win32PlatformIsUnicode then begin
1391 SetLength(Result, 256);
1392 Len := FormatMessageW(Flags, Pointer(Dll), ErrorCode, 0, PWideChar(Result), Length(Result), nil);
1393 SetLength(Result, Len);
1394 end else begin
1395 SetLength(AnsiResult, 256);
1396 Len := FormatMessageA(Flags, Pointer(Dll), ErrorCode, 0, PAnsiChar(AnsiResult), Length(AnsiResult), nil);
1397 SetLength(AnsiResult, Len);
1398 Result := AnsiResult;
1399 end;
1400 if Trim(Result) = '' then
1401 Result := WideFormat('Unspecified error (%d) from %s.', [ErrorCode, LibName]);
1402end;
1403
1404{$IFNDEF COMPILER_7_UP}
1405function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean;
1406begin
1407 Result := (Win32MajorVersion > AMajor) or
1408 ((Win32MajorVersion = AMajor) and
1409 (Win32MinorVersion >= AMinor));
1410end;
1411{$ENDIF}
1412
1413function WinCheckH(RetVal: Cardinal): Cardinal;
1414begin
1415 if RetVal = 0 then RaiseLastOSError;
1416 Result := RetVal;
1417end;
1418
1419function WinCheckFileH(RetVal: Cardinal): Cardinal;
1420begin
1421 if RetVal = INVALID_HANDLE_VALUE then RaiseLastOSError;
1422 Result := RetVal;
1423end;
1424
1425function WinCheckP(RetVal: Pointer): Pointer;
1426begin
1427 if RetVal = nil then RaiseLastOSError;
1428 Result := RetVal;
1429end;
1430
1431function WideGetModuleFileName(Instance: HModule): WideString;
1432begin
1433 SetLength(Result, MAX_PATH);
1434 WinCheckH(Tnt_GetModuleFileNameW(Instance, PWideChar(Result), Length(Result)));
1435 Result := PWideChar(Result)
1436end;
1437
1438function WideSafeLoadLibrary(const Filename: Widestring; ErrorMode: UINT): HMODULE;
1439var
1440 OldMode: UINT;
1441 FPUControlWord: Word;
1442begin
1443 OldMode := SetErrorMode(ErrorMode);
1444 try
1445 asm
1446 FNSTCW FPUControlWord
1447 end;
1448 try
1449 Result := Tnt_LoadLibraryW(PWideChar(Filename));
1450 finally
1451 asm
1452 FNCLEX
1453 FLDCW FPUControlWord
1454 end;
1455 end;
1456 finally
1457 SetErrorMode(OldMode);
1458 end;
1459end;
1460
1461function WideLoadPackage(const Name: Widestring): HMODULE;
1462begin
1463 Result := WideSafeLoadLibrary(Name);
1464 if Result = 0 then
1465 begin
1466 raise EPackageError.CreateFmt(sErrorLoadingPackage, [Name, WideSysErrorMessage(GetLastError)]);
1467 end;
1468 try
1469 InitializePackage(Result);
1470 except
1471 FreeLibrary(Result);
1472 raise;
1473 end;
1474end;
1475
1476function _WideCharType(WC: WideChar; dwInfoType: Cardinal): Word;
1477begin
1478 Win32Check(Tnt_GetStringTypeExW(GetThreadLocale, dwInfoType, PWideChar(@WC), 1, Result))
1479end;
1480
1481function IsWideCharUpper(WC: WideChar): Boolean;
1482begin
1483 Result := (_WideCharType(WC, CT_CTYPE1) and C1_UPPER) <> 0;
1484end;
1485
1486function IsWideCharLower(WC: WideChar): Boolean;
1487begin
1488 Result := (_WideCharType(WC, CT_CTYPE1) and C1_LOWER) <> 0;
1489end;
1490
1491function IsWideCharDigit(WC: WideChar): Boolean;
1492begin
1493 Result := (_WideCharType(WC, CT_CTYPE1) and C1_DIGIT) <> 0;
1494end;
1495
1496function IsWideCharSpace(WC: WideChar): Boolean;
1497begin
1498 Result := (_WideCharType(WC, CT_CTYPE1) and C1_SPACE) <> 0;
1499end;
1500
1501function IsWideCharPunct(WC: WideChar): Boolean;
1502begin
1503 Result := (_WideCharType(WC, CT_CTYPE1) and C1_PUNCT) <> 0;
1504end;
1505
1506function IsWideCharCntrl(WC: WideChar): Boolean;
1507begin
1508 Result := (_WideCharType(WC, CT_CTYPE1) and C1_CNTRL) <> 0;
1509end;
1510
1511function IsWideCharBlank(WC: WideChar): Boolean;
1512begin
1513 Result := (_WideCharType(WC, CT_CTYPE1) and C1_BLANK) <> 0;
1514end;
1515
1516function IsWideCharXDigit(WC: WideChar): Boolean;
1517begin
1518 Result := (_WideCharType(WC, CT_CTYPE1) and C1_XDIGIT) <> 0;
1519end;
1520
1521function IsWideCharAlpha(WC: WideChar): Boolean;
1522begin
1523 Result := (_WideCharType(WC, CT_CTYPE1) and C1_ALPHA) <> 0;
1524end;
1525
1526function IsWideCharAlphaNumeric(WC: WideChar): Boolean;
1527begin
1528 Result := (_WideCharType(WC, CT_CTYPE1) and (C1_ALPHA + C1_DIGIT)) <> 0;
1529end;
1530
1531function WideTextPos(const SubStr, S: WideString): Integer;
1532begin
1533 Result := Pos(Tnt_WideUpperCase(SubStr), Tnt_WideUpperCase(S));
1534end;
1535
1536function FindDoubleTerminator(P: PWideChar): PWideChar;
1537begin
1538 Result := P;
1539 while True do begin
1540 Result := WStrScan(Result, #0);
1541 Inc(Result);
1542 if Result^ = #0 then begin
1543 Dec(Result);
1544 break;
1545 end;
1546 end;
1547end;
1548
1549function ExtractStringArrayStr(P: PWideChar): WideString;
1550var
1551 PEnd: PWideChar;
1552begin
1553 PEnd := FindDoubleTerminator(P);
1554 Inc(PEnd, 2); // move past #0#0
1555 SetString(Result, P, PEnd - P);
1556end;
1557
1558function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString;
1559var
1560 Start: PWideChar;
1561begin
1562 Start := P;
1563 P := WStrScan(Start, Separator);
1564 if P = nil then begin
1565 Result := Start;
1566 P := WStrEnd(Start);
1567 end else begin
1568 SetString(Result, Start, P - Start);
1569 Inc(P);
1570 end;
1571end;
1572
1573function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray;
1574const
1575 GROW_COUNT = 256;
1576var
1577 Count: Integer;
1578 Item: WideString;
1579begin
1580 Count := 0;
1581 SetLength(Result, GROW_COUNT);
1582 Item := ExtractStringFromStringArray(P, Separator);
1583 While Item <> '' do begin
1584 if Count > High(Result) then
1585 SetLength(Result, Length(Result) + GROW_COUNT);
1586 Result[Count] := Item;
1587 Inc(Count);
1588 Item := ExtractStringFromStringArray(P, Separator);
1589 end;
1590 SetLength(Result, Count);
1591end;
1592
1593function IsWideCharMappableToAnsi(const WC: WideChar): Boolean;
1594var
1595 UsedDefaultChar: BOOL;
1596begin
1597 WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(@WC), 1, nil, 0, nil, @UsedDefaultChar);
1598 Result := not UsedDefaultChar;
1599end;
1600
1601function IsWideStringMappableToAnsi(const WS: WideString): Boolean;
1602var
1603 UsedDefaultChar: BOOL;
1604begin
1605 WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(WS), Length(WS), nil, 0, nil, @UsedDefaultChar);
1606 Result := not UsedDefaultChar;
1607end;
1608
1609function IsRTF(const Value: WideString): Boolean;
1610const
1611 RTF_BEGIN_1 = WideString('{\RTF');
1612 RTF_BEGIN_2 = WideString('{URTF');
1613begin
1614 Result := (WideTextPos(RTF_BEGIN_1, Value) = 1)
1615 or (WideTextPos(RTF_BEGIN_2, Value) = 1);
1616end;
1617
1618{$IFDEF COMPILER_7_UP}
1619var
1620 Cached_ENG_US_FormatSettings: TFormatSettings;
1621 Cached_ENG_US_FormatSettings_Time: Cardinal;
1622
1623function ENG_US_FormatSettings: TFormatSettings;
1624begin
1625 if Cached_ENG_US_FormatSettings_Time = _SettingChangeTime then
1626 Result := Cached_ENG_US_FormatSettings
1627 else begin
1628 GetLocaleFormatSettings(MAKELCID(MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US)), Result);
1629 Result.DecimalSeparator := '.'; // ignore overrides
1630 Cached_ENG_US_FormatSettings := Result;
1631 Cached_ENG_US_FormatSettings_Time := _SettingChangeTime;
1632 end;
1633 end;
1634
1635function ENG_US_FloatToStr(Value: Extended): WideString;
1636begin
1637 Result := FloatToStr(Value, ENG_US_FormatSettings);
1638end;
1639
1640function ENG_US_StrToFloat(const S: WideString): Extended;
1641begin
1642 if not TextToFloat(PAnsiChar(AnsiString(S)), Result, fvExtended, ENG_US_FormatSettings) then
1643 Result := StrToFloat(S); // try using native format
1644end;
1645
1646{$ELSE}
1647
1648function ENG_US_FloatToStr(Value: Extended): WideString;
1649var
1650 SaveDecimalSep: AnsiChar;
1651begin
1652 SaveDecimalSep := SysUtils.DecimalSeparator;
1653 try
1654 SysUtils.DecimalSeparator := '.';
1655 Result := FloatToStr(Value);
1656 finally
1657 SysUtils.DecimalSeparator := SaveDecimalSep;
1658 end;
1659end;
1660
1661function ENG_US_StrToFloat(const S: WideString): Extended;
1662var
1663 SaveDecimalSep: AnsiChar;
1664begin
1665 try
1666 SaveDecimalSep := SysUtils.DecimalSeparator;
1667 try
1668 SysUtils.DecimalSeparator := '.';
1669 Result := StrToFloat(S);
1670 finally
1671 SysUtils.DecimalSeparator := SaveDecimalSep;
1672 end;
1673 except
1674 if SysUtils.DecimalSeparator <> '.' then
1675 Result := StrToFloat(S) // try using native format
1676 else
1677 raise;
1678 end;
1679end;
1680{$ENDIF}
1681
1682//---------------------------------------------------------------------------------------------
1683// Tnt - Variants
1684//---------------------------------------------------------------------------------------------
1685
1686initialization
1687 Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT);
1688 Win32PlatformIsXP := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1))
1689 or (Win32MajorVersion > 5);
1690 Win32PlatformIs2003 := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 2))
1691 or (Win32MajorVersion > 5);
1692 Win32PlatformIsVista := (Win32MajorVersion >= 6);
1693
1694finalization
1695 Currency_DecimalSep := ''; {make memory sleuth happy}
1696 Currency_ThousandSep := ''; {make memory sleuth happy}
1697 Currency_CurrencySymbol := ''; {make memory sleuth happy}
1698
1699end.
Note: See TracBrowser for help on using the repository browser.