From eed9e76c90986b51ade27bbf322546ab5926d9f6 Mon Sep 17 00:00:00 2001 From: k-m_schindler Date: Sat, 22 Nov 2014 14:25:36 +0000 Subject: adjust eol and set svn property svn:eol-style native in TntUnicodeControls git-svn-id: svn://svn.code.sf.net/p/ultrastardx/svn/trunk@3097 b956fd51-792f-4845-bead-9b4dfca2ff2c --- src/lib/TntUnicodeControls/TntClasses.pas | 3612 +++++++++++----------- src/lib/TntUnicodeControls/TntFormatStrUtils.pas | 1042 +++---- 2 files changed, 2327 insertions(+), 2327 deletions(-) diff --git a/src/lib/TntUnicodeControls/TntClasses.pas b/src/lib/TntUnicodeControls/TntClasses.pas index f0ebd14c..164f7b45 100644 --- a/src/lib/TntUnicodeControls/TntClasses.pas +++ b/src/lib/TntUnicodeControls/TntClasses.pas @@ -1,1806 +1,1806 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntClasses; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -interface - -{ TODO: Consider: TTntRegIniFile, TTntMemIniFile (consider if UTF8 fits into this solution). } - -{***********************************************} -{ WideChar-streaming implemented by Maël Hörz } -{***********************************************} - -uses - Classes, SysUtils, Windows, - {$IFNDEF COMPILER_10_UP} - TntWideStrings, - {$ELSE} - WideStrings, - {$ENDIF} - ActiveX, Contnrs; - -// ......... introduced ......... -type - TTntStreamCharSet = (csAnsi, csUnicode, csUnicodeSwapped, csUtf8); - -function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet; - -//--------------------------------------------------------------------------------------------- -// Tnt - Classes -//--------------------------------------------------------------------------------------------- - -{TNT-WARN ExtractStrings} -{TNT-WARN LineStart} -{TNT-WARN TStringStream} // TODO: Implement a TWideStringStream - -// A potential implementation of TWideStringStream can be found at: -// http://kdsxml.cvs.sourceforge.net/kdsxml/Global/KDSClasses.pas?revision=1.10&view=markup - -procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent); - -type -{TNT-WARN TFileStream} - TTntFileStream = class(THandleStream) - public - constructor Create(const FileName: WideString; Mode: Word); - destructor Destroy; override; - end; - -{TNT-WARN TMemoryStream} - TTntMemoryStream = class(TMemoryStream{TNT-ALLOW TMemoryStream}) - public - procedure LoadFromFile(const FileName: WideString); - procedure SaveToFile(const FileName: WideString); - end; - -{TNT-WARN TResourceStream} - TTntResourceStream = class(TCustomMemoryStream) - private - HResInfo: HRSRC; - HGlobal: THandle; - procedure Initialize(Instance: THandle; Name, ResType: PWideChar); - public - constructor Create(Instance: THandle; const ResName: WideString; ResType: PWideChar); - constructor CreateFromID(Instance: THandle; ResID: Word; ResType: PWideChar); - destructor Destroy; override; - function Write(const Buffer; Count: Longint): Longint; override; - procedure SaveToFile(const FileName: WideString); - end; - - TTntStrings = class; - -{TNT-WARN TAnsiStrings} - TAnsiStrings{TNT-ALLOW TAnsiStrings} = class(TStrings{TNT-ALLOW TStrings}) - public - procedure LoadFromFile(const FileName: WideString); reintroduce; - procedure SaveToFile(const FileName: WideString); reintroduce; - procedure LoadFromFileEx(const FileName: WideString; CodePage: Cardinal); - procedure SaveToFileEx(const FileName: WideString; CodePage: Cardinal); - procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract; - procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract; - end; - - TAnsiStringsForWideStringsAdapter = class(TAnsiStrings{TNT-ALLOW TAnsiStrings}) - private - FWideStrings: TTntStrings; - FAdapterCodePage: Cardinal; - protected - function Get(Index: Integer): AnsiString; override; - procedure Put(Index: Integer; const S: AnsiString); override; - function GetCount: Integer; override; - function GetObject(Index: Integer): TObject; override; - procedure PutObject(Index: Integer; AObject: TObject); override; - procedure SetUpdateState(Updating: Boolean); override; - function AdapterCodePage: Cardinal; dynamic; - public - constructor Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal = 0); - procedure Clear; override; - procedure Delete(Index: Integer); override; - procedure Insert(Index: Integer; const S: AnsiString); override; - procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); override; - procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); override; - end; - -{TNT-WARN TStrings} - TTntStrings = class(TWideStrings) - private - FLastFileCharSet: TTntStreamCharSet; - FAnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings}; - procedure SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings}); - procedure ReadData(Reader: TReader); - procedure ReadDataUTF7(Reader: TReader); - procedure ReadDataUTF8(Reader: TReader); - procedure WriteDataUTF7(Writer: TWriter); - protected - procedure DefineProperties(Filer: TFiler); override; - public - constructor Create; - destructor Destroy; override; - - procedure LoadFromFile(const FileName: WideString); override; - procedure LoadFromStream(Stream: TStream); override; - procedure LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); virtual; - - procedure SaveToFile(const FileName: WideString); override; - procedure SaveToStream(Stream: TStream); override; - procedure SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); virtual; - - property LastFileCharSet: TTntStreamCharSet read FLastFileCharSet; - published - property AnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings} read FAnsiStrings write SetAnsiStrings stored False; - end; - -{ TTntStringList class } - - TTntStringList = class; - TWideStringListSortCompare = function(List: TTntStringList; Index1, Index2: Integer): Integer; - -{TNT-WARN TStringList} - TTntStringList = class(TTntStrings) - private - FUpdating: Boolean; - FList: PWideStringItemList; - FCount: Integer; - FCapacity: Integer; - FSorted: Boolean; - FDuplicates: TDuplicates; - FCaseSensitive: Boolean; - FOnChange: TNotifyEvent; - FOnChanging: TNotifyEvent; - procedure ExchangeItems(Index1, Index2: Integer); - procedure Grow; - procedure QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare); - procedure SetSorted(Value: Boolean); - procedure SetCaseSensitive(const Value: Boolean); - protected - procedure Changed; virtual; - procedure Changing; virtual; - function Get(Index: Integer): WideString; override; - function GetCapacity: Integer; override; - function GetCount: Integer; override; - function GetObject(Index: Integer): TObject; override; - procedure Put(Index: Integer; const S: WideString); override; - procedure PutObject(Index: Integer; AObject: TObject); override; - procedure SetCapacity(NewCapacity: Integer); override; - procedure SetUpdateState(Updating: Boolean); override; - function CompareStrings(const S1, S2: WideString): Integer; override; - procedure InsertItem(Index: Integer; const S: WideString; AObject: TObject); virtual; - public - destructor Destroy; override; - function Add(const S: WideString): Integer; override; - function AddObject(const S: WideString; AObject: TObject): Integer; override; - procedure Clear; override; - procedure Delete(Index: Integer); override; - procedure Exchange(Index1, Index2: Integer); override; - function Find(const S: WideString; var Index: Integer): Boolean; virtual; - function IndexOf(const S: WideString): Integer; override; - function IndexOfName(const Name: WideString): Integer; override; - procedure Insert(Index: Integer; const S: WideString); override; - procedure InsertObject(Index: Integer; const S: WideString; - AObject: TObject); override; - procedure Sort; virtual; - procedure CustomSort(Compare: TWideStringListSortCompare); virtual; - property Duplicates: TDuplicates read FDuplicates write FDuplicates; - property Sorted: Boolean read FSorted write SetSorted; - property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; - end; - -// ......... introduced ......... -type - TListTargetCompare = function (Item, Target: Pointer): Integer; - -function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare; - Target: Pointer; var Index: Integer): Boolean; - -function ClassIsRegistered(const clsid: TCLSID): Boolean; - -var - RuntimeUTFStreaming: Boolean; - -type - TBufferedAnsiString = class(TObject) - private - FStringBuffer: AnsiString; - LastWriteIndex: Integer; - public - procedure Clear; - procedure AddChar(const wc: AnsiChar); - procedure AddString(const s: AnsiString); - procedure AddBuffer(Buff: PAnsiChar; Chars: Integer); - function Value: AnsiString; - function BuffPtr: PAnsiChar; - end; - - TBufferedWideString = class(TObject) - private - FStringBuffer: WideString; - LastWriteIndex: Integer; - public - procedure Clear; - procedure AddChar(const wc: WideChar); - procedure AddString(const s: WideString); - procedure AddBuffer(Buff: PWideChar; Chars: Integer); - function Value: WideString; - function BuffPtr: PWideChar; - end; - - TBufferedStreamReader = class(TStream) - private - FStream: TStream; - FStreamSize: Integer; - FBuffer: array of Byte; - FBufferSize: Integer; - FBufferStartPosition: Integer; - FVirtualPosition: Integer; - procedure UpdateBufferFromPosition(StartPos: Integer); - public - constructor Create(Stream: TStream; BufferSize: Integer = 1024); - function Read(var Buffer; Count: Longint): Longint; override; - function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; - end; - -// "synced" wide string -type TSetAnsiStrEvent = procedure(const Value: AnsiString) of object; -function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString; -procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString; - const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent); - -type - TWideComponentHelper = class(TComponent) - private - FComponent: TComponent; - protected - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - public - constructor Create(AOwner: TComponent); override; - constructor CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList); - end; - -function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper; - -implementation - -uses - RTLConsts, ComObj, Math, - Registry, TypInfo, TntSystem, TntSysUtils; - -{ TntPersistent } - -//=========================================================================== -// The Delphi 5 Classes.pas never supported the streaming of WideStrings. -// The Delphi 6 Classes.pas supports WideString streaming. But it's too bad that -// the Delphi 6 IDE doesn't use the updated Classes.pas. Switching between Form/Text -// mode corrupts extended characters in WideStrings even under Delphi 6. -// Delphi 7 seems to finally get right. But let's keep the UTF7 support at design time -// to enable sharing source code with previous versions of Delphi. -// -// The purpose of this solution is to store WideString properties which contain -// non-ASCII chars in the form of UTF7 under the old property name + '_UTF7'. -// -// Special thanks go to Francisco Leong for helping to develop this solution. -// - -{ TTntWideStringPropertyFiler } -type - TTntWideStringPropertyFiler = class - private - FInstance: TPersistent; - FPropInfo: PPropInfo; - procedure ReadDataUTF8(Reader: TReader); - procedure ReadDataUTF7(Reader: TReader); - procedure WriteDataUTF7(Writer: TWriter); - public - procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString); - end; - -function ReaderNeedsUtfHelp(Reader: TReader): Boolean; -begin - if Reader.Owner = nil then - Result := False { designtime - visual form inheritance ancestor } - else if csDesigning in Reader.Owner.ComponentState then - {$IFDEF COMPILER_7_UP} - Result := False { Delphi 7+: designtime - doesn't need UTF help. } - {$ELSE} - Result := True { Delphi 6: designtime - always needs UTF help. } - {$ENDIF} - else - Result := RuntimeUTFStreaming; { runtime } -end; - -procedure TTntWideStringPropertyFiler.ReadDataUTF8(Reader: TReader); -begin - if ReaderNeedsUtfHelp(Reader) then - SetWideStrProp(FInstance, FPropInfo, UTF8ToWideString(Reader.ReadString)) - else - Reader.ReadString; { do nothing with Result } -end; - -procedure TTntWideStringPropertyFiler.ReadDataUTF7(Reader: TReader); -begin - if ReaderNeedsUtfHelp(Reader) then - SetWideStrProp(FInstance, FPropInfo, UTF7ToWideString(Reader.ReadString)) - else - Reader.ReadString; { do nothing with Result } -end; - -procedure TTntWideStringPropertyFiler.WriteDataUTF7(Writer: TWriter); -begin - Writer.WriteString(WideStringToUTF7(GetWideStrProp(FInstance, FPropInfo))); -end; - -procedure TTntWideStringPropertyFiler.DefineProperties(Filer: TFiler; Instance: TPersistent; - PropName: AnsiString); - - {$IFNDEF COMPILER_7_UP} - function HasData: Boolean; - var - CurrPropValue: WideString; - begin - // must be stored - Result := IsStoredProp(Instance, FPropInfo); - if Result - and (Filer.Ancestor <> nil) - and (GetPropInfo(Filer.Ancestor, PropName, [tkWString]) <> nil) then - begin - // must be different than ancestor - CurrPropValue := GetWideStrProp(Instance, FPropInfo); - Result := CurrPropValue <> GetWideStrProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName)); - end; - if Result then begin - // must be non-blank and different than UTF8 (implies all ASCII <= 127) - CurrPropValue := GetWideStrProp(Instance, FPropInfo); - Result := (CurrPropValue <> '') and (WideStringToUTF8(CurrPropValue) <> CurrPropValue); - end; - end; - {$ENDIF} - -begin - FInstance := Instance; - FPropInfo := GetPropInfo(Instance, PropName, [tkWString]); - if FPropInfo <> nil then begin - // must be published (and of type WideString) - Filer.DefineProperty(PropName + 'W', ReadDataUTF8, nil, False); - {$IFDEF COMPILER_7_UP} - Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, False); - {$ELSE} - Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, HasData); - {$ENDIF} - end; - FInstance := nil; - FPropInfo := nil; -end; - -{ TTntWideCharPropertyFiler } -type - TTntWideCharPropertyFiler = class - private - FInstance: TPersistent; - FPropInfo: PPropInfo; - {$IFNDEF COMPILER_9_UP} - FWriter: TWriter; - procedure GetLookupInfo(var Ancestor: TPersistent; - var Root, LookupRoot, RootAncestor: TComponent); - {$ENDIF} - procedure ReadData_W(Reader: TReader); - procedure ReadDataUTF7(Reader: TReader); - procedure WriteData_W(Writer: TWriter); - function ReadChar(Reader: TReader): WideChar; - public - procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString); - end; - -{$IFNDEF COMPILER_9_UP} -type - TGetLookupInfoEvent = procedure(var Ancestor: TPersistent; - var Root, LookupRoot, RootAncestor: TComponent) of object; - -function AncestorIsValid(Ancestor: TPersistent; Root, RootAncestor: TComponent): Boolean; -begin - Result := (Ancestor <> nil) and (RootAncestor <> nil) and - Root.InheritsFrom(RootAncestor.ClassType); -end; - -function IsDefaultOrdPropertyValue(Instance: TObject; PropInfo: PPropInfo; - OnGetLookupInfo: TGetLookupInfoEvent): Boolean; -var - Ancestor: TPersistent; - LookupRoot: TComponent; - RootAncestor: TComponent; - Root: TComponent; - AncestorValid: Boolean; - Value: Longint; - Default: LongInt; -begin - Ancestor := nil; - Root := nil; - LookupRoot := nil; - RootAncestor := nil; - - if Assigned(OnGetLookupInfo) then - OnGetLookupInfo(Ancestor, Root, LookupRoot, RootAncestor); - - AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor); - - Result := True; - if (PropInfo^.GetProc <> nil) and (PropInfo^.SetProc <> nil) then - begin - Value := GetOrdProp(Instance, PropInfo); - if AncestorValid then - Result := Value = GetOrdProp(Ancestor, PropInfo) - else - begin - Default := PPropInfo(PropInfo)^.Default; - Result := (Default <> LongInt($80000000)) and (Value = Default); - end; - end; -end; - -procedure TTntWideCharPropertyFiler.GetLookupInfo(var Ancestor: TPersistent; - var Root, LookupRoot, RootAncestor: TComponent); -begin - Ancestor := FWriter.Ancestor; - Root := FWriter.Root; - LookupRoot := FWriter.LookupRoot; - RootAncestor := FWriter.RootAncestor; -end; -{$ENDIF} - -function TTntWideCharPropertyFiler.ReadChar(Reader: TReader): WideChar; -var - Temp: WideString; -begin - case Reader.NextValue of - vaWString: - Temp := Reader.ReadWideString; - vaString: - Temp := Reader.ReadString; - else - raise EReadError.Create(SInvalidPropertyValue); - end; - - if Length(Temp) > 1 then - raise EReadError.Create(SInvalidPropertyValue); - Result := Temp[1]; -end; - -procedure TTntWideCharPropertyFiler.ReadData_W(Reader: TReader); -begin - SetOrdProp(FInstance, FPropInfo, Ord(ReadChar(Reader))); -end; - -procedure TTntWideCharPropertyFiler.ReadDataUTF7(Reader: TReader); -var - S: WideString; -begin - S := UTF7ToWideString(Reader.ReadString); - if S = '' then - SetOrdProp(FInstance, FPropInfo, 0) - else - SetOrdProp(FInstance, FPropInfo, Ord(S[1])) -end; - -type TAccessWriter = class(TWriter); - -procedure TTntWideCharPropertyFiler.WriteData_W(Writer: TWriter); -var - L: Integer; - Temp: WideString; -{$IFDEF FPC} -// Workaround: the Buffer parameter of TWriter.Write() must be of a fixed size -// type for FPC >= 2.4.0. The values vaWString, Ord(vaWString) or Integer(vaWString) -// are not allowed anymore. -const - vaWStringInt: integer = Ord(vaWString); -{$ENDIF} -begin - Temp := WideChar(GetOrdProp(FInstance, FPropInfo)); - - {$IFNDEF FPC} - TAccessWriter(Writer).WriteValue(vaWString); - {$ELSE} - TAccessWriter(Writer).Write(vaWStringInt, SizeOf(vaWString)); - {$ENDIF} - L := Length(Temp); - Writer.Write(L, SizeOf(Integer)); - Writer.Write(Pointer(@Temp[1])^, L * 2); -end; - -procedure TTntWideCharPropertyFiler.DefineProperties(Filer: TFiler; - Instance: TPersistent; PropName: AnsiString); - - {$IFNDEF COMPILER_9_UP} - function HasData: Boolean; - var - CurrPropValue: Integer; - begin - // must be stored - Result := IsStoredProp(Instance, FPropInfo); - if Result and (Filer.Ancestor <> nil) and - (GetPropInfo(Filer.Ancestor, PropName, [tkWChar]) <> nil) then - begin - // must be different than ancestor - CurrPropValue := GetOrdProp(Instance, FPropInfo); - Result := CurrPropValue <> GetOrdProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName)); - end; - if Result and (Filer is TWriter) then - begin - FWriter := TWriter(Filer); - Result := not IsDefaultOrdPropertyValue(Instance, FPropInfo, GetLookupInfo); - end; - end; - {$ENDIF} - -begin - FInstance := Instance; - FPropInfo := GetPropInfo(Instance, PropName, [tkWChar]); - if FPropInfo <> nil then - begin - // must be published (and of type WideChar) - {$IFDEF COMPILER_9_UP} - Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, False); - {$ELSE} - Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, HasData); - {$ENDIF} - Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, nil, False); - end; - FInstance := nil; - FPropInfo := nil; -end; - -procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent); -var - I, Count: Integer; - PropInfo: PPropInfo; - PropList: PPropList; - WideStringFiler: TTntWideStringPropertyFiler; - WideCharFiler: TTntWideCharPropertyFiler; -begin - Count := GetTypeData(Instance.ClassInfo)^.PropCount; - if Count > 0 then - begin - WideStringFiler := TTntWideStringPropertyFiler.Create; - try - WideCharFiler := TTntWideCharPropertyFiler.Create; - try - GetMem(PropList, Count * SizeOf(Pointer)); - try - GetPropInfos(Instance.ClassInfo, PropList); - for I := 0 to Count - 1 do - begin - PropInfo := PropList^[I]; - if (PropInfo = nil) then - break; - if (PropInfo.PropType^.Kind = tkWString) then - WideStringFiler.DefineProperties(Filer, Instance, PropInfo.Name) - else if (PropInfo.PropType^.Kind = tkWChar) then - WideCharFiler.DefineProperties(Filer, Instance, PropInfo.Name) - end; - finally - FreeMem(PropList, Count * SizeOf(Pointer)); - end; - finally - WideCharFiler.Free; - end; - finally - WideStringFiler.Free; - end; - end; -end; - -{ TTntFileStream } - -{$IFDEF FPC} - {$DEFINE HAS_SFCREATEERROREX} -{$ENDIF} -{$IFDEF DELPHI_7_UP} - {$DEFINE HAS_SFCREATEERROREX} -{$ENDIF} - -constructor TTntFileStream.Create(const FileName: WideString; Mode: Word); -var - CreateHandle: Integer; - {$IFDEF HAS_SFCREATEERROREX} - ErrorMessage: WideString; - {$ENDIF} -begin - if Mode = fmCreate then - begin - CreateHandle := WideFileCreate(FileName); - if CreateHandle < 0 then begin - {$IFDEF HAS_SFCREATEERROREX} - ErrorMessage := WideSysErrorMessage(GetLastError); - raise EFCreateError.CreateFmt(SFCreateErrorEx, [WideExpandFileName(FileName), ErrorMessage]); - {$ELSE} - raise EFCreateError.CreateFmt(SFCreateError, [WideExpandFileName(FileName)]); - {$ENDIF} - end; - end else - begin - CreateHandle := WideFileOpen(FileName, Mode); - if CreateHandle < 0 then begin - {$IFDEF HAS_SFCREATEERROREX} - ErrorMessage := WideSysErrorMessage(GetLastError); - raise EFOpenError.CreateFmt(SFOpenErrorEx, [WideExpandFileName(FileName), ErrorMessage]); - {$ELSE} - raise EFOpenError.CreateFmt(SFOpenError, [WideExpandFileName(FileName)]); - {$ENDIF} - end; - end; - inherited Create(CreateHandle); -end; - -destructor TTntFileStream.Destroy; -begin - if Handle >= 0 then FileClose(Handle); -end; - -{ TTntMemoryStream } - -procedure TTntMemoryStream.LoadFromFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TTntMemoryStream.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -{ TTntResourceStream } - -constructor TTntResourceStream.Create(Instance: THandle; const ResName: WideString; - ResType: PWideChar); -begin - inherited Create; - Initialize(Instance, PWideChar(ResName), ResType); -end; - -constructor TTntResourceStream.CreateFromID(Instance: THandle; ResID: Word; - ResType: PWideChar); -begin - inherited Create; - Initialize(Instance, PWideChar(ResID), ResType); -end; - -procedure TTntResourceStream.Initialize(Instance: THandle; Name, ResType: PWideChar); - - procedure Error; - begin - raise EResNotFound.CreateFmt(SResNotFound, [Name]); - end; - -begin - HResInfo := FindResourceW(Instance, Name, ResType); - if HResInfo = 0 then Error; - HGlobal := LoadResource(Instance, HResInfo); - if HGlobal = 0 then Error; - SetPointer(LockResource(HGlobal), SizeOfResource(Instance, HResInfo)); -end; - -destructor TTntResourceStream.Destroy; -begin - UnlockResource(HGlobal); - FreeResource(HGlobal); { Technically this is not necessary (MS KB #193678) } - inherited Destroy; -end; - -function TTntResourceStream.Write(const Buffer; Count: Longint): Longint; -begin - raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError)); -end; - -procedure TTntResourceStream.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -{ TAnsiStrings } - -procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFileEx(const FileName: WideString; CodePage: Cardinal); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStreamEx(Stream, CodePage); - finally - Stream.Free; - end; -end; - -procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFileEx(const FileName: WideString; CodePage: Cardinal); -var - Stream: TStream; - Utf8BomPtr: PAnsiChar; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - if (CodePage = CP_UTF8) then - begin - Utf8BomPtr := PAnsiChar(UTF8_BOM); - Stream.WriteBuffer(Utf8BomPtr^, Length(UTF8_BOM)); - end; - SaveToStreamEx(Stream, CodePage); - finally - Stream.Free; - end; -end; - -{ TAnsiStringsForWideStringsAdapter } - -constructor TAnsiStringsForWideStringsAdapter.Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal); -begin - inherited Create; - FWideStrings := AWideStrings; - FAdapterCodePage := _AdapterCodePage; -end; - -function TAnsiStringsForWideStringsAdapter.AdapterCodePage: Cardinal; -begin - if FAdapterCodePage = 0 then - Result := TntSystem.DefaultSystemCodePage - else - Result := FAdapterCodePage; -end; - -procedure TAnsiStringsForWideStringsAdapter.Clear; -begin - FWideStrings.Clear; -end; - -procedure TAnsiStringsForWideStringsAdapter.Delete(Index: Integer); -begin - FWideStrings.Delete(Index); -end; - -function TAnsiStringsForWideStringsAdapter.Get(Index: Integer): AnsiString; -begin - Result := WideStringToStringEx(FWideStrings.Get(Index), AdapterCodePage); -end; - -procedure TAnsiStringsForWideStringsAdapter.Put(Index: Integer; const S: AnsiString); -begin - FWideStrings.Put(Index, StringToWideStringEx(S, AdapterCodePage)); -end; - -function TAnsiStringsForWideStringsAdapter.GetCount: Integer; -begin - Result := FWideStrings.GetCount; -end; - -procedure TAnsiStringsForWideStringsAdapter.Insert(Index: Integer; const S: AnsiString); -begin - FWideStrings.Insert(Index, StringToWideStringEx(S, AdapterCodePage)); -end; - -function TAnsiStringsForWideStringsAdapter.GetObject(Index: Integer): TObject; -begin - Result := FWideStrings.GetObject(Index); -end; - -procedure TAnsiStringsForWideStringsAdapter.PutObject(Index: Integer; AObject: TObject); -begin - FWideStrings.PutObject(Index, AObject); -end; - -procedure TAnsiStringsForWideStringsAdapter.SetUpdateState(Updating: Boolean); -begin - FWideStrings.SetUpdateState(Updating); -end; - -procedure TAnsiStringsForWideStringsAdapter.LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); -var - Size: Integer; - S: AnsiString; -begin - BeginUpdate; - try - Size := Stream.Size - Stream.Position; - SetString(S, nil, Size); - Stream.Read(Pointer(S)^, Size); - FWideStrings.SetTextStr(StringToWideStringEx(S, CodePage)); - finally - EndUpdate; - end; -end; - -procedure TAnsiStringsForWideStringsAdapter.SaveToStreamEx(Stream: TStream; CodePage: Cardinal); -var - S: AnsiString; -begin - S := WideStringToStringEx(FWideStrings.GetTextStr, CodePage); - Stream.WriteBuffer(Pointer(S)^, Length(S)); -end; - -{ TTntStrings } - -constructor TTntStrings.Create; -begin - inherited; - FAnsiStrings := TAnsiStringsForWideStringsAdapter.Create(Self); - FLastFileCharSet := csUnicode; -end; - -destructor TTntStrings.Destroy; -begin - FreeAndNil(FAnsiStrings); - inherited; -end; - -procedure TTntStrings.SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings}); -begin - FAnsiStrings.Assign(Value); -end; - -procedure TTntStrings.DefineProperties(Filer: TFiler); - - {$IFNDEF COMPILER_7_UP} - function DoWrite: Boolean; - begin - if Filer.Ancestor <> nil then - begin - Result := True; - if Filer.Ancestor is TWideStrings then - Result := not Equals(TWideStrings(Filer.Ancestor)) - end - else Result := Count > 0; - end; - - function DoWriteAsUTF7: Boolean; - var - i: integer; - begin - Result := False; - for i := 0 to Count - 1 do begin - if (Strings[i] <> '') and (WideStringToUTF8(Strings[i]) <> Strings[i]) then begin - Result := True; - break; { found a string with non-ASCII chars (> 127) } - end; - end; - end; - {$ENDIF} - -begin - inherited DefineProperties(Filer); { Handles main 'Strings' property.' } - Filer.DefineProperty('WideStrings', ReadData, nil, False); - Filer.DefineProperty('WideStringsW', ReadDataUTF8, nil, False); - {$IFDEF COMPILER_7_UP} - Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, False); - {$ELSE} - Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, DoWrite and DoWriteAsUTF7); - {$ENDIF} -end; - -procedure TTntStrings.LoadFromFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - FLastFileCharSet := AutoDetectCharacterSet(Stream); - Stream.Position := 0; - LoadFromStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TTntStrings.LoadFromStream(Stream: TStream); -begin - LoadFromStream_BOM(Stream, True); -end; - -procedure TTntStrings.LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); -var - DataLeft: Integer; - StreamCharSet: TTntStreamCharSet; - SW: WideString; - SA: AnsiString; -begin - BeginUpdate; - try - if WithBOM then - StreamCharSet := AutoDetectCharacterSet(Stream) - else - StreamCharSet := csUnicode; - DataLeft := Stream.Size - Stream.Position; - if (StreamCharSet in [csUnicode, csUnicodeSwapped]) then - begin - // BOM indicates Unicode text stream - if DataLeft < SizeOf(WideChar) then - SW := '' - else begin - SetLength(SW, DataLeft div SizeOf(WideChar)); - Stream.Read(PWideChar(SW)^, DataLeft); - if StreamCharSet = csUnicodeSwapped then - StrSwapByteOrder(PWideChar(SW)); - end; - SetTextStr(SW); - end - else if StreamCharSet = csUtf8 then - begin - // BOM indicates UTF-8 text stream - SetLength(SA, DataLeft div SizeOf(AnsiChar)); - Stream.Read(PAnsiChar(SA)^, DataLeft); - SetTextStr(UTF8ToWideString(SA)); - end - else - begin - // without byte order mark it is assumed that we are loading ANSI text - SetLength(SA, DataLeft div SizeOf(AnsiChar)); - Stream.Read(PAnsiChar(SA)^, DataLeft); - SetTextStr(SA); - end; - finally - EndUpdate; - end; -end; - -procedure TTntStrings.ReadData(Reader: TReader); -begin - if Reader.NextValue in [vaString, vaLString] then - SetTextStr(Reader.ReadString) {JCL compatiblity} - else if Reader.NextValue = vaWString then - SetTextStr(Reader.ReadWideString) {JCL compatiblity} - else begin - BeginUpdate; - try - Clear; - Reader.ReadListBegin; - while not Reader.EndOfList do - if Reader.NextValue in [vaString, vaLString] then - Add(Reader.ReadString) {TStrings compatiblity} - else - Add(Reader.ReadWideString); - Reader.ReadListEnd; - finally - EndUpdate; - end; - end; -end; - -procedure TTntStrings.ReadDataUTF7(Reader: TReader); -begin - Reader.ReadListBegin; - if ReaderNeedsUtfHelp(Reader) then - begin - BeginUpdate; - try - Clear; - while not Reader.EndOfList do - Add(UTF7ToWideString(Reader.ReadString)) - finally - EndUpdate; - end; - end else begin - while not Reader.EndOfList do - Reader.ReadString; { do nothing with Result } - end; - Reader.ReadListEnd; -end; - -procedure TTntStrings.ReadDataUTF8(Reader: TReader); -begin - Reader.ReadListBegin; - if ReaderNeedsUtfHelp(Reader) - or (Count = 0){ Legacy support where 'WideStrings' was never written in lieu of WideStringsW } - then begin - BeginUpdate; - try - Clear; - while not Reader.EndOfList do - Add(UTF8ToWideString(Reader.ReadString)) - finally - EndUpdate; - end; - end else begin - while not Reader.EndOfList do - Reader.ReadString; { do nothing with Result } - end; - Reader.ReadListEnd; -end; - -procedure TTntStrings.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TTntStrings.SaveToStream(Stream: TStream); -begin - SaveToStream_BOM(Stream, True); -end; - -procedure TTntStrings.SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); -// Saves the currently loaded text into the given stream. -// WithBOM determines whether to write a byte order mark or not. -var - SW: WideString; - BOM: WideChar; -begin - if WithBOM then begin - BOM := UNICODE_BOM; - Stream.WriteBuffer(BOM, SizeOf(WideChar)); - end; - SW := GetTextStr; - Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar)); -end; - -procedure TTntStrings.WriteDataUTF7(Writer: TWriter); -var - I: Integer; -begin - Writer.WriteListBegin; - for I := 0 to Count-1 do - Writer.WriteString(WideStringToUTF7(Get(I))); - Writer.WriteListEnd; -end; - -{ TTntStringList } - -destructor TTntStringList.Destroy; -begin - FOnChange := nil; - FOnChanging := nil; - inherited Destroy; - if FCount <> 0 then Finalize(FList^[0], FCount); - FCount := 0; - SetCapacity(0); -end; - -function TTntStringList.Add(const S: WideString): Integer; -begin - Result := AddObject(S, nil); -end; - -function TTntStringList.AddObject(const S: WideString; AObject: TObject): Integer; -begin - if not Sorted then - Result := FCount - else - if Find(S, Result) then - case Duplicates of - dupIgnore: Exit; - dupError: Error(PResStringRec(@SDuplicateString), 0); - end; - InsertItem(Result, S, AObject); -end; - -procedure TTntStringList.Changed; -begin - if (not FUpdating) and Assigned(FOnChange) then - FOnChange(Self); -end; - -procedure TTntStringList.Changing; -begin - if (not FUpdating) and Assigned(FOnChanging) then - FOnChanging(Self); -end; - -procedure TTntStringList.Clear; -begin - if FCount <> 0 then - begin - Changing; - Finalize(FList^[0], FCount); - FCount := 0; - SetCapacity(0); - Changed; - end; -end; - -procedure TTntStringList.Delete(Index: Integer); -begin - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Changing; - Finalize(FList^[Index]); - Dec(FCount); - if Index < FCount then - System.Move(FList^[Index + 1], FList^[Index], - (FCount - Index) * SizeOf(TWideStringItem)); - Changed; -end; - -procedure TTntStringList.Exchange(Index1, Index2: Integer); -begin - if (Index1 < 0) or (Index1 >= FCount) then Error(PResStringRec(@SListIndexError), Index1); - if (Index2 < 0) or (Index2 >= FCount) then Error(PResStringRec(@SListIndexError), Index2); - Changing; - ExchangeItems(Index1, Index2); - Changed; -end; - -procedure TTntStringList.ExchangeItems(Index1, Index2: Integer); -var - Temp: Integer; - Item1, Item2: PWideStringItem; -begin - Item1 := @FList^[Index1]; - Item2 := @FList^[Index2]; - Temp := Integer(Item1^.FString); - Integer(Item1^.FString) := Integer(Item2^.FString); - Integer(Item2^.FString) := Temp; - Temp := Integer(Item1^.FObject); - Integer(Item1^.FObject) := Integer(Item2^.FObject); - Integer(Item2^.FObject) := Temp; -end; - -function TTntStringList.Find(const S: WideString; var Index: Integer): Boolean; -var - L, H, I, C: Integer; -begin - Result := False; - L := 0; - H := FCount - 1; - while L <= H do - begin - I := (L + H) shr 1; - C := CompareStrings(FList^[I].FString, S); - if C < 0 then L := I + 1 else - begin - H := I - 1; - if C = 0 then - begin - Result := True; - if Duplicates <> dupAccept then L := I; - end; - end; - end; - Index := L; -end; - -function TTntStringList.Get(Index: Integer): WideString; -begin - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Result := FList^[Index].FString; -end; - -function TTntStringList.GetCapacity: Integer; -begin - Result := FCapacity; -end; - -function TTntStringList.GetCount: Integer; -begin - Result := FCount; -end; - -function TTntStringList.GetObject(Index: Integer): TObject; -begin - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Result := FList^[Index].FObject; -end; - -procedure TTntStringList.Grow; -var - Delta: Integer; -begin - if FCapacity > 64 then Delta := FCapacity div 4 else - if FCapacity > 8 then Delta := 16 else - Delta := 4; - SetCapacity(FCapacity + Delta); -end; - -function TTntStringList.IndexOf(const S: WideString): Integer; -begin - if not Sorted then Result := inherited IndexOf(S) else - if not Find(S, Result) then Result := -1; -end; - -function TTntStringList.IndexOfName(const Name: WideString): Integer; -var - NameKey: WideString; -begin - if not Sorted then - Result := inherited IndexOfName(Name) - else begin - // use sort to find index more quickly - NameKey := Name + NameValueSeparator; - Find(NameKey, Result); - if (Result < 0) or (Result > Count - 1) then - Result := -1 - else if CompareStrings(NameKey, Copy(Strings[Result], 1, Length(NameKey))) <> 0 then - Result := -1 - end; -end; - -procedure TTntStringList.Insert(Index: Integer; const S: WideString); -begin - InsertObject(Index, S, nil); -end; - -procedure TTntStringList.InsertObject(Index: Integer; const S: WideString; - AObject: TObject); -begin - if Sorted then Error(PResStringRec(@SSortedListError), 0); - if (Index < 0) or (Index > FCount) then Error(PResStringRec(@SListIndexError), Index); - InsertItem(Index, S, AObject); -end; - -procedure TTntStringList.InsertItem(Index: Integer; const S: WideString; AObject: TObject); -begin - Changing; - if FCount = FCapacity then Grow; - if Index < FCount then - System.Move(FList^[Index], FList^[Index + 1], - (FCount - Index) * SizeOf(TWideStringItem)); - with FList^[Index] do - begin - Pointer(FString) := nil; - FObject := AObject; - FString := S; - end; - Inc(FCount); - Changed; -end; - -procedure TTntStringList.Put(Index: Integer; const S: WideString); -begin - if Sorted then Error(PResStringRec(@SSortedListError), 0); - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Changing; - FList^[Index].FString := S; - Changed; -end; - -procedure TTntStringList.PutObject(Index: Integer; AObject: TObject); -begin - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Changing; - FList^[Index].FObject := AObject; - Changed; -end; - -procedure TTntStringList.QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare); -var - I, J, P: Integer; -begin - repeat - I := L; - J := R; - P := (L + R) shr 1; - repeat - while SCompare(Self, I, P) < 0 do Inc(I); - while SCompare(Self, J, P) > 0 do Dec(J); - if I <= J then - begin - ExchangeItems(I, J); - if P = I then - P := J - else if P = J then - P := I; - Inc(I); - Dec(J); - end; - until I > J; - if L < J then QuickSort(L, J, SCompare); - L := I; - until I >= R; -end; - -procedure TTntStringList.SetCapacity(NewCapacity: Integer); -begin - ReallocMem(FList, NewCapacity * SizeOf(TWideStringItem)); - FCapacity := NewCapacity; -end; - -procedure TTntStringList.SetSorted(Value: Boolean); -begin - if FSorted <> Value then - begin - if Value then Sort; - FSorted := Value; - end; -end; - -procedure TTntStringList.SetUpdateState(Updating: Boolean); -begin - FUpdating := Updating; - if Updating then Changing else Changed; -end; - -function WideStringListCompareStrings(List: TTntStringList; Index1, Index2: Integer): Integer; -begin - Result := List.CompareStrings(List.FList^[Index1].FString, - List.FList^[Index2].FString); -end; - -procedure TTntStringList.Sort; -begin - CustomSort(WideStringListCompareStrings); -end; - -procedure TTntStringList.CustomSort(Compare: TWideStringListSortCompare); -begin - if not Sorted and (FCount > 1) then - begin - Changing; - QuickSort(0, FCount - 1, Compare); - Changed; - end; -end; - -function TTntStringList.CompareStrings(const S1, S2: WideString): Integer; -begin - if CaseSensitive then - Result := WideCompareStr(S1, S2) - else - Result := WideCompareText(S1, S2); -end; - -procedure TTntStringList.SetCaseSensitive(const Value: Boolean); -begin - if Value <> FCaseSensitive then - begin - FCaseSensitive := Value; - if Sorted then Sort; - end; -end; - -//------------------------- TntClasses introduced procs ---------------------------------- - -function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet; -var - ByteOrderMark: WideChar; - BytesRead: Integer; - Utf8Test: array[0..2] of AnsiChar; -begin - // Byte Order Mark - ByteOrderMark := #0; - if (Stream.Size - Stream.Position) >= SizeOf(ByteOrderMark) then begin - BytesRead := Stream.Read(ByteOrderMark, SizeOf(ByteOrderMark)); - if (ByteOrderMark <> UNICODE_BOM) and (ByteOrderMark <> UNICODE_BOM_SWAPPED) then begin - ByteOrderMark := #0; - Stream.Seek(-BytesRead, soFromCurrent); - if (Stream.Size - Stream.Position) >= Length(Utf8Test) * SizeOf(AnsiChar) then begin - BytesRead := Stream.Read(Utf8Test[0], Length(Utf8Test) * SizeOf(AnsiChar)); - if Utf8Test <> UTF8_BOM then - Stream.Seek(-BytesRead, soFromCurrent); - end; - end; - end; - // Test Byte Order Mark - if ByteOrderMark = UNICODE_BOM then - Result := csUnicode - else if ByteOrderMark = UNICODE_BOM_SWAPPED then - Result := csUnicodeSwapped - else if Utf8Test = UTF8_BOM then - Result := csUtf8 - else - Result := csAnsi; -end; - -function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare; - Target: Pointer; var Index: Integer): Boolean; -var - L, H, I, C: Integer; -begin - Result := False; - L := 0; - H := List.Count - 1; - while L <= H do - begin - I := (L + H) shr 1; - C := TargetCompare(List[i], Target); - if C < 0 then L := I + 1 else - begin - H := I - 1; - if C = 0 then - begin - Result := True; - L := I; - end; - end; - end; - Index := L; -end; - -function ClassIsRegistered(const clsid: TCLSID): Boolean; -var - OleStr: POleStr; - Reg: TRegIniFile; - Key, Filename: WideString; -begin - // First, check to see if there is a ProgID. This will tell if the - // control is registered on the machine. No ProgID, control won't run - Result := ProgIDFromCLSID(clsid, OleStr) = S_OK; - if not Result then Exit; //Bail as soon as anything goes wrong. - - // Next, make sure that the file is actually there by rooting it out - // of the registry - Key := WideFormat('\SOFTWARE\Classes\CLSID\%s', [GUIDToString(clsid)]); - Reg := TRegIniFile.Create; - try - Reg.RootKey := HKEY_LOCAL_MACHINE; - Result := Reg.OpenKeyReadOnly(Key); - if not Result then Exit; // Bail as soon as anything goes wrong. - - FileName := Reg.ReadString('InProcServer32', '', EmptyStr); - if (Filename = EmptyStr) then // try another key for the file name - begin - FileName := Reg.ReadString('InProcServer', '', EmptyStr); - end; - Result := Filename <> EmptyStr; - if not Result then Exit; - Result := WideFileExists(Filename); - finally - Reg.Free; - end; -end; - -{ TBufferedAnsiString } - -procedure TBufferedAnsiString.Clear; -begin - LastWriteIndex := 0; - if Length(FStringBuffer) > 0 then - FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(AnsiChar), 0); -end; - -procedure TBufferedAnsiString.AddChar(const wc: AnsiChar); -const - MIN_GROW_SIZE = 32; - MAX_GROW_SIZE = 256; -var - GrowSize: Integer; -begin - Inc(LastWriteIndex); - if LastWriteIndex > Length(FStringBuffer) then begin - GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer)); - GrowSize := Min(GrowSize, MAX_GROW_SIZE); - SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize); - FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(AnsiChar), 0); - end; - FStringBuffer[LastWriteIndex] := wc; -end; - -procedure TBufferedAnsiString.AddString(const s: AnsiString); -var - LenS: Integer; - BlockSize: Integer; - AllocSize: Integer; -begin - LenS := Length(s); - if LenS > 0 then begin - Inc(LastWriteIndex); - if LastWriteIndex + LenS - 1 > Length(FStringBuffer) then begin - // determine optimum new allocation size - BlockSize := Length(FStringBuffer) div 2; - if BlockSize < 8 then - BlockSize := 8; - AllocSize := ((LenS div BlockSize) + 1) * BlockSize; - // realloc buffer - SetLength(FStringBuffer, Length(FStringBuffer) + AllocSize); - FillChar(FStringBuffer[Length(FStringBuffer) - AllocSize + 1], AllocSize * SizeOf(AnsiChar), 0); - end; - CopyMemory(@FStringBuffer[LastWriteIndex], @s[1], LenS * SizeOf(AnsiChar)); - Inc(LastWriteIndex, LenS - 1); - end; -end; - -procedure TBufferedAnsiString.AddBuffer(Buff: PAnsiChar; Chars: Integer); -var - i: integer; -begin - for i := 1 to Chars do begin - if Buff^ = #0 then - break; - AddChar(Buff^); - Inc(Buff); - end; -end; - -function TBufferedAnsiString.Value: AnsiString; -begin - Result := PAnsiChar(FStringBuffer); -end; - -function TBufferedAnsiString.BuffPtr: PAnsiChar; -begin - Result := PAnsiChar(FStringBuffer); -end; - -{ TBufferedWideString } - -procedure TBufferedWideString.Clear; -begin - LastWriteIndex := 0; - if Length(FStringBuffer) > 0 then - FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(WideChar), 0); -end; - -procedure TBufferedWideString.AddChar(const wc: WideChar); -const - MIN_GROW_SIZE = 32; - MAX_GROW_SIZE = 256; -var - GrowSize: Integer; -begin - Inc(LastWriteIndex); - if LastWriteIndex > Length(FStringBuffer) then begin - GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer)); - GrowSize := Min(GrowSize, MAX_GROW_SIZE); - SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize); - FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(WideChar), 0); - end; - FStringBuffer[LastWriteIndex] := wc; -end; - -procedure TBufferedWideString.AddString(const s: WideString); -var - i: integer; -begin - for i := 1 to Length(s) do - AddChar(s[i]); -end; - -procedure TBufferedWideString.AddBuffer(Buff: PWideChar; Chars: Integer); -var - i: integer; -begin - for i := 1 to Chars do begin - if Buff^ = #0 then - break; - AddChar(Buff^); - Inc(Buff); - end; -end; - -function TBufferedWideString.Value: WideString; -begin - Result := PWideChar(FStringBuffer); -end; - -function TBufferedWideString.BuffPtr: PWideChar; -begin - Result := PWideChar(FStringBuffer); -end; - -{ TBufferedStreamReader } - -constructor TBufferedStreamReader.Create(Stream: TStream; BufferSize: Integer = 1024); -begin - // init stream - FStream := Stream; - FStreamSize := Stream.Size; - // init buffer - FBufferSize := BufferSize; - SetLength(FBuffer, BufferSize); - FBufferStartPosition := -FBufferSize; { out of any useful range } - // init virtual position - FVirtualPosition := 0; -end; - -function TBufferedStreamReader.Seek(Offset: Integer; Origin: Word): Longint; -begin - case Origin of - soFromBeginning: FVirtualPosition := Offset; - soFromCurrent: Inc(FVirtualPosition, Offset); - soFromEnd: FVirtualPosition := FStreamSize + Offset; - end; - Result := FVirtualPosition; -end; - -procedure TBufferedStreamReader.UpdateBufferFromPosition(StartPos: Integer); -begin - try - FStream.Position := StartPos; - FStream.Read(FBuffer[0], FBufferSize); - FBufferStartPosition := StartPos; - except - FBufferStartPosition := -FBufferSize; { out of any useful range } - raise; - end; -end; - -function TBufferedStreamReader.Read(var Buffer; Count: Integer): Longint; -var - BytesLeft: Integer; - FirstBufferRead: Integer; - StreamDirectRead: Integer; - Buf: PAnsiChar; -begin - if (FVirtualPosition >= 0) and (Count >= 0) then - begin - Result := FStreamSize - FVirtualPosition; - if Result > 0 then - begin - if Result > Count then - Result := Count; - - Buf := @Buffer; - BytesLeft := Result; - - // try to read what is left in buffer - FirstBufferRead := FBufferStartPosition + FBufferSize - FVirtualPosition; - if (FirstBufferRead < 0) or (FirstBufferRead > FBufferSize) then - FirstBufferRead := 0; - FirstBufferRead := Min(FirstBufferRead, Result); - if FirstBufferRead > 0 then begin - Move(FBuffer[FVirtualPosition - FBufferStartPosition], Buf[0], FirstBufferRead); - Dec(BytesLeft, FirstBufferRead); - end; - - if BytesLeft > 0 then begin - // The first read in buffer was not enough - StreamDirectRead := (BytesLeft div FBufferSize) * FBufferSize; - FStream.Position := FVirtualPosition + FirstBufferRead; - FStream.Read(Buf[FirstBufferRead], StreamDirectRead); - Dec(BytesLeft, StreamDirectRead); - - if BytesLeft > 0 then begin - // update buffer, and read what is left - UpdateBufferFromPosition(FStream.Position); - Move(FBuffer[0], Buf[FirstBufferRead + StreamDirectRead], BytesLeft); - end; - end; - - Inc(FVirtualPosition, Result); - Exit; - end; - end; - Result := 0; -end; - -function TBufferedStreamReader.Write(const Buffer; Count: Integer): Longint; -begin - raise ETntInternalError.Create('Internal Error: class can not write.'); - Result := 0; -end; - -//-------- synced wide string ----------------- - -function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString; -begin - if AnsiString(WideStr) <> (AnsiStr) then begin - WideStr := AnsiStr; {AnsiStr changed. Keep WideStr in sync.} - end; - Result := WideStr; -end; - -procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString; - const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent); -begin - if Value <> GetSyncedWideString(WideStr, AnsiStr) then - begin - if (not WideSameStr(Value, AnsiString(Value))) {unicode chars lost in conversion} - and (AnsiStr = AnsiString(Value)) {AnsiStr is not going to change} - then begin - SetAnsiStr(''); {force the change} - end; - WideStr := Value; - SetAnsiStr(Value); - end; -end; - -{ TWideComponentHelper } - -function CompareComponentHelperToTarget(Item, Target: Pointer): Integer; -begin - if PtrUInt(TWideComponentHelper(Item).FComponent) < PtrUInt(Target) then - Result := -1 - else if PtrUInt(TWideComponentHelper(Item).FComponent) > PtrUInt(Target) then - Result := 1 - else - Result := 0; -end; - -function FindWideComponentHelperIndex(ComponentHelperList: TComponentList; Component: TComponent; var Index: Integer): Boolean; -begin - // find Component in sorted wide caption list (list is sorted by TWideComponentHelper.FComponent) - Result := FindSortedListByTarget(ComponentHelperList, CompareComponentHelperToTarget, Component, Index); -end; - -constructor TWideComponentHelper.Create(AOwner: TComponent); -begin - raise ETntInternalError.Create('TNT Internal Error: TWideComponentHelper.Create should never be encountered.'); -end; - -constructor TWideComponentHelper.CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList); -var - Index: Integer; -begin - // don't use direct ownership for memory management - inherited Create(nil); - FComponent := AOwner; - FComponent.FreeNotification(Self); - - // insert into list according to sort - FindWideComponentHelperIndex(ComponentHelperList, FComponent, Index); - ComponentHelperList.Insert(Index, Self); -end; - -procedure TWideComponentHelper.Notification(AComponent: TComponent; Operation: TOperation); -begin - inherited; - if (AComponent = FComponent) and (Operation = opRemove) then begin - FComponent := nil; - Free; - end; -end; - -function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper; -var - Index: integer; -begin - if FindWideComponentHelperIndex(ComponentHelperList, Component, Index) then begin - Result := TWideComponentHelper(ComponentHelperList[Index]); - Assert(Result.FComponent = Component, 'TNT Internal Error: FindWideComponentHelperIndex failed.'); - end else - Result := nil; -end; - -initialization - RuntimeUTFStreaming := False; { Delphi 6 and higher don't need UTF help at runtime. } - -end. + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntClasses; + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$INCLUDE TntCompilers.inc} + +interface + +{ TODO: Consider: TTntRegIniFile, TTntMemIniFile (consider if UTF8 fits into this solution). } + +{***********************************************} +{ WideChar-streaming implemented by Maël Hörz } +{***********************************************} + +uses + Classes, SysUtils, Windows, + {$IFNDEF COMPILER_10_UP} + TntWideStrings, + {$ELSE} + WideStrings, + {$ENDIF} + ActiveX, Contnrs; + +// ......... introduced ......... +type + TTntStreamCharSet = (csAnsi, csUnicode, csUnicodeSwapped, csUtf8); + +function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet; + +//--------------------------------------------------------------------------------------------- +// Tnt - Classes +//--------------------------------------------------------------------------------------------- + +{TNT-WARN ExtractStrings} +{TNT-WARN LineStart} +{TNT-WARN TStringStream} // TODO: Implement a TWideStringStream + +// A potential implementation of TWideStringStream can be found at: +// http://kdsxml.cvs.sourceforge.net/kdsxml/Global/KDSClasses.pas?revision=1.10&view=markup + +procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent); + +type +{TNT-WARN TFileStream} + TTntFileStream = class(THandleStream) + public + constructor Create(const FileName: WideString; Mode: Word); + destructor Destroy; override; + end; + +{TNT-WARN TMemoryStream} + TTntMemoryStream = class(TMemoryStream{TNT-ALLOW TMemoryStream}) + public + procedure LoadFromFile(const FileName: WideString); + procedure SaveToFile(const FileName: WideString); + end; + +{TNT-WARN TResourceStream} + TTntResourceStream = class(TCustomMemoryStream) + private + HResInfo: HRSRC; + HGlobal: THandle; + procedure Initialize(Instance: THandle; Name, ResType: PWideChar); + public + constructor Create(Instance: THandle; const ResName: WideString; ResType: PWideChar); + constructor CreateFromID(Instance: THandle; ResID: Word; ResType: PWideChar); + destructor Destroy; override; + function Write(const Buffer; Count: Longint): Longint; override; + procedure SaveToFile(const FileName: WideString); + end; + + TTntStrings = class; + +{TNT-WARN TAnsiStrings} + TAnsiStrings{TNT-ALLOW TAnsiStrings} = class(TStrings{TNT-ALLOW TStrings}) + public + procedure LoadFromFile(const FileName: WideString); reintroduce; + procedure SaveToFile(const FileName: WideString); reintroduce; + procedure LoadFromFileEx(const FileName: WideString; CodePage: Cardinal); + procedure SaveToFileEx(const FileName: WideString; CodePage: Cardinal); + procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract; + procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract; + end; + + TAnsiStringsForWideStringsAdapter = class(TAnsiStrings{TNT-ALLOW TAnsiStrings}) + private + FWideStrings: TTntStrings; + FAdapterCodePage: Cardinal; + protected + function Get(Index: Integer): AnsiString; override; + procedure Put(Index: Integer; const S: AnsiString); override; + function GetCount: Integer; override; + function GetObject(Index: Integer): TObject; override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetUpdateState(Updating: Boolean); override; + function AdapterCodePage: Cardinal; dynamic; + public + constructor Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal = 0); + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Insert(Index: Integer; const S: AnsiString); override; + procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); override; + procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); override; + end; + +{TNT-WARN TStrings} + TTntStrings = class(TWideStrings) + private + FLastFileCharSet: TTntStreamCharSet; + FAnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings}; + procedure SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings}); + procedure ReadData(Reader: TReader); + procedure ReadDataUTF7(Reader: TReader); + procedure ReadDataUTF8(Reader: TReader); + procedure WriteDataUTF7(Writer: TWriter); + protected + procedure DefineProperties(Filer: TFiler); override; + public + constructor Create; + destructor Destroy; override; + + procedure LoadFromFile(const FileName: WideString); override; + procedure LoadFromStream(Stream: TStream); override; + procedure LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); virtual; + + procedure SaveToFile(const FileName: WideString); override; + procedure SaveToStream(Stream: TStream); override; + procedure SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); virtual; + + property LastFileCharSet: TTntStreamCharSet read FLastFileCharSet; + published + property AnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings} read FAnsiStrings write SetAnsiStrings stored False; + end; + +{ TTntStringList class } + + TTntStringList = class; + TWideStringListSortCompare = function(List: TTntStringList; Index1, Index2: Integer): Integer; + +{TNT-WARN TStringList} + TTntStringList = class(TTntStrings) + private + FUpdating: Boolean; + FList: PWideStringItemList; + FCount: Integer; + FCapacity: Integer; + FSorted: Boolean; + FDuplicates: TDuplicates; + FCaseSensitive: Boolean; + FOnChange: TNotifyEvent; + FOnChanging: TNotifyEvent; + procedure ExchangeItems(Index1, Index2: Integer); + procedure Grow; + procedure QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare); + procedure SetSorted(Value: Boolean); + procedure SetCaseSensitive(const Value: Boolean); + protected + procedure Changed; virtual; + procedure Changing; virtual; + function Get(Index: Integer): WideString; override; + function GetCapacity: Integer; override; + function GetCount: Integer; override; + function GetObject(Index: Integer): TObject; override; + procedure Put(Index: Integer; const S: WideString); override; + procedure PutObject(Index: Integer; AObject: TObject); override; + procedure SetCapacity(NewCapacity: Integer); override; + procedure SetUpdateState(Updating: Boolean); override; + function CompareStrings(const S1, S2: WideString): Integer; override; + procedure InsertItem(Index: Integer; const S: WideString; AObject: TObject); virtual; + public + destructor Destroy; override; + function Add(const S: WideString): Integer; override; + function AddObject(const S: WideString; AObject: TObject): Integer; override; + procedure Clear; override; + procedure Delete(Index: Integer); override; + procedure Exchange(Index1, Index2: Integer); override; + function Find(const S: WideString; var Index: Integer): Boolean; virtual; + function IndexOf(const S: WideString): Integer; override; + function IndexOfName(const Name: WideString): Integer; override; + procedure Insert(Index: Integer; const S: WideString); override; + procedure InsertObject(Index: Integer; const S: WideString; + AObject: TObject); override; + procedure Sort; virtual; + procedure CustomSort(Compare: TWideStringListSortCompare); virtual; + property Duplicates: TDuplicates read FDuplicates write FDuplicates; + property Sorted: Boolean read FSorted write SetSorted; + property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; + property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; + end; + +// ......... introduced ......... +type + TListTargetCompare = function (Item, Target: Pointer): Integer; + +function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare; + Target: Pointer; var Index: Integer): Boolean; + +function ClassIsRegistered(const clsid: TCLSID): Boolean; + +var + RuntimeUTFStreaming: Boolean; + +type + TBufferedAnsiString = class(TObject) + private + FStringBuffer: AnsiString; + LastWriteIndex: Integer; + public + procedure Clear; + procedure AddChar(const wc: AnsiChar); + procedure AddString(const s: AnsiString); + procedure AddBuffer(Buff: PAnsiChar; Chars: Integer); + function Value: AnsiString; + function BuffPtr: PAnsiChar; + end; + + TBufferedWideString = class(TObject) + private + FStringBuffer: WideString; + LastWriteIndex: Integer; + public + procedure Clear; + procedure AddChar(const wc: WideChar); + procedure AddString(const s: WideString); + procedure AddBuffer(Buff: PWideChar; Chars: Integer); + function Value: WideString; + function BuffPtr: PWideChar; + end; + + TBufferedStreamReader = class(TStream) + private + FStream: TStream; + FStreamSize: Integer; + FBuffer: array of Byte; + FBufferSize: Integer; + FBufferStartPosition: Integer; + FVirtualPosition: Integer; + procedure UpdateBufferFromPosition(StartPos: Integer); + public + constructor Create(Stream: TStream; BufferSize: Integer = 1024); + function Read(var Buffer; Count: Longint): Longint; override; + function Write(const Buffer; Count: Longint): Longint; override; + function Seek(Offset: Longint; Origin: Word): Longint; override; + end; + +// "synced" wide string +type TSetAnsiStrEvent = procedure(const Value: AnsiString) of object; +function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString; +procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString; + const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent); + +type + TWideComponentHelper = class(TComponent) + private + FComponent: TComponent; + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + public + constructor Create(AOwner: TComponent); override; + constructor CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList); + end; + +function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper; + +implementation + +uses + RTLConsts, ComObj, Math, + Registry, TypInfo, TntSystem, TntSysUtils; + +{ TntPersistent } + +//=========================================================================== +// The Delphi 5 Classes.pas never supported the streaming of WideStrings. +// The Delphi 6 Classes.pas supports WideString streaming. But it's too bad that +// the Delphi 6 IDE doesn't use the updated Classes.pas. Switching between Form/Text +// mode corrupts extended characters in WideStrings even under Delphi 6. +// Delphi 7 seems to finally get right. But let's keep the UTF7 support at design time +// to enable sharing source code with previous versions of Delphi. +// +// The purpose of this solution is to store WideString properties which contain +// non-ASCII chars in the form of UTF7 under the old property name + '_UTF7'. +// +// Special thanks go to Francisco Leong for helping to develop this solution. +// + +{ TTntWideStringPropertyFiler } +type + TTntWideStringPropertyFiler = class + private + FInstance: TPersistent; + FPropInfo: PPropInfo; + procedure ReadDataUTF8(Reader: TReader); + procedure ReadDataUTF7(Reader: TReader); + procedure WriteDataUTF7(Writer: TWriter); + public + procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString); + end; + +function ReaderNeedsUtfHelp(Reader: TReader): Boolean; +begin + if Reader.Owner = nil then + Result := False { designtime - visual form inheritance ancestor } + else if csDesigning in Reader.Owner.ComponentState then + {$IFDEF COMPILER_7_UP} + Result := False { Delphi 7+: designtime - doesn't need UTF help. } + {$ELSE} + Result := True { Delphi 6: designtime - always needs UTF help. } + {$ENDIF} + else + Result := RuntimeUTFStreaming; { runtime } +end; + +procedure TTntWideStringPropertyFiler.ReadDataUTF8(Reader: TReader); +begin + if ReaderNeedsUtfHelp(Reader) then + SetWideStrProp(FInstance, FPropInfo, UTF8ToWideString(Reader.ReadString)) + else + Reader.ReadString; { do nothing with Result } +end; + +procedure TTntWideStringPropertyFiler.ReadDataUTF7(Reader: TReader); +begin + if ReaderNeedsUtfHelp(Reader) then + SetWideStrProp(FInstance, FPropInfo, UTF7ToWideString(Reader.ReadString)) + else + Reader.ReadString; { do nothing with Result } +end; + +procedure TTntWideStringPropertyFiler.WriteDataUTF7(Writer: TWriter); +begin + Writer.WriteString(WideStringToUTF7(GetWideStrProp(FInstance, FPropInfo))); +end; + +procedure TTntWideStringPropertyFiler.DefineProperties(Filer: TFiler; Instance: TPersistent; + PropName: AnsiString); + + {$IFNDEF COMPILER_7_UP} + function HasData: Boolean; + var + CurrPropValue: WideString; + begin + // must be stored + Result := IsStoredProp(Instance, FPropInfo); + if Result + and (Filer.Ancestor <> nil) + and (GetPropInfo(Filer.Ancestor, PropName, [tkWString]) <> nil) then + begin + // must be different than ancestor + CurrPropValue := GetWideStrProp(Instance, FPropInfo); + Result := CurrPropValue <> GetWideStrProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName)); + end; + if Result then begin + // must be non-blank and different than UTF8 (implies all ASCII <= 127) + CurrPropValue := GetWideStrProp(Instance, FPropInfo); + Result := (CurrPropValue <> '') and (WideStringToUTF8(CurrPropValue) <> CurrPropValue); + end; + end; + {$ENDIF} + +begin + FInstance := Instance; + FPropInfo := GetPropInfo(Instance, PropName, [tkWString]); + if FPropInfo <> nil then begin + // must be published (and of type WideString) + Filer.DefineProperty(PropName + 'W', ReadDataUTF8, nil, False); + {$IFDEF COMPILER_7_UP} + Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, False); + {$ELSE} + Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, HasData); + {$ENDIF} + end; + FInstance := nil; + FPropInfo := nil; +end; + +{ TTntWideCharPropertyFiler } +type + TTntWideCharPropertyFiler = class + private + FInstance: TPersistent; + FPropInfo: PPropInfo; + {$IFNDEF COMPILER_9_UP} + FWriter: TWriter; + procedure GetLookupInfo(var Ancestor: TPersistent; + var Root, LookupRoot, RootAncestor: TComponent); + {$ENDIF} + procedure ReadData_W(Reader: TReader); + procedure ReadDataUTF7(Reader: TReader); + procedure WriteData_W(Writer: TWriter); + function ReadChar(Reader: TReader): WideChar; + public + procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString); + end; + +{$IFNDEF COMPILER_9_UP} +type + TGetLookupInfoEvent = procedure(var Ancestor: TPersistent; + var Root, LookupRoot, RootAncestor: TComponent) of object; + +function AncestorIsValid(Ancestor: TPersistent; Root, RootAncestor: TComponent): Boolean; +begin + Result := (Ancestor <> nil) and (RootAncestor <> nil) and + Root.InheritsFrom(RootAncestor.ClassType); +end; + +function IsDefaultOrdPropertyValue(Instance: TObject; PropInfo: PPropInfo; + OnGetLookupInfo: TGetLookupInfoEvent): Boolean; +var + Ancestor: TPersistent; + LookupRoot: TComponent; + RootAncestor: TComponent; + Root: TComponent; + AncestorValid: Boolean; + Value: Longint; + Default: LongInt; +begin + Ancestor := nil; + Root := nil; + LookupRoot := nil; + RootAncestor := nil; + + if Assigned(OnGetLookupInfo) then + OnGetLookupInfo(Ancestor, Root, LookupRoot, RootAncestor); + + AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor); + + Result := True; + if (PropInfo^.GetProc <> nil) and (PropInfo^.SetProc <> nil) then + begin + Value := GetOrdProp(Instance, PropInfo); + if AncestorValid then + Result := Value = GetOrdProp(Ancestor, PropInfo) + else + begin + Default := PPropInfo(PropInfo)^.Default; + Result := (Default <> LongInt($80000000)) and (Value = Default); + end; + end; +end; + +procedure TTntWideCharPropertyFiler.GetLookupInfo(var Ancestor: TPersistent; + var Root, LookupRoot, RootAncestor: TComponent); +begin + Ancestor := FWriter.Ancestor; + Root := FWriter.Root; + LookupRoot := FWriter.LookupRoot; + RootAncestor := FWriter.RootAncestor; +end; +{$ENDIF} + +function TTntWideCharPropertyFiler.ReadChar(Reader: TReader): WideChar; +var + Temp: WideString; +begin + case Reader.NextValue of + vaWString: + Temp := Reader.ReadWideString; + vaString: + Temp := Reader.ReadString; + else + raise EReadError.Create(SInvalidPropertyValue); + end; + + if Length(Temp) > 1 then + raise EReadError.Create(SInvalidPropertyValue); + Result := Temp[1]; +end; + +procedure TTntWideCharPropertyFiler.ReadData_W(Reader: TReader); +begin + SetOrdProp(FInstance, FPropInfo, Ord(ReadChar(Reader))); +end; + +procedure TTntWideCharPropertyFiler.ReadDataUTF7(Reader: TReader); +var + S: WideString; +begin + S := UTF7ToWideString(Reader.ReadString); + if S = '' then + SetOrdProp(FInstance, FPropInfo, 0) + else + SetOrdProp(FInstance, FPropInfo, Ord(S[1])) +end; + +type TAccessWriter = class(TWriter); + +procedure TTntWideCharPropertyFiler.WriteData_W(Writer: TWriter); +var + L: Integer; + Temp: WideString; +{$IFDEF FPC} +// Workaround: the Buffer parameter of TWriter.Write() must be of a fixed size +// type for FPC >= 2.4.0. The values vaWString, Ord(vaWString) or Integer(vaWString) +// are not allowed anymore. +const + vaWStringInt: integer = Ord(vaWString); +{$ENDIF} +begin + Temp := WideChar(GetOrdProp(FInstance, FPropInfo)); + + {$IFNDEF FPC} + TAccessWriter(Writer).WriteValue(vaWString); + {$ELSE} + TAccessWriter(Writer).Write(vaWStringInt, SizeOf(vaWString)); + {$ENDIF} + L := Length(Temp); + Writer.Write(L, SizeOf(Integer)); + Writer.Write(Pointer(@Temp[1])^, L * 2); +end; + +procedure TTntWideCharPropertyFiler.DefineProperties(Filer: TFiler; + Instance: TPersistent; PropName: AnsiString); + + {$IFNDEF COMPILER_9_UP} + function HasData: Boolean; + var + CurrPropValue: Integer; + begin + // must be stored + Result := IsStoredProp(Instance, FPropInfo); + if Result and (Filer.Ancestor <> nil) and + (GetPropInfo(Filer.Ancestor, PropName, [tkWChar]) <> nil) then + begin + // must be different than ancestor + CurrPropValue := GetOrdProp(Instance, FPropInfo); + Result := CurrPropValue <> GetOrdProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName)); + end; + if Result and (Filer is TWriter) then + begin + FWriter := TWriter(Filer); + Result := not IsDefaultOrdPropertyValue(Instance, FPropInfo, GetLookupInfo); + end; + end; + {$ENDIF} + +begin + FInstance := Instance; + FPropInfo := GetPropInfo(Instance, PropName, [tkWChar]); + if FPropInfo <> nil then + begin + // must be published (and of type WideChar) + {$IFDEF COMPILER_9_UP} + Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, False); + {$ELSE} + Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, HasData); + {$ENDIF} + Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, nil, False); + end; + FInstance := nil; + FPropInfo := nil; +end; + +procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent); +var + I, Count: Integer; + PropInfo: PPropInfo; + PropList: PPropList; + WideStringFiler: TTntWideStringPropertyFiler; + WideCharFiler: TTntWideCharPropertyFiler; +begin + Count := GetTypeData(Instance.ClassInfo)^.PropCount; + if Count > 0 then + begin + WideStringFiler := TTntWideStringPropertyFiler.Create; + try + WideCharFiler := TTntWideCharPropertyFiler.Create; + try + GetMem(PropList, Count * SizeOf(Pointer)); + try + GetPropInfos(Instance.ClassInfo, PropList); + for I := 0 to Count - 1 do + begin + PropInfo := PropList^[I]; + if (PropInfo = nil) then + break; + if (PropInfo.PropType^.Kind = tkWString) then + WideStringFiler.DefineProperties(Filer, Instance, PropInfo.Name) + else if (PropInfo.PropType^.Kind = tkWChar) then + WideCharFiler.DefineProperties(Filer, Instance, PropInfo.Name) + end; + finally + FreeMem(PropList, Count * SizeOf(Pointer)); + end; + finally + WideCharFiler.Free; + end; + finally + WideStringFiler.Free; + end; + end; +end; + +{ TTntFileStream } + +{$IFDEF FPC} + {$DEFINE HAS_SFCREATEERROREX} +{$ENDIF} +{$IFDEF DELPHI_7_UP} + {$DEFINE HAS_SFCREATEERROREX} +{$ENDIF} + +constructor TTntFileStream.Create(const FileName: WideString; Mode: Word); +var + CreateHandle: Integer; + {$IFDEF HAS_SFCREATEERROREX} + ErrorMessage: WideString; + {$ENDIF} +begin + if Mode = fmCreate then + begin + CreateHandle := WideFileCreate(FileName); + if CreateHandle < 0 then begin + {$IFDEF HAS_SFCREATEERROREX} + ErrorMessage := WideSysErrorMessage(GetLastError); + raise EFCreateError.CreateFmt(SFCreateErrorEx, [WideExpandFileName(FileName), ErrorMessage]); + {$ELSE} + raise EFCreateError.CreateFmt(SFCreateError, [WideExpandFileName(FileName)]); + {$ENDIF} + end; + end else + begin + CreateHandle := WideFileOpen(FileName, Mode); + if CreateHandle < 0 then begin + {$IFDEF HAS_SFCREATEERROREX} + ErrorMessage := WideSysErrorMessage(GetLastError); + raise EFOpenError.CreateFmt(SFOpenErrorEx, [WideExpandFileName(FileName), ErrorMessage]); + {$ELSE} + raise EFOpenError.CreateFmt(SFOpenError, [WideExpandFileName(FileName)]); + {$ENDIF} + end; + end; + inherited Create(CreateHandle); +end; + +destructor TTntFileStream.Destroy; +begin + if Handle >= 0 then FileClose(Handle); +end; + +{ TTntMemoryStream } + +procedure TTntMemoryStream.LoadFromFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TTntMemoryStream.SaveToFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +{ TTntResourceStream } + +constructor TTntResourceStream.Create(Instance: THandle; const ResName: WideString; + ResType: PWideChar); +begin + inherited Create; + Initialize(Instance, PWideChar(ResName), ResType); +end; + +constructor TTntResourceStream.CreateFromID(Instance: THandle; ResID: Word; + ResType: PWideChar); +begin + inherited Create; + Initialize(Instance, PWideChar(ResID), ResType); +end; + +procedure TTntResourceStream.Initialize(Instance: THandle; Name, ResType: PWideChar); + + procedure Error; + begin + raise EResNotFound.CreateFmt(SResNotFound, [Name]); + end; + +begin + HResInfo := FindResourceW(Instance, Name, ResType); + if HResInfo = 0 then Error; + HGlobal := LoadResource(Instance, HResInfo); + if HGlobal = 0 then Error; + SetPointer(LockResource(HGlobal), SizeOfResource(Instance, HResInfo)); +end; + +destructor TTntResourceStream.Destroy; +begin + UnlockResource(HGlobal); + FreeResource(HGlobal); { Technically this is not necessary (MS KB #193678) } + inherited Destroy; +end; + +function TTntResourceStream.Write(const Buffer; Count: Longint): Longint; +begin + raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError)); +end; + +procedure TTntResourceStream.SaveToFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +{ TAnsiStrings } + +procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFileEx(const FileName: WideString; CodePage: Cardinal); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + LoadFromStreamEx(Stream, CodePage); + finally + Stream.Free; + end; +end; + +procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFileEx(const FileName: WideString; CodePage: Cardinal); +var + Stream: TStream; + Utf8BomPtr: PAnsiChar; +begin + Stream := TTntFileStream.Create(FileName, fmCreate); + try + if (CodePage = CP_UTF8) then + begin + Utf8BomPtr := PAnsiChar(UTF8_BOM); + Stream.WriteBuffer(Utf8BomPtr^, Length(UTF8_BOM)); + end; + SaveToStreamEx(Stream, CodePage); + finally + Stream.Free; + end; +end; + +{ TAnsiStringsForWideStringsAdapter } + +constructor TAnsiStringsForWideStringsAdapter.Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal); +begin + inherited Create; + FWideStrings := AWideStrings; + FAdapterCodePage := _AdapterCodePage; +end; + +function TAnsiStringsForWideStringsAdapter.AdapterCodePage: Cardinal; +begin + if FAdapterCodePage = 0 then + Result := TntSystem.DefaultSystemCodePage + else + Result := FAdapterCodePage; +end; + +procedure TAnsiStringsForWideStringsAdapter.Clear; +begin + FWideStrings.Clear; +end; + +procedure TAnsiStringsForWideStringsAdapter.Delete(Index: Integer); +begin + FWideStrings.Delete(Index); +end; + +function TAnsiStringsForWideStringsAdapter.Get(Index: Integer): AnsiString; +begin + Result := WideStringToStringEx(FWideStrings.Get(Index), AdapterCodePage); +end; + +procedure TAnsiStringsForWideStringsAdapter.Put(Index: Integer; const S: AnsiString); +begin + FWideStrings.Put(Index, StringToWideStringEx(S, AdapterCodePage)); +end; + +function TAnsiStringsForWideStringsAdapter.GetCount: Integer; +begin + Result := FWideStrings.GetCount; +end; + +procedure TAnsiStringsForWideStringsAdapter.Insert(Index: Integer; const S: AnsiString); +begin + FWideStrings.Insert(Index, StringToWideStringEx(S, AdapterCodePage)); +end; + +function TAnsiStringsForWideStringsAdapter.GetObject(Index: Integer): TObject; +begin + Result := FWideStrings.GetObject(Index); +end; + +procedure TAnsiStringsForWideStringsAdapter.PutObject(Index: Integer; AObject: TObject); +begin + FWideStrings.PutObject(Index, AObject); +end; + +procedure TAnsiStringsForWideStringsAdapter.SetUpdateState(Updating: Boolean); +begin + FWideStrings.SetUpdateState(Updating); +end; + +procedure TAnsiStringsForWideStringsAdapter.LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); +var + Size: Integer; + S: AnsiString; +begin + BeginUpdate; + try + Size := Stream.Size - Stream.Position; + SetString(S, nil, Size); + Stream.Read(Pointer(S)^, Size); + FWideStrings.SetTextStr(StringToWideStringEx(S, CodePage)); + finally + EndUpdate; + end; +end; + +procedure TAnsiStringsForWideStringsAdapter.SaveToStreamEx(Stream: TStream; CodePage: Cardinal); +var + S: AnsiString; +begin + S := WideStringToStringEx(FWideStrings.GetTextStr, CodePage); + Stream.WriteBuffer(Pointer(S)^, Length(S)); +end; + +{ TTntStrings } + +constructor TTntStrings.Create; +begin + inherited; + FAnsiStrings := TAnsiStringsForWideStringsAdapter.Create(Self); + FLastFileCharSet := csUnicode; +end; + +destructor TTntStrings.Destroy; +begin + FreeAndNil(FAnsiStrings); + inherited; +end; + +procedure TTntStrings.SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings}); +begin + FAnsiStrings.Assign(Value); +end; + +procedure TTntStrings.DefineProperties(Filer: TFiler); + + {$IFNDEF COMPILER_7_UP} + function DoWrite: Boolean; + begin + if Filer.Ancestor <> nil then + begin + Result := True; + if Filer.Ancestor is TWideStrings then + Result := not Equals(TWideStrings(Filer.Ancestor)) + end + else Result := Count > 0; + end; + + function DoWriteAsUTF7: Boolean; + var + i: integer; + begin + Result := False; + for i := 0 to Count - 1 do begin + if (Strings[i] <> '') and (WideStringToUTF8(Strings[i]) <> Strings[i]) then begin + Result := True; + break; { found a string with non-ASCII chars (> 127) } + end; + end; + end; + {$ENDIF} + +begin + inherited DefineProperties(Filer); { Handles main 'Strings' property.' } + Filer.DefineProperty('WideStrings', ReadData, nil, False); + Filer.DefineProperty('WideStringsW', ReadDataUTF8, nil, False); + {$IFDEF COMPILER_7_UP} + Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, False); + {$ELSE} + Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, DoWrite and DoWriteAsUTF7); + {$ENDIF} +end; + +procedure TTntStrings.LoadFromFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + try + FLastFileCharSet := AutoDetectCharacterSet(Stream); + Stream.Position := 0; + LoadFromStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TTntStrings.LoadFromStream(Stream: TStream); +begin + LoadFromStream_BOM(Stream, True); +end; + +procedure TTntStrings.LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); +var + DataLeft: Integer; + StreamCharSet: TTntStreamCharSet; + SW: WideString; + SA: AnsiString; +begin + BeginUpdate; + try + if WithBOM then + StreamCharSet := AutoDetectCharacterSet(Stream) + else + StreamCharSet := csUnicode; + DataLeft := Stream.Size - Stream.Position; + if (StreamCharSet in [csUnicode, csUnicodeSwapped]) then + begin + // BOM indicates Unicode text stream + if DataLeft < SizeOf(WideChar) then + SW := '' + else begin + SetLength(SW, DataLeft div SizeOf(WideChar)); + Stream.Read(PWideChar(SW)^, DataLeft); + if StreamCharSet = csUnicodeSwapped then + StrSwapByteOrder(PWideChar(SW)); + end; + SetTextStr(SW); + end + else if StreamCharSet = csUtf8 then + begin + // BOM indicates UTF-8 text stream + SetLength(SA, DataLeft div SizeOf(AnsiChar)); + Stream.Read(PAnsiChar(SA)^, DataLeft); + SetTextStr(UTF8ToWideString(SA)); + end + else + begin + // without byte order mark it is assumed that we are loading ANSI text + SetLength(SA, DataLeft div SizeOf(AnsiChar)); + Stream.Read(PAnsiChar(SA)^, DataLeft); + SetTextStr(SA); + end; + finally + EndUpdate; + end; +end; + +procedure TTntStrings.ReadData(Reader: TReader); +begin + if Reader.NextValue in [vaString, vaLString] then + SetTextStr(Reader.ReadString) {JCL compatiblity} + else if Reader.NextValue = vaWString then + SetTextStr(Reader.ReadWideString) {JCL compatiblity} + else begin + BeginUpdate; + try + Clear; + Reader.ReadListBegin; + while not Reader.EndOfList do + if Reader.NextValue in [vaString, vaLString] then + Add(Reader.ReadString) {TStrings compatiblity} + else + Add(Reader.ReadWideString); + Reader.ReadListEnd; + finally + EndUpdate; + end; + end; +end; + +procedure TTntStrings.ReadDataUTF7(Reader: TReader); +begin + Reader.ReadListBegin; + if ReaderNeedsUtfHelp(Reader) then + begin + BeginUpdate; + try + Clear; + while not Reader.EndOfList do + Add(UTF7ToWideString(Reader.ReadString)) + finally + EndUpdate; + end; + end else begin + while not Reader.EndOfList do + Reader.ReadString; { do nothing with Result } + end; + Reader.ReadListEnd; +end; + +procedure TTntStrings.ReadDataUTF8(Reader: TReader); +begin + Reader.ReadListBegin; + if ReaderNeedsUtfHelp(Reader) + or (Count = 0){ Legacy support where 'WideStrings' was never written in lieu of WideStringsW } + then begin + BeginUpdate; + try + Clear; + while not Reader.EndOfList do + Add(UTF8ToWideString(Reader.ReadString)) + finally + EndUpdate; + end; + end else begin + while not Reader.EndOfList do + Reader.ReadString; { do nothing with Result } + end; + Reader.ReadListEnd; +end; + +procedure TTntStrings.SaveToFile(const FileName: WideString); +var + Stream: TStream; +begin + Stream := TTntFileStream.Create(FileName, fmCreate); + try + SaveToStream(Stream); + finally + Stream.Free; + end; +end; + +procedure TTntStrings.SaveToStream(Stream: TStream); +begin + SaveToStream_BOM(Stream, True); +end; + +procedure TTntStrings.SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); +// Saves the currently loaded text into the given stream. +// WithBOM determines whether to write a byte order mark or not. +var + SW: WideString; + BOM: WideChar; +begin + if WithBOM then begin + BOM := UNICODE_BOM; + Stream.WriteBuffer(BOM, SizeOf(WideChar)); + end; + SW := GetTextStr; + Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar)); +end; + +procedure TTntStrings.WriteDataUTF7(Writer: TWriter); +var + I: Integer; +begin + Writer.WriteListBegin; + for I := 0 to Count-1 do + Writer.WriteString(WideStringToUTF7(Get(I))); + Writer.WriteListEnd; +end; + +{ TTntStringList } + +destructor TTntStringList.Destroy; +begin + FOnChange := nil; + FOnChanging := nil; + inherited Destroy; + if FCount <> 0 then Finalize(FList^[0], FCount); + FCount := 0; + SetCapacity(0); +end; + +function TTntStringList.Add(const S: WideString): Integer; +begin + Result := AddObject(S, nil); +end; + +function TTntStringList.AddObject(const S: WideString; AObject: TObject): Integer; +begin + if not Sorted then + Result := FCount + else + if Find(S, Result) then + case Duplicates of + dupIgnore: Exit; + dupError: Error(PResStringRec(@SDuplicateString), 0); + end; + InsertItem(Result, S, AObject); +end; + +procedure TTntStringList.Changed; +begin + if (not FUpdating) and Assigned(FOnChange) then + FOnChange(Self); +end; + +procedure TTntStringList.Changing; +begin + if (not FUpdating) and Assigned(FOnChanging) then + FOnChanging(Self); +end; + +procedure TTntStringList.Clear; +begin + if FCount <> 0 then + begin + Changing; + Finalize(FList^[0], FCount); + FCount := 0; + SetCapacity(0); + Changed; + end; +end; + +procedure TTntStringList.Delete(Index: Integer); +begin + if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); + Changing; + Finalize(FList^[Index]); + Dec(FCount); + if Index < FCount then + System.Move(FList^[Index + 1], FList^[Index], + (FCount - Index) * SizeOf(TWideStringItem)); + Changed; +end; + +procedure TTntStringList.Exchange(Index1, Index2: Integer); +begin + if (Index1 < 0) or (Index1 >= FCount) then Error(PResStringRec(@SListIndexError), Index1); + if (Index2 < 0) or (Index2 >= FCount) then Error(PResStringRec(@SListIndexError), Index2); + Changing; + ExchangeItems(Index1, Index2); + Changed; +end; + +procedure TTntStringList.ExchangeItems(Index1, Index2: Integer); +var + Temp: Integer; + Item1, Item2: PWideStringItem; +begin + Item1 := @FList^[Index1]; + Item2 := @FList^[Index2]; + Temp := Integer(Item1^.FString); + Integer(Item1^.FString) := Integer(Item2^.FString); + Integer(Item2^.FString) := Temp; + Temp := Integer(Item1^.FObject); + Integer(Item1^.FObject) := Integer(Item2^.FObject); + Integer(Item2^.FObject) := Temp; +end; + +function TTntStringList.Find(const S: WideString; var Index: Integer): Boolean; +var + L, H, I, C: Integer; +begin + Result := False; + L := 0; + H := FCount - 1; + while L <= H do + begin + I := (L + H) shr 1; + C := CompareStrings(FList^[I].FString, S); + if C < 0 then L := I + 1 else + begin + H := I - 1; + if C = 0 then + begin + Result := True; + if Duplicates <> dupAccept then L := I; + end; + end; + end; + Index := L; +end; + +function TTntStringList.Get(Index: Integer): WideString; +begin + if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); + Result := FList^[Index].FString; +end; + +function TTntStringList.GetCapacity: Integer; +begin + Result := FCapacity; +end; + +function TTntStringList.GetCount: Integer; +begin + Result := FCount; +end; + +function TTntStringList.GetObject(Index: Integer): TObject; +begin + if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); + Result := FList^[Index].FObject; +end; + +procedure TTntStringList.Grow; +var + Delta: Integer; +begin + if FCapacity > 64 then Delta := FCapacity div 4 else + if FCapacity > 8 then Delta := 16 else + Delta := 4; + SetCapacity(FCapacity + Delta); +end; + +function TTntStringList.IndexOf(const S: WideString): Integer; +begin + if not Sorted then Result := inherited IndexOf(S) else + if not Find(S, Result) then Result := -1; +end; + +function TTntStringList.IndexOfName(const Name: WideString): Integer; +var + NameKey: WideString; +begin + if not Sorted then + Result := inherited IndexOfName(Name) + else begin + // use sort to find index more quickly + NameKey := Name + NameValueSeparator; + Find(NameKey, Result); + if (Result < 0) or (Result > Count - 1) then + Result := -1 + else if CompareStrings(NameKey, Copy(Strings[Result], 1, Length(NameKey))) <> 0 then + Result := -1 + end; +end; + +procedure TTntStringList.Insert(Index: Integer; const S: WideString); +begin + InsertObject(Index, S, nil); +end; + +procedure TTntStringList.InsertObject(Index: Integer; const S: WideString; + AObject: TObject); +begin + if Sorted then Error(PResStringRec(@SSortedListError), 0); + if (Index < 0) or (Index > FCount) then Error(PResStringRec(@SListIndexError), Index); + InsertItem(Index, S, AObject); +end; + +procedure TTntStringList.InsertItem(Index: Integer; const S: WideString; AObject: TObject); +begin + Changing; + if FCount = FCapacity then Grow; + if Index < FCount then + System.Move(FList^[Index], FList^[Index + 1], + (FCount - Index) * SizeOf(TWideStringItem)); + with FList^[Index] do + begin + Pointer(FString) := nil; + FObject := AObject; + FString := S; + end; + Inc(FCount); + Changed; +end; + +procedure TTntStringList.Put(Index: Integer; const S: WideString); +begin + if Sorted then Error(PResStringRec(@SSortedListError), 0); + if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); + Changing; + FList^[Index].FString := S; + Changed; +end; + +procedure TTntStringList.PutObject(Index: Integer; AObject: TObject); +begin + if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); + Changing; + FList^[Index].FObject := AObject; + Changed; +end; + +procedure TTntStringList.QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare); +var + I, J, P: Integer; +begin + repeat + I := L; + J := R; + P := (L + R) shr 1; + repeat + while SCompare(Self, I, P) < 0 do Inc(I); + while SCompare(Self, J, P) > 0 do Dec(J); + if I <= J then + begin + ExchangeItems(I, J); + if P = I then + P := J + else if P = J then + P := I; + Inc(I); + Dec(J); + end; + until I > J; + if L < J then QuickSort(L, J, SCompare); + L := I; + until I >= R; +end; + +procedure TTntStringList.SetCapacity(NewCapacity: Integer); +begin + ReallocMem(FList, NewCapacity * SizeOf(TWideStringItem)); + FCapacity := NewCapacity; +end; + +procedure TTntStringList.SetSorted(Value: Boolean); +begin + if FSorted <> Value then + begin + if Value then Sort; + FSorted := Value; + end; +end; + +procedure TTntStringList.SetUpdateState(Updating: Boolean); +begin + FUpdating := Updating; + if Updating then Changing else Changed; +end; + +function WideStringListCompareStrings(List: TTntStringList; Index1, Index2: Integer): Integer; +begin + Result := List.CompareStrings(List.FList^[Index1].FString, + List.FList^[Index2].FString); +end; + +procedure TTntStringList.Sort; +begin + CustomSort(WideStringListCompareStrings); +end; + +procedure TTntStringList.CustomSort(Compare: TWideStringListSortCompare); +begin + if not Sorted and (FCount > 1) then + begin + Changing; + QuickSort(0, FCount - 1, Compare); + Changed; + end; +end; + +function TTntStringList.CompareStrings(const S1, S2: WideString): Integer; +begin + if CaseSensitive then + Result := WideCompareStr(S1, S2) + else + Result := WideCompareText(S1, S2); +end; + +procedure TTntStringList.SetCaseSensitive(const Value: Boolean); +begin + if Value <> FCaseSensitive then + begin + FCaseSensitive := Value; + if Sorted then Sort; + end; +end; + +//------------------------- TntClasses introduced procs ---------------------------------- + +function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet; +var + ByteOrderMark: WideChar; + BytesRead: Integer; + Utf8Test: array[0..2] of AnsiChar; +begin + // Byte Order Mark + ByteOrderMark := #0; + if (Stream.Size - Stream.Position) >= SizeOf(ByteOrderMark) then begin + BytesRead := Stream.Read(ByteOrderMark, SizeOf(ByteOrderMark)); + if (ByteOrderMark <> UNICODE_BOM) and (ByteOrderMark <> UNICODE_BOM_SWAPPED) then begin + ByteOrderMark := #0; + Stream.Seek(-BytesRead, soFromCurrent); + if (Stream.Size - Stream.Position) >= Length(Utf8Test) * SizeOf(AnsiChar) then begin + BytesRead := Stream.Read(Utf8Test[0], Length(Utf8Test) * SizeOf(AnsiChar)); + if Utf8Test <> UTF8_BOM then + Stream.Seek(-BytesRead, soFromCurrent); + end; + end; + end; + // Test Byte Order Mark + if ByteOrderMark = UNICODE_BOM then + Result := csUnicode + else if ByteOrderMark = UNICODE_BOM_SWAPPED then + Result := csUnicodeSwapped + else if Utf8Test = UTF8_BOM then + Result := csUtf8 + else + Result := csAnsi; +end; + +function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare; + Target: Pointer; var Index: Integer): Boolean; +var + L, H, I, C: Integer; +begin + Result := False; + L := 0; + H := List.Count - 1; + while L <= H do + begin + I := (L + H) shr 1; + C := TargetCompare(List[i], Target); + if C < 0 then L := I + 1 else + begin + H := I - 1; + if C = 0 then + begin + Result := True; + L := I; + end; + end; + end; + Index := L; +end; + +function ClassIsRegistered(const clsid: TCLSID): Boolean; +var + OleStr: POleStr; + Reg: TRegIniFile; + Key, Filename: WideString; +begin + // First, check to see if there is a ProgID. This will tell if the + // control is registered on the machine. No ProgID, control won't run + Result := ProgIDFromCLSID(clsid, OleStr) = S_OK; + if not Result then Exit; //Bail as soon as anything goes wrong. + + // Next, make sure that the file is actually there by rooting it out + // of the registry + Key := WideFormat('\SOFTWARE\Classes\CLSID\%s', [GUIDToString(clsid)]); + Reg := TRegIniFile.Create; + try + Reg.RootKey := HKEY_LOCAL_MACHINE; + Result := Reg.OpenKeyReadOnly(Key); + if not Result then Exit; // Bail as soon as anything goes wrong. + + FileName := Reg.ReadString('InProcServer32', '', EmptyStr); + if (Filename = EmptyStr) then // try another key for the file name + begin + FileName := Reg.ReadString('InProcServer', '', EmptyStr); + end; + Result := Filename <> EmptyStr; + if not Result then Exit; + Result := WideFileExists(Filename); + finally + Reg.Free; + end; +end; + +{ TBufferedAnsiString } + +procedure TBufferedAnsiString.Clear; +begin + LastWriteIndex := 0; + if Length(FStringBuffer) > 0 then + FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(AnsiChar), 0); +end; + +procedure TBufferedAnsiString.AddChar(const wc: AnsiChar); +const + MIN_GROW_SIZE = 32; + MAX_GROW_SIZE = 256; +var + GrowSize: Integer; +begin + Inc(LastWriteIndex); + if LastWriteIndex > Length(FStringBuffer) then begin + GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer)); + GrowSize := Min(GrowSize, MAX_GROW_SIZE); + SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize); + FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(AnsiChar), 0); + end; + FStringBuffer[LastWriteIndex] := wc; +end; + +procedure TBufferedAnsiString.AddString(const s: AnsiString); +var + LenS: Integer; + BlockSize: Integer; + AllocSize: Integer; +begin + LenS := Length(s); + if LenS > 0 then begin + Inc(LastWriteIndex); + if LastWriteIndex + LenS - 1 > Length(FStringBuffer) then begin + // determine optimum new allocation size + BlockSize := Length(FStringBuffer) div 2; + if BlockSize < 8 then + BlockSize := 8; + AllocSize := ((LenS div BlockSize) + 1) * BlockSize; + // realloc buffer + SetLength(FStringBuffer, Length(FStringBuffer) + AllocSize); + FillChar(FStringBuffer[Length(FStringBuffer) - AllocSize + 1], AllocSize * SizeOf(AnsiChar), 0); + end; + CopyMemory(@FStringBuffer[LastWriteIndex], @s[1], LenS * SizeOf(AnsiChar)); + Inc(LastWriteIndex, LenS - 1); + end; +end; + +procedure TBufferedAnsiString.AddBuffer(Buff: PAnsiChar; Chars: Integer); +var + i: integer; +begin + for i := 1 to Chars do begin + if Buff^ = #0 then + break; + AddChar(Buff^); + Inc(Buff); + end; +end; + +function TBufferedAnsiString.Value: AnsiString; +begin + Result := PAnsiChar(FStringBuffer); +end; + +function TBufferedAnsiString.BuffPtr: PAnsiChar; +begin + Result := PAnsiChar(FStringBuffer); +end; + +{ TBufferedWideString } + +procedure TBufferedWideString.Clear; +begin + LastWriteIndex := 0; + if Length(FStringBuffer) > 0 then + FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(WideChar), 0); +end; + +procedure TBufferedWideString.AddChar(const wc: WideChar); +const + MIN_GROW_SIZE = 32; + MAX_GROW_SIZE = 256; +var + GrowSize: Integer; +begin + Inc(LastWriteIndex); + if LastWriteIndex > Length(FStringBuffer) then begin + GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer)); + GrowSize := Min(GrowSize, MAX_GROW_SIZE); + SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize); + FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(WideChar), 0); + end; + FStringBuffer[LastWriteIndex] := wc; +end; + +procedure TBufferedWideString.AddString(const s: WideString); +var + i: integer; +begin + for i := 1 to Length(s) do + AddChar(s[i]); +end; + +procedure TBufferedWideString.AddBuffer(Buff: PWideChar; Chars: Integer); +var + i: integer; +begin + for i := 1 to Chars do begin + if Buff^ = #0 then + break; + AddChar(Buff^); + Inc(Buff); + end; +end; + +function TBufferedWideString.Value: WideString; +begin + Result := PWideChar(FStringBuffer); +end; + +function TBufferedWideString.BuffPtr: PWideChar; +begin + Result := PWideChar(FStringBuffer); +end; + +{ TBufferedStreamReader } + +constructor TBufferedStreamReader.Create(Stream: TStream; BufferSize: Integer = 1024); +begin + // init stream + FStream := Stream; + FStreamSize := Stream.Size; + // init buffer + FBufferSize := BufferSize; + SetLength(FBuffer, BufferSize); + FBufferStartPosition := -FBufferSize; { out of any useful range } + // init virtual position + FVirtualPosition := 0; +end; + +function TBufferedStreamReader.Seek(Offset: Integer; Origin: Word): Longint; +begin + case Origin of + soFromBeginning: FVirtualPosition := Offset; + soFromCurrent: Inc(FVirtualPosition, Offset); + soFromEnd: FVirtualPosition := FStreamSize + Offset; + end; + Result := FVirtualPosition; +end; + +procedure TBufferedStreamReader.UpdateBufferFromPosition(StartPos: Integer); +begin + try + FStream.Position := StartPos; + FStream.Read(FBuffer[0], FBufferSize); + FBufferStartPosition := StartPos; + except + FBufferStartPosition := -FBufferSize; { out of any useful range } + raise; + end; +end; + +function TBufferedStreamReader.Read(var Buffer; Count: Integer): Longint; +var + BytesLeft: Integer; + FirstBufferRead: Integer; + StreamDirectRead: Integer; + Buf: PAnsiChar; +begin + if (FVirtualPosition >= 0) and (Count >= 0) then + begin + Result := FStreamSize - FVirtualPosition; + if Result > 0 then + begin + if Result > Count then + Result := Count; + + Buf := @Buffer; + BytesLeft := Result; + + // try to read what is left in buffer + FirstBufferRead := FBufferStartPosition + FBufferSize - FVirtualPosition; + if (FirstBufferRead < 0) or (FirstBufferRead > FBufferSize) then + FirstBufferRead := 0; + FirstBufferRead := Min(FirstBufferRead, Result); + if FirstBufferRead > 0 then begin + Move(FBuffer[FVirtualPosition - FBufferStartPosition], Buf[0], FirstBufferRead); + Dec(BytesLeft, FirstBufferRead); + end; + + if BytesLeft > 0 then begin + // The first read in buffer was not enough + StreamDirectRead := (BytesLeft div FBufferSize) * FBufferSize; + FStream.Position := FVirtualPosition + FirstBufferRead; + FStream.Read(Buf[FirstBufferRead], StreamDirectRead); + Dec(BytesLeft, StreamDirectRead); + + if BytesLeft > 0 then begin + // update buffer, and read what is left + UpdateBufferFromPosition(FStream.Position); + Move(FBuffer[0], Buf[FirstBufferRead + StreamDirectRead], BytesLeft); + end; + end; + + Inc(FVirtualPosition, Result); + Exit; + end; + end; + Result := 0; +end; + +function TBufferedStreamReader.Write(const Buffer; Count: Integer): Longint; +begin + raise ETntInternalError.Create('Internal Error: class can not write.'); + Result := 0; +end; + +//-------- synced wide string ----------------- + +function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString; +begin + if AnsiString(WideStr) <> (AnsiStr) then begin + WideStr := AnsiStr; {AnsiStr changed. Keep WideStr in sync.} + end; + Result := WideStr; +end; + +procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString; + const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent); +begin + if Value <> GetSyncedWideString(WideStr, AnsiStr) then + begin + if (not WideSameStr(Value, AnsiString(Value))) {unicode chars lost in conversion} + and (AnsiStr = AnsiString(Value)) {AnsiStr is not going to change} + then begin + SetAnsiStr(''); {force the change} + end; + WideStr := Value; + SetAnsiStr(Value); + end; +end; + +{ TWideComponentHelper } + +function CompareComponentHelperToTarget(Item, Target: Pointer): Integer; +begin + if PtrUInt(TWideComponentHelper(Item).FComponent) < PtrUInt(Target) then + Result := -1 + else if PtrUInt(TWideComponentHelper(Item).FComponent) > PtrUInt(Target) then + Result := 1 + else + Result := 0; +end; + +function FindWideComponentHelperIndex(ComponentHelperList: TComponentList; Component: TComponent; var Index: Integer): Boolean; +begin + // find Component in sorted wide caption list (list is sorted by TWideComponentHelper.FComponent) + Result := FindSortedListByTarget(ComponentHelperList, CompareComponentHelperToTarget, Component, Index); +end; + +constructor TWideComponentHelper.Create(AOwner: TComponent); +begin + raise ETntInternalError.Create('TNT Internal Error: TWideComponentHelper.Create should never be encountered.'); +end; + +constructor TWideComponentHelper.CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList); +var + Index: Integer; +begin + // don't use direct ownership for memory management + inherited Create(nil); + FComponent := AOwner; + FComponent.FreeNotification(Self); + + // insert into list according to sort + FindWideComponentHelperIndex(ComponentHelperList, FComponent, Index); + ComponentHelperList.Insert(Index, Self); +end; + +procedure TWideComponentHelper.Notification(AComponent: TComponent; Operation: TOperation); +begin + inherited; + if (AComponent = FComponent) and (Operation = opRemove) then begin + FComponent := nil; + Free; + end; +end; + +function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper; +var + Index: integer; +begin + if FindWideComponentHelperIndex(ComponentHelperList, Component, Index) then begin + Result := TWideComponentHelper(ComponentHelperList[Index]); + Assert(Result.FComponent = Component, 'TNT Internal Error: FindWideComponentHelperIndex failed.'); + end else + Result := nil; +end; + +initialization + RuntimeUTFStreaming := False; { Delphi 6 and higher don't need UTF help at runtime. } + +end. diff --git a/src/lib/TntUnicodeControls/TntFormatStrUtils.pas b/src/lib/TntUnicodeControls/TntFormatStrUtils.pas index 80aefd4a..a5ea0868 100644 --- a/src/lib/TntUnicodeControls/TntFormatStrUtils.pas +++ b/src/lib/TntUnicodeControls/TntFormatStrUtils.pas @@ -1,521 +1,521 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntFormatStrUtils; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -interface - -// this unit provides functions to work with format strings - -uses - TntSysUtils; - -function GetCanonicalFormatStr(const _FormatString: WideString): WideString; - -{$IFNDEF FPC} -{$IFNDEF COMPILER_9_UP} -function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString; - const Args: array of const - {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString; -{$ENDIF} -{$ENDIF} -procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString); -function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean; - -type - EFormatSpecError = class(ETntGeneralError); - -implementation - -uses - SysUtils, Math, TntClasses; - -resourcestring - SInvalidFormatSpecifier = 'Invalid Format Specifier: %s'; - SMismatchedArgumentTypes = 'Argument types for index %d do not match. (%s <> %s)'; - SMismatchedArgumentCounts = 'Number of format specifiers do not match.'; - -type - TFormatSpecifierType = (fstInteger, fstFloating, fstPointer, fstString); - -function GetFormatSpecifierType(const FormatSpecifier: WideString): TFormatSpecifierType; -var - LastChar: WideChar; -begin - LastChar := TntWideLastChar(FormatSpecifier); - case LastChar of - 'd', 'D', 'u', 'U', 'x', 'X': - result := fstInteger; - 'e', 'E', 'f', 'F', 'g', 'G', 'n', 'N', 'm', 'M': - result := fstFloating; - 'p', 'P': - result := fstPointer; - 's', 'S': - result := fstString - else - raise ETntInternalError.CreateFmt('Internal Error: Unexpected format type (%s)', [LastChar]); - end; -end; - -type - TFormatStrParser = class(TObject) - private - ParsedString: TBufferedWideString; - PFormatString: PWideChar; - LastIndex: Integer; - ExplicitCount: Integer; - ImplicitCount: Integer; - procedure RaiseInvalidFormatSpecifier; - function ParseChar(c: WideChar): Boolean; - procedure ForceParseChar(c: WideChar); - function ParseDigit: Boolean; - function ParseInteger: Boolean; - procedure ForceParseType; - function PeekDigit: Boolean; - function PeekIndexSpecifier(out Index: Integer): Boolean; - public - constructor Create(const _FormatString: WideString); - destructor Destroy; override; - function ParseFormatSpecifier: Boolean; - end; - -constructor TFormatStrParser.Create(const _FormatString: WideString); -begin - inherited Create; - PFormatString := PWideChar(_FormatString); - ExplicitCount := 0; - ImplicitCount := 0; - LastIndex := -1; - ParsedString := TBufferedWideString.Create; -end; - -destructor TFormatStrParser.Destroy; -begin - FreeAndNil(ParsedString); - inherited; -end; - -procedure TFormatStrParser.RaiseInvalidFormatSpecifier; -begin - raise EFormatSpecError.CreateFmt(SInvalidFormatSpecifier, [ParsedString.Value + PFormatString]); -end; - -function TFormatStrParser.ParseChar(c: WideChar): Boolean; -begin - result := False; - if PFormatString^ = c then begin - result := True; - ParsedString.AddChar(c); - Inc(PFormatString); - end; -end; - -procedure TFormatStrParser.ForceParseChar(c: WideChar); -begin - if not ParseChar(c) then - RaiseInvalidFormatSpecifier; -end; - -function TFormatStrParser.PeekDigit: Boolean; -begin - result := False; - if (PFormatString^ <> #0) - and (PFormatString^ >= '0') - and (PFormatString^ <= '9') then - result := True; -end; - -function TFormatStrParser.ParseDigit: Boolean; -begin - result := False; - if PeekDigit then begin - result := True; - ForceParseChar(PFormatString^); - end; -end; - -function TFormatStrParser.ParseInteger: Boolean; -const - MAX_INT_DIGITS = 6; -var - digitcount: integer; -begin - digitcount := 0; - While ParseDigit do begin - inc(digitcount); - end; - result := (digitcount > 0); - if digitcount > MAX_INT_DIGITS then - RaiseInvalidFormatSpecifier; -end; - -procedure TFormatStrParser.ForceParseType; -begin - if PFormatString^ = #0 then - RaiseInvalidFormatSpecifier; - - case PFormatString^ of - 'd', 'u', 'x', 'e', 'f', 'g', 'n', 'm', 'p', 's', - 'D', 'U', 'X', 'E', 'F', 'G', 'N', 'M', 'P', 'S': - begin - // do nothing - end - else - RaiseInvalidFormatSpecifier; - end; - ForceParseChar(PFormatString^); -end; - -function TFormatStrParser.PeekIndexSpecifier(out Index: Integer): Boolean; -var - SaveParsedString: WideString; - SaveFormatString: PWideChar; -begin - SaveParsedString := ParsedString.Value; - SaveFormatString := PFormatString; - try - ParsedString.Clear; - Result := False; - Index := -1; - if ParseInteger then begin - Index := StrToInt(ParsedString.Value); - if ParseChar(':') then - Result := True; - end; - finally - ParsedString.Clear; - ParsedString.AddString(SaveParsedString); - PFormatString := SaveFormatString; - end; -end; - -function TFormatStrParser.ParseFormatSpecifier: Boolean; -var - ExplicitIndex: Integer; -begin - Result := False; - // Parse entire format specifier - ForceParseChar('%'); - if (PFormatString^ <> #0) - and (not ParseChar(' ')) - and (not ParseChar('%')) then begin - if PeekIndexSpecifier(ExplicitIndex) then begin - Inc(ExplicitCount); - LastIndex := Max(LastIndex, ExplicitIndex); - end else begin - Inc(ImplicitCount); - Inc(LastIndex); - ParsedString.AddString(IntToStr(LastIndex)); - ParsedString.AddChar(':'); - end; - if ParseChar('*') then - begin - Inc(ImplicitCount); - Inc(LastIndex); - ParseChar(':'); - end else if ParseInteger then - ParseChar(':'); - ParseChar('-'); - if ParseChar('*') then begin - Inc(ImplicitCount); - Inc(LastIndex); - end else - ParseInteger; - if ParseChar('.') then begin - if not ParseChar('*') then - ParseInteger; - end; - ForceParseType; - Result := True; - end; -end; - -//----------------------------------- - -function GetCanonicalFormatStr(const _FormatString: WideString): WideString; -var - PosSpec: Integer; -begin - with TFormatStrParser.Create(_FormatString) do - try - // loop until no more '%' - PosSpec := Pos(WideString('%'), PFormatString); - While PosSpec <> 0 do begin - try - // delete everything up until '%' - ParsedString.AddBuffer(PFormatString, PosSpec - 1); - Inc(PFormatString, PosSpec - 1); - // parse format specifier - ParseFormatSpecifier; - finally - PosSpec := Pos(WideString('%'), PFormatString); - end; - end; - if ((ExplicitCount = 0) and (ImplicitCount = 1)) {simple expression} - or ((ExplicitCount > 0) and (ImplicitCount = 0)) {nothing converted} then - result := _FormatString {original} - else - result := ParsedString.Value + PFormatString; - finally - Free; - end; -end; - -{$IFNDEF FPC} -{$IFNDEF COMPILER_9_UP} -function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString; - const Args: array of const - {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString; -{ This function replaces floating point format specifiers with their actual formatted values. - It also adds index specifiers so that the other format specifiers don't lose their place. - The reason for this is that WideFormat doesn't correctly format floating point specifiers. - See QC#4254. } -var - Parser: TFormatStrParser; - PosSpec: Integer; - Output: TBufferedWideString; -begin - Output := TBufferedWideString.Create; - try - Parser := TFormatStrParser.Create(_FormatString); - with Parser do - try - // loop until no more '%' - PosSpec := Pos('%', PFormatString); - While PosSpec <> 0 do begin - try - // delete everything up until '%' - Output.AddBuffer(PFormatString, PosSpec - 1); - Inc(PFormatString, PosSpec - 1); - // parse format specifier - ParsedString.Clear; - if (not ParseFormatSpecifier) - or (GetFormatSpecifierType(ParsedString.Value) <> fstFloating) then - Output.AddBuffer(ParsedString.BuffPtr, MaxInt) - {$IFDEF COMPILER_7_UP} - else if Assigned(FormatSettings) then - Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args, FormatSettings^)) - {$ENDIF} - else - Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args)); - finally - PosSpec := Pos('%', PFormatString); - end; - end; - Output.AddString(PFormatString); - finally - Free; - end; - Result := Output.Value; - finally - Output.Free; - end; -end; -{$ENDIF} -{$ENDIF} - -procedure GetFormatArgs(const _FormatString: WideString; FormatArgs: TTntStrings); -var - PosSpec: Integer; -begin - with TFormatStrParser.Create(_FormatString) do - try - FormatArgs.Clear; - // loop until no more '%' - PosSpec := Pos(WideString('%'), PFormatString); - While PosSpec <> 0 do begin - try - // delete everything up until '%' - Inc(PFormatString, PosSpec - 1); - // add format specifier to list - ParsedString.Clear; - if ParseFormatSpecifier then - FormatArgs.Add(ParsedString.Value); - finally - PosSpec := Pos(WideString('%'), PFormatString); - end; - end; - finally - Free; - end; -end; - -function GetExplicitIndex(const FormatSpecifier: WideString): Integer; -var - IndexStr: WideString; - PosColon: Integer; -begin - result := -1; - PosColon := Pos(':', FormatSpecifier); - if PosColon <> 0 then begin - IndexStr := Copy(FormatSpecifier, 2, PosColon - 2); - result := StrToInt(IndexStr); - end; -end; - -function GetMaxIndex(FormatArgs: TTntStrings): Integer; -var - i: integer; - RunningIndex: Integer; - ExplicitIndex: Integer; -begin - result := -1; - RunningIndex := -1; - for i := 0 to FormatArgs.Count - 1 do begin - ExplicitIndex := GetExplicitIndex(FormatArgs[i]); - if ExplicitIndex <> -1 then - RunningIndex := ExplicitIndex - else - inc(RunningIndex); - result := Max(result, RunningIndex); - end; -end; - -function FormatSpecToObject(SpecType: TFormatSpecifierType): TObject; -begin - {$IFNDEF FPC} - Result := TObject(SpecType); - {$ELSE} - Result := Pointer(SpecType); - {$ENDIF} -end; - -procedure UpdateTypeList(FormatArgs, TypeList: TTntStrings); -var - i: integer; - f: WideString; - SpecType: TFormatSpecifierType; - ExplicitIndex: Integer; - MaxIndex: Integer; - RunningIndex: Integer; -begin - // set count of TypeList to accomodate maximum index - MaxIndex := GetMaxIndex(FormatArgs); - TypeList.Clear; - for i := 0 to MaxIndex do - TypeList.Add(''); - - // for each arg... - RunningIndex := -1; - for i := 0 to FormatArgs.Count - 1 do begin - f := FormatArgs[i]; - ExplicitIndex := GetExplicitIndex(f); - SpecType := GetFormatSpecifierType(f); - - // determine running arg index - if ExplicitIndex <> -1 then - RunningIndex := ExplicitIndex - else - inc(RunningIndex); - - if TypeList[RunningIndex] <> '' then begin - // already exists in list, check for compatibility - if TypeList.Objects[RunningIndex] <> FormatSpecToObject(SpecType) then - raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes, - [RunningIndex, TypeList[RunningIndex], f]); - end else begin - // not in list so update it - TypeList[RunningIndex] := f; - TypeList.Objects[RunningIndex] := FormatSpecToObject(SpecType); - end; - end; -end; - -procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString); -var - ArgList1: TTntStringList; - ArgList2: TTntStringList; - TypeList1: TTntStringList; - TypeList2: TTntStringList; - i: integer; -begin - ArgList1 := nil; - ArgList2 := nil; - TypeList1 := nil; - TypeList2 := nil; - try - ArgList1 := TTntStringList.Create; - ArgList2 := TTntStringList.Create; - TypeList1 := TTntStringList.Create; - TypeList2 := TTntStringList.Create; - - GetFormatArgs(FormatStr1, ArgList1); - UpdateTypeList(ArgList1, TypeList1); - - GetFormatArgs(FormatStr2, ArgList2); - UpdateTypeList(ArgList2, TypeList2); - - if TypeList1.Count <> TypeList2.Count then - raise EFormatSpecError.Create(SMismatchedArgumentCounts + CRLF + CRLF + '> ' + FormatStr1 + CRLF + '> ' + FormatStr2); - - for i := 0 to TypeList1.Count - 1 do begin - if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin - raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes, - [i, TypeList1[i], TypeList2[i]]); - end; - end; - - finally - ArgList1.Free; - ArgList2.Free; - TypeList1.Free; - TypeList2.Free; - end; -end; - -function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean; -var - ArgList1: TTntStringList; - ArgList2: TTntStringList; - TypeList1: TTntStringList; - TypeList2: TTntStringList; - i: integer; -begin - ArgList1 := nil; - ArgList2 := nil; - TypeList1 := nil; - TypeList2 := nil; - try - ArgList1 := TTntStringList.Create; - ArgList2 := TTntStringList.Create; - TypeList1 := TTntStringList.Create; - TypeList2 := TTntStringList.Create; - - GetFormatArgs(FormatStr1, ArgList1); - UpdateTypeList(ArgList1, TypeList1); - - GetFormatArgs(FormatStr2, ArgList2); - UpdateTypeList(ArgList2, TypeList2); - - Result := (TypeList1.Count = TypeList2.Count); - if Result then begin - for i := 0 to TypeList1.Count - 1 do begin - if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin - Result := False; - break; - end; - end; - end; - finally - ArgList1.Free; - ArgList2.Free; - TypeList1.Free; - TypeList2.Free; - end; -end; - -end. + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntFormatStrUtils; + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$INCLUDE TntCompilers.inc} + +interface + +// this unit provides functions to work with format strings + +uses + TntSysUtils; + +function GetCanonicalFormatStr(const _FormatString: WideString): WideString; + +{$IFNDEF FPC} +{$IFNDEF COMPILER_9_UP} +function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString; + const Args: array of const + {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString; +{$ENDIF} +{$ENDIF} +procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString); +function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean; + +type + EFormatSpecError = class(ETntGeneralError); + +implementation + +uses + SysUtils, Math, TntClasses; + +resourcestring + SInvalidFormatSpecifier = 'Invalid Format Specifier: %s'; + SMismatchedArgumentTypes = 'Argument types for index %d do not match. (%s <> %s)'; + SMismatchedArgumentCounts = 'Number of format specifiers do not match.'; + +type + TFormatSpecifierType = (fstInteger, fstFloating, fstPointer, fstString); + +function GetFormatSpecifierType(const FormatSpecifier: WideString): TFormatSpecifierType; +var + LastChar: WideChar; +begin + LastChar := TntWideLastChar(FormatSpecifier); + case LastChar of + 'd', 'D', 'u', 'U', 'x', 'X': + result := fstInteger; + 'e', 'E', 'f', 'F', 'g', 'G', 'n', 'N', 'm', 'M': + result := fstFloating; + 'p', 'P': + result := fstPointer; + 's', 'S': + result := fstString + else + raise ETntInternalError.CreateFmt('Internal Error: Unexpected format type (%s)', [LastChar]); + end; +end; + +type + TFormatStrParser = class(TObject) + private + ParsedString: TBufferedWideString; + PFormatString: PWideChar; + LastIndex: Integer; + ExplicitCount: Integer; + ImplicitCount: Integer; + procedure RaiseInvalidFormatSpecifier; + function ParseChar(c: WideChar): Boolean; + procedure ForceParseChar(c: WideChar); + function ParseDigit: Boolean; + function ParseInteger: Boolean; + procedure ForceParseType; + function PeekDigit: Boolean; + function PeekIndexSpecifier(out Index: Integer): Boolean; + public + constructor Create(const _FormatString: WideString); + destructor Destroy; override; + function ParseFormatSpecifier: Boolean; + end; + +constructor TFormatStrParser.Create(const _FormatString: WideString); +begin + inherited Create; + PFormatString := PWideChar(_FormatString); + ExplicitCount := 0; + ImplicitCount := 0; + LastIndex := -1; + ParsedString := TBufferedWideString.Create; +end; + +destructor TFormatStrParser.Destroy; +begin + FreeAndNil(ParsedString); + inherited; +end; + +procedure TFormatStrParser.RaiseInvalidFormatSpecifier; +begin + raise EFormatSpecError.CreateFmt(SInvalidFormatSpecifier, [ParsedString.Value + PFormatString]); +end; + +function TFormatStrParser.ParseChar(c: WideChar): Boolean; +begin + result := False; + if PFormatString^ = c then begin + result := True; + ParsedString.AddChar(c); + Inc(PFormatString); + end; +end; + +procedure TFormatStrParser.ForceParseChar(c: WideChar); +begin + if not ParseChar(c) then + RaiseInvalidFormatSpecifier; +end; + +function TFormatStrParser.PeekDigit: Boolean; +begin + result := False; + if (PFormatString^ <> #0) + and (PFormatString^ >= '0') + and (PFormatString^ <= '9') then + result := True; +end; + +function TFormatStrParser.ParseDigit: Boolean; +begin + result := False; + if PeekDigit then begin + result := True; + ForceParseChar(PFormatString^); + end; +end; + +function TFormatStrParser.ParseInteger: Boolean; +const + MAX_INT_DIGITS = 6; +var + digitcount: integer; +begin + digitcount := 0; + While ParseDigit do begin + inc(digitcount); + end; + result := (digitcount > 0); + if digitcount > MAX_INT_DIGITS then + RaiseInvalidFormatSpecifier; +end; + +procedure TFormatStrParser.ForceParseType; +begin + if PFormatString^ = #0 then + RaiseInvalidFormatSpecifier; + + case PFormatString^ of + 'd', 'u', 'x', 'e', 'f', 'g', 'n', 'm', 'p', 's', + 'D', 'U', 'X', 'E', 'F', 'G', 'N', 'M', 'P', 'S': + begin + // do nothing + end + else + RaiseInvalidFormatSpecifier; + end; + ForceParseChar(PFormatString^); +end; + +function TFormatStrParser.PeekIndexSpecifier(out Index: Integer): Boolean; +var + SaveParsedString: WideString; + SaveFormatString: PWideChar; +begin + SaveParsedString := ParsedString.Value; + SaveFormatString := PFormatString; + try + ParsedString.Clear; + Result := False; + Index := -1; + if ParseInteger then begin + Index := StrToInt(ParsedString.Value); + if ParseChar(':') then + Result := True; + end; + finally + ParsedString.Clear; + ParsedString.AddString(SaveParsedString); + PFormatString := SaveFormatString; + end; +end; + +function TFormatStrParser.ParseFormatSpecifier: Boolean; +var + ExplicitIndex: Integer; +begin + Result := False; + // Parse entire format specifier + ForceParseChar('%'); + if (PFormatString^ <> #0) + and (not ParseChar(' ')) + and (not ParseChar('%')) then begin + if PeekIndexSpecifier(ExplicitIndex) then begin + Inc(ExplicitCount); + LastIndex := Max(LastIndex, ExplicitIndex); + end else begin + Inc(ImplicitCount); + Inc(LastIndex); + ParsedString.AddString(IntToStr(LastIndex)); + ParsedString.AddChar(':'); + end; + if ParseChar('*') then + begin + Inc(ImplicitCount); + Inc(LastIndex); + ParseChar(':'); + end else if ParseInteger then + ParseChar(':'); + ParseChar('-'); + if ParseChar('*') then begin + Inc(ImplicitCount); + Inc(LastIndex); + end else + ParseInteger; + if ParseChar('.') then begin + if not ParseChar('*') then + ParseInteger; + end; + ForceParseType; + Result := True; + end; +end; + +//----------------------------------- + +function GetCanonicalFormatStr(const _FormatString: WideString): WideString; +var + PosSpec: Integer; +begin + with TFormatStrParser.Create(_FormatString) do + try + // loop until no more '%' + PosSpec := Pos(WideString('%'), PFormatString); + While PosSpec <> 0 do begin + try + // delete everything up until '%' + ParsedString.AddBuffer(PFormatString, PosSpec - 1); + Inc(PFormatString, PosSpec - 1); + // parse format specifier + ParseFormatSpecifier; + finally + PosSpec := Pos(WideString('%'), PFormatString); + end; + end; + if ((ExplicitCount = 0) and (ImplicitCount = 1)) {simple expression} + or ((ExplicitCount > 0) and (ImplicitCount = 0)) {nothing converted} then + result := _FormatString {original} + else + result := ParsedString.Value + PFormatString; + finally + Free; + end; +end; + +{$IFNDEF FPC} +{$IFNDEF COMPILER_9_UP} +function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString; + const Args: array of const + {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString; +{ This function replaces floating point format specifiers with their actual formatted values. + It also adds index specifiers so that the other format specifiers don't lose their place. + The reason for this is that WideFormat doesn't correctly format floating point specifiers. + See QC#4254. } +var + Parser: TFormatStrParser; + PosSpec: Integer; + Output: TBufferedWideString; +begin + Output := TBufferedWideString.Create; + try + Parser := TFormatStrParser.Create(_FormatString); + with Parser do + try + // loop until no more '%' + PosSpec := Pos('%', PFormatString); + While PosSpec <> 0 do begin + try + // delete everything up until '%' + Output.AddBuffer(PFormatString, PosSpec - 1); + Inc(PFormatString, PosSpec - 1); + // parse format specifier + ParsedString.Clear; + if (not ParseFormatSpecifier) + or (GetFormatSpecifierType(ParsedString.Value) <> fstFloating) then + Output.AddBuffer(ParsedString.BuffPtr, MaxInt) + {$IFDEF COMPILER_7_UP} + else if Assigned(FormatSettings) then + Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args, FormatSettings^)) + {$ENDIF} + else + Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args)); + finally + PosSpec := Pos('%', PFormatString); + end; + end; + Output.AddString(PFormatString); + finally + Free; + end; + Result := Output.Value; + finally + Output.Free; + end; +end; +{$ENDIF} +{$ENDIF} + +procedure GetFormatArgs(const _FormatString: WideString; FormatArgs: TTntStrings); +var + PosSpec: Integer; +begin + with TFormatStrParser.Create(_FormatString) do + try + FormatArgs.Clear; + // loop until no more '%' + PosSpec := Pos(WideString('%'), PFormatString); + While PosSpec <> 0 do begin + try + // delete everything up until '%' + Inc(PFormatString, PosSpec - 1); + // add format specifier to list + ParsedString.Clear; + if ParseFormatSpecifier then + FormatArgs.Add(ParsedString.Value); + finally + PosSpec := Pos(WideString('%'), PFormatString); + end; + end; + finally + Free; + end; +end; + +function GetExplicitIndex(const FormatSpecifier: WideString): Integer; +var + IndexStr: WideString; + PosColon: Integer; +begin + result := -1; + PosColon := Pos(':', FormatSpecifier); + if PosColon <> 0 then begin + IndexStr := Copy(FormatSpecifier, 2, PosColon - 2); + result := StrToInt(IndexStr); + end; +end; + +function GetMaxIndex(FormatArgs: TTntStrings): Integer; +var + i: integer; + RunningIndex: Integer; + ExplicitIndex: Integer; +begin + result := -1; + RunningIndex := -1; + for i := 0 to FormatArgs.Count - 1 do begin + ExplicitIndex := GetExplicitIndex(FormatArgs[i]); + if ExplicitIndex <> -1 then + RunningIndex := ExplicitIndex + else + inc(RunningIndex); + result := Max(result, RunningIndex); + end; +end; + +function FormatSpecToObject(SpecType: TFormatSpecifierType): TObject; +begin + {$IFNDEF FPC} + Result := TObject(SpecType); + {$ELSE} + Result := Pointer(SpecType); + {$ENDIF} +end; + +procedure UpdateTypeList(FormatArgs, TypeList: TTntStrings); +var + i: integer; + f: WideString; + SpecType: TFormatSpecifierType; + ExplicitIndex: Integer; + MaxIndex: Integer; + RunningIndex: Integer; +begin + // set count of TypeList to accomodate maximum index + MaxIndex := GetMaxIndex(FormatArgs); + TypeList.Clear; + for i := 0 to MaxIndex do + TypeList.Add(''); + + // for each arg... + RunningIndex := -1; + for i := 0 to FormatArgs.Count - 1 do begin + f := FormatArgs[i]; + ExplicitIndex := GetExplicitIndex(f); + SpecType := GetFormatSpecifierType(f); + + // determine running arg index + if ExplicitIndex <> -1 then + RunningIndex := ExplicitIndex + else + inc(RunningIndex); + + if TypeList[RunningIndex] <> '' then begin + // already exists in list, check for compatibility + if TypeList.Objects[RunningIndex] <> FormatSpecToObject(SpecType) then + raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes, + [RunningIndex, TypeList[RunningIndex], f]); + end else begin + // not in list so update it + TypeList[RunningIndex] := f; + TypeList.Objects[RunningIndex] := FormatSpecToObject(SpecType); + end; + end; +end; + +procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString); +var + ArgList1: TTntStringList; + ArgList2: TTntStringList; + TypeList1: TTntStringList; + TypeList2: TTntStringList; + i: integer; +begin + ArgList1 := nil; + ArgList2 := nil; + TypeList1 := nil; + TypeList2 := nil; + try + ArgList1 := TTntStringList.Create; + ArgList2 := TTntStringList.Create; + TypeList1 := TTntStringList.Create; + TypeList2 := TTntStringList.Create; + + GetFormatArgs(FormatStr1, ArgList1); + UpdateTypeList(ArgList1, TypeList1); + + GetFormatArgs(FormatStr2, ArgList2); + UpdateTypeList(ArgList2, TypeList2); + + if TypeList1.Count <> TypeList2.Count then + raise EFormatSpecError.Create(SMismatchedArgumentCounts + CRLF + CRLF + '> ' + FormatStr1 + CRLF + '> ' + FormatStr2); + + for i := 0 to TypeList1.Count - 1 do begin + if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin + raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes, + [i, TypeList1[i], TypeList2[i]]); + end; + end; + + finally + ArgList1.Free; + ArgList2.Free; + TypeList1.Free; + TypeList2.Free; + end; +end; + +function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean; +var + ArgList1: TTntStringList; + ArgList2: TTntStringList; + TypeList1: TTntStringList; + TypeList2: TTntStringList; + i: integer; +begin + ArgList1 := nil; + ArgList2 := nil; + TypeList1 := nil; + TypeList2 := nil; + try + ArgList1 := TTntStringList.Create; + ArgList2 := TTntStringList.Create; + TypeList1 := TTntStringList.Create; + TypeList2 := TTntStringList.Create; + + GetFormatArgs(FormatStr1, ArgList1); + UpdateTypeList(ArgList1, TypeList1); + + GetFormatArgs(FormatStr2, ArgList2); + UpdateTypeList(ArgList2, TypeList2); + + Result := (TypeList1.Count = TypeList2.Count); + if Result then begin + for i := 0 to TypeList1.Count - 1 do begin + if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin + Result := False; + break; + end; + end; + end; + finally + ArgList1.Free; + ArgList2.Free; + TypeList1.Free; + TypeList2.Free; + end; +end; + +end. -- cgit v1.2.3