source: cprs/branches/tmg-cprs/TntWare/Delphi Unicode Controls/Source/TntClasses.pas@ 683

Last change on this file since 683 was 453, checked in by Kevin Toppenberg, 16 years ago

Initial upload of TMG-CPRS 1.0.26.69
File size: 52.0 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 TntClasses;
13
14{$INCLUDE TntCompilers.inc}
15
16interface
17
18{ TODO: Consider: TTntRegIniFile, TTntMemIniFile (consider if UTF8 fits into this solution). }
19
20{***********************************************}
21{ WideChar-streaming implemented by Maël Hörz }
22{***********************************************}
23
24uses
25 Classes, SysUtils, Windows,
26 {$IFNDEF COMPILER_10_UP}
27 TntWideStrings,
28 {$ELSE}
29 WideStrings,
30 {$ENDIF}
31 ActiveX, Contnrs;
32
33// ......... introduced .........
34type
35 TTntStreamCharSet = (csAnsi, csUnicode, csUnicodeSwapped, csUtf8);
36
37function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet;
38
39//---------------------------------------------------------------------------------------------
40// Tnt - Classes
41//---------------------------------------------------------------------------------------------
42
43{TNT-WARN ExtractStrings}
44{TNT-WARN LineStart}
45{TNT-WARN TStringStream} // TODO: Implement a TWideStringStream
46
47// A potential implementation of TWideStringStream can be found at:
48// http://kdsxml.cvs.sourceforge.net/kdsxml/Global/KDSClasses.pas?revision=1.10&view=markup
49
50procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent);
51
52type
53{TNT-WARN TFileStream}
54 TTntFileStream = class(THandleStream)
55 public
56 constructor Create(const FileName: WideString; Mode: Word);
57 destructor Destroy; override;
58 end;
59
60{TNT-WARN TMemoryStream}
61 TTntMemoryStream = class(TMemoryStream{TNT-ALLOW TMemoryStream})
62 public
63 procedure LoadFromFile(const FileName: WideString);
64 procedure SaveToFile(const FileName: WideString);
65 end;
66
67{TNT-WARN TResourceStream}
68 TTntResourceStream = class(TCustomMemoryStream)
69 private
70 HResInfo: HRSRC;
71 HGlobal: THandle;
72 procedure Initialize(Instance: THandle; Name, ResType: PWideChar);
73 public
74 constructor Create(Instance: THandle; const ResName: WideString; ResType: PWideChar);
75 constructor CreateFromID(Instance: THandle; ResID: Word; ResType: PWideChar);
76 destructor Destroy; override;
77 function Write(const Buffer; Count: Longint): Longint; override;
78 procedure SaveToFile(const FileName: WideString);
79 end;
80
81 TTntStrings = class;
82
83{TNT-WARN TAnsiStrings}
84 TAnsiStrings{TNT-ALLOW TAnsiStrings} = class(TStrings{TNT-ALLOW TStrings})
85 public
86 procedure LoadFromFile(const FileName: WideString); reintroduce;
87 procedure SaveToFile(const FileName: WideString); reintroduce;
88 procedure LoadFromFileEx(const FileName: WideString; CodePage: Cardinal);
89 procedure SaveToFileEx(const FileName: WideString; CodePage: Cardinal);
90 procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract;
91 procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract;
92 end;
93
94 TAnsiStringsForWideStringsAdapter = class(TAnsiStrings{TNT-ALLOW TAnsiStrings})
95 private
96 FWideStrings: TTntStrings;
97 FAdapterCodePage: Cardinal;
98 protected
99 function Get(Index: Integer): AnsiString; override;
100 procedure Put(Index: Integer; const S: AnsiString); override;
101 function GetCount: Integer; override;
102 function GetObject(Index: Integer): TObject; override;
103 procedure PutObject(Index: Integer; AObject: TObject); override;
104 procedure SetUpdateState(Updating: Boolean); override;
105 function AdapterCodePage: Cardinal; dynamic;
106 public
107 constructor Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal = 0);
108 procedure Clear; override;
109 procedure Delete(Index: Integer); override;
110 procedure Insert(Index: Integer; const S: AnsiString); override;
111 procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); override;
112 procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); override;
113 end;
114
115{TNT-WARN TStrings}
116 TTntStrings = class(TWideStrings)
117 private
118 FLastFileCharSet: TTntStreamCharSet;
119 FAnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings};
120 procedure SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings});
121 procedure ReadData(Reader: TReader);
122 procedure ReadDataUTF7(Reader: TReader);
123 procedure ReadDataUTF8(Reader: TReader);
124 procedure WriteDataUTF7(Writer: TWriter);
125 protected
126 procedure DefineProperties(Filer: TFiler); override;
127 public
128 constructor Create;
129 destructor Destroy; override;
130
131 procedure LoadFromFile(const FileName: WideString); override;
132 procedure LoadFromStream(Stream: TStream); override;
133 procedure LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); virtual;
134
135 procedure SaveToFile(const FileName: WideString); override;
136 procedure SaveToStream(Stream: TStream); override;
137 procedure SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); virtual;
138
139 property LastFileCharSet: TTntStreamCharSet read FLastFileCharSet;
140 published
141 property AnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings} read FAnsiStrings write SetAnsiStrings stored False;
142 end;
143
144{ TTntStringList class }
145
146 TTntStringList = class;
147 TWideStringListSortCompare = function(List: TTntStringList; Index1, Index2: Integer): Integer;
148
149{TNT-WARN TStringList}
150 TTntStringList = class(TTntStrings)
151 private
152 FUpdating: Boolean;
153 FList: PWideStringItemList;
154 FCount: Integer;
155 FCapacity: Integer;
156 FSorted: Boolean;
157 FDuplicates: TDuplicates;
158 FCaseSensitive: Boolean;
159 FOnChange: TNotifyEvent;
160 FOnChanging: TNotifyEvent;
161 procedure ExchangeItems(Index1, Index2: Integer);
162 procedure Grow;
163 procedure QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare);
164 procedure SetSorted(Value: Boolean);
165 procedure SetCaseSensitive(const Value: Boolean);
166 protected
167 procedure Changed; virtual;
168 procedure Changing; virtual;
169 function Get(Index: Integer): WideString; override;
170 function GetCapacity: Integer; override;
171 function GetCount: Integer; override;
172 function GetObject(Index: Integer): TObject; override;
173 procedure Put(Index: Integer; const S: WideString); override;
174 procedure PutObject(Index: Integer; AObject: TObject); override;
175 procedure SetCapacity(NewCapacity: Integer); override;
176 procedure SetUpdateState(Updating: Boolean); override;
177 function CompareStrings(const S1, S2: WideString): Integer; override;
178 procedure InsertItem(Index: Integer; const S: WideString; AObject: TObject); virtual;
179 public
180 destructor Destroy; override;
181 function Add(const S: WideString): Integer; override;
182 function AddObject(const S: WideString; AObject: TObject): Integer; override;
183 procedure Clear; override;
184 procedure Delete(Index: Integer); override;
185 procedure Exchange(Index1, Index2: Integer); override;
186 function Find(const S: WideString; var Index: Integer): Boolean; virtual;
187 function IndexOf(const S: WideString): Integer; override;
188 function IndexOfName(const Name: WideString): Integer; override;
189 procedure Insert(Index: Integer; const S: WideString); override;
190 procedure InsertObject(Index: Integer; const S: WideString;
191 AObject: TObject); override;
192 procedure Sort; virtual;
193 procedure CustomSort(Compare: TWideStringListSortCompare); virtual;
194 property Duplicates: TDuplicates read FDuplicates write FDuplicates;
195 property Sorted: Boolean read FSorted write SetSorted;
196 property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive;
197 property OnChange: TNotifyEvent read FOnChange write FOnChange;
198 property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
199 end;
200
201// ......... introduced .........
202type
203 TListTargetCompare = function (Item, Target: Pointer): Integer;
204
205function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare;
206 Target: Pointer; var Index: Integer): Boolean;
207
208function ClassIsRegistered(const clsid: TCLSID): Boolean;
209
210var
211 RuntimeUTFStreaming: Boolean;
212
213type
214 TBufferedAnsiString = class(TObject)
215 private
216 FStringBuffer: AnsiString;
217 LastWriteIndex: Integer;
218 public
219 procedure Clear;
220 procedure AddChar(const wc: AnsiChar);
221 procedure AddString(const s: AnsiString);
222 procedure AddBuffer(Buff: PAnsiChar; Chars: Integer);
223 function Value: AnsiString;
224 function BuffPtr: PAnsiChar;
225 end;
226
227 TBufferedWideString = class(TObject)
228 private
229 FStringBuffer: WideString;
230 LastWriteIndex: Integer;
231 public
232 procedure Clear;
233 procedure AddChar(const wc: WideChar);
234 procedure AddString(const s: WideString);
235 procedure AddBuffer(Buff: PWideChar; Chars: Integer);
236 function Value: WideString;
237 function BuffPtr: PWideChar;
238 end;
239
240 TBufferedStreamReader = class(TStream)
241 private
242 FStream: TStream;
243 FStreamSize: Integer;
244 FBuffer: array of Byte;
245 FBufferSize: Integer;
246 FBufferStartPosition: Integer;
247 FVirtualPosition: Integer;
248 procedure UpdateBufferFromPosition(StartPos: Integer);
249 public
250 constructor Create(Stream: TStream; BufferSize: Integer = 1024);
251 function Read(var Buffer; Count: Longint): Longint; override;
252 function Write(const Buffer; Count: Longint): Longint; override;
253 function Seek(Offset: Longint; Origin: Word): Longint; override;
254 end;
255
256// "synced" wide string
257type TSetAnsiStrEvent = procedure(const Value: AnsiString) of object;
258function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString;
259procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString;
260 const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent);
261
262type
263 TWideComponentHelper = class(TComponent)
264 private
265 FComponent: TComponent;
266 protected
267 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
268 public
269 constructor Create(AOwner: TComponent); override;
270 constructor CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList);
271 end;
272
273function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper;
274
275implementation
276
277uses
278 RTLConsts, ComObj, Math,
279 Registry, TypInfo, TntSystem, TntSysUtils;
280
281{ TntPersistent }
282
283//===========================================================================
284// The Delphi 5 Classes.pas never supported the streaming of WideStrings.
285// The Delphi 6 Classes.pas supports WideString streaming. But it's too bad that
286// the Delphi 6 IDE doesn't use the updated Classes.pas. Switching between Form/Text
287// mode corrupts extended characters in WideStrings even under Delphi 6.
288// Delphi 7 seems to finally get right. But let's keep the UTF7 support at design time
289// to enable sharing source code with previous versions of Delphi.
290//
291// The purpose of this solution is to store WideString properties which contain
292// non-ASCII chars in the form of UTF7 under the old property name + '_UTF7'.
293//
294// Special thanks go to Francisco Leong for helping to develop this solution.
295//
296
297{ TTntWideStringPropertyFiler }
298type
299 TTntWideStringPropertyFiler = class
300 private
301 FInstance: TPersistent;
302 FPropInfo: PPropInfo;
303 procedure ReadDataUTF8(Reader: TReader);
304 procedure ReadDataUTF7(Reader: TReader);
305 procedure WriteDataUTF7(Writer: TWriter);
306 public
307 procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString);
308 end;
309
310function ReaderNeedsUtfHelp(Reader: TReader): Boolean;
311begin
312 if Reader.Owner = nil then
313 Result := False { designtime - visual form inheritance ancestor }
314 else if csDesigning in Reader.Owner.ComponentState then
315 {$IFDEF COMPILER_7_UP}
316 Result := False { Delphi 7+: designtime - doesn't need UTF help. }
317 {$ELSE}
318 Result := True { Delphi 6: designtime - always needs UTF help. }
319 {$ENDIF}
320 else
321 Result := RuntimeUTFStreaming; { runtime }
322end;
323
324procedure TTntWideStringPropertyFiler.ReadDataUTF8(Reader: TReader);
325begin
326 if ReaderNeedsUtfHelp(Reader) then
327 SetWideStrProp(FInstance, FPropInfo, UTF8ToWideString(Reader.ReadString))
328 else
329 Reader.ReadString; { do nothing with Result }
330end;
331
332procedure TTntWideStringPropertyFiler.ReadDataUTF7(Reader: TReader);
333begin
334 if ReaderNeedsUtfHelp(Reader) then
335 SetWideStrProp(FInstance, FPropInfo, UTF7ToWideString(Reader.ReadString))
336 else
337 Reader.ReadString; { do nothing with Result }
338end;
339
340procedure TTntWideStringPropertyFiler.WriteDataUTF7(Writer: TWriter);
341begin
342 Writer.WriteString(WideStringToUTF7(GetWideStrProp(FInstance, FPropInfo)));
343end;
344
345procedure TTntWideStringPropertyFiler.DefineProperties(Filer: TFiler; Instance: TPersistent;
346 PropName: AnsiString);
347
348 {$IFNDEF COMPILER_7_UP}
349 function HasData: Boolean;
350 var
351 CurrPropValue: WideString;
352 begin
353 // must be stored
354 Result := IsStoredProp(Instance, FPropInfo);
355 if Result
356 and (Filer.Ancestor <> nil)
357 and (GetPropInfo(Filer.Ancestor, PropName, [tkWString]) <> nil) then
358 begin
359 // must be different than ancestor
360 CurrPropValue := GetWideStrProp(Instance, FPropInfo);
361 Result := CurrPropValue <> GetWideStrProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName));
362 end;
363 if Result then begin
364 // must be non-blank and different than UTF8 (implies all ASCII <= 127)
365 CurrPropValue := GetWideStrProp(Instance, FPropInfo);
366 Result := (CurrPropValue <> '') and (WideStringToUTF8(CurrPropValue) <> CurrPropValue);
367 end;
368 end;
369 {$ENDIF}
370
371begin
372 FInstance := Instance;
373 FPropInfo := GetPropInfo(Instance, PropName, [tkWString]);
374 if FPropInfo <> nil then begin
375 // must be published (and of type WideString)
376 Filer.DefineProperty(PropName + 'W', ReadDataUTF8, nil, False);
377 {$IFDEF COMPILER_7_UP}
378 Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, False);
379 {$ELSE}
380 Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, HasData);
381 {$ENDIF}
382 end;
383 FInstance := nil;
384 FPropInfo := nil;
385end;
386
387{ TTntWideCharPropertyFiler }
388type
389 TTntWideCharPropertyFiler = class
390 private
391 FInstance: TPersistent;
392 FPropInfo: PPropInfo;
393 {$IFNDEF COMPILER_9_UP}
394 FWriter: TWriter;
395 procedure GetLookupInfo(var Ancestor: TPersistent;
396 var Root, LookupRoot, RootAncestor: TComponent);
397 {$ENDIF}
398 procedure ReadData_W(Reader: TReader);
399 procedure ReadDataUTF7(Reader: TReader);
400 procedure WriteData_W(Writer: TWriter);
401 function ReadChar(Reader: TReader): WideChar;
402 public
403 procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString);
404 end;
405
406{$IFNDEF COMPILER_9_UP}
407type
408 TGetLookupInfoEvent = procedure(var Ancestor: TPersistent;
409 var Root, LookupRoot, RootAncestor: TComponent) of object;
410
411function AncestorIsValid(Ancestor: TPersistent; Root, RootAncestor: TComponent): Boolean;
412begin
413 Result := (Ancestor <> nil) and (RootAncestor <> nil) and
414 Root.InheritsFrom(RootAncestor.ClassType);
415end;
416
417function IsDefaultOrdPropertyValue(Instance: TObject; PropInfo: PPropInfo;
418 OnGetLookupInfo: TGetLookupInfoEvent): Boolean;
419var
420 Ancestor: TPersistent;
421 LookupRoot: TComponent;
422 RootAncestor: TComponent;
423 Root: TComponent;
424 AncestorValid: Boolean;
425 Value: Longint;
426 Default: LongInt;
427begin
428 Ancestor := nil;
429 Root := nil;
430 LookupRoot := nil;
431 RootAncestor := nil;
432
433 if Assigned(OnGetLookupInfo) then
434 OnGetLookupInfo(Ancestor, Root, LookupRoot, RootAncestor);
435
436 AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor);
437
438 Result := True;
439 if (PropInfo^.GetProc <> nil) and (PropInfo^.SetProc <> nil) then
440 begin
441 Value := GetOrdProp(Instance, PropInfo);
442 if AncestorValid then
443 Result := Value = GetOrdProp(Ancestor, PropInfo)
444 else
445 begin
446 Default := PPropInfo(PropInfo)^.Default;
447 Result := (Default <> LongInt($80000000)) and (Value = Default);
448 end;
449 end;
450end;
451
452procedure TTntWideCharPropertyFiler.GetLookupInfo(var Ancestor: TPersistent;
453 var Root, LookupRoot, RootAncestor: TComponent);
454begin
455 Ancestor := FWriter.Ancestor;
456 Root := FWriter.Root;
457 LookupRoot := FWriter.LookupRoot;
458 RootAncestor := FWriter.RootAncestor;
459end;
460{$ENDIF}
461
462function TTntWideCharPropertyFiler.ReadChar(Reader: TReader): WideChar;
463var
464 Temp: WideString;
465begin
466 case Reader.NextValue of
467 vaWString:
468 Temp := Reader.ReadWideString;
469 vaString:
470 Temp := Reader.ReadString;
471 else
472 raise EReadError.Create(SInvalidPropertyValue);
473 end;
474
475 if Length(Temp) > 1 then
476 raise EReadError.Create(SInvalidPropertyValue);
477 Result := Temp[1];
478end;
479
480procedure TTntWideCharPropertyFiler.ReadData_W(Reader: TReader);
481begin
482 SetOrdProp(FInstance, FPropInfo, Ord(ReadChar(Reader)));
483end;
484
485procedure TTntWideCharPropertyFiler.ReadDataUTF7(Reader: TReader);
486var
487 S: WideString;
488begin
489 S := UTF7ToWideString(Reader.ReadString);
490 if S = '' then
491 SetOrdProp(FInstance, FPropInfo, 0)
492 else
493 SetOrdProp(FInstance, FPropInfo, Ord(S[1]))
494end;
495
496type TAccessWriter = class(TWriter);
497
498procedure TTntWideCharPropertyFiler.WriteData_W(Writer: TWriter);
499var
500 L: Integer;
501 Temp: WideString;
502begin
503 Temp := WideChar(GetOrdProp(FInstance, FPropInfo));
504
505 TAccessWriter(Writer).WriteValue(vaWString);
506 L := Length(Temp);
507 Writer.Write(L, SizeOf(Integer));
508 Writer.Write(Pointer(@Temp[1])^, L * 2);
509end;
510
511procedure TTntWideCharPropertyFiler.DefineProperties(Filer: TFiler;
512 Instance: TPersistent; PropName: AnsiString);
513
514 {$IFNDEF COMPILER_9_UP}
515 function HasData: Boolean;
516 var
517 CurrPropValue: Integer;
518 begin
519 // must be stored
520 Result := IsStoredProp(Instance, FPropInfo);
521 if Result and (Filer.Ancestor <> nil) and
522 (GetPropInfo(Filer.Ancestor, PropName, [tkWChar]) <> nil) then
523 begin
524 // must be different than ancestor
525 CurrPropValue := GetOrdProp(Instance, FPropInfo);
526 Result := CurrPropValue <> GetOrdProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName));
527 end;
528 if Result and (Filer is TWriter) then
529 begin
530 FWriter := TWriter(Filer);
531 Result := not IsDefaultOrdPropertyValue(Instance, FPropInfo, GetLookupInfo);
532 end;
533 end;
534 {$ENDIF}
535
536begin
537 FInstance := Instance;
538 FPropInfo := GetPropInfo(Instance, PropName, [tkWChar]);
539 if FPropInfo <> nil then
540 begin
541 // must be published (and of type WideChar)
542 {$IFDEF COMPILER_9_UP}
543 Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, False);
544 {$ELSE}
545 Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, HasData);
546 {$ENDIF}
547 Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, nil, False);
548 end;
549 FInstance := nil;
550 FPropInfo := nil;
551end;
552
553procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent);
554var
555 I, Count: Integer;
556 PropInfo: PPropInfo;
557 PropList: PPropList;
558 WideStringFiler: TTntWideStringPropertyFiler;
559 WideCharFiler: TTntWideCharPropertyFiler;
560begin
561 Count := GetTypeData(Instance.ClassInfo)^.PropCount;
562 if Count > 0 then
563 begin
564 WideStringFiler := TTntWideStringPropertyFiler.Create;
565 try
566 WideCharFiler := TTntWideCharPropertyFiler.Create;
567 try
568 GetMem(PropList, Count * SizeOf(Pointer));
569 try
570 GetPropInfos(Instance.ClassInfo, PropList);
571 for I := 0 to Count - 1 do
572 begin
573 PropInfo := PropList^[I];
574 if (PropInfo = nil) then
575 break;
576 if (PropInfo.PropType^.Kind = tkWString) then
577 WideStringFiler.DefineProperties(Filer, Instance, PropInfo.Name)
578 else if (PropInfo.PropType^.Kind = tkWChar) then
579 WideCharFiler.DefineProperties(Filer, Instance, PropInfo.Name)
580 end;
581 finally
582 FreeMem(PropList, Count * SizeOf(Pointer));
583 end;
584 finally
585 WideCharFiler.Free;
586 end;
587 finally
588 WideStringFiler.Free;
589 end;
590 end;
591end;
592
593{ TTntFileStream }
594
595constructor TTntFileStream.Create(const FileName: WideString; Mode: Word);
596var
597 CreateHandle: Integer;
598 {$IFDEF DELPHI_7_UP}
599 ErrorMessage: WideString;
600 {$ENDIF}
601begin
602 if Mode = fmCreate then
603 begin
604 CreateHandle := WideFileCreate(FileName);
605 if CreateHandle < 0 then begin
606 {$IFDEF DELPHI_7_UP}
607 ErrorMessage := WideSysErrorMessage(GetLastError);
608 raise EFCreateError.CreateFmt(SFCreateErrorEx, [WideExpandFileName(FileName), ErrorMessage]);
609 {$ELSE}
610 raise EFCreateError.CreateFmt(SFCreateError, [WideExpandFileName(FileName)]);
611 {$ENDIF}
612 end;
613 end else
614 begin
615 CreateHandle := WideFileOpen(FileName, Mode);
616 if CreateHandle < 0 then begin
617 {$IFDEF DELPHI_7_UP}
618 ErrorMessage := WideSysErrorMessage(GetLastError);
619 raise EFOpenError.CreateFmt(SFOpenErrorEx, [WideExpandFileName(FileName), ErrorMessage]);
620 {$ELSE}
621 raise EFOpenError.CreateFmt(SFOpenError, [WideExpandFileName(FileName)]);
622 {$ENDIF}
623 end;
624 end;
625 inherited Create(CreateHandle);
626end;
627
628destructor TTntFileStream.Destroy;
629begin
630 if Handle >= 0 then FileClose(Handle);
631end;
632
633{ TTntMemoryStream }
634
635procedure TTntMemoryStream.LoadFromFile(const FileName: WideString);
636var
637 Stream: TStream;
638begin
639 Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
640 try
641 LoadFromStream(Stream);
642 finally
643 Stream.Free;
644 end;
645end;
646
647procedure TTntMemoryStream.SaveToFile(const FileName: WideString);
648var
649 Stream: TStream;
650begin
651 Stream := TTntFileStream.Create(FileName, fmCreate);
652 try
653 SaveToStream(Stream);
654 finally
655 Stream.Free;
656 end;
657end;
658
659{ TTntResourceStream }
660
661constructor TTntResourceStream.Create(Instance: THandle; const ResName: WideString;
662 ResType: PWideChar);
663begin
664 inherited Create;
665 Initialize(Instance, PWideChar(ResName), ResType);
666end;
667
668constructor TTntResourceStream.CreateFromID(Instance: THandle; ResID: Word;
669 ResType: PWideChar);
670begin
671 inherited Create;
672 Initialize(Instance, PWideChar(ResID), ResType);
673end;
674
675procedure TTntResourceStream.Initialize(Instance: THandle; Name, ResType: PWideChar);
676
677 procedure Error;
678 begin
679 raise EResNotFound.CreateFmt(SResNotFound, [Name]);
680 end;
681
682begin
683 HResInfo := FindResourceW(Instance, Name, ResType);
684 if HResInfo = 0 then Error;
685 HGlobal := LoadResource(Instance, HResInfo);
686 if HGlobal = 0 then Error;
687 SetPointer(LockResource(HGlobal), SizeOfResource(Instance, HResInfo));
688end;
689
690destructor TTntResourceStream.Destroy;
691begin
692 UnlockResource(HGlobal);
693 FreeResource(HGlobal); { Technically this is not necessary (MS KB #193678) }
694 inherited Destroy;
695end;
696
697function TTntResourceStream.Write(const Buffer; Count: Longint): Longint;
698begin
699 raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError));
700end;
701
702procedure TTntResourceStream.SaveToFile(const FileName: WideString);
703var
704 Stream: TStream;
705begin
706 Stream := TTntFileStream.Create(FileName, fmCreate);
707 try
708 SaveToStream(Stream);
709 finally
710 Stream.Free;
711 end;
712end;
713
714{ TAnsiStrings }
715
716procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFile(const FileName: WideString);
717var
718 Stream: TStream;
719begin
720 Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
721 try
722 LoadFromStream(Stream);
723 finally
724 Stream.Free;
725 end;
726end;
727
728procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFile(const FileName: WideString);
729var
730 Stream: TStream;
731begin
732 Stream := TTntFileStream.Create(FileName, fmCreate);
733 try
734 SaveToStream(Stream);
735 finally
736 Stream.Free;
737 end;
738end;
739
740procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFileEx(const FileName: WideString; CodePage: Cardinal);
741var
742 Stream: TStream;
743begin
744 Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
745 try
746 LoadFromStreamEx(Stream, CodePage);
747 finally
748 Stream.Free;
749 end;
750end;
751
752procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFileEx(const FileName: WideString; CodePage: Cardinal);
753var
754 Stream: TStream;
755begin
756 Stream := TTntFileStream.Create(FileName, fmCreate);
757 try
758 if (CodePage = CP_UTF8) then
759 Stream.WriteBuffer(PAnsiChar(UTF8_BOM)^, Length(UTF8_BOM));
760 SaveToStreamEx(Stream, CodePage);
761 finally
762 Stream.Free;
763 end;
764end;
765
766{ TAnsiStringsForWideStringsAdapter }
767
768constructor TAnsiStringsForWideStringsAdapter.Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal);
769begin
770 inherited Create;
771 FWideStrings := AWideStrings;
772 FAdapterCodePage := _AdapterCodePage;
773end;
774
775function TAnsiStringsForWideStringsAdapter.AdapterCodePage: Cardinal;
776begin
777 if FAdapterCodePage = 0 then
778 Result := TntSystem.DefaultSystemCodePage
779 else
780 Result := FAdapterCodePage;
781end;
782
783procedure TAnsiStringsForWideStringsAdapter.Clear;
784begin
785 FWideStrings.Clear;
786end;
787
788procedure TAnsiStringsForWideStringsAdapter.Delete(Index: Integer);
789begin
790 FWideStrings.Delete(Index);
791end;
792
793function TAnsiStringsForWideStringsAdapter.Get(Index: Integer): AnsiString;
794begin
795 Result := WideStringToStringEx(FWideStrings.Get(Index), AdapterCodePage);
796end;
797
798procedure TAnsiStringsForWideStringsAdapter.Put(Index: Integer; const S: AnsiString);
799begin
800 FWideStrings.Put(Index, StringToWideStringEx(S, AdapterCodePage));
801end;
802
803function TAnsiStringsForWideStringsAdapter.GetCount: Integer;
804begin
805 Result := FWideStrings.GetCount;
806end;
807
808procedure TAnsiStringsForWideStringsAdapter.Insert(Index: Integer; const S: AnsiString);
809begin
810 FWideStrings.Insert(Index, StringToWideStringEx(S, AdapterCodePage));
811end;
812
813function TAnsiStringsForWideStringsAdapter.GetObject(Index: Integer): TObject;
814begin
815 Result := FWideStrings.GetObject(Index);
816end;
817
818procedure TAnsiStringsForWideStringsAdapter.PutObject(Index: Integer; AObject: TObject);
819begin
820 FWideStrings.PutObject(Index, AObject);
821end;
822
823procedure TAnsiStringsForWideStringsAdapter.SetUpdateState(Updating: Boolean);
824begin
825 FWideStrings.SetUpdateState(Updating);
826end;
827
828procedure TAnsiStringsForWideStringsAdapter.LoadFromStreamEx(Stream: TStream; CodePage: Cardinal);
829var
830 Size: Integer;
831 S: AnsiString;
832begin
833 BeginUpdate;
834 try
835 Size := Stream.Size - Stream.Position;
836 SetString(S, nil, Size);
837 Stream.Read(Pointer(S)^, Size);
838 FWideStrings.SetTextStr(StringToWideStringEx(S, CodePage));
839 finally
840 EndUpdate;
841 end;
842end;
843
844procedure TAnsiStringsForWideStringsAdapter.SaveToStreamEx(Stream: TStream; CodePage: Cardinal);
845var
846 S: AnsiString;
847begin
848 S := WideStringToStringEx(FWideStrings.GetTextStr, CodePage);
849 Stream.WriteBuffer(Pointer(S)^, Length(S));
850end;
851
852{ TTntStrings }
853
854constructor TTntStrings.Create;
855begin
856 inherited;
857 FAnsiStrings := TAnsiStringsForWideStringsAdapter.Create(Self);
858 FLastFileCharSet := csUnicode;
859end;
860
861destructor TTntStrings.Destroy;
862begin
863 FreeAndNil(FAnsiStrings);
864 inherited;
865end;
866
867procedure TTntStrings.SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings});
868begin
869 FAnsiStrings.Assign(Value);
870end;
871
872procedure TTntStrings.DefineProperties(Filer: TFiler);
873
874 {$IFNDEF COMPILER_7_UP}
875 function DoWrite: Boolean;
876 begin
877 if Filer.Ancestor <> nil then
878 begin
879 Result := True;
880 if Filer.Ancestor is TWideStrings then
881 Result := not Equals(TWideStrings(Filer.Ancestor))
882 end
883 else Result := Count > 0;
884 end;
885
886 function DoWriteAsUTF7: Boolean;
887 var
888 i: integer;
889 begin
890 Result := False;
891 for i := 0 to Count - 1 do begin
892 if (Strings[i] <> '') and (WideStringToUTF8(Strings[i]) <> Strings[i]) then begin
893 Result := True;
894 break; { found a string with non-ASCII chars (> 127) }
895 end;
896 end;
897 end;
898 {$ENDIF}
899
900begin
901 inherited DefineProperties(Filer); { Handles main 'Strings' property.' }
902 Filer.DefineProperty('WideStrings', ReadData, nil, False);
903 Filer.DefineProperty('WideStringsW', ReadDataUTF8, nil, False);
904 {$IFDEF COMPILER_7_UP}
905 Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, False);
906 {$ELSE}
907 Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, DoWrite and DoWriteAsUTF7);
908 {$ENDIF}
909end;
910
911procedure TTntStrings.LoadFromFile(const FileName: WideString);
912var
913 Stream: TStream;
914begin
915 Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
916 try
917 FLastFileCharSet := AutoDetectCharacterSet(Stream);
918 Stream.Position := 0;
919 LoadFromStream(Stream);
920 finally
921 Stream.Free;
922 end;
923end;
924
925procedure TTntStrings.LoadFromStream(Stream: TStream);
926begin
927 LoadFromStream_BOM(Stream, True);
928end;
929
930procedure TTntStrings.LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean);
931var
932 DataLeft: Integer;
933 StreamCharSet: TTntStreamCharSet;
934 SW: WideString;
935 SA: AnsiString;
936begin
937 BeginUpdate;
938 try
939 if WithBOM then
940 StreamCharSet := AutoDetectCharacterSet(Stream)
941 else
942 StreamCharSet := csUnicode;
943 DataLeft := Stream.Size - Stream.Position;
944 if (StreamCharSet in [csUnicode, csUnicodeSwapped]) then
945 begin
946 // BOM indicates Unicode text stream
947 if DataLeft < SizeOf(WideChar) then
948 SW := ''
949 else begin
950 SetLength(SW, DataLeft div SizeOf(WideChar));
951 Stream.Read(PWideChar(SW)^, DataLeft);
952 if StreamCharSet = csUnicodeSwapped then
953 StrSwapByteOrder(PWideChar(SW));
954 end;
955 SetTextStr(SW);
956 end
957 else if StreamCharSet = csUtf8 then
958 begin
959 // BOM indicates UTF-8 text stream
960 SetLength(SA, DataLeft div SizeOf(AnsiChar));
961 Stream.Read(PAnsiChar(SA)^, DataLeft);
962 SetTextStr(UTF8ToWideString(SA));
963 end
964 else
965 begin
966 // without byte order mark it is assumed that we are loading ANSI text
967 SetLength(SA, DataLeft div SizeOf(AnsiChar));
968 Stream.Read(PAnsiChar(SA)^, DataLeft);
969 SetTextStr(SA);
970 end;
971 finally
972 EndUpdate;
973 end;
974end;
975
976procedure TTntStrings.ReadData(Reader: TReader);
977begin
978 if Reader.NextValue in [vaString, vaLString] then
979 SetTextStr(Reader.ReadString) {JCL compatiblity}
980 else if Reader.NextValue = vaWString then
981 SetTextStr(Reader.ReadWideString) {JCL compatiblity}
982 else begin
983 BeginUpdate;
984 try
985 Clear;
986 Reader.ReadListBegin;
987 while not Reader.EndOfList do
988 if Reader.NextValue in [vaString, vaLString] then
989 Add(Reader.ReadString) {TStrings compatiblity}
990 else
991 Add(Reader.ReadWideString);
992 Reader.ReadListEnd;
993 finally
994 EndUpdate;
995 end;
996 end;
997end;
998
999procedure TTntStrings.ReadDataUTF7(Reader: TReader);
1000begin
1001 Reader.ReadListBegin;
1002 if ReaderNeedsUtfHelp(Reader) then
1003 begin
1004 BeginUpdate;
1005 try
1006 Clear;
1007 while not Reader.EndOfList do
1008 Add(UTF7ToWideString(Reader.ReadString))
1009 finally
1010 EndUpdate;
1011 end;
1012 end else begin
1013 while not Reader.EndOfList do
1014 Reader.ReadString; { do nothing with Result }
1015 end;
1016 Reader.ReadListEnd;
1017end;
1018
1019procedure TTntStrings.ReadDataUTF8(Reader: TReader);
1020begin
1021 Reader.ReadListBegin;
1022 if ReaderNeedsUtfHelp(Reader)
1023 or (Count = 0){ Legacy support where 'WideStrings' was never written in lieu of WideStringsW }
1024 then begin
1025 BeginUpdate;
1026 try
1027 Clear;
1028 while not Reader.EndOfList do
1029 Add(UTF8ToWideString(Reader.ReadString))
1030 finally
1031 EndUpdate;
1032 end;
1033 end else begin
1034 while not Reader.EndOfList do
1035 Reader.ReadString; { do nothing with Result }
1036 end;
1037 Reader.ReadListEnd;
1038end;
1039
1040procedure TTntStrings.SaveToFile(const FileName: WideString);
1041var
1042 Stream: TStream;
1043begin
1044 Stream := TTntFileStream.Create(FileName, fmCreate);
1045 try
1046 SaveToStream(Stream);
1047 finally
1048 Stream.Free;
1049 end;
1050end;
1051
1052procedure TTntStrings.SaveToStream(Stream: TStream);
1053begin
1054 SaveToStream_BOM(Stream, True);
1055end;
1056
1057procedure TTntStrings.SaveToStream_BOM(Stream: TStream; WithBOM: Boolean);
1058// Saves the currently loaded text into the given stream.
1059// WithBOM determines whether to write a byte order mark or not.
1060var
1061 SW: WideString;
1062 BOM: WideChar;
1063begin
1064 if WithBOM then begin
1065 BOM := UNICODE_BOM;
1066 Stream.WriteBuffer(BOM, SizeOf(WideChar));
1067 end;
1068 SW := GetTextStr;
1069 Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar));
1070end;
1071
1072procedure TTntStrings.WriteDataUTF7(Writer: TWriter);
1073var
1074 I: Integer;
1075begin
1076 Writer.WriteListBegin;
1077 for I := 0 to Count-1 do
1078 Writer.WriteString(WideStringToUTF7(Get(I)));
1079 Writer.WriteListEnd;
1080end;
1081
1082{ TTntStringList }
1083
1084destructor TTntStringList.Destroy;
1085begin
1086 FOnChange := nil;
1087 FOnChanging := nil;
1088 inherited Destroy;
1089 if FCount <> 0 then Finalize(FList^[0], FCount);
1090 FCount := 0;
1091 SetCapacity(0);
1092end;
1093
1094function TTntStringList.Add(const S: WideString): Integer;
1095begin
1096 Result := AddObject(S, nil);
1097end;
1098
1099function TTntStringList.AddObject(const S: WideString; AObject: TObject): Integer;
1100begin
1101 if not Sorted then
1102 Result := FCount
1103 else
1104 if Find(S, Result) then
1105 case Duplicates of
1106 dupIgnore: Exit;
1107 dupError: Error(PResStringRec(@SDuplicateString), 0);
1108 end;
1109 InsertItem(Result, S, AObject);
1110end;
1111
1112procedure TTntStringList.Changed;
1113begin
1114 if (not FUpdating) and Assigned(FOnChange) then
1115 FOnChange(Self);
1116end;
1117
1118procedure TTntStringList.Changing;
1119begin
1120 if (not FUpdating) and Assigned(FOnChanging) then
1121 FOnChanging(Self);
1122end;
1123
1124procedure TTntStringList.Clear;
1125begin
1126 if FCount <> 0 then
1127 begin
1128 Changing;
1129 Finalize(FList^[0], FCount);
1130 FCount := 0;
1131 SetCapacity(0);
1132 Changed;
1133 end;
1134end;
1135
1136procedure TTntStringList.Delete(Index: Integer);
1137begin
1138 if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index);
1139 Changing;
1140 Finalize(FList^[Index]);
1141 Dec(FCount);
1142 if Index < FCount then
1143 System.Move(FList^[Index + 1], FList^[Index],
1144 (FCount - Index) * SizeOf(TWideStringItem));
1145 Changed;
1146end;
1147
1148procedure TTntStringList.Exchange(Index1, Index2: Integer);
1149begin
1150 if (Index1 < 0) or (Index1 >= FCount) then Error(PResStringRec(@SListIndexError), Index1);
1151 if (Index2 < 0) or (Index2 >= FCount) then Error(PResStringRec(@SListIndexError), Index2);
1152 Changing;
1153 ExchangeItems(Index1, Index2);
1154 Changed;
1155end;
1156
1157procedure TTntStringList.ExchangeItems(Index1, Index2: Integer);
1158var
1159 Temp: Integer;
1160 Item1, Item2: PWideStringItem;
1161begin
1162 Item1 := @FList^[Index1];
1163 Item2 := @FList^[Index2];
1164 Temp := Integer(Item1^.FString);
1165 Integer(Item1^.FString) := Integer(Item2^.FString);
1166 Integer(Item2^.FString) := Temp;
1167 Temp := Integer(Item1^.FObject);
1168 Integer(Item1^.FObject) := Integer(Item2^.FObject);
1169 Integer(Item2^.FObject) := Temp;
1170end;
1171
1172function TTntStringList.Find(const S: WideString; var Index: Integer): Boolean;
1173var
1174 L, H, I, C: Integer;
1175begin
1176 Result := False;
1177 L := 0;
1178 H := FCount - 1;
1179 while L <= H do
1180 begin
1181 I := (L + H) shr 1;
1182 C := CompareStrings(FList^[I].FString, S);
1183 if C < 0 then L := I + 1 else
1184 begin
1185 H := I - 1;
1186 if C = 0 then
1187 begin
1188 Result := True;
1189 if Duplicates <> dupAccept then L := I;
1190 end;
1191 end;
1192 end;
1193 Index := L;
1194end;
1195
1196function TTntStringList.Get(Index: Integer): WideString;
1197begin
1198 if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index);
1199 Result := FList^[Index].FString;
1200end;
1201
1202function TTntStringList.GetCapacity: Integer;
1203begin
1204 Result := FCapacity;
1205end;
1206
1207function TTntStringList.GetCount: Integer;
1208begin
1209 Result := FCount;
1210end;
1211
1212function TTntStringList.GetObject(Index: Integer): TObject;
1213begin
1214 if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index);
1215 Result := FList^[Index].FObject;
1216end;
1217
1218procedure TTntStringList.Grow;
1219var
1220 Delta: Integer;
1221begin
1222 if FCapacity > 64 then Delta := FCapacity div 4 else
1223 if FCapacity > 8 then Delta := 16 else
1224 Delta := 4;
1225 SetCapacity(FCapacity + Delta);
1226end;
1227
1228function TTntStringList.IndexOf(const S: WideString): Integer;
1229begin
1230 if not Sorted then Result := inherited IndexOf(S) else
1231 if not Find(S, Result) then Result := -1;
1232end;
1233
1234function TTntStringList.IndexOfName(const Name: WideString): Integer;
1235var
1236 NameKey: WideString;
1237begin
1238 if not Sorted then
1239 Result := inherited IndexOfName(Name)
1240 else begin
1241 // use sort to find index more quickly
1242 NameKey := Name + NameValueSeparator;
1243 Find(NameKey, Result);
1244 if (Result < 0) or (Result > Count - 1) then
1245 Result := -1
1246 else if CompareStrings(NameKey, Copy(Strings[Result], 1, Length(NameKey))) <> 0 then
1247 Result := -1
1248 end;
1249end;
1250
1251procedure TTntStringList.Insert(Index: Integer; const S: WideString);
1252begin
1253 InsertObject(Index, S, nil);
1254end;
1255
1256procedure TTntStringList.InsertObject(Index: Integer; const S: WideString;
1257 AObject: TObject);
1258begin
1259 if Sorted then Error(PResStringRec(@SSortedListError), 0);
1260 if (Index < 0) or (Index > FCount) then Error(PResStringRec(@SListIndexError), Index);
1261 InsertItem(Index, S, AObject);
1262end;
1263
1264procedure TTntStringList.InsertItem(Index: Integer; const S: WideString; AObject: TObject);
1265begin
1266 Changing;
1267 if FCount = FCapacity then Grow;
1268 if Index < FCount then
1269 System.Move(FList^[Index], FList^[Index + 1],
1270 (FCount - Index) * SizeOf(TWideStringItem));
1271 with FList^[Index] do
1272 begin
1273 Pointer(FString) := nil;
1274 FObject := AObject;
1275 FString := S;
1276 end;
1277 Inc(FCount);
1278 Changed;
1279end;
1280
1281procedure TTntStringList.Put(Index: Integer; const S: WideString);
1282begin
1283 if Sorted then Error(PResStringRec(@SSortedListError), 0);
1284 if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index);
1285 Changing;
1286 FList^[Index].FString := S;
1287 Changed;
1288end;
1289
1290procedure TTntStringList.PutObject(Index: Integer; AObject: TObject);
1291begin
1292 if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index);
1293 Changing;
1294 FList^[Index].FObject := AObject;
1295 Changed;
1296end;
1297
1298procedure TTntStringList.QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare);
1299var
1300 I, J, P: Integer;
1301begin
1302 repeat
1303 I := L;
1304 J := R;
1305 P := (L + R) shr 1;
1306 repeat
1307 while SCompare(Self, I, P) < 0 do Inc(I);
1308 while SCompare(Self, J, P) > 0 do Dec(J);
1309 if I <= J then
1310 begin
1311 ExchangeItems(I, J);
1312 if P = I then
1313 P := J
1314 else if P = J then
1315 P := I;
1316 Inc(I);
1317 Dec(J);
1318 end;
1319 until I > J;
1320 if L < J then QuickSort(L, J, SCompare);
1321 L := I;
1322 until I >= R;
1323end;
1324
1325procedure TTntStringList.SetCapacity(NewCapacity: Integer);
1326begin
1327 ReallocMem(FList, NewCapacity * SizeOf(TWideStringItem));
1328 FCapacity := NewCapacity;
1329end;
1330
1331procedure TTntStringList.SetSorted(Value: Boolean);
1332begin
1333 if FSorted <> Value then
1334 begin
1335 if Value then Sort;
1336 FSorted := Value;
1337 end;
1338end;
1339
1340procedure TTntStringList.SetUpdateState(Updating: Boolean);
1341begin
1342 FUpdating := Updating;
1343 if Updating then Changing else Changed;
1344end;
1345
1346function WideStringListCompareStrings(List: TTntStringList; Index1, Index2: Integer): Integer;
1347begin
1348 Result := List.CompareStrings(List.FList^[Index1].FString,
1349 List.FList^[Index2].FString);
1350end;
1351
1352procedure TTntStringList.Sort;
1353begin
1354 CustomSort(WideStringListCompareStrings);
1355end;
1356
1357procedure TTntStringList.CustomSort(Compare: TWideStringListSortCompare);
1358begin
1359 if not Sorted and (FCount > 1) then
1360 begin
1361 Changing;
1362 QuickSort(0, FCount - 1, Compare);
1363 Changed;
1364 end;
1365end;
1366
1367function TTntStringList.CompareStrings(const S1, S2: WideString): Integer;
1368begin
1369 if CaseSensitive then
1370 Result := WideCompareStr(S1, S2)
1371 else
1372 Result := WideCompareText(S1, S2);
1373end;
1374
1375procedure TTntStringList.SetCaseSensitive(const Value: Boolean);
1376begin
1377 if Value <> FCaseSensitive then
1378 begin
1379 FCaseSensitive := Value;
1380 if Sorted then Sort;
1381 end;
1382end;
1383
1384//------------------------- TntClasses introduced procs ----------------------------------
1385
1386function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet;
1387var
1388 ByteOrderMark: WideChar;
1389 BytesRead: Integer;
1390 Utf8Test: array[0..2] of AnsiChar;
1391begin
1392 // Byte Order Mark
1393 ByteOrderMark := #0;
1394 if (Stream.Size - Stream.Position) >= SizeOf(ByteOrderMark) then begin
1395 BytesRead := Stream.Read(ByteOrderMark, SizeOf(ByteOrderMark));
1396 if (ByteOrderMark <> UNICODE_BOM) and (ByteOrderMark <> UNICODE_BOM_SWAPPED) then begin
1397 ByteOrderMark := #0;
1398 Stream.Seek(-BytesRead, soFromCurrent);
1399 if (Stream.Size - Stream.Position) >= Length(Utf8Test) * SizeOf(AnsiChar) then begin
1400 BytesRead := Stream.Read(Utf8Test[0], Length(Utf8Test) * SizeOf(AnsiChar));
1401 if Utf8Test <> UTF8_BOM then
1402 Stream.Seek(-BytesRead, soFromCurrent);
1403 end;
1404 end;
1405 end;
1406 // Test Byte Order Mark
1407 if ByteOrderMark = UNICODE_BOM then
1408 Result := csUnicode
1409 else if ByteOrderMark = UNICODE_BOM_SWAPPED then
1410 Result := csUnicodeSwapped
1411 else if Utf8Test = UTF8_BOM then
1412 Result := csUtf8
1413 else
1414 Result := csAnsi;
1415end;
1416
1417function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare;
1418 Target: Pointer; var Index: Integer): Boolean;
1419var
1420 L, H, I, C: Integer;
1421begin
1422 Result := False;
1423 L := 0;
1424 H := List.Count - 1;
1425 while L <= H do
1426 begin
1427 I := (L + H) shr 1;
1428 C := TargetCompare(List[i], Target);
1429 if C < 0 then L := I + 1 else
1430 begin
1431 H := I - 1;
1432 if C = 0 then
1433 begin
1434 Result := True;
1435 L := I;
1436 end;
1437 end;
1438 end;
1439 Index := L;
1440end;
1441
1442function ClassIsRegistered(const clsid: TCLSID): Boolean;
1443var
1444 OleStr: POleStr;
1445 Reg: TRegIniFile;
1446 Key, Filename: WideString;
1447begin
1448 // First, check to see if there is a ProgID. This will tell if the
1449 // control is registered on the machine. No ProgID, control won't run
1450 Result := ProgIDFromCLSID(clsid, OleStr) = S_OK;
1451 if not Result then Exit; //Bail as soon as anything goes wrong.
1452
1453 // Next, make sure that the file is actually there by rooting it out
1454 // of the registry
1455 Key := WideFormat('\SOFTWARE\Classes\CLSID\%s', [GUIDToString(clsid)]);
1456 Reg := TRegIniFile.Create;
1457 try
1458 Reg.RootKey := HKEY_LOCAL_MACHINE;
1459 Result := Reg.OpenKeyReadOnly(Key);
1460 if not Result then Exit; // Bail as soon as anything goes wrong.
1461
1462 FileName := Reg.ReadString('InProcServer32', '', EmptyStr);
1463 if (Filename = EmptyStr) then // try another key for the file name
1464 begin
1465 FileName := Reg.ReadString('InProcServer', '', EmptyStr);
1466 end;
1467 Result := Filename <> EmptyStr;
1468 if not Result then Exit;
1469 Result := WideFileExists(Filename);
1470 finally
1471 Reg.Free;
1472 end;
1473end;
1474
1475{ TBufferedAnsiString }
1476
1477procedure TBufferedAnsiString.Clear;
1478begin
1479 LastWriteIndex := 0;
1480 if Length(FStringBuffer) > 0 then
1481 FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(AnsiChar), 0);
1482end;
1483
1484procedure TBufferedAnsiString.AddChar(const wc: AnsiChar);
1485const
1486 MIN_GROW_SIZE = 32;
1487 MAX_GROW_SIZE = 256;
1488var
1489 GrowSize: Integer;
1490begin
1491 Inc(LastWriteIndex);
1492 if LastWriteIndex > Length(FStringBuffer) then begin
1493 GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer));
1494 GrowSize := Min(GrowSize, MAX_GROW_SIZE);
1495 SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize);
1496 FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(AnsiChar), 0);
1497 end;
1498 FStringBuffer[LastWriteIndex] := wc;
1499end;
1500
1501procedure TBufferedAnsiString.AddString(const s: AnsiString);
1502var
1503 LenS: Integer;
1504 BlockSize: Integer;
1505 AllocSize: Integer;
1506begin
1507 LenS := Length(s);
1508 if LenS > 0 then begin
1509 Inc(LastWriteIndex);
1510 if LastWriteIndex + LenS - 1 > Length(FStringBuffer) then begin
1511 // determine optimum new allocation size
1512 BlockSize := Length(FStringBuffer) div 2;
1513 if BlockSize < 8 then
1514 BlockSize := 8;
1515 AllocSize := ((LenS div BlockSize) + 1) * BlockSize;
1516 // realloc buffer
1517 SetLength(FStringBuffer, Length(FStringBuffer) + AllocSize);
1518 FillChar(FStringBuffer[Length(FStringBuffer) - AllocSize + 1], AllocSize * SizeOf(AnsiChar), 0);
1519 end;
1520 CopyMemory(@FStringBuffer[LastWriteIndex], @s[1], LenS * SizeOf(AnsiChar));
1521 Inc(LastWriteIndex, LenS - 1);
1522 end;
1523end;
1524
1525procedure TBufferedAnsiString.AddBuffer(Buff: PAnsiChar; Chars: Integer);
1526var
1527 i: integer;
1528begin
1529 for i := 1 to Chars do begin
1530 if Buff^ = #0 then
1531 break;
1532 AddChar(Buff^);
1533 Inc(Buff);
1534 end;
1535end;
1536
1537function TBufferedAnsiString.Value: AnsiString;
1538begin
1539 Result := PAnsiChar(FStringBuffer);
1540end;
1541
1542function TBufferedAnsiString.BuffPtr: PAnsiChar;
1543begin
1544 Result := PAnsiChar(FStringBuffer);
1545end;
1546
1547{ TBufferedWideString }
1548
1549procedure TBufferedWideString.Clear;
1550begin
1551 LastWriteIndex := 0;
1552 if Length(FStringBuffer) > 0 then
1553 FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(WideChar), 0);
1554end;
1555
1556procedure TBufferedWideString.AddChar(const wc: WideChar);
1557const
1558 MIN_GROW_SIZE = 32;
1559 MAX_GROW_SIZE = 256;
1560var
1561 GrowSize: Integer;
1562begin
1563 Inc(LastWriteIndex);
1564 if LastWriteIndex > Length(FStringBuffer) then begin
1565 GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer));
1566 GrowSize := Min(GrowSize, MAX_GROW_SIZE);
1567 SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize);
1568 FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(WideChar), 0);
1569 end;
1570 FStringBuffer[LastWriteIndex] := wc;
1571end;
1572
1573procedure TBufferedWideString.AddString(const s: WideString);
1574var
1575 i: integer;
1576begin
1577 for i := 1 to Length(s) do
1578 AddChar(s[i]);
1579end;
1580
1581procedure TBufferedWideString.AddBuffer(Buff: PWideChar; Chars: Integer);
1582var
1583 i: integer;
1584begin
1585 for i := 1 to Chars do begin
1586 if Buff^ = #0 then
1587 break;
1588 AddChar(Buff^);
1589 Inc(Buff);
1590 end;
1591end;
1592
1593function TBufferedWideString.Value: WideString;
1594begin
1595 Result := PWideChar(FStringBuffer);
1596end;
1597
1598function TBufferedWideString.BuffPtr: PWideChar;
1599begin
1600 Result := PWideChar(FStringBuffer);
1601end;
1602
1603{ TBufferedStreamReader }
1604
1605constructor TBufferedStreamReader.Create(Stream: TStream; BufferSize: Integer = 1024);
1606begin
1607 // init stream
1608 FStream := Stream;
1609 FStreamSize := Stream.Size;
1610 // init buffer
1611 FBufferSize := BufferSize;
1612 SetLength(FBuffer, BufferSize);
1613 FBufferStartPosition := -FBufferSize; { out of any useful range }
1614 // init virtual position
1615 FVirtualPosition := 0;
1616end;
1617
1618function TBufferedStreamReader.Seek(Offset: Integer; Origin: Word): Longint;
1619begin
1620 case Origin of
1621 soFromBeginning: FVirtualPosition := Offset;
1622 soFromCurrent: Inc(FVirtualPosition, Offset);
1623 soFromEnd: FVirtualPosition := FStreamSize + Offset;
1624 end;
1625 Result := FVirtualPosition;
1626end;
1627
1628procedure TBufferedStreamReader.UpdateBufferFromPosition(StartPos: Integer);
1629begin
1630 try
1631 FStream.Position := StartPos;
1632 FStream.Read(FBuffer[0], FBufferSize);
1633 FBufferStartPosition := StartPos;
1634 except
1635 FBufferStartPosition := -FBufferSize; { out of any useful range }
1636 raise;
1637 end;
1638end;
1639
1640function TBufferedStreamReader.Read(var Buffer; Count: Integer): Longint;
1641var
1642 BytesLeft: Integer;
1643 FirstBufferRead: Integer;
1644 StreamDirectRead: Integer;
1645 Buf: PAnsiChar;
1646begin
1647 if (FVirtualPosition >= 0) and (Count >= 0) then
1648 begin
1649 Result := FStreamSize - FVirtualPosition;
1650 if Result > 0 then
1651 begin
1652 if Result > Count then
1653 Result := Count;
1654
1655 Buf := @Buffer;
1656 BytesLeft := Result;
1657
1658 // try to read what is left in buffer
1659 FirstBufferRead := FBufferStartPosition + FBufferSize - FVirtualPosition;
1660 if (FirstBufferRead < 0) or (FirstBufferRead > FBufferSize) then
1661 FirstBufferRead := 0;
1662 FirstBufferRead := Min(FirstBufferRead, Result);
1663 if FirstBufferRead > 0 then begin
1664 Move(FBuffer[FVirtualPosition - FBufferStartPosition], Buf[0], FirstBufferRead);
1665 Dec(BytesLeft, FirstBufferRead);
1666 end;
1667
1668 if BytesLeft > 0 then begin
1669 // The first read in buffer was not enough
1670 StreamDirectRead := (BytesLeft div FBufferSize) * FBufferSize;
1671 FStream.Position := FVirtualPosition + FirstBufferRead;
1672 FStream.Read(Buf[FirstBufferRead], StreamDirectRead);
1673 Dec(BytesLeft, StreamDirectRead);
1674
1675 if BytesLeft > 0 then begin
1676 // update buffer, and read what is left
1677 UpdateBufferFromPosition(FStream.Position);
1678 Move(FBuffer[0], Buf[FirstBufferRead + StreamDirectRead], BytesLeft);
1679 end;
1680 end;
1681
1682 Inc(FVirtualPosition, Result);
1683 Exit;
1684 end;
1685 end;
1686 Result := 0;
1687end;
1688
1689function TBufferedStreamReader.Write(const Buffer; Count: Integer): Longint;
1690begin
1691 raise ETntInternalError.Create('Internal Error: class can not write.');
1692 Result := 0;
1693end;
1694
1695//-------- synced wide string -----------------
1696
1697function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString;
1698begin
1699 if AnsiString(WideStr) <> (AnsiStr) then begin
1700 WideStr := AnsiStr; {AnsiStr changed. Keep WideStr in sync.}
1701 end;
1702 Result := WideStr;
1703end;
1704
1705procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString;
1706 const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent);
1707begin
1708 if Value <> GetSyncedWideString(WideStr, AnsiStr) then
1709 begin
1710 if (not WideSameStr(Value, AnsiString(Value))) {unicode chars lost in conversion}
1711 and (AnsiStr = AnsiString(Value)) {AnsiStr is not going to change}
1712 then begin
1713 SetAnsiStr(''); {force the change}
1714 end;
1715 WideStr := Value;
1716 SetAnsiStr(Value);
1717 end;
1718end;
1719
1720{ TWideComponentHelper }
1721
1722function CompareComponentHelperToTarget(Item, Target: Pointer): Integer;
1723begin
1724 if Integer(TWideComponentHelper(Item).FComponent) < Integer(Target) then
1725 Result := -1
1726 else if Integer(TWideComponentHelper(Item).FComponent) > Integer(Target) then
1727 Result := 1
1728 else
1729 Result := 0;
1730end;
1731
1732function FindWideComponentHelperIndex(ComponentHelperList: TComponentList; Component: TComponent; var Index: Integer): Boolean;
1733begin
1734 // find Component in sorted wide caption list (list is sorted by TWideComponentHelper.FComponent)
1735 Result := FindSortedListByTarget(ComponentHelperList, CompareComponentHelperToTarget, Component, Index);
1736end;
1737
1738constructor TWideComponentHelper.Create(AOwner: TComponent);
1739begin
1740 raise ETntInternalError.Create('TNT Internal Error: TWideComponentHelper.Create should never be encountered.');
1741end;
1742
1743constructor TWideComponentHelper.CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList);
1744var
1745 Index: Integer;
1746begin
1747 // don't use direct ownership for memory management
1748 inherited Create(nil);
1749 FComponent := AOwner;
1750 FComponent.FreeNotification(Self);
1751
1752 // insert into list according to sort
1753 FindWideComponentHelperIndex(ComponentHelperList, FComponent, Index);
1754 ComponentHelperList.Insert(Index, Self);
1755end;
1756
1757procedure TWideComponentHelper.Notification(AComponent: TComponent; Operation: TOperation);
1758begin
1759 inherited;
1760 if (AComponent = FComponent) and (Operation = opRemove) then begin
1761 FComponent := nil;
1762 Free;
1763 end;
1764end;
1765
1766function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper;
1767var
1768 Index: integer;
1769begin
1770 if FindWideComponentHelperIndex(ComponentHelperList, Component, Index) then begin
1771 Result := TWideComponentHelper(ComponentHelperList[Index]);
1772 Assert(Result.FComponent = Component, 'TNT Internal Error: FindWideComponentHelperIndex failed.');
1773 end else
1774 Result := nil;
1775end;
1776
1777initialization
1778 RuntimeUTFStreaming := False; { Delphi 6 and higher don't need UTF help at runtime. }
1779
1780end.
Note: See TracBrowser for help on using the repository browser.