diff options
Diffstat (limited to '')
-rw-r--r-- | src/lib/TntUnicodeControls/TntClasses.pas | 3612 | ||||
-rw-r--r-- | 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. |