source: cprs/branches/tmg-cprs/TMG_Extra/tntUniCode/Source/TntClasses.pas

Last change on this file was 672, checked in by Kevin Toppenberg, 10 years ago

Adding source to tntControls for compilation

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.