diff options
Diffstat (limited to '')
| -rw-r--r-- | src/lib/TntUnicodeControls/TntClasses.pas | 1799 | ||||
| -rw-r--r-- | src/lib/TntUnicodeControls/TntFormatStrUtils.pas | 521 | ||||
| -rw-r--r-- | src/lib/TntUnicodeControls/TntSysUtils.pas | 1753 | ||||
| -rw-r--r-- | src/lib/TntUnicodeControls/TntSystem.pas | 1427 | ||||
| -rw-r--r-- | src/lib/TntUnicodeControls/TntWideStrUtils.pas | 455 | ||||
| -rw-r--r-- | src/lib/TntUnicodeControls/TntWideStrings.pas | 846 | ||||
| -rw-r--r-- | src/lib/TntUnicodeControls/TntWindows.pas | 1501 |
7 files changed, 0 insertions, 8302 deletions
diff --git a/src/lib/TntUnicodeControls/TntClasses.pas b/src/lib/TntUnicodeControls/TntClasses.pas deleted file mode 100644 index be043421..00000000 --- a/src/lib/TntUnicodeControls/TntClasses.pas +++ /dev/null @@ -1,1799 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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; -begin - Temp := WideChar(GetOrdProp(FInstance, FPropInfo)); - - {$IFNDEF FPC} - TAccessWriter(Writer).WriteValue(vaWString); - {$ELSE} - TAccessWriter(Writer).Write(vaWString, 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 deleted file mode 100644 index c6b65082..00000000 --- a/src/lib/TntUnicodeControls/TntFormatStrUtils.pas +++ /dev/null @@ -1,521 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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('%', 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('%', 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('%', 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('%', 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. diff --git a/src/lib/TntUnicodeControls/TntSysUtils.pas b/src/lib/TntUnicodeControls/TntSysUtils.pas deleted file mode 100644 index b7cf2467..00000000 --- a/src/lib/TntUnicodeControls/TntSysUtils.pas +++ /dev/null @@ -1,1753 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 TntSysUtils; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -interface - -{ TODO: Consider: more filename functions from SysUtils } -{ TODO: Consider: string functions from StrUtils. } - -uses - Types, SysUtils, Windows, TntWindows; - -//--------------------------------------------------------------------------------------------- -// Tnt - Types -//--------------------------------------------------------------------------------------------- - -// ......... introduced ......... -type - // The user of the application did something plainly wrong. - ETntUserError = class(Exception); - // A general error occured. (ie. file didn't exist, server didn't return data, etc.) - ETntGeneralError = class(Exception); - // Like Assert(). An error occured that should never have happened, send me a bug report now! - ETntInternalError = class(Exception); - -{$IFNDEF FPC} -type - PtrInt = LongInt; - PtrUInt = LongWord; -{$ENDIF} - -//--------------------------------------------------------------------------------------------- -// Tnt - SysUtils -//--------------------------------------------------------------------------------------------- - -// ......... SBCS and MBCS functions with WideString replacements in SysUtils.pas ......... - -{TNT-WARN CompareStr} {TNT-WARN AnsiCompareStr} -{TNT-WARN SameStr} {TNT-WARN AnsiSameStr} -{TNT-WARN SameText} {TNT-WARN AnsiSameText} -{TNT-WARN CompareText} {TNT-WARN AnsiCompareText} -{TNT-WARN UpperCase} {TNT-WARN AnsiUpperCase} -{TNT-WARN LowerCase} {TNT-WARN AnsiLowerCase} - -{TNT-WARN AnsiPos} { --> Pos() supports WideString. } -{TNT-WARN FmtStr} -{TNT-WARN Format} -{TNT-WARN FormatBuf} - -// ......... MBCS Byte Type Procs ......... - -{TNT-WARN ByteType} -{TNT-WARN StrByteType} -{TNT-WARN ByteToCharIndex} -{TNT-WARN ByteToCharLen} -{TNT-WARN CharToByteIndex} -{TNT-WARN CharToByteLen} - -// ........ null-terminated string functions ......... - -{TNT-WARN StrEnd} -{TNT-WARN StrLen} -{TNT-WARN StrLCopy} -{TNT-WARN StrCopy} -{TNT-WARN StrECopy} -{TNT-WARN StrPLCopy} -{TNT-WARN StrPCopy} -{TNT-WARN StrLComp} -{TNT-WARN AnsiStrLComp} -{TNT-WARN StrComp} -{TNT-WARN AnsiStrComp} -{TNT-WARN StrLIComp} -{TNT-WARN AnsiStrLIComp} -{TNT-WARN StrIComp} -{TNT-WARN AnsiStrIComp} -{TNT-WARN StrLower} -{TNT-WARN AnsiStrLower} -{TNT-WARN StrUpper} -{TNT-WARN AnsiStrUpper} -{TNT-WARN StrPos} -{TNT-WARN AnsiStrPos} -{TNT-WARN StrScan} -{TNT-WARN AnsiStrScan} -{TNT-WARN StrRScan} -{TNT-WARN AnsiStrRScan} -{TNT-WARN StrLCat} -{TNT-WARN StrCat} -{TNT-WARN StrMove} -{TNT-WARN StrPas} -{TNT-WARN StrAlloc} -{TNT-WARN StrBufSize} -{TNT-WARN StrNew} -{TNT-WARN StrDispose} - -{TNT-WARN AnsiExtractQuotedStr} -{TNT-WARN AnsiLastChar} -{TNT-WARN AnsiStrLastChar} -{TNT-WARN QuotedStr} -{TNT-WARN AnsiQuotedStr} -{TNT-WARN AnsiDequotedStr} - -// ........ string functions ......... - -{$IFNDEF FPC} -{$IFNDEF COMPILER_9_UP} - // - // pre-Delphi 9 issues w/ WideFormatBuf, WideFmtStr and WideFormat - // - - {$IFDEF COMPILER_7_UP} - type - PFormatSettings = ^TFormatSettings; - {$ENDIF} - - // SysUtils.WideFormatBuf doesn't correctly handle numeric specifiers. - function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const): Cardinal; {$IFDEF COMPILER_7_UP} overload; {$ENDIF} - - {$IFDEF COMPILER_7_UP} - function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const; - const FormatSettings: TFormatSettings): Cardinal; overload; - {$ENDIF} - - // SysUtils.WideFmtStr doesn't handle string lengths > 4096. - procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const); {$IFDEF COMPILER_7_UP} overload; {$ENDIF} - - {$IFDEF COMPILER_7_UP} - procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const; const FormatSettings: TFormatSettings); overload; - {$ENDIF} - - {---------------------------------------------------------------------------------------- - Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary... - TntSystem.InstallTntSystemUpdates([tsFixWideFormat]); - will fix WideFormat as well as WideFmtStr. - ----------------------------------------------------------------------------------------} - function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString; {$IFDEF COMPILER_7_UP} overload; {$ENDIF} - - {$IFDEF COMPILER_7_UP} - function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const; - const FormatSettings: TFormatSettings): WideString; overload; - {$ENDIF} - -{$ENDIF} -{$ENDIF} - -{TNT-WARN WideUpperCase} // SysUtils.WideUpperCase is broken on Win9x for D6, D7, D9. -function Tnt_WideUpperCase(const S: WideString): WideString; -{TNT-WARN WideLowerCase} // SysUtils.WideLowerCase is broken on Win9x for D6, D7, D9. -function Tnt_WideLowerCase(const S: WideString): WideString; - -function TntWideLastChar(const S: WideString): WideChar; - -{TNT-WARN StringReplace} -{TNT-WARN WideStringReplace} // <-- WideStrUtils.WideStringReplace uses SysUtils.WideUpperCase which is broken on Win9x. -function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString; - Flags: TReplaceFlags; WholeWord: Boolean = False): WideString; - -{TNT-WARN AdjustLineBreaks} -type TTntTextLineBreakStyle = (tlbsLF, tlbsCRLF, tlbsCR); -function TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer; -function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString; - -{TNT-WARN WrapText} -function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet; - MaxCol: Integer): WideString; overload; -function WideWrapText(const Line: WideString; MaxCol: Integer): WideString; overload; - -// ........ filename manipulation ......... - -{TNT-WARN SameFileName} // doesn't apply to Unicode filenames, use WideSameText -{TNT-WARN AnsiCompareFileName} // doesn't apply to Unicode filenames, use WideCompareText -{TNT-WARN AnsiLowerCaseFileName} // doesn't apply to Unicode filenames, use WideLowerCase -{TNT-WARN AnsiUpperCaseFileName} // doesn't apply to Unicode filenames, use WideUpperCase - -{TNT-WARN IncludeTrailingBackslash} -function WideIncludeTrailingBackslash(const S: WideString): WideString; -{TNT-WARN IncludeTrailingPathDelimiter} -function WideIncludeTrailingPathDelimiter(const S: WideString): WideString; -{TNT-WARN ExcludeTrailingBackslash} -function WideExcludeTrailingBackslash(const S: WideString): WideString; -{TNT-WARN ExcludeTrailingPathDelimiter} -function WideExcludeTrailingPathDelimiter(const S: WideString): WideString; -{TNT-WARN IsDelimiter} -function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean; -{TNT-WARN IsPathDelimiter} -function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean; -{TNT-WARN LastDelimiter} -function WideLastDelimiter(const Delimiters, S: WideString): Integer; -{TNT-WARN ChangeFileExt} -function WideChangeFileExt(const FileName, Extension: WideString): WideString; -{TNT-WARN ExtractFilePath} -function WideExtractFilePath(const FileName: WideString): WideString; -{TNT-WARN ExtractFileDir} -function WideExtractFileDir(const FileName: WideString): WideString; -{TNT-WARN ExtractFileDrive} -function WideExtractFileDrive(const FileName: WideString): WideString; -{TNT-WARN ExtractFileName} -function WideExtractFileName(const FileName: WideString): WideString; -{TNT-WARN ExtractFileExt} -function WideExtractFileExt(const FileName: WideString): WideString; -{TNT-WARN ExtractRelativePath} -function WideExtractRelativePath(const BaseName, DestName: WideString): WideString; - -// ........ file management routines ......... - -{TNT-WARN ExpandFileName} -function WideExpandFileName(const FileName: WideString): WideString; -{TNT-WARN ExtractShortPathName} -function WideExtractShortPathName(const FileName: WideString): WideString; -{TNT-WARN FileCreate} -function WideFileCreate(const FileName: WideString): Integer; -{TNT-WARN FileOpen} -function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer; -{TNT-WARN FileAge} -function WideFileAge(const FileName: WideString): Integer; overload; -function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean; overload; -{TNT-WARN DirectoryExists} -function WideDirectoryExists(const Name: WideString): Boolean; -{TNT-WARN FileExists} -function WideFileExists(const Name: WideString): Boolean; -{TNT-WARN FileGetAttr} -function WideFileGetAttr(const FileName: WideString): Cardinal; -{TNT-WARN FileSetAttr} -function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean; -{TNT-WARN FileIsReadOnly} -function WideFileIsReadOnly(const FileName: WideString): Boolean; -{TNT-WARN FileSetReadOnly} -function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean; -{TNT-WARN ForceDirectories} -function WideForceDirectories(Dir: WideString): Boolean; -{TNT-WARN FileSearch} -function WideFileSearch(const Name, DirList: WideString): WideString; -{TNT-WARN RenameFile} -function WideRenameFile(const OldName, NewName: WideString): Boolean; -{TNT-WARN DeleteFile} -function WideDeleteFile(const FileName: WideString): Boolean; -{TNT-WARN CopyFile} -function WideCopyFile(const FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean; - - -{TNT-WARN TFileName} -type - TWideFileName = type WideString; - -{TNT-WARN TSearchRec} // <-- FindFile - warning on TSearchRec is all that is necessary -type - TSearchRecW = record - Time: Integer; - Size: Int64; - Attr: Integer; - Name: TWideFileName; - ExcludeAttr: Integer; - FindHandle: THandle; - FindData: TWin32FindDataW; - end; -function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer; -function WideFindNext(var F: TSearchRecW): Integer; -procedure WideFindClose(var F: TSearchRecW); - -{TNT-WARN CreateDir} -function WideCreateDir(const Dir: WideString): Boolean; -{TNT-WARN RemoveDir} -function WideRemoveDir(const Dir: WideString): Boolean; -{TNT-WARN GetCurrentDir} -function WideGetCurrentDir: WideString; -{TNT-WARN SetCurrentDir} -function WideSetCurrentDir(const Dir: WideString): Boolean; - - -// ........ date/time functions ......... - -{TNT-WARN TryStrToDateTime} -function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean; -{TNT-WARN TryStrToDate} -function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean; -{TNT-WARN TryStrToTime} -function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean; - -{ introduced } -function ValidDateTimeStr(Str: WideString): Boolean; -function ValidDateStr(Str: WideString): Boolean; -function ValidTimeStr(Str: WideString): Boolean; - -{TNT-WARN StrToDateTime} -function TntStrToDateTime(Str: WideString): TDateTime; -{TNT-WARN StrToDate} -function TntStrToDate(Str: WideString): TDateTime; -{TNT-WARN StrToTime} -function TntStrToTime(Str: WideString): TDateTime; -{TNT-WARN StrToDateTimeDef} -function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime; -{TNT-WARN StrToDateDef} -function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime; -{TNT-WARN StrToTimeDef} -function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime; - -{TNT-WARN CurrToStr} -{TNT-WARN CurrToStrF} -function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString; -{TNT-WARN StrToCurr} -function TntStrToCurr(const S: WideString): Currency; -{TNT-WARN StrToCurrDef} -function ValidCurrencyStr(const S: WideString): Boolean; -function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency; -function GetDefaultCurrencyFmt: TCurrencyFmtW; - -// ........ misc functions ......... - -{TNT-WARN GetLocaleStr} -function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString; -{TNT-WARN SysErrorMessage} -function WideSysErrorMessage(ErrorCode: Integer): WideString; - -// ......... introduced ......... - -function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString; - -const - CR = WideChar(#13); - LF = WideChar(#10); - CRLF = WideString(#13#10); - WideLineSeparator = WideChar($2028); - -var - Win32PlatformIsUnicode: Boolean; - Win32PlatformIsXP: Boolean; - Win32PlatformIs2003: Boolean; - Win32PlatformIsVista: Boolean; - -{$IFNDEF FPC} -{$IFNDEF COMPILER_7_UP} -function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; -{$ENDIF} -{$ENDIF} -function WinCheckH(RetVal: Cardinal): Cardinal; -function WinCheckFileH(RetVal: Cardinal): Cardinal; -function WinCheckP(RetVal: Pointer): Pointer; - -function WideGetModuleFileName(Instance: HModule): WideString; -function WideSafeLoadLibrary(const Filename: Widestring; - ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE; -{$IFNDEF FPC} -function WideLoadPackage(const Name: Widestring): HMODULE; -{$ENDIF} - -function IsWideCharUpper(WC: WideChar): Boolean; -function IsWideCharLower(WC: WideChar): Boolean; -function IsWideCharDigit(WC: WideChar): Boolean; -function IsWideCharSpace(WC: WideChar): Boolean; -function IsWideCharPunct(WC: WideChar): Boolean; -function IsWideCharCntrl(WC: WideChar): Boolean; -function IsWideCharBlank(WC: WideChar): Boolean; -function IsWideCharXDigit(WC: WideChar): Boolean; -function IsWideCharAlpha(WC: WideChar): Boolean; -function IsWideCharAlphaNumeric(WC: WideChar): Boolean; - -function WideTextPos(const SubStr, S: WideString): Integer; - -function ExtractStringArrayStr(P: PWideChar): WideString; -function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString; -function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray; - -function IsWideCharMappableToAnsi(const WC: WideChar): Boolean; -function IsWideStringMappableToAnsi(const WS: WideString): Boolean; -function IsRTF(const Value: WideString): Boolean; - -function ENG_US_FloatToStr(Value: Extended): WideString; -function ENG_US_StrToFloat(const S: WideString): Extended; - -//--------------------------------------------------------------------------------------------- -// Tnt - Variants -//--------------------------------------------------------------------------------------------- - -// ........ Variants.pas has WideString versions of these functions ......... -{TNT-WARN VarToStr} -{TNT-WARN VarToStrDef} - -var - _SettingChangeTime: Cardinal; - -implementation - -uses - ActiveX, ComObj, SysConst, - {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils, - TntSystem, TntFormatStrUtils; - -//--------------------------------------------------------------------------------------------- -// Tnt - SysUtils -//--------------------------------------------------------------------------------------------- - -{$IFNDEF FPC} -{$IFNDEF COMPILER_9_UP} - - function _Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const - {$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings {$ENDIF}): Cardinal; - var - OldFormat: WideString; - NewFormat: WideString; - begin - SetString(OldFormat, PWideChar(@FormatStr), FmtLen); - { The reason for this is that WideFormat doesn't correctly format floating point specifiers. - See QC#4254. } - NewFormat := ReplaceFloatingArgumentsInFormatString(OldFormat, Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}); - {$IFDEF COMPILER_7_UP} - if FormatSettings <> nil then - Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^, - Length(NewFormat), Args, FormatSettings^) - else - {$ENDIF} - Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^, - Length(NewFormat), Args); - end; - - function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const): Cardinal; - begin - Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF}); - end; - - {$IFDEF COMPILER_7_UP} - function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const; const FormatSettings: TFormatSettings): Cardinal; - begin - Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args, @FormatSettings); - end; - {$ENDIF} - - procedure _Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const{$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings{$ENDIF}); - var - Len, BufLen: Integer; - Buffer: array[0..4095] of WideChar; - begin - BufLen := Length(Buffer); // Fixes buffer overwrite issue. (See QC #4703, #4744) - if Length(FormatStr) < (Length(Buffer) - (Length(Buffer) div 4)) then - Len := _Tnt_WideFormatBuf(Buffer, Length(Buffer) - 1, Pointer(FormatStr)^, - Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}) - else - begin - BufLen := Length(FormatStr); - Len := BufLen; - end; - if Len >= BufLen - 1 then - begin - while Len >= BufLen - 1 do - begin - Inc(BufLen, BufLen); - Result := ''; // prevent copying of existing data, for speed - SetLength(Result, BufLen); - Len := _Tnt_WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(FormatStr)^, - Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}); - end; - SetLength(Result, Len); - end - else - SetString(Result, Buffer, Len); - end; - - procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const); - begin - _Tnt_WideFmtStr(Result, FormatStr, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF}); - end; - - {$IFDEF COMPILER_7_UP} - procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const; const FormatSettings: TFormatSettings); - begin - _Tnt_WideFmtStr(Result, FormatStr, Args, @FormatSettings); - end; - {$ENDIF} - - {---------------------------------------------------------------------------------------- - Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary... - TntSystem.InstallTntSystemUpdates([tsFixWideFormat]); - will fix WideFormat as well as WideFmtStr. - ----------------------------------------------------------------------------------------} - function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString; - begin - Tnt_WideFmtStr(Result, FormatStr, Args); - end; - - {$IFDEF COMPILER_7_UP} - function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const; - const FormatSettings: TFormatSettings): WideString; - begin - Tnt_WideFmtStr(Result, FormatStr, Args, FormatSettings); - end; - {$ENDIF} - -{$ENDIF} -{$ENDIF FPC} - -function Tnt_WideUpperCase(const S: WideString): WideString; -begin - {$IFNDEF FPC} - {$IFNDEF COMPILER_10_UP} - {$DEFINE WIDEUPPERCASE_BROKEN} - {$ENDIF} - {$ENDIF} - {$IFDEF WIDEUPPERCASE_BROKEN} - { SysUtils.WideUpperCase is broken for Win9x. } - Result := S; - if Length(Result) > 0 then - Tnt_CharUpperBuffW(PWideChar(Result), Length(Result)); - {$ELSE} - Result := SysUtils.WideUpperCase{TNT-ALLOW WideUpperCase}(S); - {$ENDIF} -end; - -function Tnt_WideLowerCase(const S: WideString): WideString; -begin - {$IFNDEF FPC} - {$IFNDEF COMPILER_10_UP} - {$DEFINE WIDELOWERCASE_BROKEN} - {$ENDIF} - {$ENDIF} - {$IFDEF WIDELOWERCASE_BROKEN} - { SysUtils.WideLowerCase is broken for Win9x. } - Result := S; - if Length(Result) > 0 then - Tnt_CharLowerBuffW(PWideChar(Result), Length(Result)); - {$ELSE} - Result := SysUtils.WideLowerCase{TNT-ALLOW WideLowerCase}(S); - {$ENDIF} -end; - -function TntWideLastChar(const S: WideString): WideChar; -var - P: PWideChar; -begin - P := WideLastChar(S); - if P = nil then - Result := #0 - else - Result := P^; -end; - -function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString; - Flags: TReplaceFlags; WholeWord: Boolean = False): WideString; - - function IsWordSeparator(WC: WideChar): Boolean; - begin - Result := (WC = WideChar(#0)) - or IsWideCharSpace(WC) - or IsWideCharPunct(WC); - end; - -var - SearchStr, Patt, NewStr: WideString; - Offset: Integer; - PrevChar, NextChar: WideChar; -begin - if rfIgnoreCase in Flags then - begin - SearchStr := Tnt_WideUpperCase(S); - Patt := Tnt_WideUpperCase(OldPattern); - end else - begin - SearchStr := S; - Patt := OldPattern; - end; - NewStr := S; - Result := ''; - while SearchStr <> '' do - begin - Offset := Pos(Patt, SearchStr); - if Offset = 0 then - begin - Result := Result + NewStr; - Break; - end; // done - - if (WholeWord) then - begin - if (Offset = 1) then - PrevChar := TntWideLastChar(Result) - else - PrevChar := NewStr[Offset - 1]; - - if Offset + Length(OldPattern) <= Length(NewStr) then - NextChar := NewStr[Offset + Length(OldPattern)] - else - NextChar := WideChar(#0); - - if (not IsWordSeparator(PrevChar)) - or (not IsWordSeparator(NextChar)) then - begin - Result := Result + Copy(NewStr, 1, Offset + Length(OldPattern) - 1); - NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); - SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt); - continue; - end; - end; - - Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern; - NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); - if not (rfReplaceAll in Flags) then - begin - Result := Result + NewStr; - Break; - end; - SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt); - end; -end; - -function TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer; -var - Source, SourceEnd: PWideChar; -begin - Source := Pointer(S); - SourceEnd := Source + Length(S); - Result := Length(S); - while Source < SourceEnd do - begin - case Source^ of - #10, WideLineSeparator: - if Style = tlbsCRLF then - Inc(Result); - #13: - if Style = tlbsCRLF then - if Source[1] = #10 then - Inc(Source) - else - Inc(Result) - else - if Source[1] = #10 then - Dec(Result); - end; - Inc(Source); - end; -end; - -function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString; -var - Source, SourceEnd, Dest: PWideChar; - DestLen: Integer; -begin - Source := Pointer(S); - SourceEnd := Source + Length(S); - DestLen := TntAdjustLineBreaksLength(S, Style); - SetString(Result, nil, DestLen); - Dest := Pointer(Result); - while Source < SourceEnd do begin - case Source^ of - #10, WideLineSeparator: - begin - if Style in [tlbsCRLF, tlbsCR] then - begin - Dest^ := #13; - Inc(Dest); - end; - if Style in [tlbsCRLF, tlbsLF] then - begin - Dest^ := #10; - Inc(Dest); - end; - Inc(Source); - end; - #13: - begin - if Style in [tlbsCRLF, tlbsCR] then - begin - Dest^ := #13; - Inc(Dest); - end; - if Style in [tlbsCRLF, tlbsLF] then - begin - Dest^ := #10; - Inc(Dest); - end; - Inc(Source); - if Source^ = #10 then Inc(Source); - end; - else - Dest^ := Source^; - Inc(Dest); - Inc(Source); - end; - end; -end; - -function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet; - MaxCol: Integer): WideString; - - function WideCharIn(C: WideChar; SysCharSet: TSysCharSet): Boolean; - begin - Result := (C <= High(AnsiChar)) and (AnsiChar(C) in SysCharSet); - end; - -const - QuoteChars = ['''', '"']; -var - Col, Pos: Integer; - LinePos, LineLen: Integer; - BreakLen, BreakPos: Integer; - QuoteChar, CurChar: WideChar; - ExistingBreak: Boolean; -begin - Col := 1; - Pos := 1; - LinePos := 1; - BreakPos := 0; - QuoteChar := ' '; - ExistingBreak := False; - LineLen := Length(Line); - BreakLen := Length(BreakStr); - Result := ''; - while Pos <= LineLen do - begin - CurChar := Line[Pos]; - if CurChar = BreakStr[1] then - begin - if QuoteChar = ' ' then - begin - ExistingBreak := WideSameText(BreakStr, Copy(Line, Pos, BreakLen)); - if ExistingBreak then - begin - Inc(Pos, BreakLen-1); - BreakPos := Pos; - end; - end - end - else if WideCharIn(CurChar, BreakChars) then - begin - if QuoteChar = ' ' then BreakPos := Pos - end - else if WideCharIn(CurChar, QuoteChars) then - begin - if CurChar = QuoteChar then - QuoteChar := ' ' - else if QuoteChar = ' ' then - QuoteChar := CurChar; - end; - Inc(Pos); - Inc(Col); - if not (WideCharIn(QuoteChar, QuoteChars)) and (ExistingBreak or - ((Col > MaxCol) and (BreakPos > LinePos))) then - begin - Col := Pos - BreakPos; - Result := Result + Copy(Line, LinePos, BreakPos - LinePos + 1); - if not (WideCharIn(CurChar, QuoteChars)) then - while Pos <= LineLen do - begin - if WideCharIn(Line[Pos], BreakChars) then - Inc(Pos) - else if Copy(Line, Pos, Length(sLineBreak)) = sLineBreak then - Inc(Pos, Length(sLineBreak)) - else - break; - end; - if not ExistingBreak and (Pos < LineLen) then - Result := Result + BreakStr; - Inc(BreakPos); - LinePos := BreakPos; - ExistingBreak := False; - end; - end; - Result := Result + Copy(Line, LinePos, MaxInt); -end; - -function WideWrapText(const Line: WideString; MaxCol: Integer): WideString; -begin - Result := WideWrapText(Line, sLineBreak, [' ', '-', #9], MaxCol); { do not localize } -end; - -function WideIncludeTrailingBackslash(const S: WideString): WideString; -begin - Result := WideIncludeTrailingPathDelimiter(S); -end; - -function WideIncludeTrailingPathDelimiter(const S: WideString): WideString; -begin - Result := S; - if not WideIsPathDelimiter(Result, Length(Result)) then Result := Result + PathDelim; -end; - -function WideExcludeTrailingBackslash(const S: WideString): WideString; -begin - Result := WideExcludeTrailingPathDelimiter(S); -end; - -function WideExcludeTrailingPathDelimiter(const S: WideString): WideString; -begin - Result := S; - if WideIsPathDelimiter(Result, Length(Result)) then - SetLength(Result, Length(Result)-1); -end; - -function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean; -begin - Result := False; - if (Index <= 0) or (Index > Length(S)) then exit; - Result := WStrScan(PWideChar(Delimiters), S[Index]) <> nil; -end; - -function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean; -begin - Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = PathDelim); -end; - -function WideLastDelimiter(const Delimiters, S: WideString): Integer; -var - P: PWideChar; -begin - Result := Length(S); - P := PWideChar(Delimiters); - while Result > 0 do - begin - if (S[Result] <> #0) and (WStrScan(P, S[Result]) <> nil) then - Exit; - Dec(Result); - end; -end; - -function WideChangeFileExt(const FileName, Extension: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter('.\:',Filename); - if (I = 0) or (FileName[I] <> '.') then I := MaxInt; - Result := Copy(FileName, 1, I - 1) + Extension; -end; - -function WideExtractFilePath(const FileName: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter('\:', FileName); - Result := Copy(FileName, 1, I); -end; - -function WideExtractFileDir(const FileName: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter(DriveDelim + PathDelim,Filename); - if (I > 1) and (FileName[I] = PathDelim) and - (not (FileName[I - 1] in [WideChar(PathDelim), WideChar(DriveDelim)])) then Dec(I); - Result := Copy(FileName, 1, I); -end; - -function WideExtractFileDrive(const FileName: WideString): WideString; -var - I, J: Integer; -begin - if (Length(FileName) >= 2) and (FileName[2] = DriveDelim) then - Result := Copy(FileName, 1, 2) - else if (Length(FileName) >= 2) and (FileName[1] = PathDelim) and - (FileName[2] = PathDelim) then - begin - J := 0; - I := 3; - While (I < Length(FileName)) and (J < 2) do - begin - if FileName[I] = PathDelim then Inc(J); - if J < 2 then Inc(I); - end; - if FileName[I] = PathDelim then Dec(I); - Result := Copy(FileName, 1, I); - end else Result := ''; -end; - -function WideExtractFileName(const FileName: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter('\:', FileName); - Result := Copy(FileName, I + 1, MaxInt); -end; - -function WideExtractFileExt(const FileName: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter('.\:', FileName); - if (I > 0) and (FileName[I] = '.') then - Result := Copy(FileName, I, MaxInt) else - Result := ''; -end; - -function WideExtractRelativePath(const BaseName, DestName: WideString): WideString; -var - BasePath, DestPath: WideString; - BaseLead, DestLead: PWideChar; - BasePtr, DestPtr: PWideChar; - - function WideExtractFilePathNoDrive(const FileName: WideString): WideString; - begin - Result := WideExtractFilePath(FileName); - Delete(Result, 1, Length(WideExtractFileDrive(FileName))); - end; - - function Next(var Lead: PWideChar): PWideChar; - begin - Result := Lead; - if Result = nil then Exit; - Lead := WStrScan(Lead, PathDelim); - if Lead <> nil then - begin - Lead^ := #0; - Inc(Lead); - end; - end; - -begin - if WideSameText(WideExtractFileDrive(BaseName), WideExtractFileDrive(DestName)) then - begin - BasePath := WideExtractFilePathNoDrive(BaseName); - DestPath := WideExtractFilePathNoDrive(DestName); - BaseLead := Pointer(BasePath); - BasePtr := Next(BaseLead); - DestLead := Pointer(DestPath); - DestPtr := Next(DestLead); - while (BasePtr <> nil) and (DestPtr <> nil) and WideSameText(BasePtr, DestPtr) do - begin - BasePtr := Next(BaseLead); - DestPtr := Next(DestLead); - end; - Result := ''; - while BaseLead <> nil do - begin - Result := Result + '..' + PathDelim; { Do not localize } - Next(BaseLead); - end; - if (DestPtr <> nil) and (DestPtr^ <> #0) then - Result := Result + DestPtr + PathDelim; - if DestLead <> nil then - Result := Result + DestLead; // destlead already has a trailing backslash - Result := Result + WideExtractFileName(DestName); - end - else - Result := DestName; -end; - -function WideExpandFileName(const FileName: WideString): WideString; -var - FName: PWideChar; - Buffer: array[0..MAX_PATH - 1] of WideChar; -begin - SetString(Result, Buffer, Tnt_GetFullPathNameW(PWideChar(FileName), MAX_PATH, Buffer, FName)); -end; - -function WideExtractShortPathName(const FileName: WideString): WideString; -var - Buffer: array[0..MAX_PATH - 1] of WideChar; -begin - SetString(Result, Buffer, Tnt_GetShortPathNameW(PWideChar(FileName), Buffer, MAX_PATH)); -end; - -function WideFileCreate(const FileName: WideString): Integer; -begin - Result := Integer(Tnt_CreateFileW(PWideChar(FileName), GENERIC_READ or GENERIC_WRITE, - 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)) -end; - -function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer; -const - AccessMode: array[0..2] of LongWord = ( - GENERIC_READ, - GENERIC_WRITE, - GENERIC_READ or GENERIC_WRITE); - ShareMode: array[0..4] of LongWord = ( - 0, - 0, - FILE_SHARE_READ, - FILE_SHARE_WRITE, - FILE_SHARE_READ or FILE_SHARE_WRITE); -begin - Result := Integer(Tnt_CreateFileW(PWideChar(FileName), AccessMode[Mode and 3], - ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING, - FILE_ATTRIBUTE_NORMAL, 0)); -end; - -function WideFileAge(const FileName: WideString): Integer; -var - Handle: THandle; - FindData: TWin32FindDataW; - LocalFileTime: TFileTime; -begin - Handle := Tnt_FindFirstFileW(PWideChar(FileName), FindData); - if Handle <> INVALID_HANDLE_VALUE then - begin - Windows.FindClose(Handle); - if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then - begin - FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); - if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi, LongRec(Result).Lo) then - Exit - end; - end; - Result := -1; -end; - -function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean; -var - Handle: THandle; - FindData: TWin32FindDataW; - LSystemTime: TSystemTime; - LocalFileTime: TFileTime; -begin - Result := False; - Handle := Tnt_FindFirstFileW(PWideChar(FileName), FindData); - if Handle <> INVALID_HANDLE_VALUE then - begin - Windows.FindClose(Handle); - if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then - begin - Result := True; - FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); - FileTimeToSystemTime(LocalFileTime, LSystemTime); - with LSystemTime do - FileDateTime := EncodeDate(wYear, wMonth, wDay) + - EncodeTime(wHour, wMinute, wSecond, wMilliSeconds); - end; - end; -end; - -function WideDirectoryExists(const Name: WideString): Boolean; -var - Code: Cardinal; -begin - Code := WideFileGetAttr(Name); - Result := (Code <> INVALID_FILE_ATTRIBUTES) and ((FILE_ATTRIBUTE_DIRECTORY and Code) <> 0); -end; - -function WideFileExists(const Name: WideString): Boolean; -var - Code: Cardinal; -begin - Code := WideFileGetAttr(Name); - Result := (Code <> INVALID_FILE_ATTRIBUTES) and ((FILE_ATTRIBUTE_DIRECTORY and Code) = 0); -end; - -function WideFileGetAttr(const FileName: WideString): Cardinal; -begin - Result := Tnt_GetFileAttributesW(PWideChar(FileName)); -end; - -function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean; -begin - Result := Tnt_SetFileAttributesW(PWideChar(FileName), Attr) -end; - -function WideFileIsReadOnly(const FileName: WideString): Boolean; -begin - Result := (Tnt_GetFileAttributesW(PWideChar(FileName)) and faReadOnly) <> 0; -end; - -function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean; -var - Flags: Integer; -begin - Result := False; - Flags := Tnt_GetFileAttributesW(PWideChar(FileName)); - if Flags = -1 then Exit; - if ReadOnly then - Flags := Flags or faReadOnly - else - Flags := Flags and not faReadOnly; - Result := Tnt_SetFileAttributesW(PWideChar(FileName), Flags); -end; - -function WideForceDirectories(Dir: WideString): Boolean; -begin - Result := True; - if Length(Dir) = 0 then - raise ETntGeneralError.Create( - {$IFNDEF FPC} SCannotCreateDir {$ELSE} SCannotCreateEmptyDir {$ENDIF}); - Dir := WideExcludeTrailingBackslash(Dir); - if (Length(Dir) < 3) or WideDirectoryExists(Dir) - or (WideExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem. - Result := WideForceDirectories(WideExtractFilePath(Dir)); - if Result then - Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil) -end; - -function WideFileSearch(const Name, DirList: WideString): WideString; -var - I, P, L: Integer; - C: WideChar; -begin - Result := Name; - P := 1; - L := Length(DirList); - while True do - begin - if WideFileExists(Result) then Exit; - while (P <= L) and (DirList[P] = PathSep) do Inc(P); - if P > L then Break; - I := P; - while (P <= L) and (DirList[P] <> PathSep) do - Inc(P); - Result := Copy(DirList, I, P - I); - C := TntWideLastChar(Result); - if (C <> DriveDelim) and (C <> PathDelim) then - Result := Result + PathDelim; - Result := Result + Name; - end; - Result := ''; -end; - -function WideRenameFile(const OldName, NewName: WideString): Boolean; -begin - Result := Tnt_MoveFileW(PWideChar(OldName), PWideChar(NewName)) -end; - -function WideDeleteFile(const FileName: WideString): Boolean; -begin - Result := Tnt_DeleteFileW(PWideChar(FileName)) -end; - -function WideCopyFile(const FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean; -begin - Result := Tnt_CopyFileW(PWideChar(FromFile), PWideChar(ToFile), FailIfExists) -end; - -function _WideFindMatchingFile(var F: TSearchRecW): Integer; -var - LocalFileTime: TFileTime; -begin - with F do - begin - while FindData.dwFileAttributes and ExcludeAttr <> 0 do - if not Tnt_FindNextFileW(FindHandle, FindData) then - begin - Result := GetLastError; - Exit; - end; - FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); - FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo); - Size := (Int64(FindData.nFileSizeHigh) shl 32) + FindData.nFileSizeLow; - Attr := FindData.dwFileAttributes; - Name := FindData.cFileName; - end; - Result := 0; -end; - -function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer; -const - faSpecial = faHidden or faSysFile {$IFNDEF COMPILER_9_UP} or faVolumeID {$ENDIF} or faDirectory; -begin - F.ExcludeAttr := not Attr and faSpecial; - F.FindHandle := Tnt_FindFirstFileW(PWideChar(Path), F.FindData); - if F.FindHandle <> INVALID_HANDLE_VALUE then - begin - Result := _WideFindMatchingFile(F); - if Result <> 0 then WideFindClose(F); - end else - Result := GetLastError; -end; - -function WideFindNext(var F: TSearchRecW): Integer; -begin - if Tnt_FindNextFileW(F.FindHandle, F.FindData) then - Result := _WideFindMatchingFile(F) else - Result := GetLastError; -end; - -procedure WideFindClose(var F: TSearchRecW); -begin - if F.FindHandle <> INVALID_HANDLE_VALUE then - begin - Windows.FindClose(F.FindHandle); - F.FindHandle := INVALID_HANDLE_VALUE; - end; -end; - -function WideCreateDir(const Dir: WideString): Boolean; -begin - Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil); -end; - -function WideRemoveDir(const Dir: WideString): Boolean; -begin - Result := Tnt_RemoveDirectoryW(PWideChar(Dir)); -end; - -function WideGetCurrentDir: WideString; -begin - SetLength(Result, MAX_PATH); - Tnt_GetCurrentDirectoryW(MAX_PATH, PWideChar(Result)); - Result := PWideChar(Result); -end; - -function WideSetCurrentDir(const Dir: WideString): Boolean; -begin - Result := Tnt_SetCurrentDirectoryW(PWideChar(Dir)); -end; - -//============================================================================================= -//== DATE/TIME STRING PARSING ================================================================ -//============================================================================================= - -{$IFDEF FPC} -const - VAR_TIMEVALUEONLY = 1; - VAR_DATEVALUEONLY = 2; -{$ENDIF} - -function _IntTryStrToDateTime(Str: WideString; Flags: Integer; out DateTime: TDateTime): HResult; -begin - Result := VarDateFromStr( - {$IFDEF FPC} POLECHAR(Str) {$ELSE} Str {$ENDIF}, - GetThreadLocale, Flags, Double(DateTime)); - if (not Succeeded(Result)) then begin - if (Flags = VAR_TIMEVALUEONLY) - and SysUtils.TryStrToTime{TNT-ALLOW TryStrToTime}(Str, DateTime) then - Result := S_OK // SysUtils seems confident (works for date = "dd.MM.yy" and time = "H.mm.ss") - else if (Flags = VAR_DATEVALUEONLY) - and SysUtils.TryStrToDate{TNT-ALLOW TryStrToDate}(Str, DateTime) then - Result := S_OK // SysUtils seems confident - else if (Flags = 0) - and SysUtils.TryStrToDateTime{TNT-ALLOW TryStrToDateTime}(Str, DateTime) then - Result := S_OK // SysUtils seems confident - end; -end; - -function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, 0, DateTime)); -end; - -function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, DateTime)); -end; - -function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, DateTime)); -end; - -function ValidDateTimeStr(Str: WideString): Boolean; -var - Temp: TDateTime; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, 0, Temp)); -end; - -function ValidDateStr(Str: WideString): Boolean; -var - Temp: TDateTime; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, Temp)); -end; - -function ValidTimeStr(Str: WideString): Boolean; -var - Temp: TDateTime; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, Temp)); -end; - -function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime; -begin - if not TntTryStrToDateTime(Str, Result) then - Result := Default; -end; - -function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime; -begin - if not TntTryStrToDate(Str, Result) then - Result := Default; -end; - -function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime; -begin - if not TntTryStrToTime(Str, Result) then - Result := Default; -end; - -function _IntStrToDateTime(Str: WideString; Flags: Integer; ErrorFormatStr: WideString): TDateTime; -begin - try - OleCheck(_IntTryStrToDateTime(Str, Flags, Result)); - except - on E: Exception do begin - E.Message := E.Message + CRLF + WideFormat(ErrorFormatStr, [Str]); - raise EConvertError.Create(E.Message); - end; - end; -end; - -function TntStrToDateTime(Str: WideString): TDateTime; -begin - Result := _IntStrToDateTime(Str, 0, SInvalidDateTime); -end; - -function TntStrToDate(Str: WideString): TDateTime; -begin - Result := _IntStrToDateTime(Str, VAR_DATEVALUEONLY, - {$IFNDEF FPC} SInvalidDate {$ELSE} SInvalidDateTime {$ENDIF}); -end; - -function TntStrToTime(Str: WideString): TDateTime; -begin - Result := _IntStrToDateTime(Str, VAR_TIMEVALUEONLY, - {$IFNDEF FPC} SInvalidTime {$ELSE} SInvalidDateTime {$ENDIF}); -end; - -//============================================================================================= -//== CURRENCY STRING PARSING ================================================================= -//============================================================================================= - -function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString; -const - MAX_BUFF_SIZE = 64; // can a currency string actually be larger? -var - ValueStr: WideString; -begin - // format lpValue using ENG-US settings - ValueStr := ENG_US_FloatToStr(Value); - // get currency format - SetLength(Result, MAX_BUFF_SIZE); - if 0 = Tnt_GetCurrencyFormatW(GetThreadLocale, 0, PWideChar(ValueStr), - lpFormat, PWideChar(Result), Length(Result)) - then begin - RaiseLastOSError; - end; - Result := PWideChar(Result); -end; - -function TntStrToCurr(const S: WideString): Currency; -begin - try - OleCheck(VarCyFromStr( - {$IFDEF FPC} POLECHAR(S) {$ELSE} S {$ENDIF}, - GetThreadLocale, 0, Result)); - except - on E: Exception do begin - E.Message := E.Message + CRLF + WideFormat(SInvalidCurrency, [S]); - raise EConvertError.Create(E.Message); - end; - end; -end; - -function ValidCurrencyStr(const S: WideString): Boolean; -var - Dummy: Currency; -begin - Result := Succeeded(VarCyFromStr( - {$IFDEF FPC} POLECHAR(S) {$ELSE} S {$ENDIF}, - GetThreadLocale, 0, Dummy)); -end; - -function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency; -begin - if not Succeeded(VarCyFromStr( - {$IFDEF FPC} POLECHAR(S) {$ELSE} S {$ENDIF}, - GetThreadLocale, 0, Result)) then - Result := Default; -end; - -threadvar - Currency_DecimalSep: WideString; - Currency_ThousandSep: WideString; - Currency_CurrencySymbol: WideString; - -function GetDefaultCurrencyFmt: TCurrencyFmtW; -begin - ZeroMemory(@Result, SizeOf(Result)); - Result.NumDigits := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRDIGITS, '2'), 2); - Result.LeadingZero := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ILZERO, '1'), 1); - Result.Grouping := StrToIntDef(Copy(WideGetLocaleStr(GetThreadLocale, LOCALE_SMONGROUPING, '3;0'), 1, 1), 3); - Currency_DecimalSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONDECIMALSEP, '.'); - Result.lpDecimalSep := {$IFNDEF FPC} PWideChar(Currency_DecimalSep) - {$ELSE} LPTSTR(PWideChar(Currency_DecimalSep)) {$ENDIF}; - Currency_ThousandSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONTHOUSANDSEP, ','); - Result.lpThousandSep := {$IFNDEF FPC} PWideChar(Currency_ThousandSep) - {$ELSE} LPTSTR(PWideChar(Currency_ThousandSep)) {$ENDIF}; - Result.NegativeOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_INEGCURR, '0'), 0); - Result.PositiveOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRENCY, '0'), 0); - Currency_CurrencySymbol := WideGetLocaleStr(GetThreadLocale, LOCALE_SCURRENCY, ''); - Result.lpCurrencySymbol := {$IFNDEF FPC} PWideChar(Currency_CurrencySymbol) - {$ELSE} LPTSTR(PWideChar(Currency_CurrencySymbol)) {$ENDIF}; -end; - -//============================================================================================= - -{$IFDEF FPC} -function GetLocaleStr(Locale, LocaleType: Integer; const Default: string): string; -var - L: Integer; - Buffer: array[0..255] of Char; -begin - L := GetLocaleInfo(Locale, LocaleType, Buffer, SizeOf(Buffer)); - if L > 0 then SetString(Result, Buffer, L - 1) else Result := Default; -end; -{$ENDIF} - -function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString; -var - L: Integer; -begin - if (not Win32PlatformIsUnicode) then - Result := GetLocaleStr{TNT-ALLOW GetLocaleStr}(LocaleID, LocaleType, Default) - else begin - SetLength(Result, 255); - L := GetLocaleInfoW(LocaleID, LocaleType, PWideChar(Result), Length(Result)); - if L > 0 then - SetLength(Result, L - 1) - else - Result := Default; - end; -end; - -function WideSysErrorMessage(ErrorCode: Integer): WideString; -begin - Result := WideLibraryErrorMessage('system', 0, ErrorCode); -end; - -function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString; -var - Len: Integer; - AnsiResult: AnsiString; - Flags: Cardinal; -begin - Flags := FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY; - if Dll <> 0 then - Flags := Flags or FORMAT_MESSAGE_FROM_HMODULE; - if Win32PlatformIsUnicode then begin - SetLength(Result, 256); - Len := FormatMessageW(Flags, Pointer(Dll), ErrorCode, 0, PWideChar(Result), Length(Result), nil); - SetLength(Result, Len); - end else begin - SetLength(AnsiResult, 256); - Len := FormatMessageA(Flags, Pointer(Dll), ErrorCode, 0, PAnsiChar(AnsiResult), Length(AnsiResult), nil); - SetLength(AnsiResult, Len); - Result := AnsiResult; - end; - if Trim(Result) = '' then - Result := WideFormat('Unspecified error (%d) from %s.', [ErrorCode, LibName]); -end; - -{$IFNDEF COMPILER_7_UP} -function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; -begin - Result := (Win32MajorVersion > AMajor) or - ((Win32MajorVersion = AMajor) and - (Win32MinorVersion >= AMinor)); -end; -{$ENDIF} - -function WinCheckH(RetVal: Cardinal): Cardinal; -begin - if RetVal = 0 then RaiseLastOSError; - Result := RetVal; -end; - -function WinCheckFileH(RetVal: Cardinal): Cardinal; -begin - if RetVal = INVALID_HANDLE_VALUE then RaiseLastOSError; - Result := RetVal; -end; - -function WinCheckP(RetVal: Pointer): Pointer; -begin - if RetVal = nil then RaiseLastOSError; - Result := RetVal; -end; - -function WideGetModuleFileName(Instance: HModule): WideString; -begin - SetLength(Result, MAX_PATH); - WinCheckH(Tnt_GetModuleFileNameW(Instance, PWideChar(Result), Length(Result))); - Result := PWideChar(Result) -end; - -function WideSafeLoadLibrary(const Filename: Widestring; ErrorMode: UINT): HMODULE; -var - OldMode: UINT; - FPUControlWord: Word; -begin - OldMode := SetErrorMode(ErrorMode); - try - asm - FNSTCW FPUControlWord - end; - try - Result := Tnt_LoadLibraryW(PWideChar(Filename)); - finally - asm - FNCLEX - FLDCW FPUControlWord - end; - end; - finally - SetErrorMode(OldMode); - end; -end; - -{$IFNDEF FPC} -function WideLoadPackage(const Name: Widestring): HMODULE; -begin - Result := WideSafeLoadLibrary(Name); - if Result = 0 then - begin - raise EPackageError.CreateFmt(sErrorLoadingPackage, [Name, WideSysErrorMessage(GetLastError)]); - end; - try - InitializePackage(Result); - except - FreeLibrary(Result); - raise; - end; -end; -{$ENDIF} - -function _WideCharType(WC: WideChar; dwInfoType: Cardinal): Word; -begin - Win32Check(Tnt_GetStringTypeExW(GetThreadLocale, dwInfoType, PWideChar(@WC), 1, Result)) -end; - -function IsWideCharUpper(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_UPPER) <> 0; -end; - -function IsWideCharLower(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_LOWER) <> 0; -end; - -function IsWideCharDigit(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_DIGIT) <> 0; -end; - -function IsWideCharSpace(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_SPACE) <> 0; -end; - -function IsWideCharPunct(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_PUNCT) <> 0; -end; - -function IsWideCharCntrl(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_CNTRL) <> 0; -end; - -function IsWideCharBlank(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_BLANK) <> 0; -end; - -function IsWideCharXDigit(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_XDIGIT) <> 0; -end; - -function IsWideCharAlpha(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_ALPHA) <> 0; -end; - -function IsWideCharAlphaNumeric(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and (C1_ALPHA + C1_DIGIT)) <> 0; -end; - -function WideTextPos(const SubStr, S: WideString): Integer; -begin - Result := Pos(Tnt_WideUpperCase(SubStr), Tnt_WideUpperCase(S)); -end; - -function FindDoubleTerminator(P: PWideChar): PWideChar; -begin - Result := P; - while True do begin - Result := WStrScan(Result, #0); - Inc(Result); - if Result^ = #0 then begin - Dec(Result); - break; - end; - end; -end; - -function ExtractStringArrayStr(P: PWideChar): WideString; -var - PEnd: PWideChar; -begin - PEnd := FindDoubleTerminator(P); - Inc(PEnd, 2); // move past #0#0 - SetString(Result, P, PEnd - P); -end; - -function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString; -var - Start: PWideChar; -begin - Start := P; - P := WStrScan(Start, Separator); - if P = nil then begin - Result := Start; - P := WStrEnd(Start); - end else begin - SetString(Result, Start, P - Start); - Inc(P); - end; -end; - -function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray; -const - GROW_COUNT = 256; -var - Count: Integer; - Item: WideString; -begin - Count := 0; - SetLength(Result, GROW_COUNT); - Item := ExtractStringFromStringArray(P, Separator); - While Item <> '' do begin - if Count > High(Result) then - SetLength(Result, Length(Result) + GROW_COUNT); - Result[Count] := Item; - Inc(Count); - Item := ExtractStringFromStringArray(P, Separator); - end; - SetLength(Result, Count); -end; - -function IsWideCharMappableToAnsi(const WC: WideChar): Boolean; -var - UsedDefaultChar: BOOL; -begin - WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(@WC), 1, nil, 0, nil, @UsedDefaultChar); - Result := not UsedDefaultChar; -end; - -function IsWideStringMappableToAnsi(const WS: WideString): Boolean; -var - UsedDefaultChar: BOOL; -begin - WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(WS), Length(WS), nil, 0, nil, @UsedDefaultChar); - Result := not UsedDefaultChar; -end; - -function IsRTF(const Value: WideString): Boolean; -const - RTF_BEGIN_1 = WideString('{\RTF'); - RTF_BEGIN_2 = WideString('{URTF'); -begin - Result := (WideTextPos(RTF_BEGIN_1, Value) = 1) - or (WideTextPos(RTF_BEGIN_2, Value) = 1); -end; - -{$IFDEF COMPILER_7_UP} -var - Cached_ENG_US_FormatSettings: TFormatSettings; - Cached_ENG_US_FormatSettings_Time: Cardinal; - -function ENG_US_FormatSettings: TFormatSettings; -begin - if Cached_ENG_US_FormatSettings_Time = _SettingChangeTime then - Result := Cached_ENG_US_FormatSettings - else begin - GetLocaleFormatSettings(MAKELCID(MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US)), Result); - Result.DecimalSeparator := '.'; // ignore overrides - Cached_ENG_US_FormatSettings := Result; - Cached_ENG_US_FormatSettings_Time := _SettingChangeTime; - end; - end; - -function ENG_US_FloatToStr(Value: Extended): WideString; -begin - Result := FloatToStr(Value, ENG_US_FormatSettings); -end; - -function ENG_US_StrToFloat(const S: WideString): Extended; -begin - if not TextToFloat(PAnsiChar(AnsiString(S)), Result, fvExtended, ENG_US_FormatSettings) then - Result := StrToFloat(S); // try using native format -end; - -{$ELSE} - -function ENG_US_FloatToStr(Value: Extended): WideString; -var - SaveDecimalSep: AnsiChar; -begin - SaveDecimalSep := SysUtils.DecimalSeparator; - try - SysUtils.DecimalSeparator := '.'; - Result := FloatToStr(Value); - finally - SysUtils.DecimalSeparator := SaveDecimalSep; - end; -end; - -function ENG_US_StrToFloat(const S: WideString): Extended; -var - SaveDecimalSep: AnsiChar; -begin - try - SaveDecimalSep := SysUtils.DecimalSeparator; - try - SysUtils.DecimalSeparator := '.'; - Result := StrToFloat(S); - finally - SysUtils.DecimalSeparator := SaveDecimalSep; - end; - except - if SysUtils.DecimalSeparator <> '.' then - Result := StrToFloat(S) // try using native format - else - raise; - end; -end; -{$ENDIF} - -//--------------------------------------------------------------------------------------------- -// Tnt - Variants -//--------------------------------------------------------------------------------------------- - -initialization - Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT); - Win32PlatformIsXP := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) - or (Win32MajorVersion > 5); - Win32PlatformIs2003 := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 2)) - or (Win32MajorVersion > 5); - Win32PlatformIsVista := (Win32MajorVersion >= 6); - -finalization - Currency_DecimalSep := ''; {make memory sleuth happy} - Currency_ThousandSep := ''; {make memory sleuth happy} - Currency_CurrencySymbol := ''; {make memory sleuth happy} - -end. diff --git a/src/lib/TntUnicodeControls/TntSystem.pas b/src/lib/TntUnicodeControls/TntSystem.pas deleted file mode 100644 index e613ce0c..00000000 --- a/src/lib/TntUnicodeControls/TntSystem.pas +++ /dev/null @@ -1,1427 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 TntSystem; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -{*****************************************************************************} -{ Special thanks go to Francisco Leong for originating the design for } -{ WideString-enabled resourcestrings. } -{*****************************************************************************} - -interface - -uses - Windows; - -// These functions should not be used by Delphi code since conversions are implicit. -{TNT-WARN WideCharToString} -{TNT-WARN WideCharLenToString} -{TNT-WARN WideCharToStrVar} -{TNT-WARN WideCharLenToStrVar} -{TNT-WARN StringToWideChar} - -// ................ ANSI TYPES ................ -{TNT-WARN Char} -{TNT-WARN PChar} -{TNT-WARN String} - -{TNT-WARN CP_ACP} // <-- use DefaultSystemCodePage -function DefaultSystemCodePage: Cardinal; // implicitly used when converting AnsiString <--> WideString. - -{$IFNDEF FPC} -var - WideCustomLoadResString: function(ResStringRec: PResStringRec; var Value: WideString): Boolean; -{$ENDIF} - -{TNT-WARN LoadResString} -function WideLoadResString(ResStringRec: PResStringRec): WideString; -{TNT-WARN ParamCount} -function WideParamCount: Integer; -{TNT-WARN ParamStr} -function WideParamStr(Index: Integer): WideString; - -// ......... introduced ......... - -const - { Each Unicode stream should begin with the code U+FEFF, } - { which the standard defines as the *byte order mark*. } - UNICODE_BOM = WideChar($FEFF); - UNICODE_BOM_SWAPPED = WideChar($FFFE); - UTF8_BOM = AnsiString(#$EF#$BB#$BF); - -function WideStringToUTF8(const S: WideString): AnsiString; -function UTF8ToWideString(const S: AnsiString): WideString; - -function WideStringToUTF7(const W: WideString): AnsiString; -function UTF7ToWideString(const S: AnsiString): WideString; - -function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString; -function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString; - -function UCS2ToWideString(const Value: AnsiString): WideString; -function WideStringToUCS2(const Value: WideString): AnsiString; - -function CharSetToCodePage(ciCharset: UINT): Cardinal; -function LCIDToCodePage(ALcid: LCID): Cardinal; -function KeyboardCodePage: Cardinal; -function KeyUnicode(CharCode: Word): WideChar; - -procedure StrSwapByteOrder(Str: PWideChar); - -{$IFDEF USE_SYSTEM_OVERRIDES} - -type - TTntSystemUpdate = - (tsWideResourceStrings - {$IFNDEF COMPILER_9_UP}, tsFixImplicitCodePage, tsFixWideStrConcat, tsFixWideFormat {$ENDIF} - ); - TTntSystemUpdateSet = set of TTntSystemUpdate; - -const - AllTntSystemUpdates = [Low(TTntSystemUpdate)..High(TTntSystemUpdate)]; - -procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates); - -{$ENDIF USE_SYSTEM_OVERRIDES} - -implementation - -uses - SysUtils, Variants, TntWindows, TntSysUtils; - -var - GDefaultSystemCodePage: Cardinal; - -function DefaultSystemCodePage: Cardinal; -begin - Result := GDefaultSystemCodePage; -end; - -{$IFDEF USE_SYSTEM_OVERRIDES} -var - IsDebugging: Boolean; -{$ENDIF USE_SYSTEM_OVERRIDES} - -function WideLoadResStringDetect(ResStringRec: PResStringRec): WideString; -var - PCustom: PAnsiChar; -begin - // custom string pointer - PCustom := PAnsiChar(ResStringRec); { I would like to use PWideChar, but this would break legacy code. } - if (StrLen{TNT-ALLOW StrLen}(PCustom) > Cardinal(Length(UTF8_BOM))) - and CompareMem(PCustom, PAnsiChar(UTF8_BOM), Length(UTF8_BOM)) then - // detected UTF8 - Result := UTF8ToWideString(PAnsiChar(PCustom + Length(UTF8_BOM))) - else - // normal - Result := PCustom; -end; - -{$IFNDEF FPC} - -function WideLoadResString(ResStringRec: PResStringRec): WideString; -const - MAX_RES_STRING_SIZE = 4097; { MSDN documents this as the maximum size of a string in table. } -var - Buffer: array [0..MAX_RES_STRING_SIZE] of WideChar; { Buffer leaves room for null terminator. } -begin - if Assigned(WideCustomLoadResString) and WideCustomLoadResString(ResStringRec, Result) then - exit; { a custom resourcestring has been loaded. } - - if ResStringRec = nil then - Result := '' - else if ResStringRec.Identifier < 64*1024 then - SetString(Result, Buffer, - Tnt_LoadStringW(FindResourceHInstance(ResStringRec.Module^), - ResStringRec.Identifier, Buffer, MAX_RES_STRING_SIZE)) - else begin - Result := WideLoadResStringDetect(ResStringRec); - end; -end; - -{$ELSE} - -function WideLoadResString(ResStringRec: PResStringRec): WideString; -begin - Result := WideLoadResStringDetect(ResStringRec); -end; - -{$ENDIF} - -function WideGetParamStr(P: PWideChar; var Param: WideString): PWideChar; -var - i, Len: Integer; - Start, S, Q: PWideChar; -begin - while True do - begin - while (P[0] <> #0) and (P[0] <= ' ') do - Inc(P); - if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; - end; - Len := 0; - Start := P; - while P[0] > ' ' do - begin - if P[0] = '"' then - begin - Inc(P); - while (P[0] <> #0) and (P[0] <> '"') do - begin - Q := P + 1; - Inc(Len, Q - P); - P := Q; - end; - if P[0] <> #0 then - Inc(P); - end - else - begin - Q := P + 1; - Inc(Len, Q - P); - P := Q; - end; - end; - - SetLength(Param, Len); - - P := Start; - S := PWideChar(Param); - i := 0; - while P[0] > ' ' do - begin - if P[0] = '"' then - begin - Inc(P); - while (P[0] <> #0) and (P[0] <> '"') do - begin - Q := P + 1; - while P < Q do - begin - S[i] := P^; - Inc(P); - Inc(i); - end; - end; - if P[0] <> #0 then Inc(P); - end - else - begin - Q := P + 1; - while P < Q do - begin - S[i] := P^; - Inc(P); - Inc(i); - end; - end; - end; - - Result := P; -end; - -function WideParamCount: Integer; -var - P: PWideChar; - S: WideString; -begin - P := WideGetParamStr(GetCommandLineW, S); - Result := 0; - while True do - begin - P := WideGetParamStr(P, S); - if S = '' then Break; - Inc(Result); - end; -end; - -function WideParamStr(Index: Integer): WideString; -var - P: PWideChar; -begin - if Index = 0 then - Result := WideGetModuleFileName(0) - else - begin - P := GetCommandLineW; - while True do - begin - P := WideGetParamStr(P, Result); - if (Index = 0) or (Result = '') then Break; - Dec(Index); - end; - end; -end; - -function WideStringToUTF8(const S: WideString): AnsiString; -begin - Result := UTF8Encode(S); -end; - -function UTF8ToWideString(const S: AnsiString): WideString; -begin - Result := UTF8Decode(S); -end; - - { ======================================================================= } - { Original File: ConvertUTF7.c } - { Author: David B. Goldsmith } - { Copyright (C) 1994, 1996 Taligent, Inc. All rights reserved. } - { } - { This code is copyrighted. Under the copyright laws, this code may not } - { be copied, in whole or part, without prior written consent of Taligent. } - { } - { Taligent grants the right to use this code as long as this ENTIRE } - { copyright notice is reproduced in the code. The code is provided } - { AS-IS, AND TALIGENT DISCLAIMS ALL WARRANTIES, EITHER EXPRESS OR } - { IMPLIED, INCLUDING, BUT NOT LIMITED TO IMPLIED WARRANTIES OF } - { MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT } - { WILL TALIGENT BE LIABLE FOR ANY DAMAGES WHATSOEVER (INCLUDING, } - { WITHOUT LIMITATION, DAMAGES FOR LOSS OF BUSINESS PROFITS, BUSINESS } - { INTERRUPTION, LOSS OF BUSINESS INFORMATION, OR OTHER PECUNIARY } - { LOSS) ARISING OUT OF THE USE OR INABILITY TO USE THIS CODE, EVEN } - { IF TALIGENT HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. } - { BECAUSE SOME STATES DO NOT ALLOW THE EXCLUSION OR LIMITATION OF } - { LIABILITY FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES, THE ABOVE } - { LIMITATION MAY NOT APPLY TO YOU. } - { } - { RESTRICTED RIGHTS LEGEND: Use, duplication, or disclosure by the } - { government is subject to restrictions as set forth in subparagraph } - { (c)(l)(ii) of the Rights in Technical Data and Computer Software } - { clause at DFARS 252.227-7013 and FAR 52.227-19. } - { } - { This code may be protected by one or more U.S. and International } - { Patents. } - { } - { TRADEMARKS: Taligent and the Taligent Design Mark are registered } - { trademarks of Taligent, Inc. } - { ======================================================================= } - -type UCS2 = Word; - -const - _base64: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; - _direct: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789''(),-./:?'; - _optional: AnsiString = '!"#$%&*;<=>@[]^_`{|}'; - _spaces: AnsiString = #9#13#10#32; - -var - base64: PAnsiChar; - invbase64: array[0..127] of SmallInt; - direct: PAnsiChar; - optional: PAnsiChar; - spaces: PAnsiChar; - mustshiftsafe: array[0..127] of AnsiChar; - mustshiftopt: array[0..127] of AnsiChar; - -var - needtables: Boolean = True; - -procedure Initialize_UTF7_Data; -begin - base64 := PAnsiChar(_base64); - direct := PAnsiChar(_direct); - optional := PAnsiChar(_optional); - spaces := PAnsiChar(_spaces); -end; - -procedure tabinit; -var - i: Integer; - limit: Integer; -begin - i := 0; - while (i < 128) do - begin - mustshiftopt[i] := #1; - mustshiftsafe[i] := #1; - invbase64[i] := -1; - Inc(i); - end { For }; - limit := Length(_Direct); - i := 0; - while (i < limit) do - begin - mustshiftopt[Integer(direct[i])] := #0; - mustshiftsafe[Integer(direct[i])] := #0; - Inc(i); - end { For }; - limit := Length(_Spaces); - i := 0; - while (i < limit) do - begin - mustshiftopt[Integer(spaces[i])] := #0; - mustshiftsafe[Integer(spaces[i])] := #0; - Inc(i); - end { For }; - limit := Length(_Optional); - i := 0; - while (i < limit) do - begin - mustshiftopt[Integer(optional[i])] := #0; - Inc(i); - end { For }; - limit := Length(_Base64); - i := 0; - while (i < limit) do - begin - invbase64[Integer(base64[i])] := i; - Inc(i); - end { For }; - needtables := False; -end; { tabinit } - -function WRITE_N_BITS(x: UCS2; n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): Integer; -begin - BITbuffer := BITbuffer or (x and (not (-1 shl n))) shl (32 - n - bufferbits); - bufferbits := bufferbits + n; - Result := bufferbits; -end; { WRITE_N_BITS } - -function READ_N_BITS(n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): UCS2; -var - buffertemp: Cardinal; -begin - buffertemp := BITbuffer shr (32 - n); - BITbuffer := BITbuffer shl n; - bufferbits := bufferbits - n; - Result := UCS2(buffertemp); -end; { READ_N_BITS } - -function ConvertUCS2toUTF7(var sourceStart: PWideChar; sourceEnd: PWideChar; - var targetStart: PAnsiChar; targetEnd: PAnsiChar; optional: Boolean; - verbose: Boolean): Integer; -var - r: UCS2; - target: PAnsiChar; - source: PWideChar; - BITbuffer: Cardinal; - bufferbits: Integer; - shifted: Boolean; - needshift: Boolean; - done: Boolean; - mustshift: PAnsiChar; -begin - Initialize_UTF7_Data; - Result := 0; - BITbuffer := 0; - bufferbits := 0; - shifted := False; - source := sourceStart; - target := targetStart; - r := 0; - if needtables then - tabinit; - if optional then - mustshift := @mustshiftopt[0] - else - mustshift := @mustshiftsafe[0]; - repeat - done := source >= sourceEnd; - if not Done then - begin - r := Word(source^); - Inc(Source); - end { If }; - needshift := (not done) and ((r > $7F) or (mustshift[r] <> #0)); - if needshift and (not shifted) then - begin - if (Target >= TargetEnd) then - begin - Result := 2; - break; - end { If }; - target^ := '+'; - Inc(target); - { Special case handling of the SHIFT_IN character } - if (r = UCS2('+')) then - begin - if (target >= targetEnd) then - begin - Result := 2; - break; - end; - target^ := '-'; - Inc(target); - end - else - shifted := True; - end { If }; - if shifted then - begin - { Either write the character to the bit buffer, or pad } - { the bit buffer out to a full base64 character. } - { } - if needshift then - WRITE_N_BITS(r, 16, BITbuffer, bufferbits) - else - WRITE_N_BITS(0, (6 - (bufferbits mod 6)) mod 6, BITbuffer, - bufferbits); - { Flush out as many full base64 characters as possible } - { from the bit buffer. } - { } - while (target < targetEnd) and (bufferbits >= 6) do - begin - Target^ := base64[READ_N_BITS(6, BITbuffer, bufferbits)]; - Inc(Target); - end { While }; - if (bufferbits >= 6) then - begin - if (target >= targetEnd) then - begin - Result := 2; - break; - end { If }; - end { If }; - if (not needshift) then - begin - { Write the explicit shift out character if } - { 1) The caller has requested we always do it, or } - { 2) The directly encoded character is in the } - { base64 set, or } - { 3) The directly encoded character is SHIFT_OUT. } - { } - if verbose or ((not done) and ((invbase64[r] >= 0) or (r = - Integer('-')))) then - begin - if (target >= targetEnd) then - begin - Result := 2; - Break; - end { If }; - Target^ := '-'; - Inc(Target); - end { If }; - shifted := False; - end { If }; - { The character can be directly encoded as ASCII. } - end { If }; - if (not needshift) and (not done) then - begin - if (target >= targetEnd) then - begin - Result := 2; - break; - end { If }; - Target^ := AnsiChar(r); - Inc(Target); - end { If }; - until (done); - sourceStart := source; - targetStart := target; -end; { ConvertUCS2toUTF7 } - -function ConvertUTF7toUCS2(var sourceStart: PAnsiChar; sourceEnd: PAnsiChar; - var targetStart: PWideChar; targetEnd: PWideChar): Integer; -var - target: PWideChar { Register }; - source: PAnsiChar { Register }; - BITbuffer: Cardinal { & "Address Of" Used }; - bufferbits: Integer { & "Address Of" Used }; - shifted: Boolean { Used In Boolean Context }; - first: Boolean { Used In Boolean Context }; - wroteone: Boolean; - base64EOF: Boolean; - base64value: Integer; - done: Boolean; - c: UCS2; - prevc: UCS2; - junk: UCS2 { Used In Boolean Context }; -begin - Initialize_UTF7_Data; - Result := 0; - BITbuffer := 0; - bufferbits := 0; - shifted := False; - first := False; - wroteone := False; - source := sourceStart; - target := targetStart; - c := 0; - if needtables then - tabinit; - repeat - { read an ASCII character c } - done := Source >= SourceEnd; - if (not done) then - begin - c := Word(Source^); - Inc(Source); - end { If }; - if shifted then - begin - { We're done with a base64 string if we hit EOF, it's not a valid } - { ASCII character, or it's not in the base64 set. } - { } - base64value := invbase64[c]; - base64EOF := (done or (c > $7F)) or (base64value < 0); - if base64EOF then - begin - shifted := False; - { If the character causing us to drop out was SHIFT_IN or } - { SHIFT_OUT, it may be a special escape for SHIFT_IN. The } - { test for SHIFT_IN is not necessary, but allows an alternate } - { form of UTF-7 where SHIFT_IN is escaped by SHIFT_IN. This } - { only works for some values of SHIFT_IN. } - { } - if ((not done) and ((c = Integer('+')) or (c = Integer('-')))) then - begin - { get another character c } - prevc := c; - Done := Source >= SourceEnd; - if (not Done) then - begin - c := Word(Source^); - Inc(Source); - { If no base64 characters were encountered, and the } - { character terminating the shift sequence was } - { SHIFT_OUT, then it's a special escape for SHIFT_IN. } - { } - end; - if first and (prevc = Integer('-')) then - begin - { write SHIFT_IN unicode } - if (target >= targetEnd) then - begin - Result := 2; - break; - end { If }; - Target^ := WideChar('+'); - Inc(Target); - end - else - begin - if (not wroteone) then - begin - Result := 1; - end { If }; - end { Else }; - ; - end { If } - else - begin - if (not wroteone) then - begin - Result := 1; - end { If }; - end { Else }; - end { If } - else - begin - { Add another 6 bits of base64 to the bit buffer. } - WRITE_N_BITS(base64value, 6, BITbuffer, - bufferbits); - first := False; - end { Else }; - { Extract as many full 16 bit characters as possible from the } - { bit buffer. } - { } - while (bufferbits >= 16) and (target < targetEnd) do - begin - { write a unicode } - Target^ := WideChar(READ_N_BITS(16, BITbuffer, bufferbits)); - Inc(Target); - wroteone := True; - end { While }; - if (bufferbits >= 16) then - begin - if (target >= targetEnd) then - begin - Result := 2; - Break; - end; - end { If }; - if (base64EOF) then - begin - junk := READ_N_BITS(bufferbits, BITbuffer, bufferbits); - if (junk <> 0) then - begin - Result := 1; - end { If }; - end { If }; - end { If }; - if (not shifted) and (not done) then - begin - if (c = Integer('+')) then - begin - shifted := True; - first := True; - wroteone := False; - end { If } - else - begin - { It must be a directly encoded character. } - if (c > $7F) then - begin - Result := 1; - end { If }; - if (target >= targetEnd) then - begin - Result := 2; - break; - end { If }; - Target^ := WideChar(c); - Inc(Target); - end { Else }; - end { If }; - until (done); - sourceStart := source; - targetStart := target; -end; { ConvertUTF7toUCS2 } - - {*****************************************************************************} - { Thanks to Francisco Leong for providing the Pascal conversion of } - { ConvertUTF7.c (by David B. Goldsmith) } - {*****************************************************************************} - -resourcestring - SBufferOverflow = 'Buffer overflow'; - SInvalidUTF7 = 'Invalid UTF7'; - -function WideStringToUTF7(const W: WideString): AnsiString; -var - SourceStart, SourceEnd: PWideChar; - TargetStart, TargetEnd: PAnsiChar; -begin - if W = '' then - Result := '' - else - begin - SetLength(Result, Length(W) * 7); // Assume worst case - SourceStart := PWideChar(@W[1]); - SourceEnd := PWideChar(@W[Length(W)]) + 1; - TargetStart := PAnsiChar(@Result[1]); - TargetEnd := PAnsiChar(@Result[Length(Result)]) + 1; - if ConvertUCS2toUTF7(SourceStart, SourceEnd, TargetStart, - TargetEnd, True, False) <> 0 - then - raise ETntInternalError.Create(SBufferOverflow); - SetLength(Result, TargetStart - PAnsiChar(@Result[1])); - end; -end; - -function UTF7ToWideString(const S: AnsiString): WideString; -var - SourceStart, SourceEnd: PAnsiChar; - TargetStart, TargetEnd: PWideChar; -begin - if (S = '') then - Result := '' - else - begin - SetLength(Result, Length(S)); // Assume Worst case - SourceStart := PAnsiChar(@S[1]); - SourceEnd := PAnsiChar(@S[Length(S)]) + 1; - TargetStart := PWideChar(@Result[1]); - TargetEnd := PWideChar(@Result[Length(Result)]) + 1; - case ConvertUTF7toUCS2(SourceStart, SourceEnd, TargetStart, - TargetEnd) of - 1: raise ETntGeneralError.Create(SInvalidUTF7); - 2: raise ETntInternalError.Create(SBufferOverflow); - end; - SetLength(Result, TargetStart - PWideChar(@Result[1])); - end; -end; - -function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString; -var - InputLength, - OutputLength: Integer; -begin - if CodePage = CP_UTF7 then - Result := UTF7ToWideString(S) // CP_UTF7 not supported on Windows 95 - else if CodePage = CP_UTF8 then - Result := UTF8ToWideString(S) // CP_UTF8 not supported on Windows 95 - else begin - InputLength := Length(S); - OutputLength := MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, nil, 0); - SetLength(Result, OutputLength); - MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, PWideChar(Result), OutputLength); - end; -end; - -function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString; -var - InputLength, - OutputLength: Integer; -begin - if CodePage = CP_UTF7 then - Result := WideStringToUTF7(WS) // CP_UTF7 not supported on Windows 95 - else if CodePage = CP_UTF8 then - Result := WideStringToUTF8(WS) // CP_UTF8 not supported on Windows 95 - else begin - InputLength := Length(WS); - OutputLength := WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, nil, 0, nil, nil); - SetLength(Result, OutputLength); - WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, PAnsiChar(Result), OutputLength, nil, nil); - end; -end; - -function UCS2ToWideString(const Value: AnsiString): WideString; -begin - if Length(Value) = 0 then - Result := '' - else - SetString(Result, PWideChar(@Value[1]), Length(Value) div SizeOf(WideChar)) -end; - -function WideStringToUCS2(const Value: WideString): AnsiString; -begin - if Length(Value) = 0 then - Result := '' - else - SetString(Result, PAnsiChar(@Value[1]), Length(Value) * SizeOf(WideChar)) -end; - -{ Windows.pas doesn't declare TranslateCharsetInfo() correctly. } -function TranslateCharsetInfo(lpSrc: PDWORD; var lpCs: TCharsetInfo; dwFlags: DWORD): BOOL; stdcall; external gdi32 name 'TranslateCharsetInfo'; - -function CharSetToCodePage(ciCharset: UINT): Cardinal; -var - C: TCharsetInfo; -begin - Win32Check(TranslateCharsetInfo(PDWORD(ciCharset), C, TCI_SRCCHARSET)); - Result := C.ciACP -end; - -function LCIDToCodePage(ALcid: LCID): Cardinal; -var - Buf: array[0..6] of AnsiChar; -begin - GetLocaleInfo(ALcid, LOCALE_IDefaultAnsiCodePage, Buf, 6); - Result := StrToIntDef(Buf, GetACP); -end; - -function KeyboardCodePage: Cardinal; -begin - Result := LCIDToCodePage(GetKeyboardLayout(0) and $FFFF); -end; - -function KeyUnicode(CharCode: Word): WideChar; -var - AChar: AnsiChar; -begin - // converts the given character (as it comes with a WM_CHAR message) into its - // corresponding Unicode character depending on the active keyboard layout - if CharCode <= Word(High(AnsiChar)) then begin - AChar := AnsiChar(CharCode); - MultiByteToWideChar(KeyboardCodePage, MB_USEGLYPHCHARS, @AChar, 1, @Result, 1); - end else - Result := WideChar(CharCode); -end; - -procedure StrSwapByteOrder(Str: PWideChar); -var - P: PWord; -begin - P := PWord(Str); - While (P^ <> 0) do begin - P^ := MakeWord(HiByte(P^), LoByte(P^)); - Inc(P); - end; -end; - -{$IFDEF USE_SYSTEM_OVERRIDES} - -//-------------------------------------------------------------------- -// LoadResString() -// -// This system function is used to retrieve a resourcestring and -// return the result as an AnsiString. If we believe that the result -// is only a temporary value, and that it will be immediately -// assigned to a WideString or a Variant, then we will save the -// Unicode result as well as a reference to the original Ansi string. -// WStrFromPCharLen() or VarFromLStr() will return this saved -// Unicode string if it appears to receive the most recent result -// of LoadResString. -//-------------------------------------------------------------------- - - - //=========================================================================================== - // - // function CodeMatchesPatternForUnicode(...); - // - // GIVEN: SomeWideString := SSomeResString; { WideString := resourcestring } - // - // Delphi will compile this statement into the following: - // ------------------------------------------------- - // TempAnsiString := LoadResString(@SSomeResString); - // LINE 1: lea edx,[SomeTempAnsiString] - // LINE 2: mov eax,[@SomeResString] - // LINE 3: call LoadResString - // - // WStrFromLStr(SomeWideString, TempAnsiString); { SomeWideString := TempAnsiString } - // LINE 4: mov edx,[SomeTempAnsiString] - // LINE 5: mov/lea eax [@SomeWideString] - // LINE 6: call @WStrFromLStr - // ------------------------------------------------- - // - // The order in which the parameters are prepared for WStrFromLStr (ie LINE 4 & 5) is - // reversed when assigning a non-temporary AnsiString to a WideString. - // - // This code, for example, results in LINE 4 and LINE 5 being swapped. - // - // SomeAnsiString := SSomeResString; - // SomeWideString := SomeAnsiString; - // - // Since we know the "signature" used by the compiler, we can detect this pattern. - // If we believe it is only temporary, we can save the Unicode results for later - // retrieval from WStrFromLStr. - // - // One final note: When assigning a resourcestring to a Variant, the same patterns exist. - //=========================================================================================== - -function CodeMatchesPatternForUnicode(PLine4: PAnsiChar): Boolean; -const - SIZEOF_OPCODE = 1 {byte}; - MOV_16_OPCODE = AnsiChar($8B); { we'll assume operand size is 16 bits } - MOV_32_OPCODE = AnsiChar($B8); { we'll assume operand size is 32 bits } - LEA_OPCODE = AnsiChar($8D); { operand size can be 16 or 40 bits } - CALL_OPCODE = AnsiChar($E8); { assumed operand size is 32 bits } - BREAK_OPCODE = AnsiChar($CC); {in a breakpoint} -var - PLine1: PAnsiChar; - PLine2: PAnsiChar; - PLine3: PAnsiChar; - DataSize: Integer; // bytes in first LEA operand -begin - Result := False; - - PLine3 := PLine4 - SizeOf(CALL_OPCODE) - 4; - PLine2 := PLine3 - SizeOf(MOV_32_OPCODE) - 4; - - // figure PLine1 and operand size - DataSize := 2; { try 16 bit operand for line 1 } - PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE); - if (PLine1^ <> LEA_OPCODE) and (not (IsDebugging and (PLine1^ = BREAK_OPCODE))) then - begin - DataSize := 5; { try 40 bit operand for line 1 } - PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE); - end; - if (PLine1^ = LEA_OPCODE) or (IsDebugging and (PLine1^ = BREAK_OPCODE)) then - begin - if CompareMem(PLine1 + SIZEOF_OPCODE, PLine4 + SIZEOF_OPCODE, DataSize) then - begin - // After this check, it seems to match the WideString <- (temp) AnsiString pattern - Result := True; // It is probably OK. (The side effects of being wrong aren't very bad.) - end; - end; -end; - -threadvar - PLastResString: PAnsiChar; - LastResStringValue: AnsiString; - LastWideResString: WideString; - -procedure FreeTntSystemThreadVars; -begin - LastResStringValue := ''; - LastWideResString := ''; -end; - -procedure Custom_System_EndThread(ExitCode: Integer); -begin - FreeTntSystemThreadVars; - {$IFDEF COMPILER_10_UP} - if Assigned(SystemThreadEndProc) then - SystemThreadEndProc(ExitCode); - {$ENDIF} - ExitThread(ExitCode); -end; - -function Custom_System_LoadResString(ResStringRec: PResStringRec): AnsiString; -var - ReturnAddr: Pointer; -begin - // get return address - asm - PUSH ECX - MOV ECX, [EBP + 4] - MOV ReturnAddr, ECX - POP ECX - end; - // check calling code pattern - if CodeMatchesPatternForUnicode(ReturnAddr) then begin - // result will probably be assigned to an intermediate AnsiString - // on its way to either a WideString or Variant. - LastWideResString := WideLoadResString(ResStringRec); - Result := LastWideResString; - LastResStringValue := Result; - if Result = '' then - PLastResString := nil - else - PLastResString := PAnsiChar(Result); - end else begin - // result will probably be assigned to an actual AnsiString variable. - PLastResString := nil; - Result := WideLoadResString(ResStringRec); - end; -end; - -//-------------------------------------------------------------------- -// WStrFromPCharLen() -// -// This system function is used to assign an AnsiString to a WideString. -// It has been modified to assign Unicode results from LoadResString. -// Another purpose of this function is to specify the code page. -//-------------------------------------------------------------------- - -procedure Custom_System_WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); -var - DestLen: Integer; - Buffer: array[0..2047] of WideChar; - Local_PLastResString: Pointer; -begin - Local_PLastResString := PLastResString; - if (Local_PLastResString <> nil) - and (Local_PLastResString = Source) - and (System.Length(LastResStringValue) = Length) - and (LastResStringValue = Source) then begin - // use last unicode resource string - PLastResString := nil; { clear for further use } - Dest := LastWideResString; - end else begin - if Local_PLastResString <> nil then - PLastResString := nil; { clear for further use } - if Length <= 0 then - begin - Dest := ''; - Exit; - end; - if Length + 1 < High(Buffer) then - begin - DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Buffer, - High(Buffer)); - if DestLen > 0 then - begin - SetLength(Dest, DestLen); - Move(Pointer(@Buffer[0])^, Pointer(Dest)^, DestLen * SizeOf(WideChar)); - Exit; - end; - end; - DestLen := (Length + 1); - SetLength(Dest, DestLen); // overallocate, trim later - DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest), - DestLen); - if DestLen < 0 then - DestLen := 0; - SetLength(Dest, DestLen); - end; -end; - -{$IFNDEF COMPILER_9_UP} - -//-------------------------------------------------------------------- -// LStrFromPWCharLen() -// -// This system function is used to assign an WideString to an AnsiString. -// It has not been modified from its original purpose other than to specify the code page. -//-------------------------------------------------------------------- - -procedure Custom_System_LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer); -var - DestLen: Integer; - Buffer: array[0..4095] of AnsiChar; -begin - if Length <= 0 then - begin - Dest := ''; - Exit; - end; - if Length + 1 < (High(Buffer) div sizeof(WideChar)) then - begin - DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source, - Length, Buffer, High(Buffer), - nil, nil); - if DestLen >= 0 then - begin - SetLength(Dest, DestLen); - Move(Pointer(@Buffer[0])^, PAnsiChar(Dest)^, DestLen); - Exit; - end; - end; - - DestLen := (Length + 1) * sizeof(WideChar); - SetLength(Dest, DestLen); // overallocate, trim later - DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest), DestLen, - nil, nil); - if DestLen < 0 then - DestLen := 0; - SetLength(Dest, DestLen); -end; - -//-------------------------------------------------------------------- -// WStrToString() -// -// This system function is used to assign an WideString to an short string. -// It has not been modified from its original purpose other than to specify the code page. -//-------------------------------------------------------------------- - -procedure Custom_System_WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer); -var - SourceLen, DestLen: Integer; - Buffer: array[0..511] of AnsiChar; -begin - if MaxLen > 255 then MaxLen := 255; - SourceLen := Length(Source); - if SourceLen >= MaxLen then SourceLen := MaxLen; - if SourceLen = 0 then - DestLen := 0 - else begin - DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Pointer(Source), SourceLen, - Buffer, SizeOf(Buffer), nil, nil); - if DestLen > MaxLen then DestLen := MaxLen; - end; - Dest^[0] := Chr(DestLen); - if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); -end; - -{$ENDIF} - -//-------------------------------------------------------------------- -// VarFromLStr() -// -// This system function is used to assign an AnsiString to a Variant. -// It has been modified to assign Unicode results from LoadResString. -//-------------------------------------------------------------------- - -procedure Custom_System_VarFromLStr(var V: TVarData; const Value: AnsiString); -const - varDeepData = $BFE8; -var - Local_PLastResString: Pointer; -begin - if (V.VType and varDeepData) <> 0 then - VarClear(PVariant(@V)^); - - Local_PLastResString := PLastResString; - if (Local_PLastResString <> nil) - and (Local_PLastResString = PAnsiChar(Value)) - and (LastResStringValue = Value) then begin - // use last unicode resource string - PLastResString := nil; { clear for further use } - V.VOleStr := nil; - V.VType := varOleStr; - WideString(Pointer(V.VOleStr)) := Copy(LastWideResString, 1, MaxInt); - end else begin - if Local_PLastResString <> nil then - PLastResString := nil; { clear for further use } - V.VString := nil; - V.VType := varString; - AnsiString(V.VString) := Value; - end; -end; - -{$IFNDEF COMPILER_9_UP} - -//-------------------------------------------------------------------- -// WStrCat3() A := B + C; -// -// This system function is used to concatenate two strings into one result. -// This function is added because A := '' + '' doesn't necessarily result in A = ''; -//-------------------------------------------------------------------- - -procedure Custom_System_WStrCat3(var Dest: WideString; const Source1, Source2: WideString); - - function NewWideString(CharLength: Longint): Pointer; - var - _NewWideString: function(CharLength: Longint): Pointer; - begin - asm - PUSH ECX - MOV ECX, offset System.@NewWideString; - MOV _NewWideString, ECX - POP ECX - end; - Result := _NewWideString(CharLength); - end; - - procedure WStrSet(var S: WideString; P: PWideChar); - var - Temp: Pointer; - begin - Temp := Pointer(InterlockedExchange(Integer(S), Integer(P))); - if Temp <> nil then - WideString(Temp) := ''; - end; - -var - Source1Len, Source2Len: Integer; - NewStr: PWideChar; -begin - Source1Len := Length(Source1); - Source2Len := Length(Source2); - if (Source1Len <> 0) or (Source2Len <> 0) then - begin - NewStr := NewWideString(Source1Len + Source2Len); - Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar)); - Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar)); - WStrSet(Dest, NewStr); - end else - Dest := ''; -end; - -{$ENDIF} - -//-------------------------------------------------------------------- -// System proc replacements -//-------------------------------------------------------------------- - -type - POverwrittenData = ^TOverwrittenData; - TOverwrittenData = record - Location: Pointer; - OldCode: array[0..6] of Byte; - end; - -procedure OverwriteProcedure(OldProcedure, NewProcedure: pointer; Data: POverwrittenData = nil); -{ OverwriteProcedure originally from Igor Siticov } -{ Modified by Jacques Garcia Vazquez } -var - x: PAnsiChar; - y: integer; - ov2, ov: cardinal; - p: pointer; -begin - if Assigned(Data) and (Data.Location <> nil) then - exit; { procedure already overwritten } - - // need six bytes in place of 5 - x := PAnsiChar(OldProcedure); - if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then - RaiseLastOSError; - - // if a jump is present then a redirect is found - // $FF25 = jmp dword ptr [xxx] - // This redirect is normally present in bpl files, but not in exe files - p := OldProcedure; - - if Word(p^) = $25FF then - begin - Inc(Integer(p), 2); // skip the jump - // get the jump address p^ and dereference it p^^ - p := Pointer(Pointer(p^)^); - - // release the memory - if not VirtualProtect(Pointer(x), 6, ov, @ov2) then - RaiseLastOSError; - - // re protect the correct one - x := PAnsiChar(p); - if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then - RaiseLastOSError; - end; - - if Assigned(Data) then - begin - Move(x^, Data.OldCode, 6); - { Assign Location last so that Location <> nil only if OldCode is properly initialized. } - Data.Location := x; - end; - - x[0] := AnsiChar($E9); - y := integer(NewProcedure) - integer(p) - 5; - x[1] := AnsiChar(y and 255); - x[2] := AnsiChar((y shr 8) and 255); - x[3] := AnsiChar((y shr 16) and 255); - x[4] := AnsiChar((y shr 24) and 255); - - if not VirtualProtect(Pointer(x), 6, ov, @ov2) then - RaiseLastOSError; -end; - -procedure RestoreProcedure(OriginalProc: Pointer; Data: TOverwrittenData); -var - ov, ov2: Cardinal; -begin - if Data.Location <> nil then begin - if not VirtualProtect(Data.Location, 6, PAGE_EXECUTE_READWRITE, @ov) then - RaiseLastOSError; - Move(Data.OldCode, Data.Location^, 6); - if not VirtualProtect(Data.Location, 6, ov, @ov2) then - RaiseLastOSError; - end; -end; - -function Addr_System_EndThread: Pointer; -begin - Result := @System.EndThread; -end; - -function Addr_System_LoadResString: Pointer; -begin - Result := @System.LoadResString{TNT-ALLOW LoadResString}; -end; - -function Addr_System_WStrFromPCharLen: Pointer; -asm - mov eax, offset System.@WStrFromPCharLen; -end; - -{$IFNDEF COMPILER_9_UP} -function Addr_System_LStrFromPWCharLen: Pointer; -asm - mov eax, offset System.@LStrFromPWCharLen; -end; - -function Addr_System_WStrToString: Pointer; -asm - mov eax, offset System.@WStrToString; -end; -{$ENDIF} - -function Addr_System_VarFromLStr: Pointer; -asm - mov eax, offset System.@VarFromLStr; -end; - -function Addr_System_WStrCat3: Pointer; -asm - mov eax, offset System.@WStrCat3; -end; - -var - System_EndThread_Code, - System_LoadResString_Code, - System_WStrFromPCharLen_Code, - {$IFNDEF COMPILER_9_UP} - System_LStrFromPWCharLen_Code, - System_WStrToString_Code, - {$ENDIF} - System_VarFromLStr_Code - {$IFNDEF COMPILER_9_UP} - , - System_WStrCat3_Code, - SysUtils_WideFmtStr_Code - {$ENDIF} - : TOverwrittenData; - -procedure InstallEndThreadOverride; -begin - OverwriteProcedure(Addr_System_EndThread, @Custom_System_EndThread, @System_EndThread_Code); -end; - -procedure InstallStringConversionOverrides; -begin - OverwriteProcedure(Addr_System_WStrFromPCharLen, @Custom_System_WStrFromPCharLen, @System_WStrFromPCharLen_Code); - {$IFNDEF COMPILER_9_UP} - OverwriteProcedure(Addr_System_LStrFromPWCharLen, @Custom_System_LStrFromPWCharLen, @System_LStrFromPWCharLen_Code); - OverwriteProcedure(Addr_System_WStrToString, @Custom_System_WStrToString, @System_WStrToString_Code); - {$ENDIF} -end; - -procedure InstallWideResourceStrings; -begin - OverwriteProcedure(Addr_System_LoadResString, @Custom_System_LoadResString, @System_LoadResString_Code); - OverwriteProcedure(Addr_System_VarFromLStr, @Custom_System_VarFromLStr, @System_VarFromLStr_Code); -end; - -{$IFNDEF COMPILER_9_UP} -procedure InstallWideStringConcatenationFix; -begin - OverwriteProcedure(Addr_System_WStrCat3, @Custom_System_WStrCat3, @System_WStrCat3_Code); -end; - -procedure InstallWideFormatFixes; -begin - OverwriteProcedure(@SysUtils.WideFmtStr, @TntSysUtils.Tnt_WideFmtStr, @SysUtils_WideFmtStr_Code); -end; -{$ENDIF} - -procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates); -begin - InstallEndThreadOverride; - if tsWideResourceStrings in Updates then begin - InstallStringConversionOverrides; - InstallWideResourceStrings; - end; - {$IFNDEF COMPILER_9_UP} - if tsFixImplicitCodePage in Updates then begin - InstallStringConversionOverrides; - { CP_ACP is the code page used by the non-Unicode Windows API. } - GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP}; - end; - if tsFixWideStrConcat in Updates then begin - InstallWideStringConcatenationFix; - end; - if tsFixWideFormat in Updates then begin - InstallWideFormatFixes; - end; - {$ENDIF} -end; - -{$IFNDEF COMPILER_9_UP} -var - StartupDefaultUserCodePage: Cardinal; -{$ENDIF} - -procedure UninstallSystemOverrides; -begin - RestoreProcedure(Addr_System_EndThread, System_EndThread_Code); - // String Conversion - RestoreProcedure(Addr_System_WStrFromPCharLen, System_WStrFromPCharLen_Code); - {$IFNDEF COMPILER_9_UP} - RestoreProcedure(Addr_System_LStrFromPWCharLen, System_LStrFromPWCharLen_Code); - RestoreProcedure(Addr_System_WStrToString, System_WStrToString_Code); - GDefaultSystemCodePage := StartupDefaultUserCodePage; - {$ENDIF} - // Wide resourcestring - RestoreProcedure(Addr_System_LoadResString, System_LoadResString_Code); - RestoreProcedure(Addr_System_VarFromLStr, System_VarFromLStr_Code); - {$IFNDEF COMPILER_9_UP} - // WideString concat fix - RestoreProcedure(Addr_System_WStrCat3, System_WStrCat3_Code); - // WideFormat fixes - RestoreProcedure(@SysUtils.WideFmtStr, SysUtils_WideFmtStr_Code); - {$ENDIF} -end; - -{$ENDIF USE_SYSTEM_OVERRIDES} - -initialization - {$IFDEF COMPILER_9_UP} - {$DEFINE USE_GETACP} - {$ENDIF} - {$IFDEF FPC} - {$DEFINE USE_GETACP} - {$ENDIF} - {$IFDEF USE_GETACP} - GDefaultSystemCodePage := GetACP; - {$ELSE} - {$IFDEF COMPILER_7_UP} - if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5) then - GDefaultSystemCodePage := CP_THREAD_ACP // Win 2K/XP/... - else - GDefaultSystemCodePage := LCIDToCodePage(GetThreadLocale); // Win NT4/95/98/ME - {$ELSE} - GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP}; - {$ENDIF} - {$ENDIF} - {$IFDEF USE_SYSTEM_OVERRIDES} - {$IFNDEF COMPILER_9_UP} - StartupDefaultUserCodePage := DefaultSystemCodePage; - {$ENDIF} - IsDebugging := DebugHook > 0; - {$ENDIF USE_SYSTEM_OVERRIDES} - -finalization - {$IFDEF USE_SYSTEM_OVERRIDES} - UninstallSystemOverrides; - FreeTntSystemThreadVars; { Make MemorySleuth happy. } - {$ENDIF USE_SYSTEM_OVERRIDES} - -end. diff --git a/src/lib/TntUnicodeControls/TntWideStrUtils.pas b/src/lib/TntUnicodeControls/TntWideStrUtils.pas deleted file mode 100644 index 99f63aea..00000000 --- a/src/lib/TntUnicodeControls/TntWideStrUtils.pas +++ /dev/null @@ -1,455 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 TntWideStrUtils; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -interface - -{ Wide string manipulation functions } - -{$IFNDEF COMPILER_9_UP} -function WStrAlloc(Size: Cardinal): PWideChar; -function WStrBufSize(const Str: PWideChar): Cardinal; -{$ENDIF} -{$IFNDEF COMPILER_10_UP} -function WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Cardinal): PWideChar; -{$ENDIF} -{$IFNDEF COMPILER_9_UP} -function WStrNew(const Str: PWideChar): PWideChar; -procedure WStrDispose(Str: PWideChar); -{$ENDIF} -//--------------------------------------------------------------------------------------------- -{$IFNDEF COMPILER_9_UP} -function WStrLen(Str: PWideChar): Cardinal; -function WStrEnd(Str: PWideChar): PWideChar; -{$ENDIF} -{$IFNDEF COMPILER_10_UP} -function WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar; -{$ENDIF} -{$IFNDEF COMPILER_9_UP} -function WStrCopy(Dest, Source: PWideChar): PWideChar; -function WStrLCopy(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar; -function WStrPCopy(Dest: PWideChar; const Source: WideString): PWideChar; -function WStrPLCopy(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar; -{$ENDIF} -{$IFNDEF COMPILER_10_UP} -function WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar; -// WStrComp and WStrPos were introduced as broken in Delphi 2006, but fixed in Delphi 2006 Update 2 -function WStrComp(Str1, Str2: PWideChar): Integer; -function WStrPos(Str, SubStr: PWideChar): PWideChar; -{$ENDIF} -function Tnt_WStrComp(Str1, Str2: PWideChar): Integer; deprecated; -function Tnt_WStrPos(Str, SubStr: PWideChar): PWideChar; deprecated; - -{ ------------ introduced --------------- } -function WStrECopy(Dest, Source: PWideChar): PWideChar; -function WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; -function WStrLIComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; -function WStrIComp(Str1, Str2: PWideChar): Integer; -function WStrLower(Str: PWideChar): PWideChar; -function WStrUpper(Str: PWideChar): PWideChar; -function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; -function WStrLCat(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar; -function WStrPas(const Str: PWideChar): WideString; - -{ SysUtils.pas } //------------------------------------------------------------------------- - -{$IFNDEF COMPILER_10_UP} -function WideLastChar(const S: WideString): PWideChar; -function WideQuotedStr(const S: WideString; Quote: WideChar): WideString; -{$ENDIF} -{$IFNDEF COMPILER_9_UP} -function WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): Widestring; -{$ENDIF} -{$IFNDEF COMPILER_10_UP} -function WideDequotedStr(const S: WideString; AQuote: WideChar): WideString; -{$ENDIF} - -implementation - -uses - {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} Math, Windows, TntWindows; - -{$IFNDEF COMPILER_9_UP} -function WStrAlloc(Size: Cardinal): PWideChar; -begin - Size := SizeOf(Cardinal) + (Size * SizeOf(WideChar)); - GetMem(Result, Size); - PCardinal(Result)^ := Size; - Inc(PAnsiChar(Result), SizeOf(Cardinal)); -end; - -function WStrBufSize(const Str: PWideChar): Cardinal; -var - P: PWideChar; -begin - P := Str; - Dec(PAnsiChar(P), SizeOf(Cardinal)); - Result := PCardinal(P)^ - SizeOf(Cardinal); - Result := Result div SizeOf(WideChar); -end; -{$ENDIF} - -{$IFNDEF COMPILER_10_UP} -function WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Cardinal): PWideChar; -var - Length: Integer; -begin - Result := Dest; - Length := Count * SizeOf(WideChar); - Move(Source^, Dest^, Length); -end; -{$ENDIF} - -{$IFNDEF COMPILER_9_UP} -function WStrNew(const Str: PWideChar): PWideChar; -var - Size: Cardinal; -begin - if Str = nil then Result := nil else - begin - Size := WStrLen(Str) + 1; - Result := WStrMove(WStrAlloc(Size), Str, Size); - end; -end; - -procedure WStrDispose(Str: PWideChar); -begin - if Str <> nil then - begin - Dec(PAnsiChar(Str), SizeOf(Cardinal)); - FreeMem(Str, Cardinal(Pointer(Str)^)); - end; -end; -{$ENDIF} - -//--------------------------------------------------------------------------------------------- - -{$IFNDEF COMPILER_9_UP} -function WStrLen(Str: PWideChar): Cardinal; -begin - Result := WStrEnd(Str) - Str; -end; - -function WStrEnd(Str: PWideChar): PWideChar; -begin - // returns a pointer to the end of a null terminated string - Result := Str; - While Result^ <> #0 do - Inc(Result); -end; -{$ENDIF} - -{$IFNDEF COMPILER_10_UP} -function WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar; -begin - Result := Dest; - WStrCopy(WStrEnd(Dest), Source); -end; -{$ENDIF} - -{$IFNDEF COMPILER_9_UP} -function WStrCopy(Dest, Source: PWideChar): PWideChar; -begin - Result := WStrLCopy(Dest, Source, MaxInt); -end; - -function WStrLCopy(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar; -var - Count: Cardinal; -begin - // copies a specified maximum number of characters from Source to Dest - Result := Dest; - Count := 0; - While (Count < MaxLen) and (Source^ <> #0) do begin - Dest^ := Source^; - Inc(Source); - Inc(Dest); - Inc(Count); - end; - Dest^ := #0; -end; - -function WStrPCopy(Dest: PWideChar; const Source: WideString): PWideChar; -begin - Result := WStrLCopy(Dest, PWideChar(Source), Length(Source)); -end; - -function WStrPLCopy(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar; -begin - Result := WStrLCopy(Dest, PWideChar(Source), MaxLen); -end; -{$ENDIF} - -{$IFNDEF COMPILER_10_UP} -function WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar; -begin - Result := Str; - while Result^ <> Chr do - begin - if Result^ = #0 then - begin - Result := nil; - Exit; - end; - Inc(Result); - end; -end; - -function WStrComp(Str1, Str2: PWideChar): Integer; -begin - Result := WStrLComp(Str1, Str2, MaxInt); -end; - -function WStrPos(Str, SubStr: PWideChar): PWideChar; -var - PSave: PWideChar; - P: PWideChar; - PSub: PWideChar; -begin - // returns a pointer to the first occurance of SubStr in Str - Result := nil; - if (Str <> nil) and (Str^ <> #0) and (SubStr <> nil) and (SubStr^ <> #0) then begin - P := Str; - While P^ <> #0 do begin - if P^ = SubStr^ then begin - // investigate possibility here - PSave := P; - PSub := SubStr; - While (P^ = PSub^) do begin - Inc(P); - Inc(PSub); - if (PSub^ = #0) then begin - Result := PSave; - exit; // found a match - end; - if (P^ = #0) then - exit; // no match, hit end of string - end; - P := PSave; - end; - Inc(P); - end; - end; -end; -{$ENDIF} - -function Tnt_WStrComp(Str1, Str2: PWideChar): Integer; deprecated; -begin - Result := WStrComp(Str1, Str2); -end; - -function Tnt_WStrPos(Str, SubStr: PWideChar): PWideChar; deprecated; -begin - Result := WStrPos(Str, SubStr); -end; - -//------------------------------------------------------------------------------ - -function WStrECopy(Dest, Source: PWideChar): PWideChar; -begin - Result := WStrEnd(WStrCopy(Dest, Source)); -end; - -function WStrComp_EX(Str1, Str2: PWideChar; MaxLen: Cardinal; dwCmpFlags: Cardinal): Integer; -var - Len1, Len2: Integer; -begin - if MaxLen = Cardinal(MaxInt) then begin - Len1 := -1; - Len2 := -1; - end else begin - Len1 := Min(WStrLen(Str1), MaxLen); - Len2 := Min(WStrLen(Str2), MaxLen); - end; - Result := Tnt_CompareStringW(GetThreadLocale, dwCmpFlags, Str1, Len1, Str2, Len2) - 2; -end; - -function WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; -begin - Result := WStrComp_EX(Str1, Str2, MaxLen, 0); -end; - -function WStrLIComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; -begin - Result := WStrComp_EX(Str1, Str2, MaxLen, NORM_IGNORECASE); -end; - -function WStrIComp(Str1, Str2: PWideChar): Integer; -begin - Result := WStrLIComp(Str1, Str2, MaxInt); -end; - -function WStrLower(Str: PWideChar): PWideChar; -begin - Result := Str; - Tnt_CharLowerBuffW(Str, WStrLen(Str)) -end; - -function WStrUpper(Str: PWideChar): PWideChar; -begin - Result := Str; - Tnt_CharUpperBuffW(Str, WStrLen(Str)) -end; - -function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; -var - MostRecentFound: PWideChar; -begin - if Chr = #0 then - Result := WStrEnd(Str) - else - begin - Result := nil; - MostRecentFound := Str; - while True do - begin - while MostRecentFound^ <> Chr do - begin - if MostRecentFound^ = #0 then - Exit; - Inc(MostRecentFound); - end; - Result := MostRecentFound; - Inc(MostRecentFound); - end; - end; -end; - -function WStrLCat(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar; -begin - Result := Dest; - WStrLCopy(WStrEnd(Dest), Source, MaxLen - WStrLen(Dest)); -end; - -function WStrPas(const Str: PWideChar): WideString; -begin - Result := Str; -end; - -//--------------------------------------------------------------------------------------------- - -{$IFNDEF COMPILER_10_UP} -function WideLastChar(const S: WideString): PWideChar; -begin - if S = '' then - Result := nil - else - Result := @S[Length(S)]; -end; - -function WideQuotedStr(const S: WideString; Quote: WideChar): WideString; -var - P, Src, - Dest: PWideChar; - AddCount: Integer; -begin - AddCount := 0; - P := WStrScan(PWideChar(S), Quote); - while (P <> nil) do - begin - Inc(P); - Inc(AddCount); - P := WStrScan(P, Quote); - end; - - if AddCount = 0 then - Result := Quote + S + Quote - else - begin - SetLength(Result, Length(S) + AddCount + 2); - Dest := PWideChar(Result); - Dest^ := Quote; - Inc(Dest); - Src := PWideChar(S); - P := WStrScan(Src, Quote); - repeat - Inc(P); - Move(Src^, Dest^, 2 * (P - Src)); - Inc(Dest, P - Src); - Dest^ := Quote; - Inc(Dest); - Src := P; - P := WStrScan(Src, Quote); - until P = nil; - P := WStrEnd(Src); - Move(Src^, Dest^, 2 * (P - Src)); - Inc(Dest, P - Src); - Dest^ := Quote; - end; -end; -{$ENDIF} - -{$IFNDEF COMPILER_9_UP} -function WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): Widestring; -var - P, Dest: PWideChar; - DropCount: Integer; -begin - Result := ''; - if (Src = nil) or (Src^ <> Quote) then Exit; - Inc(Src); - DropCount := 1; - P := Src; - Src := WStrScan(Src, Quote); - while Src <> nil do // count adjacent pairs of quote chars - begin - Inc(Src); - if Src^ <> Quote then Break; - Inc(Src); - Inc(DropCount); - Src := WStrScan(Src, Quote); - end; - if Src = nil then Src := WStrEnd(P); - if ((Src - P) <= 1) then Exit; - if DropCount = 1 then - SetString(Result, P, Src - P - 1) - else - begin - SetLength(Result, Src - P - DropCount); - Dest := PWideChar(Result); - Src := WStrScan(P, Quote); - while Src <> nil do - begin - Inc(Src); - if Src^ <> Quote then Break; - Move(P^, Dest^, (Src - P) * SizeOf(WideChar)); - Inc(Dest, Src - P); - Inc(Src); - P := Src; - Src := WStrScan(Src, Quote); - end; - if Src = nil then Src := WStrEnd(P); - Move(P^, Dest^, (Src - P - 1) * SizeOf(WideChar)); - end; -end; -{$ENDIF} - -{$IFNDEF COMPILER_10_UP} -function WideDequotedStr(const S: WideString; AQuote: WideChar): WideString; -var - LText : PWideChar; -begin - LText := PWideChar(S); - Result := WideExtractQuotedStr(LText, AQuote); - if Result = '' then - Result := S; -end; -{$ENDIF} - - -end. diff --git a/src/lib/TntUnicodeControls/TntWideStrings.pas b/src/lib/TntUnicodeControls/TntWideStrings.pas deleted file mode 100644 index 75132d22..00000000 --- a/src/lib/TntUnicodeControls/TntWideStrings.pas +++ /dev/null @@ -1,846 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 TntWideStrings; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -interface - -{$IFDEF COMPILER_10_UP} - {$MESSAGE FATAL 'Do not refer to TntWideStrings.pas. It works correctly in Delphi 2006.'} -{$ENDIF} - -uses - Classes; - -{******************************************************************************} -{ } -{ Delphi 2005 introduced TWideStrings in WideStrings.pas. } -{ Unfortunately, it was not ready for prime time. } -{ Setting CommaText is not consistent, and it relies on CharNextW } -{ Which is only available on Windows NT+. } -{ } -{******************************************************************************} - -type - TWideStrings = class; - -{ IWideStringsAdapter interface } -{ Maintains link between TWideStrings and IWideStrings implementations } - - IWideStringsAdapter = interface - ['{25FE0E3B-66CB-48AA-B23B-BCFA67E8F5DA}'] - procedure ReferenceStrings(S: TWideStrings); - procedure ReleaseStrings; - end; - - TWideStringsEnumerator = class - private - FIndex: Integer; - FStrings: TWideStrings; - public - constructor Create(AStrings: TWideStrings); - function GetCurrent: WideString; - function MoveNext: Boolean; - property Current: WideString read GetCurrent; - end; - -{$IFDEF FPC} - TStringsDefined = set of ( - sdDelimiter, sdQuoteChar, sdNameValueSeparator, sdLineBreak, - sdStrictDelimiter); -{$ENDIF} - -{$DEFINE NAMEVALUESEPARATOR_RW} -{$IFNDEF COMPILER_7_UP} - {$UNDEF NAMEVALUESEPARATOR_RW} -{$ENDIF} - -{ TWideStrings class } - - TWideStrings = class(TPersistent) - private - FDefined: TStringsDefined; - FDelimiter: WideChar; - FQuoteChar: WideChar; - {$IFDEF NAMEVALUESEPARATOR_RW} - FNameValueSeparator: WideChar; - {$ENDIF} - FUpdateCount: Integer; - FAdapter: IWideStringsAdapter; - function GetCommaText: WideString; - function GetDelimitedText: WideString; - function GetName(Index: Integer): WideString; - function GetValue(const Name: WideString): WideString; - procedure ReadData(Reader: TReader); - procedure SetCommaText(const Value: WideString); - procedure SetDelimitedText(const Value: WideString); - procedure SetStringsAdapter(const Value: IWideStringsAdapter); - procedure SetValue(const Name, Value: WideString); - procedure WriteData(Writer: TWriter); - function GetDelimiter: WideChar; - procedure SetDelimiter(const Value: WideChar); - function GetQuoteChar: WideChar; - procedure SetQuoteChar(const Value: WideChar); - function GetNameValueSeparator: WideChar; - {$IFDEF NAMEVALUESEPARATOR_RW} - procedure SetNameValueSeparator(const Value: WideChar); - {$ENDIF} - function GetValueFromIndex(Index: Integer): WideString; - procedure SetValueFromIndex(Index: Integer; const Value: WideString); - protected - procedure AssignTo(Dest: TPersistent); override; - procedure DefineProperties(Filer: TFiler); override; - procedure Error(const Msg: WideString; Data: Integer); overload; - procedure Error(Msg: PResStringRec; Data: Integer); overload; - function ExtractName(const S: WideString): WideString; - function Get(Index: Integer): WideString; virtual; abstract; - function GetCapacity: Integer; virtual; - function GetCount: Integer; virtual; abstract; - function GetObject(Index: Integer): TObject; virtual; - function GetTextStr: WideString; virtual; - procedure Put(Index: Integer; const S: WideString); virtual; - procedure PutObject(Index: Integer; AObject: TObject); virtual; - procedure SetCapacity(NewCapacity: Integer); virtual; - procedure SetTextStr(const Value: WideString); virtual; - procedure SetUpdateState(Updating: Boolean); virtual; - property UpdateCount: Integer read FUpdateCount; - function CompareStrings(const S1, S2: WideString): Integer; virtual; - public - destructor Destroy; override; - function Add(const S: WideString): Integer; virtual; - function AddObject(const S: WideString; AObject: TObject): Integer; virtual; - procedure Append(const S: WideString); - procedure AddStrings(Strings: TStrings{TNT-ALLOW TStrings}); overload; virtual; - procedure AddStrings(Strings: TWideStrings); overload; virtual; - procedure Assign(Source: TPersistent); override; - procedure BeginUpdate; - procedure Clear; virtual; abstract; - procedure Delete(Index: Integer); virtual; abstract; - procedure EndUpdate; - function Equals(Strings: TWideStrings): Boolean; - procedure Exchange(Index1, Index2: Integer); virtual; - function GetEnumerator: TWideStringsEnumerator; - function GetTextW: PWideChar; virtual; - function IndexOf(const S: WideString): Integer; virtual; - function IndexOfName(const Name: WideString): Integer; virtual; - function IndexOfObject(AObject: TObject): Integer; virtual; - procedure Insert(Index: Integer; const S: WideString); virtual; abstract; - procedure InsertObject(Index: Integer; const S: WideString; - AObject: TObject); virtual; - procedure LoadFromFile(const FileName: WideString); virtual; - procedure LoadFromStream(Stream: TStream); virtual; - procedure Move(CurIndex, NewIndex: Integer); virtual; - procedure SaveToFile(const FileName: WideString); virtual; - procedure SaveToStream(Stream: TStream); virtual; - procedure SetTextW(const Text: PWideChar); virtual; - property Capacity: Integer read GetCapacity write SetCapacity; - property CommaText: WideString read GetCommaText write SetCommaText; - property Count: Integer read GetCount; - property Delimiter: WideChar read GetDelimiter write SetDelimiter; - property DelimitedText: WideString read GetDelimitedText write SetDelimitedText; - property Names[Index: Integer]: WideString read GetName; - property Objects[Index: Integer]: TObject read GetObject write PutObject; - property QuoteChar: WideChar read GetQuoteChar write SetQuoteChar; - property Values[const Name: WideString]: WideString read GetValue write SetValue; - property ValueFromIndex[Index: Integer]: WideString read GetValueFromIndex write SetValueFromIndex; - property NameValueSeparator: WideChar read GetNameValueSeparator {$IFDEF NAMEVALUESEPARATOR_RW} write SetNameValueSeparator {$ENDIF}; - property Strings[Index: Integer]: WideString read Get write Put; default; - property Text: WideString read GetTextStr write SetTextStr; - property StringsAdapter: IWideStringsAdapter read FAdapter write SetStringsAdapter; - end; - - PWideStringItem = ^TWideStringItem; - TWideStringItem = record - FString: WideString; - FObject: TObject; - end; - - PWideStringItemList = ^TWideStringItemList; - TWideStringItemList = array[0..MaxListSize] of TWideStringItem; - -implementation - -uses - Windows, SysUtils, TntSystem, {$IFDEF COMPILER_9_UP} WideStrUtils, {$ELSE} TntWideStrUtils, {$ENDIF} - TntSysUtils, TntClasses; - -{ TWideStringsEnumerator } - -constructor TWideStringsEnumerator.Create(AStrings: TWideStrings); -begin - inherited Create; - FIndex := -1; - FStrings := AStrings; -end; - -function TWideStringsEnumerator.GetCurrent: WideString; -begin - Result := FStrings[FIndex]; -end; - -function TWideStringsEnumerator.MoveNext: Boolean; -begin - Result := FIndex < FStrings.Count - 1; - if Result then - Inc(FIndex); -end; - -{ TWideStrings } - -destructor TWideStrings.Destroy; -begin - StringsAdapter := nil; - inherited; -end; - -function TWideStrings.Add(const S: WideString): Integer; -begin - Result := GetCount; - Insert(Result, S); -end; - -function TWideStrings.AddObject(const S: WideString; AObject: TObject): Integer; -begin - Result := Add(S); - PutObject(Result, AObject); -end; - -procedure TWideStrings.Append(const S: WideString); -begin - Add(S); -end; - -procedure TWideStrings.AddStrings(Strings: TStrings{TNT-ALLOW TStrings}); -var - I: Integer; -begin - BeginUpdate; - try - for I := 0 to Strings.Count - 1 do - AddObject(Strings[I], Strings.Objects[I]); - finally - EndUpdate; - end; -end; - -procedure TWideStrings.AddStrings(Strings: TWideStrings); -var - I: Integer; -begin - BeginUpdate; - try - for I := 0 to Strings.Count - 1 do - AddObject(Strings[I], Strings.Objects[I]); - finally - EndUpdate; - end; -end; - -procedure TWideStrings.Assign(Source: TPersistent); -begin - if Source is TWideStrings then - begin - BeginUpdate; - try - Clear; - FDefined := TWideStrings(Source).FDefined; - {$IFDEF NAMEVALUESEPARATOR_RW} - FNameValueSeparator := TWideStrings(Source).FNameValueSeparator; - {$ENDIF} - FQuoteChar := TWideStrings(Source).FQuoteChar; - FDelimiter := TWideStrings(Source).FDelimiter; - AddStrings(TWideStrings(Source)); - finally - EndUpdate; - end; - end - else if Source is TStrings{TNT-ALLOW TStrings} then - begin - BeginUpdate; - try - Clear; - {$IFDEF NAMEVALUESEPARATOR_RW} - FNameValueSeparator := WideChar(TStrings{TNT-ALLOW TStrings}(Source).NameValueSeparator); - {$ENDIF} - FQuoteChar := WideChar(TStrings{TNT-ALLOW TStrings}(Source).QuoteChar); - FDelimiter := WideChar(TStrings{TNT-ALLOW TStrings}(Source).Delimiter); - AddStrings(TStrings{TNT-ALLOW TStrings}(Source)); - finally - EndUpdate; - end; - end - else - inherited Assign(Source); -end; - -procedure TWideStrings.AssignTo(Dest: TPersistent); -var - I: Integer; -begin - if Dest is TWideStrings then Dest.Assign(Self) - else if Dest is TStrings{TNT-ALLOW TStrings} then - begin - TStrings{TNT-ALLOW TStrings}(Dest).BeginUpdate; - try - TStrings{TNT-ALLOW TStrings}(Dest).Clear; - {$IFDEF NAMEVALUESEPARATOR_RW} - TStrings{TNT-ALLOW TStrings}(Dest).NameValueSeparator := AnsiChar(NameValueSeparator); - {$ENDIF} - TStrings{TNT-ALLOW TStrings}(Dest).QuoteChar := AnsiChar(QuoteChar); - TStrings{TNT-ALLOW TStrings}(Dest).Delimiter := AnsiChar(Delimiter); - for I := 0 to Count - 1 do - TStrings{TNT-ALLOW TStrings}(Dest).AddObject(Strings[I], Objects[I]); - finally - TStrings{TNT-ALLOW TStrings}(Dest).EndUpdate; - end; - end - else - inherited AssignTo(Dest); -end; - -procedure TWideStrings.BeginUpdate; -begin - if FUpdateCount = 0 then SetUpdateState(True); - Inc(FUpdateCount); -end; - -procedure TWideStrings.DefineProperties(Filer: TFiler); - - 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; - -begin - Filer.DefineProperty('Strings', ReadData, WriteData, DoWrite); -end; - -procedure TWideStrings.EndUpdate; -begin - Dec(FUpdateCount); - if FUpdateCount = 0 then SetUpdateState(False); -end; - -function TWideStrings.Equals(Strings: TWideStrings): Boolean; -var - I, Count: Integer; -begin - Result := False; - Count := GetCount; - if Count <> Strings.GetCount then Exit; - for I := 0 to Count - 1 do if Get(I) <> Strings.Get(I) then Exit; - Result := True; -end; - -procedure TWideStrings.Error(const Msg: WideString; Data: Integer); - - function ReturnAddr: Pointer; - asm - MOV EAX,[EBP+4] - end; - -begin - raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr; -end; - -procedure TWideStrings.Error(Msg: PResStringRec; Data: Integer); -begin - Error(WideLoadResString(Msg), Data); -end; - -procedure TWideStrings.Exchange(Index1, Index2: Integer); -var - TempObject: TObject; - TempString: WideString; -begin - BeginUpdate; - try - TempString := Strings[Index1]; - TempObject := Objects[Index1]; - Strings[Index1] := Strings[Index2]; - Objects[Index1] := Objects[Index2]; - Strings[Index2] := TempString; - Objects[Index2] := TempObject; - finally - EndUpdate; - end; -end; - -function TWideStrings.ExtractName(const S: WideString): WideString; -var - P: Integer; -begin - Result := S; - P := Pos(NameValueSeparator, Result); - if P <> 0 then - SetLength(Result, P-1) else - SetLength(Result, 0); -end; - -function TWideStrings.GetCapacity: Integer; -begin // descendents may optionally override/replace this default implementation - Result := Count; -end; - -function TWideStrings.GetCommaText: WideString; -var - LOldDefined: TStringsDefined; - LOldDelimiter: WideChar; - LOldQuoteChar: WideChar; -begin - LOldDefined := FDefined; - LOldDelimiter := FDelimiter; - LOldQuoteChar := FQuoteChar; - Delimiter := ','; - QuoteChar := '"'; - try - Result := GetDelimitedText; - finally - FDelimiter := LOldDelimiter; - FQuoteChar := LOldQuoteChar; - FDefined := LOldDefined; - end; -end; - -function TWideStrings.GetDelimitedText: WideString; -var - S: WideString; - P: PWideChar; - I, Count: Integer; -begin - Count := GetCount; - if (Count = 1) and (Get(0) = '') then - Result := WideString(QuoteChar) + QuoteChar - else - begin - Result := ''; - for I := 0 to Count - 1 do - begin - S := Get(I); - P := PWideChar(S); - while not ((P^ in [WideChar(#0)..WideChar(' ')]) or (P^ = QuoteChar) or (P^ = Delimiter)) do - Inc(P); - if (P^ <> #0) then S := WideQuotedStr(S, QuoteChar); - Result := Result + S + Delimiter; - end; - System.Delete(Result, Length(Result), 1); - end; -end; - -function TWideStrings.GetName(Index: Integer): WideString; -begin - Result := ExtractName(Get(Index)); -end; - -function TWideStrings.GetObject(Index: Integer): TObject; -begin - Result := nil; -end; - -function TWideStrings.GetEnumerator: TWideStringsEnumerator; -begin - Result := TWideStringsEnumerator.Create(Self); -end; - -function TWideStrings.GetTextW: PWideChar; -begin - Result := WStrNew(PWideChar(GetTextStr)); -end; - -function TWideStrings.GetTextStr: WideString; -var - I, L, Size, Count: Integer; - P: PWideChar; - S, LB: WideString; -begin - Count := GetCount; - Size := 0; - LB := sLineBreak; - for I := 0 to Count - 1 do Inc(Size, Length(Get(I)) + Length(LB)); - SetString(Result, nil, Size); - P := Pointer(Result); - for I := 0 to Count - 1 do - begin - S := Get(I); - L := Length(S); - if L <> 0 then - begin - System.Move(Pointer(S)^, P^, L * SizeOf(WideChar)); - Inc(P, L); - end; - L := Length(LB); - if L <> 0 then - begin - System.Move(Pointer(LB)^, P^, L * SizeOf(WideChar)); - Inc(P, L); - end; - end; -end; - -function TWideStrings.GetValue(const Name: WideString): WideString; -var - I: Integer; -begin - I := IndexOfName(Name); - if I >= 0 then - Result := Copy(Get(I), Length(Name) + 2, MaxInt) else - Result := ''; -end; - -function TWideStrings.IndexOf(const S: WideString): Integer; -begin - for Result := 0 to GetCount - 1 do - if CompareStrings(Get(Result), S) = 0 then Exit; - Result := -1; -end; - -function TWideStrings.IndexOfName(const Name: WideString): Integer; -var - P: Integer; - S: WideString; -begin - for Result := 0 to GetCount - 1 do - begin - S := Get(Result); - P := Pos(NameValueSeparator, S); - if (P <> 0) and (CompareStrings(Copy(S, 1, P - 1), Name) = 0) then Exit; - end; - Result := -1; -end; - -function TWideStrings.IndexOfObject(AObject: TObject): Integer; -begin - for Result := 0 to GetCount - 1 do - if GetObject(Result) = AObject then Exit; - Result := -1; -end; - -procedure TWideStrings.InsertObject(Index: Integer; const S: WideString; - AObject: TObject); -begin - Insert(Index, S); - PutObject(Index, AObject); -end; - -procedure TWideStrings.LoadFromFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TWideStrings.LoadFromStream(Stream: TStream); -var - Size: Integer; - S: WideString; -begin - BeginUpdate; - try - Size := Stream.Size - Stream.Position; - SetString(S, nil, Size div SizeOf(WideChar)); - Stream.Read(Pointer(S)^, Length(S) * SizeOf(WideChar)); - SetTextStr(S); - finally - EndUpdate; - end; -end; - -procedure TWideStrings.Move(CurIndex, NewIndex: Integer); -var - TempObject: TObject; - TempString: WideString; -begin - if CurIndex <> NewIndex then - begin - BeginUpdate; - try - TempString := Get(CurIndex); - TempObject := GetObject(CurIndex); - Delete(CurIndex); - InsertObject(NewIndex, TempString, TempObject); - finally - EndUpdate; - end; - end; -end; - -procedure TWideStrings.Put(Index: Integer; const S: WideString); -var - TempObject: TObject; -begin - TempObject := GetObject(Index); - Delete(Index); - InsertObject(Index, S, TempObject); -end; - -procedure TWideStrings.PutObject(Index: Integer; AObject: TObject); -begin -end; - -procedure TWideStrings.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 TWideStrings.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TWideStrings.SaveToStream(Stream: TStream); -var - SW: WideString; -begin - SW := GetTextStr; - Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar)); -end; - -procedure TWideStrings.SetCapacity(NewCapacity: Integer); -begin - // do nothing - descendents may optionally implement this method -end; - -procedure TWideStrings.SetCommaText(const Value: WideString); -begin - Delimiter := ','; - QuoteChar := '"'; - SetDelimitedText(Value); -end; - -procedure TWideStrings.SetStringsAdapter(const Value: IWideStringsAdapter); -begin - if FAdapter <> nil then FAdapter.ReleaseStrings; - FAdapter := Value; - if FAdapter <> nil then FAdapter.ReferenceStrings(Self); -end; - -procedure TWideStrings.SetTextW(const Text: PWideChar); -begin - SetTextStr(Text); -end; - -procedure TWideStrings.SetTextStr(const Value: WideString); -var - P, Start: PWideChar; - S: WideString; -begin - BeginUpdate; - try - Clear; - P := Pointer(Value); - if P <> nil then - while P^ <> #0 do - begin - Start := P; - while not (P^ in [WideChar(#0), WideChar(#10), WideChar(#13)]) and (P^ <> WideLineSeparator) do - Inc(P); - SetString(S, Start, P - Start); - Add(S); - if P^ = #13 then Inc(P); - if P^ = #10 then Inc(P); - if P^ = WideLineSeparator then Inc(P); - end; - finally - EndUpdate; - end; -end; - -procedure TWideStrings.SetUpdateState(Updating: Boolean); -begin -end; - -procedure TWideStrings.SetValue(const Name, Value: WideString); -var - I: Integer; -begin - I := IndexOfName(Name); - if Value <> '' then - begin - if I < 0 then I := Add(''); - Put(I, Name + NameValueSeparator + Value); - end else - begin - if I >= 0 then Delete(I); - end; -end; - -procedure TWideStrings.WriteData(Writer: TWriter); -var - I: Integer; -begin - Writer.WriteListBegin; - for I := 0 to Count-1 do begin - Writer.WriteWideString(Get(I)); - end; - Writer.WriteListEnd; -end; - -procedure TWideStrings.SetDelimitedText(const Value: WideString); -var - P, P1: PWideChar; - S: WideString; -begin - BeginUpdate; - try - Clear; - P := PWideChar(Value); - while P^ in [WideChar(#1)..WideChar(' ')] do - Inc(P); - while P^ <> #0 do - begin - if P^ = QuoteChar then - S := WideExtractQuotedStr(P, QuoteChar) - else - begin - P1 := P; - while (P^ > ' ') and (P^ <> Delimiter) do - Inc(P); - SetString(S, P1, P - P1); - end; - Add(S); - while P^ in [WideChar(#1)..WideChar(' ')] do - Inc(P); - if P^ = Delimiter then - begin - P1 := P; - Inc(P1); - if P1^ = #0 then - Add(''); - repeat - Inc(P); - until not (P^ in [WideChar(#1)..WideChar(' ')]); - end; - end; - finally - EndUpdate; - end; -end; - -function TWideStrings.GetDelimiter: WideChar; -begin - if not (sdDelimiter in FDefined) then - Delimiter := ','; - Result := FDelimiter; -end; - -function TWideStrings.GetQuoteChar: WideChar; -begin - if not (sdQuoteChar in FDefined) then - QuoteChar := '"'; - Result := FQuoteChar; -end; - -procedure TWideStrings.SetDelimiter(const Value: WideChar); -begin - if (FDelimiter <> Value) or not (sdDelimiter in FDefined) then - begin - Include(FDefined, sdDelimiter); - FDelimiter := Value; - end -end; - -procedure TWideStrings.SetQuoteChar(const Value: WideChar); -begin - if (FQuoteChar <> Value) or not (sdQuoteChar in FDefined) then - begin - Include(FDefined, sdQuoteChar); - FQuoteChar := Value; - end -end; - -function TWideStrings.CompareStrings(const S1, S2: WideString): Integer; -begin - Result := WideCompareText(S1, S2); -end; - -function TWideStrings.GetNameValueSeparator: WideChar; -begin - {$IFDEF NAMEVALUESEPARATOR_RW} - if not (sdNameValueSeparator in FDefined) then - NameValueSeparator := '='; - Result := FNameValueSeparator; - {$ELSE} - Result := '='; - {$ENDIF} -end; - -{$IFDEF NAMEVALUESEPARATOR_RW} -procedure TWideStrings.SetNameValueSeparator(const Value: WideChar); -begin - if (FNameValueSeparator <> Value) or not (sdNameValueSeparator in FDefined) then - begin - Include(FDefined, sdNameValueSeparator); - FNameValueSeparator := Value; - end -end; -{$ENDIF} - -function TWideStrings.GetValueFromIndex(Index: Integer): WideString; -begin - if Index >= 0 then - Result := Copy(Get(Index), Length(Names[Index]) + 2, MaxInt) else - Result := ''; -end; - -procedure TWideStrings.SetValueFromIndex(Index: Integer; const Value: WideString); -begin - if Value <> '' then - begin - if Index < 0 then Index := Add(''); - Put(Index, Names[Index] + NameValueSeparator + Value); - end - else - if Index >= 0 then Delete(Index); -end; - -end. diff --git a/src/lib/TntUnicodeControls/TntWindows.pas b/src/lib/TntUnicodeControls/TntWindows.pas deleted file mode 100644 index 8fd7ec88..00000000 --- a/src/lib/TntUnicodeControls/TntWindows.pas +++ /dev/null @@ -1,1501 +0,0 @@ - -{*****************************************************************************} -{ } -{ 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 TntWindows; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Windows, ShellApi, ShlObj; - -// ......... compatibility - -const - DT_NOFULLWIDTHCHARBREAK = $00080000; - -const - INVALID_FILE_ATTRIBUTES = DWORD(-1); - -// ................ ANSI TYPES ................ -{TNT-WARN LPSTR} -{TNT-WARN PLPSTR} -{TNT-WARN LPCSTR} -{TNT-WARN LPCTSTR} -{TNT-WARN LPTSTR} - -// ........ EnumResourceTypesW, EnumResourceNamesW and EnumResourceLanguagesW are supposed .... -// ........ to work on Win95/98/ME but have caused access violations in testing on Win95 ...... -// .. TNT--WARN EnumResourceTypes .. -// .. TNT--WARN EnumResourceTypesA .. -// .. TNT--WARN EnumResourceNames .. -// .. TNT--WARN EnumResourceNamesA .. -// .. TNT--WARN EnumResourceLanguages .. -// .. TNT--WARN EnumResourceLanguagesA .. - -//------------------------------------------------------------------------------------------ - -// ......... The Unicode form of these functions are supported on Windows 95/98/ME ......... -{TNT-WARN ExtTextOut} -{TNT-WARN ExtTextOutA} -{TNT-WARN Tnt_ExtTextOutW} - -{TNT-WARN FindResource} -{TNT-WARN FindResourceA} -{TNT-WARN Tnt_FindResourceW} - -{TNT-WARN FindResourceEx} -{TNT-WARN FindResourceExA} -{TNT-WARN Tnt_FindResourceExW} - -{TNT-WARN GetCharWidth} -{TNT-WARN GetCharWidthA} -{TNT-WARN Tnt_GetCharWidthW} - -{TNT-WARN GetCommandLine} -{TNT-WARN GetCommandLineA} -{TNT-WARN Tnt_GetCommandLineW} - -{TNT-WARN GetTextExtentPoint} -{TNT-WARN GetTextExtentPointA} -{TNT-WARN Tnt_GetTextExtentPointW} - -{TNT-WARN GetTextExtentPoint32} -{TNT-WARN GetTextExtentPoint32A} -{TNT-WARN Tnt_GetTextExtentPoint32W} - -{TNT-WARN lstrcat} -{TNT-WARN lstrcatA} -{TNT-WARN Tnt_lstrcatW} - -{TNT-WARN lstrcpy} -{TNT-WARN lstrcpyA} -{TNT-WARN Tnt_lstrcpyW} - -{TNT-WARN lstrlen} -{TNT-WARN lstrlenA} -{TNT-WARN Tnt_lstrlenW} - -{TNT-WARN MessageBox} -{TNT-WARN MessageBoxA} -{TNT-WARN Tnt_MessageBoxW} - -{TNT-WARN MessageBoxEx} -{TNT-WARN MessageBoxExA} -{TNT-WARN Tnt_MessageBoxExA} - -{TNT-WARN TextOut} -{TNT-WARN TextOutA} -{TNT-WARN Tnt_TextOutW} - -//------------------------------------------------------------------------------------------ - -{TNT-WARN LOCALE_USER_DEFAULT} // <-- use GetThreadLocale -{TNT-WARN LOCALE_SYSTEM_DEFAULT} // <-- use GetThreadLocale - -//------------------------------------------------------------------------------------------ -// compatiblity -//------------------------------------------------------------------------------------------ -{$IFNDEF COMPILER_9_UP} -type - {$IFDEF FPC} - TStartupInfoA = STARTUPINFO; - TStartupInfoW = STARTUPINFO; - {$ELSE} - TStartupInfoA = _STARTUPINFOA; - TStartupInfoW = record - cb: DWORD; - lpReserved: PWideChar; - lpDesktop: PWideChar; - lpTitle: PWideChar; - dwX: DWORD; - dwY: DWORD; - dwXSize: DWORD; - dwYSize: DWORD; - dwXCountChars: DWORD; - dwYCountChars: DWORD; - dwFillAttribute: DWORD; - dwFlags: DWORD; - wShowWindow: Word; - cbReserved2: Word; - lpReserved2: PByte; - hStdInput: THandle; - hStdOutput: THandle; - hStdError: THandle; - end; - {$ENDIF} - -function CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName: PWideChar; lpCommandLine: PWideChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; - var lpProcessInformation: TProcessInformation): BOOL; stdcall; external kernel32 name 'CreateProcessW'; - -{$ENDIF} - -{$IFDEF FPC} -type - TCurrencyFmtA = CURRENCYFMT; - TCurrencyFmtW = CURRENCYFMT; - PCurrencyFmtA = ^TCurrencyFmtA; - PCurrencyFmtW = ^TCurrencyFmtW; -{$ENDIF} - -//------------------------------------------------------------------------------------------ - -{TNT-WARN SetWindowText} -{TNT-WARN SetWindowTextA} -{TNT-WARN SetWindowTextW} -function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; - -{TNT-WARN RemoveDirectory} -{TNT-WARN RemoveDirectoryA} -{TNT-WARN RemoveDirectoryW} -function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; - -{TNT-WARN GetShortPathName} -{TNT-WARN GetShortPathNameA} -{TNT-WARN GetShortPathNameW} -function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; - cchBuffer: DWORD): DWORD; - -{TNT-WARN GetFullPathName} -{TNT-WARN GetFullPathNameA} -{TNT-WARN GetFullPathNameW} -function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; - lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; - -{TNT-WARN CreateFile} -{TNT-WARN CreateFileA} -{TNT-WARN CreateFileW} -function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; - lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; - hTemplateFile: THandle): THandle; - -{TNT-WARN FindFirstFile} -{TNT-WARN FindFirstFileA} -{TNT-WARN FindFirstFileW} -function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; - -{TNT-WARN FindNextFile} -{TNT-WARN FindNextFileA} -{TNT-WARN FindNextFileW} -function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; - -{TNT-WARN GetFileAttributes} -{TNT-WARN GetFileAttributesA} -{TNT-WARN GetFileAttributesW} -function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; - -{TNT-WARN SetFileAttributes} -{TNT-WARN SetFileAttributesA} -{TNT-WARN SetFileAttributesW} -function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; - -{TNT-WARN CreateDirectory} -{TNT-WARN CreateDirectoryA} -{TNT-WARN CreateDirectoryW} -function Tnt_CreateDirectoryW(lpPathName: PWideChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; - -{TNT-WARN MoveFile} -{TNT-WARN MoveFileA} -{TNT-WARN MoveFileW} -function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; - -{TNT-WARN CopyFile} -{TNT-WARN CopyFileA} -{TNT-WARN CopyFileW} -function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; - -{TNT-WARN DeleteFile} -{TNT-WARN DeleteFileA} -{TNT-WARN DeleteFileW} -function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; - -{TNT-WARN DrawText} -{TNT-WARN DrawTextA} -{TNT-WARN DrawTextW} -function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; - var lpRect: TRect; uFormat: UINT): Integer; - -{TNT-WARN GetDiskFreeSpace} -{TNT-WARN GetDiskFreeSpaceA} -{TNT-WARN GetDiskFreeSpaceW} -function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, - lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; - -{TNT-WARN GetVolumeInformation} -{TNT-WARN GetVolumeInformationA} -{TNT-WARN GetVolumeInformationW} -function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; - nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; - var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; - nFileSystemNameSize: DWORD): BOOL; - -{TNT-WARN GetModuleFileName} -{TNT-WARN GetModuleFileNameA} -{TNT-WARN GetModuleFileNameW} -function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; - -{TNT-WARN GetTempPath} -{TNT-WARN GetTempPathA} -{TNT-WARN GetTempPathW} -function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; - -{TNT-WARN GetTempFileName} -{TNT-WARN GetTempFileNameA} -{TNT-WARN GetTempFileNameW} -function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; - lpTempFileName: PWideChar): UINT; - -{TNT-WARN GetWindowsDirectory} -{TNT-WARN GetWindowsDirectoryA} -{TNT-WARN GetWindowsDirectoryW} -function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; - -{TNT-WARN GetSystemDirectory} -{TNT-WARN GetSystemDirectoryA} -{TNT-WARN GetSystemDirectoryW} -function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; - -{TNT-WARN GetCurrentDirectory} -{TNT-WARN GetCurrentDirectoryA} -{TNT-WARN GetCurrentDirectoryW} -function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; - -{TNT-WARN SetCurrentDirectory} -{TNT-WARN SetCurrentDirectoryA} -{TNT-WARN SetCurrentDirectoryW} -function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; - -{TNT-WARN GetComputerName} -{TNT-WARN GetComputerNameA} -{TNT-WARN GetComputerNameW} -function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; - -{TNT-WARN GetUserName} -{TNT-WARN GetUserNameA} -{TNT-WARN GetUserNameW} -function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; - -{TNT-WARN ShellExecute} -{TNT-WARN ShellExecuteA} -{TNT-WARN ShellExecuteW} -function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, - Directory: PWideChar; ShowCmd: Integer): HINST; - -{TNT-WARN LoadLibrary} -{TNT-WARN LoadLibraryA} -{TNT-WARN LoadLibraryW} -function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; - -{TNT-WARN LoadLibraryEx} -{TNT-WARN LoadLibraryExA} -{TNT-WARN LoadLibraryExW} -function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; - -{TNT-WARN CreateProcess} -{TNT-WARN CreateProcessA} -{TNT-WARN CreateProcessW} -function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; - var lpProcessInformation: TProcessInformation): BOOL; - -{TNT-WARN GetCurrencyFormat} -{TNT-WARN GetCurrencyFormatA} -{TNT-WARN GetCurrencyFormatW} -function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; - lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; - -{TNT-WARN CompareString} -{TNT-WARN CompareStringA} -{TNT-WARN CompareStringW} -function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; - cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; - -{TNT-WARN CharUpper} -{TNT-WARN CharUpperA} -{TNT-WARN CharUpperW} -function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; - -{TNT-WARN CharUpperBuff} -{TNT-WARN CharUpperBuffA} -{TNT-WARN CharUpperBuffW} -function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; - -{TNT-WARN CharLower} -{TNT-WARN CharLowerA} -{TNT-WARN CharLowerW} -function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; - -{TNT-WARN CharLowerBuff} -{TNT-WARN CharLowerBuffA} -{TNT-WARN CharLowerBuffW} -function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; - -{TNT-WARN GetStringTypeEx} -{TNT-WARN GetStringTypeExA} -{TNT-WARN GetStringTypeExW} -function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; - lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; - -{TNT-WARN LoadString} -{TNT-WARN LoadStringA} -{TNT-WARN LoadStringW} -function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; - -{$IFDEF FPC} -type - TMenuItemInfoW = TMENUITEMINFO; - tagMenuItemINFOW = tagMENUITEMINFO; -{$ENDIF} - -{TNT-WARN InsertMenuItem} -{TNT-WARN InsertMenuItemA} -{TNT-WARN InsertMenuItemW} -function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: tagMenuItemINFOW): BOOL; - -{TNT-WARN ExtractIconEx} -{TNT-WARN ExtractIconExA} -{TNT-WARN ExtractIconExW} -function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; - var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; - -{TNT-WARN ExtractAssociatedIcon} -{TNT-WARN ExtractAssociatedIconA} -{TNT-WARN ExtractAssociatedIconW} -function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; - var lpiIcon: Word): HICON; - -{TNT-WARN GetFileVersionInfoSize} -{TNT-WARN GetFileVersionInfoSizeA} -{TNT-WARN GetFileVersionInfoSizeW} -function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; - -{TNT-WARN GetFileVersionInfo} -{TNT-WARN GetFileVersionInfoA} -{TNT-WARN GetFileVersionInfoW} -function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; - lpData: Pointer): BOOL; - -const - VQV_FIXEDFILEINFO = '\'; - VQV_VARFILEINFO_TRANSLATION = '\VarFileInfo\Translation'; - VQV_STRINGFILEINFO = '\StringFileInfo'; - - VER_COMMENTS = 'Comments'; - VER_INTERNALNAME = 'InternalName'; - VER_PRODUCTNAME = 'ProductName'; - VER_COMPANYNAME = 'CompanyName'; - VER_LEGALCOPYRIGHT = 'LegalCopyright'; - VER_PRODUCTVERSION = 'ProductVersion'; - VER_FILEDESCRIPTION = 'FileDescription'; - VER_LEGALTRADEMARKS = 'LegalTrademarks'; - VER_PRIVATEBUILD = 'PrivateBuild'; - VER_FILEVERSION = 'FileVersion'; - VER_ORIGINALFILENAME = 'OriginalFilename'; - VER_SPECIALBUILD = 'SpecialBuild'; - -{TNT-WARN VerQueryValue} -{TNT-WARN VerQueryValueA} -{TNT-WARN VerQueryValueW} -function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; - var lplpBuffer: Pointer; var puLen: UINT): BOOL; - -type -{$IFDEF FPC} - PSHNAMEMAPPINGA = ^SHNAMEMAPPINGA; - SHNAMEMAPPINGA = record - pszOldPath : LPSTR; - pszNewPath : LPSTR; - cchOldPath : longint; - cchNewPath : longint; - end; - - PSHNAMEMAPPINGW = ^SHNAMEMAPPINGW; - SHNAMEMAPPINGW = record - pszOldPath : LPWSTR; - pszNewPath : LPWSTR; - cchOldPath : longint; - cchNewPath : longint; - end; -{$ENDIF} - - TSHNameMappingHeaderA = record - cNumOfMappings: Cardinal; - lpNM: PSHNAMEMAPPINGA; - end; - PSHNameMappingHeaderA = ^TSHNameMappingHeaderA; - - TSHNameMappingHeaderW = record - cNumOfMappings: Cardinal; - lpNM: PSHNAMEMAPPINGW; - end; - PSHNameMappingHeaderW = ^TSHNameMappingHeaderW; - -{TNT-WARN SHFileOperation} -{TNT-WARN SHFileOperationA} -{TNT-WARN SHFileOperationW} // <-- no stub on early Windows 95 -function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; - -{TNT-WARN SHFreeNameMappings} -procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); - -{TNT-WARN SHBrowseForFolder} -{TNT-WARN SHBrowseForFolderA} -{TNT-WARN SHBrowseForFolderW} // <-- no stub on early Windows 95 -function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; - -{TNT-WARN SHGetPathFromIDList} -{TNT-WARN SHGetPathFromIDListA} -{TNT-WARN SHGetPathFromIDListW} // <-- no stub on early Windows 95 -function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; - -{TNT-WARN SHGetFileInfo} -{TNT-WARN SHGetFileInfoA} -{TNT-WARN SHGetFileInfoW} // <-- no stub on early Windows 95 -function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; - -// ......... introduced ......... -function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; - -function LANGIDFROMLCID(lcid: LCID): WORD; -function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; -function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; -function PRIMARYLANGID(lgid: WORD): WORD; -function SORTIDFROMLCID(lcid: LCID): WORD; -function SUBLANGID(lgid: WORD): WORD; - -implementation - -uses - SysUtils, Math, TntSysUtils, - {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils; - -function _PAnsiCharWithNil(const S: AnsiString): PAnsiChar; -begin - if S = '' then - Result := nil {Win9x needs nil for some parameters instead of empty strings} - else - Result := PAnsiChar(S); -end; - -function _PWideCharWithNil(const S: WideString): PWideChar; -begin - if S = '' then - Result := nil {Win9x needs nil for some parameters instead of empty strings} - else - Result := PWideChar(S); -end; - -function _WStr(lpString: PWideChar; cchCount: Integer): WideString; -begin - if cchCount = -1 then - Result := lpString - else - Result := Copy(WideString(lpString), 1, cchCount); -end; - -procedure _MakeWideWin32FindData(var WideFindData: TWIN32FindDataW; AnsiFindData: TWIN32FindDataA); -begin - CopyMemory(@WideFindData, @AnsiFindData, - PtrUInt(@WideFindData.cFileName) - PtrUInt(@WideFindData)); - WStrPCopy(WideFindData.cFileName, AnsiFindData.cFileName); - WStrPCopy(WideFindData.cAlternateFileName, AnsiFindData.cAlternateFileName); -end; - -function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := SetWindowTextW{TNT-ALLOW SetWindowTextW}(hWnd, lpString) - else - Result := SetWindowTextA{TNT-ALLOW SetWindowTextA}(hWnd, PAnsiChar(AnsiString(lpString))); -end; - -//----------------------------- - -type - TPathLengthResultOption = (poAllowDirectoryMode, poZeroSmallBuff, poExactCopy, poExactCopySubPaths); - TPathLengthResultOptions = set of TPathLengthResultOption; - -procedure _ExactStrCopyW(pDest, pSource: PWideChar; Count: Integer); -var - i: integer; -begin - for i := 1 to Count do begin - pDest^ := pSource^; - Inc(PSource); - Inc(pDest); - end; -end; - -procedure _ExactCopySubPaths(pDest, pSource: PWideChar; Count: Integer); -var - i: integer; - OriginalSource: PWideChar; - PNextSlash: PWideChar; -begin - if Count >= 4 then begin - OriginalSource := pSource; - PNextSlash := WStrScan(pSource, '\'); - for i := 1 to Count - 1 do begin - // determine next path delimiter - if pSource > pNextSlash then begin - PNextSlash := WStrScan(pSource, '\'); - end; - // leave if no more sub paths - if (PNextSlash = nil) - or ((pNextSlash - OriginalSource) >= Count) then begin - exit; - end; - // copy char - pDest^ := pSource^; - Inc(PSource); - Inc(pDest); - end; - end; -end; - -function _HandlePathLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; -var - WideBuff: WideString; -begin - WideBuff := AnsiBuff; - if nBufferLength > Cardinal(Length(WideBuff)) then begin - // normal - Result := Length(WideBuff); - WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); - end else if (poExactCopy in Options) then begin - // exact - Result := nBufferLength; - _ExactStrCopyW(lpBuffer, PWideChar(WideBuff), nBufferLength); - end else begin - // other - if (poAllowDirectoryMode in Options) - and (nBufferLength = Cardinal(Length(WideBuff))) then begin - Result := Length(WideBuff) + 1; - WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength - 1); - end else begin - Result := Length(WideBuff) + 1; - if (nBufferLength > 0) then begin - if (poZeroSmallBuff in Options) then - lpBuffer^ := #0 - else if (poExactCopySubPaths in Options) then - _ExactCopySubPaths(lpBuffer, PWideChar(WideBuff), nBufferLength); - end; - end; - end; -end; - -function _HandleStringLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; -var - WideBuff: WideString; -begin - WideBuff := AnsiBuff; - if nBufferLength >= Cardinal(Length(WideBuff)) then begin - // normal - Result := Length(WideBuff); - WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); - end else if nBufferLength = 0 then - Result := Length(WideBuff) - else - Result := 0; -end; - -//------------------------------------------- - -function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := RemoveDirectoryW{TNT-ALLOW RemoveDirectoryW}(PWideChar(lpPathName)) - else - Result := RemoveDirectoryA{TNT-ALLOW RemoveDirectoryA}(PAnsiChar(AnsiString(lpPathName))); -end; - -function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; - cchBuffer: DWORD): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetShortPathNameW{TNT-ALLOW GetShortPathNameW}(lpszLongPath, lpszShortPath, cchBuffer) - else begin - SetLength(AnsiBuff, MAX_PATH * 2); - SetLength(AnsiBuff, GetShortPathNameA{TNT-ALLOW GetShortPathNameA}(PAnsiChar(AnsiString(lpszLongPath)), - PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(cchBuffer, lpszShortPath, AnsiBuff, [poExactCopySubPaths]); - end; -end; - -function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; - lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; -var - AnsiBuff: AnsiString; - AnsiFilePart: PAnsiChar; - AnsiLeadingChars: Integer; - WideLeadingChars: Integer; -begin - if Win32PlatformIsUnicode then - Result := GetFullPathNameW{TNT-ALLOW GetFullPathNameW}(lpFileName, nBufferLength, lpBuffer, lpFilePart) - else begin - SetLength(AnsiBuff, MAX_PATH * 2); - SetLength(AnsiBuff, GetFullPathNameA{TNT-ALLOW GetFullPathNameA}(PAnsiChar(AnsiString(lpFileName)), - Length(AnsiBuff), PAnsiChar(AnsiBuff), AnsiFilePart)); - Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poZeroSmallBuff]); - // deal w/ lpFilePart - if (AnsiFilePart = nil) or (nBufferLength < Result) then - lpFilePart := nil - else begin - AnsiLeadingChars := AnsiFilePart - PAnsiChar(AnsiBuff); - WideLeadingChars := Length(WideString(Copy(AnsiBuff, 1, AnsiLeadingChars))); - lpFilePart := lpBuffer + WideLeadingChars; - end; - end; -end; - -function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; - lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; - hTemplateFile: THandle): THandle; -begin - if Win32PlatformIsUnicode then - Result := CreateFileW{TNT-ALLOW CreateFileW}(lpFileName, dwDesiredAccess, dwShareMode, - lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) - else - Result := CreateFileA{TNT-ALLOW CreateFileA}(PAnsiChar(AnsiString(lpFileName)), dwDesiredAccess, dwShareMode, - lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) -end; - -function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; -var - Ansi_lpFindFileData: TWIN32FindDataA; -begin - if Win32PlatformIsUnicode then - Result := FindFirstFileW{TNT-ALLOW FindFirstFileW}(lpFileName, lpFindFileData) - else begin - Result := FindFirstFileA{TNT-ALLOW FindFirstFileA}(PAnsiChar(AnsiString(lpFileName)), - Ansi_lpFindFileData); - if Result <> INVALID_HANDLE_VALUE then - _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); - end; -end; - -function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; -var - Ansi_lpFindFileData: TWIN32FindDataA; -begin - if Win32PlatformIsUnicode then - Result := FindNextFileW{TNT-ALLOW FindNextFileW}(hFindFile, lpFindFileData) - else begin - Result := FindNextFileA{TNT-ALLOW FindNextFileA}(hFindFile, Ansi_lpFindFileData); - if Result then - _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); - end; -end; - -function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetFileAttributesW{TNT-ALLOW GetFileAttributesW}(lpFileName) - else - Result := GetFileAttributesA{TNT-ALLOW GetFileAttributesA}(PAnsiChar(AnsiString(lpFileName))); -end; - -function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; -begin - if Win32PlatformIsUnicode then - Result := SetFileAttributesW{TNT-ALLOW SetFileAttributesW}(lpFileName, dwFileAttributes) - else - Result := SetFileAttributesA{TNT-ALLOW SetFileAttributesA}(PAnsiChar(AnsiString(lpFileName)), dwFileAttributes); -end; - -function Tnt_CreateDirectoryW(lpPathName: PWideChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; -begin - if Win32PlatformIsUnicode then - Result := CreateDirectoryW{TNT-ALLOW CreateDirectoryW}(lpPathName, lpSecurityAttributes) - else - Result := CreateDirectoryA{TNT-ALLOW CreateDirectoryA}(PAnsiChar(AnsiString(lpPathName)), lpSecurityAttributes); -end; - -function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := MoveFileW{TNT-ALLOW MoveFileW}(lpExistingFileName, lpNewFileName) - else - Result := MoveFileA{TNT-ALLOW MoveFileA}(PAnsiChar(AnsiString(lpExistingFileName)), PAnsiChar(AnsiString(lpNewFileName))); -end; - -function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; -begin - if Win32PlatformIsUnicode then - Result := CopyFileW{TNT-ALLOW CopyFileW}(lpExistingFileName, lpNewFileName, bFailIfExists) - else - Result := CopyFileA{TNT-ALLOW CopyFileA}(PAnsiChar(AnsiString(lpExistingFileName)), - PAnsiChar(AnsiString(lpNewFileName)), bFailIfExists); -end; - -function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := DeleteFileW{TNT-ALLOW DeleteFileW}(lpFileName) - else - Result := DeleteFileA{TNT-ALLOW DeleteFileA}(PAnsiChar(AnsiString(lpFileName))); -end; - -function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; - var lpRect: TRect; uFormat: UINT): Integer; -begin - if Win32PlatformIsUnicode then - Result := DrawTextW{TNT-ALLOW DrawTextW}(hDC, lpString, nCount, lpRect, uFormat) - else - Result := DrawTextA{TNT-ALLOW DrawTextA}(hDC, - PAnsiChar(AnsiString(_WStr(lpString, nCount))), -1, lpRect, uFormat); -end; - -function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, - lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; -begin - if Win32PlatformIsUnicode then - Result := GetDiskFreeSpaceW{TNT-ALLOW GetDiskFreeSpaceW}(lpRootPathName, - lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) - else - Result := GetDiskFreeSpaceA{TNT-ALLOW GetDiskFreeSpaceA}(PAnsiChar(AnsiString(lpRootPathName)), - lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) -end; - -function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; - nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; - var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; - nFileSystemNameSize: DWORD): BOOL; -var - AnsiFileSystemNameBuffer: AnsiString; - AnsiVolumeNameBuffer: AnsiString; - AnsiBuffLen: DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetVolumeInformationW{TNT-ALLOW GetVolumeInformationW}(lpRootPathName, lpVolumeNameBuffer, nVolumeNameSize, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, lpFileSystemNameBuffer, nFileSystemNameSize) - else begin - SetLength(AnsiVolumeNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); - SetLength(AnsiFileSystemNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); - AnsiBuffLen := Length(AnsiFileSystemNameBuffer); - Result := GetVolumeInformationA{TNT-ALLOW GetVolumeInformationA}(PAnsiChar(AnsiString(lpRootPathName)), PAnsiChar(AnsiVolumeNameBuffer), AnsiBuffLen, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, PAnsiChar(AnsiFileSystemNameBuffer), AnsiBuffLen); - if Result then begin - SetLength(AnsiFileSystemNameBuffer, AnsiBuffLen); - if (nFileSystemNameSize <= AnsiBuffLen) or (Length(AnsiFileSystemNameBuffer) = 0) then - Result := False - else begin - WStrPLCopy(lpFileSystemNameBuffer, AnsiFileSystemNameBuffer, nFileSystemNameSize); - WStrPLCopy(lpVolumeNameBuffer, AnsiVolumeNameBuffer, nVolumeNameSize); - end; - end; - end; -end; - -function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetModuleFileNameW{TNT-ALLOW GetModuleFileNameW}(hModule, lpFilename, nSize) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetModuleFileNameA{TNT-ALLOW GetModuleFileNameA}(hModule, PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(nSize, lpFilename, AnsiBuff, [poExactCopy]); - end; -end; - -function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetTempPathW{TNT-ALLOW GetTempPathW}(nBufferLength, lpBuffer) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetTempPathA{TNT-ALLOW GetTempPathA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); - Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); - end; -end; - -function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; - lpTempFileName: PWideChar): UINT; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetTempFileNameW{TNT-ALLOW GetTempFileNameW}(lpPathName, lpPrefixString, uUnique, lpTempFileName) - else begin - SetLength(AnsiBuff, MAX_PATH); - Result := GetTempFileNameA{TNT-ALLOW GetTempFileNameA}(PAnsiChar(AnsiString(lpPathName)), PAnsiChar(lpPrefixString), uUnique, PAnsiChar(AnsiBuff)); - AnsiBuff := PAnsiChar(AnsiBuff); - _HandlePathLengthResult(MAX_PATH, lpTempFileName, AnsiBuff, [poZeroSmallBuff]); - end; -end; - -function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetWindowsDirectoryW{TNT-ALLOW GetWindowsDirectoryW}(lpBuffer, uSize) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetWindowsDirectoryA{TNT-ALLOW GetWindowsDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); - end; -end; - -function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetSystemDirectoryW{TNT-ALLOW GetSystemDirectoryW}(lpBuffer, uSize) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetSystemDirectoryA{TNT-ALLOW GetSystemDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); - end; -end; - -function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetCurrentDirectoryW{TNT-ALLOW GetCurrentDirectoryW}(nBufferLength, lpBuffer) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetCurrentDirectoryA{TNT-ALLOW GetCurrentDirectoryA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); - Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); - end; -end; - -function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := SetCurrentDirectoryW{TNT-ALLOW SetCurrentDirectoryW}(lpPathName) - else - Result := SetCurrentDirectoryA{TNT-ALLOW SetCurrentDirectoryA}(PAnsiChar(AnsiString(lpPathName))); -end; - -function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; -var - AnsiBuff: AnsiString; - AnsiBuffLen: DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetComputerNameW{TNT-ALLOW GetComputerNameW}(lpBuffer, nSize) - else begin - SetLength(AnsiBuff, MAX_COMPUTERNAME_LENGTH + 1); - AnsiBuffLen := Length(AnsiBuff); - Result := GetComputerNameA{TNT-ALLOW GetComputerNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); - if Result then begin - SetLength(AnsiBuff, AnsiBuffLen); - if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin - nSize := AnsiBuffLen + 1; - Result := False; - end else begin - WStrPLCopy(lpBuffer, AnsiBuff, nSize); - nSize := WStrLen(lpBuffer); - end; - end; - end; -end; - -function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; -var - AnsiBuff: AnsiString; - AnsiBuffLen: DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetUserNameW{TNT-ALLOW GetUserNameW}(lpBuffer, nSize) - else begin - SetLength(AnsiBuff, 255); - AnsiBuffLen := Length(AnsiBuff); - Result := GetUserNameA{TNT-ALLOW GetUserNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); - if Result then begin - SetLength(AnsiBuff, AnsiBuffLen); - if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin - nSize := AnsiBuffLen + 1; - Result := False; - end else begin - WStrPLCopy(lpBuffer, AnsiBuff, nSize); - nSize := WStrLen(lpBuffer); - end; - end; - end; -end; - -function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, - Directory: PWideChar; ShowCmd: Integer): HINST; -begin - if Win32PlatformIsUnicode then - Result := ShellExecuteW{TNT-ALLOW ShellExecuteW}(hWnd, _PWideCharWithNil(WideString(Operation)), - FileName, Parameters, - Directory, ShowCmd) - else begin - Result := ShellExecuteA{TNT-ALLOW ShellExecuteA}(hWnd, _PAnsiCharWithNil(AnsiString(Operation)), - _PAnsiCharWithNil(AnsiString(FileName)), _PAnsiCharWithNil(AnsiString(Parameters)), - _PAnsiCharWithNil(AnsiString(Directory)), ShowCmd) - end; -end; - -function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; -begin - if Win32PlatformIsUnicode then - Result := LoadLibraryW{TNT-ALLOW LoadLibraryW}(lpLibFileName) - else - Result := LoadLibraryA{TNT-ALLOW LoadLibraryA}(PAnsiChar(AnsiString(lpLibFileName))); -end; - -function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; -begin - if Win32PlatformIsUnicode then - Result := LoadLibraryExW{TNT-ALLOW LoadLibraryExW}(lpLibFileName, hFile, dwFlags) - else - Result := LoadLibraryExA{TNT-ALLOW LoadLibraryExA}(PAnsiChar(AnsiString(lpLibFileName)), hFile, dwFlags); -end; - -function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; - var lpProcessInformation: TProcessInformation): BOOL; -var - AnsiStartupInfo: TStartupInfoA; -begin - if Win32PlatformIsUnicode then begin - Result := CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName, lpCommandLine, - lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, - lpCurrentDirectory, lpStartupInfo, lpProcessInformation) - end else begin - CopyMemory(@AnsiStartupInfo, @lpStartupInfo, SizeOf(TStartupInfo)); - AnsiStartupInfo.lpReserved := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpReserved)); - AnsiStartupInfo.lpDesktop := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpDesktop)); - AnsiStartupInfo.lpTitle := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpTitle)); - Result := CreateProcessA{TNT-ALLOW CreateProcessA}(_PAnsiCharWithNil(AnsiString(lpApplicationName)), - _PAnsiCharWithNil(AnsiString(lpCommandLine)), - lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, - _PAnsiCharWithNil(AnsiString(lpCurrentDirectory)), AnsiStartupInfo, lpProcessInformation); - end; -end; - -function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; - lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; -const - MAX_ANSI_BUFF_SIZE = 64; // can a currency string actually be larger? -var - AnsiFormat: TCurrencyFmtA; - PAnsiFormat: PCurrencyFmtA; - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetCurrencyFormatW{TNT-ALLOW GetCurrencyFormatW}(Locale, dwFlags, lpValue, - {$IFNDEF FPC} lpFormat {$ELSE} PCurrencyFmt(lpFormat) {$ENDIF}, - lpCurrencyStr, cchCurrency) - else begin - if lpFormat = nil then - PAnsiFormat := nil - else begin - ZeroMemory(@AnsiFormat, SizeOf(AnsiFormat)); - AnsiFormat.NumDigits := lpFormat.NumDigits; - AnsiFormat.LeadingZero := lpFormat.LeadingZero; - AnsiFormat.Grouping := lpFormat.Grouping; - AnsiFormat.lpDecimalSep := PAnsiChar(AnsiString(lpFormat.lpDecimalSep)); - AnsiFormat.lpThousandSep := PAnsiChar(AnsiString(lpFormat.lpThousandSep)); - AnsiFormat.NegativeOrder := lpFormat.NegativeOrder; - AnsiFormat.PositiveOrder := lpFormat.PositiveOrder; - AnsiFormat.lpCurrencySymbol := PAnsiChar(AnsiString(lpFormat.lpCurrencySymbol)); - PAnsiFormat := @AnsiFormat; - end; - SetLength(AnsiBuff, MAX_ANSI_BUFF_SIZE); - SetLength(AnsiBuff, GetCurrencyFormatA{TNT-ALLOW GetCurrencyFormatA}(Locale, dwFlags, - PAnsiChar(AnsiString(lpValue)), PAnsiFormat, PAnsiChar(AnsiBuff), MAX_ANSI_BUFF_SIZE)); - Result := _HandleStringLengthResult(cchCurrency, lpCurrencyStr, AnsiBuff, []); - end; -end; - -function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; - cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; -var - WideStr1, WideStr2: WideString; - AnsiStr1, AnsiStr2: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := CompareStringW{TNT-ALLOW CompareStringW}(Locale, dwCmpFlags, lpString1, cchCount1, lpString2, cchCount2) - else begin - WideStr1 := _WStr(lpString1, cchCount1); - WideStr2 := _WStr(lpString2, cchCount2); - if (dwCmpFlags = 0) then begin - // binary comparison - if WideStr1 < WideStr2 then - Result := 1 - else if WideStr1 = WideStr2 then - Result := 2 - else - Result := 3; - end else begin - AnsiStr1 := WideStr1; - AnsiStr2 := WideStr2; - Result := CompareStringA{TNT-ALLOW CompareStringA}(Locale, dwCmpFlags, - PAnsiChar(AnsiStr1), -1, PAnsiChar(AnsiStr2), -1); - end; - end; -end; - -function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; -var - AStr: AnsiString; - WStr: WideString; -begin - if Win32PlatformIsUnicode then - Result := CharUpperW{TNT-ALLOW CharUpperW}(lpsz) - else begin - if HiWord(Cardinal(lpsz)) = 0 then begin - // literal char mode - Result := lpsz; - if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin - AStr := WideChar(lpsz); // single character may be more than one byte - CharUpperA{TNT-ALLOW CharUpperA}(PAnsiChar(AStr)); - WStr := AStr; // should always be single wide char - if Length(WStr) = 1 then - Result := PWideChar(WStr[1]); - end - end else begin - // null-terminated string mode - Result := lpsz; - while lpsz^ <> #0 do begin - lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; - end; -end; - -function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; -var - i: integer; -begin - if Win32PlatformIsUnicode then - Result := CharUpperBuffW{TNT-ALLOW CharUpperBuffW}(lpsz, cchLength) - else begin - Result := cchLength; - for i := 1 to cchLength do begin - lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; -end; - -function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; -var - AStr: AnsiString; - WStr: WideString; -begin - if Win32PlatformIsUnicode then - Result := CharLowerW{TNT-ALLOW CharLowerW}(lpsz) - else begin - if HiWord(Cardinal(lpsz)) = 0 then begin - // literal char mode - Result := lpsz; - if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin - AStr := WideChar(lpsz); // single character may be more than one byte - CharLowerA{TNT-ALLOW CharLowerA}(PAnsiChar(AStr)); - WStr := AStr; // should always be single wide char - if Length(WStr) = 1 then - Result := PWideChar(WStr[1]); - end - end else begin - // null-terminated string mode - Result := lpsz; - while lpsz^ <> #0 do begin - lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; - end; -end; - -function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; -var - i: integer; -begin - if Win32PlatformIsUnicode then - Result := CharLowerBuffW{TNT-ALLOW CharLowerBuffW}(lpsz, cchLength) - else begin - Result := cchLength; - for i := 1 to cchLength do begin - lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; -end; - -function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; - lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; -var - AStr: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetStringTypeExW{TNT-ALLOW GetStringTypeExW}(Locale, dwInfoType, lpSrcStr, cchSrc, lpCharType) - else begin - AStr := _WStr(lpSrcStr, cchSrc); - Result := GetStringTypeExA{TNT-ALLOW GetStringTypeExA}(Locale, dwInfoType, - PAnsiChar(AStr), -1, lpCharType); - end; -end; - -function Win9x_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; -// This function originated by the WINE Project. -// It was translated to Pascal by Francisco Leong. -// It was further modified by Troy Wolbrink. -var - hmem: HGLOBAL; - hrsrc: THandle; - p: PWideChar; - string_num, i: Integer; - block: Integer; -begin - Result := 0; - // Netscape v3 fix... - if (HIWORD(uID) = $FFFF) then begin - uID := UINT(-(Integer(uID))); - end; - // figure block, string_num - block := ((uID shr 4) and $FFFF) + 1; // bits 4 - 19, mask out bits 20 - 31, inc by 1 - string_num := uID and $000F; - // get handle & pointer to string block - hrsrc := FindResource{TNT-ALLOW FindResource}(hInstance, MAKEINTRESOURCE(block), RT_STRING); - if (hrsrc <> 0) then - begin - hmem := LoadResource(hInstance, hrsrc); - if (hmem <> 0) then - begin - p := LockResource(hmem); - // walk the block to the requested string - for i := 0 to string_num - 1 do begin - p := p + Integer(p^) + 1; - end; - Result := Integer(p^); { p points to the length of string } - Inc(p); { p now points to the actual string } - if (lpBuffer <> nil) and (nBufferMax > 0) then - begin - Result := min(nBufferMax - 1, Result); { max length to copy } - if (Result > 0) then begin - CopyMemory(lpBuffer, p, Result * sizeof(WideChar)); - end; - lpBuffer[Result] := WideChar(0); { null terminate } - end; - end; - end; -end; - -function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; -begin - if Win32PlatformIsUnicode then - Result := Windows.LoadStringW{TNT-ALLOW LoadStringW}(hInstance, uID, lpBuffer, nBufferMax) - else - Result := Win9x_LoadStringW(hInstance, uID, lpBuffer, nBufferMax); -end; - -function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: TMenuItemInfoW): BOOL; -begin - if Win32PlatformIsUnicode then - Result := InsertMenuItemW{TNT-ALLOW InsertMenuItemW}(hMenu, uItem, fByPosition, - {$IFDEF FPC}@{$ENDIF}lpmii) - else begin - TMenuItemInfoA(lpmii).dwTypeData := PAnsiChar(AnsiString(lpmii.dwTypeData)); - Result := InsertMenuItemA{TNT-ALLOW InsertMenuItemA}(hMenu, uItem, fByPosition, - {$IFDEF FPC}@{$ENDIF}TMenuItemInfoA(lpmii)); - end; -end; - -function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; - var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; -begin - if Win32PlatformIsUnicode then - Result := ExtractIconExW{TNT-ALLOW ExtractIconExW}(lpszFile, - nIconIndex, phiconLarge, phiconSmall, nIcons) - else - Result := ExtractIconExA{TNT-ALLOW ExtractIconExA}(PAnsiChar(AnsiString(lpszFile)), - nIconIndex, phiconLarge, phiconSmall, nIcons); -end; - -function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; - var lpiIcon: Word): HICON; -begin - if Win32PlatformIsUnicode then - Result := ExtractAssociatedIconW{TNT-ALLOW ExtractAssociatedIconW}(hInst, - lpIconPath, {$IFDEF FPC}@{$ENDIF}lpiIcon) - else - Result := ExtractAssociatedIconA{TNT-ALLOW ExtractAssociatedIconA}(hInst, - PAnsiChar(AnsiString(lpIconPath)), {$IFDEF FPC}@{$ENDIF}lpiIcon) -end; - -function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetFileVersionInfoSizeW{TNT-ALLOW GetFileVersionInfoSizeW}(lptstrFilename, lpdwHandle) - else - Result := GetFileVersionInfoSizeA{TNT-ALLOW GetFileVersionInfoSizeA}(PAnsiChar(AnsiString(lptstrFilename)), lpdwHandle); -end; - -function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; - lpData: Pointer): BOOL; -begin - if Win32PlatformIsUnicode then - Result := GetFileVersionInfoW{TNT-ALLOW GetFileVersionInfoW}(lptstrFilename, dwHandle, dwLen, lpData) - else - Result := GetFileVersionInfoA{TNT-ALLOW GetFileVersionInfoA}(PAnsiChar(AnsiString(lptstrFilename)), dwHandle, dwLen, lpData); -end; - -var - Last_VerQueryValue_String: WideString; - -function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; - var lplpBuffer: Pointer; var puLen: UINT): BOOL; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := VerQueryValueW{TNT-ALLOW VerQueryValueW}(pBlock, lpSubBlock, lplpBuffer, puLen) - else begin - Result := VerQueryValueA{TNT-ALLOW VerQueryValueA}(pBlock, PAnsiChar(AnsiString(lpSubBlock)), lplpBuffer, puLen); - if WideTextPos(VQV_STRINGFILEINFO, lpSubBlock) <> 1 then - else begin - { /StringFileInfo, convert ansi result to unicode } - SetString(AnsiBuff, PAnsiChar(lplpBuffer), puLen); - Last_VerQueryValue_String := AnsiBuff; - lplpBuffer := PWideChar(Last_VerQueryValue_String); - puLen := Length(Last_VerQueryValue_String); - end; - end; -end; - -//--------------------------------------------------------------------------------------- -// Wide functions from Shell32.dll should be loaded dynamically (no stub on early Win95) -//--------------------------------------------------------------------------------------- - -type - TSHFileOperationW = function(var lpFileOp: TSHFileOpStructW): Integer; stdcall; - TSHBrowseForFolderW = function(var lpbi: TBrowseInfoW): PItemIDList; stdcall; - TSHGetPathFromIDListW = function(pidl: PItemIDList; pszPath: PWideChar): BOOL; stdcall; - TSHGetFileInfoW = function(pszPath: PWideChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; stdcall; - -var - Safe_SHFileOperationW: TSHFileOperationW = nil; - Safe_SHBrowseForFolderW: TSHBrowseForFolderW = nil; - Safe_SHGetPathFromIDListW: TSHGetPathFromIDListW = nil; - Safe_SHGetFileInfoW: TSHGetFileInfoW = nil; - -var Shell32DLL: HModule = 0; - -procedure LoadWideShell32Procs; -begin - if Shell32DLL = 0 then begin - Shell32DLL := WinCheckH(Tnt_LoadLibraryW('shell32.dll')); - Safe_SHFileOperationW := WinCheckP(GetProcAddress(Shell32DLL, 'SHFileOperationW')); - Safe_SHBrowseForFolderW := WinCheckP(GetProcAddress(Shell32DLL, 'SHBrowseForFolderW')); - Safe_SHGetPathFromIDListW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetPathFromIDListW')); - Safe_SHGetFileInfoW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetFileInfoW')); - end; -end; - -function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; -var - AnsiFileOp: TSHFileOpStructA; - MapCount: Integer; - PAnsiMap: PSHNameMappingA; - PWideMap: PSHNameMappingW; - OldPath: WideString; - NewPath: WideString; - i: integer; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHFileOperationW(lpFileOp); - end else begin - AnsiFileOp := TSHFileOpStructA(lpFileOp); - // convert PChar -> PWideChar - if lpFileOp.pFrom = nil then - AnsiFileOp.pFrom := nil - else - AnsiFileOp.pFrom := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pFrom))); - if lpFileOp.pTo = nil then - AnsiFileOp.pTo := nil - else - AnsiFileOp.pTo := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pTo))); - AnsiFileOp.lpszProgressTitle := PAnsiChar(AnsiString(lpFileOp.lpszProgressTitle)); - Result := SHFileOperationA{TNT-ALLOW SHFileOperationA}( - {$IFDEF FPC}@{$ENDIF}AnsiFileOp); - // return struct results - lpFileOp.fAnyOperationsAborted := AnsiFileOp.fAnyOperationsAborted; - lpFileOp.hNameMappings := nil; - if (AnsiFileOp.hNameMappings <> nil) - and ((FOF_WANTMAPPINGHANDLE and AnsiFileOp.fFlags) <> 0) then begin - // alloc mem - MapCount := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).cNumOfMappings; - lpFileOp.hNameMappings := - AllocMem(SizeOf({hNameMappings}Cardinal) + SizeOf(TSHNameMappingW) * MapCount); - PSHNameMappingHeaderW(lpFileOp.hNameMappings).cNumOfMappings := MapCount; - // init pointers - PAnsiMap := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).lpNM; - PWideMap := PSHNameMappingHeaderW(lpFileOp.hNameMappings).lpNM; - for i := 1 to MapCount do begin - // old path - OldPath := Copy(PAnsiMap.pszOldPath, 1, PAnsiMap.cchOldPath); - PWideMap.pszOldPath := WStrNew(PWideChar(OldPath)); - PWideMap.cchOldPath := WStrLen(PWideMap.pszOldPath); - // new path - NewPath := Copy(PAnsiMap.pszNewPath, 1, PAnsiMap.cchNewPath); - PWideMap.pszNewPath := WStrNew(PWideChar(NewPath)); - PWideMap.cchNewPath := WStrLen(PWideMap.pszNewPath); - // next record - Inc(PAnsiMap); - Inc(PWideMap); - end; - end; - end; -end; - -procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); -var - i: integer; - MapCount: Integer; - PWideMap: PSHNameMappingW; -begin - if Win32PlatformIsUnicode then - SHFreeNameMappings{TNT-ALLOW SHFreeNameMappings}(hNameMappings) - else begin - // free strings - MapCount := PSHNameMappingHeaderW(hNameMappings).cNumOfMappings; - PWideMap := PSHNameMappingHeaderW(hNameMappings).lpNM; - for i := 1 to MapCount do begin - WStrDispose(PWideMap.pszOldPath); - WStrDispose(PWideMap.pszNewPath); - Inc(PWideMap); - end; - // free struct - FreeMem(Pointer(hNameMappings)); - end; -end; - -function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; -var - AnsiInfo: TBrowseInfoA; - AnsiBuffer: array[0..MAX_PATH] of AnsiChar; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHBrowseForFolderW(lpbi); - end else begin - AnsiInfo := TBrowseInfoA(lpbi); - AnsiInfo.lpszTitle := PAnsiChar(AnsiString(lpbi.lpszTitle)); - if lpbi.pszDisplayName <> nil then - AnsiInfo.pszDisplayName := AnsiBuffer; - Result := SHBrowseForFolderA{TNT-ALLOW SHBrowseForFolderA}( - {$IFDEF FPC}@{$ENDIF}AnsiInfo); - if lpbi.pszDisplayName <> nil then - WStrPCopy(lpbi.pszDisplayName, AnsiInfo.pszDisplayName); - lpbi.iImage := AnsiInfo.iImage; - end; -end; - -function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; -var - AnsiPath: AnsiString; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHGetPathFromIDListW(pidl, pszPath); - end else begin - SetLength(AnsiPath, MAX_PATH); - Result := SHGetPathFromIDListA{TNT-ALLOW SHGetPathFromIDListA}(pidl, PAnsiChar(AnsiPath)); - if Result then - WStrPCopy(pszPath, PAnsiChar(AnsiPath)) - end; -end; - -function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; -var - SHFileInfoA: TSHFileInfoA; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHGetFileInfoW(pszPath, dwFileAttributes, psfi, cbFileInfo, uFlags) - end else begin - Result := SHGetFileInfoA{TNT-ALLOW SHGetFileInfoA}(PAnsiChar(AnsiString(pszPath)), - dwFileAttributes, SHFileInfoA, SizeOf(TSHFileInfoA), uFlags); - // update pfsi... - ZeroMemory(@psfi, SizeOf(TSHFileInfoW)); - psfi.hIcon := SHFileInfoA.hIcon; - psfi.iIcon := SHFileInfoA.iIcon; - psfi.dwAttributes := SHFileInfoA.dwAttributes; - WStrPLCopy(psfi.szDisplayName, SHFileInfoA.szDisplayName, MAX_PATH); - WStrPLCopy(psfi.szTypeName, SHFileInfoA.szTypeName, 80); - end; -end; - - -function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; -begin - Result := HiWord(Cardinal(ResStr)) = 0; -end; - -function LANGIDFROMLCID(lcid: LCID): WORD; -begin - Result := LoWord(lcid); -end; - -function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; -begin - Result := (usSubLanguage shl 10) or usPrimaryLanguage; -end; - -function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; -begin - Result := MakeLong(wLanguageID, wSortID); -end; - -function PRIMARYLANGID(lgid: WORD): WORD; -begin - Result := lgid and $03FF; -end; - -function SORTIDFROMLCID(lcid: LCID): WORD; -begin - Result := HiWord(lcid); -end; - -function SUBLANGID(lgid: WORD): WORD; -begin - Result := lgid shr 10; -end; - -initialization - -finalization - if Shell32DLL <> 0 then - FreeLibrary(Shell32DLL); - -end. |