Source/TntClasses.pas

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