diff options
Diffstat (limited to 'src/lib')
39 files changed, 11864 insertions, 989 deletions
diff --git a/src/lib/FreeImage/FreeBitmap.pas b/src/lib/FreeImage/FreeBitmap.pas index 4e5f50a4..d32fb5cb 100644 --- a/src/lib/FreeImage/FreeBitmap.pas +++ b/src/lib/FreeImage/FreeBitmap.pas @@ -33,7 +33,7 @@ unit FreeBitmap; {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} interface diff --git a/src/lib/SQLite/SQLite3.pas b/src/lib/SQLite/SQLite3.pas index 9537606c..7b7207c4 100644 --- a/src/lib/SQLite/SQLite3.pas +++ b/src/lib/SQLite/SQLite3.pas @@ -10,7 +10,7 @@ unit SQLite3; {$IFDEF FPC} {$MODE DELPHI} - {$H+} (* use AnsiString *) + {$H+} (* use long strings *) {$PACKENUM 4} (* use 4-byte enums *) {$PACKRECORDS C} (* C/C++-compatible record packing *) {$ELSE} diff --git a/src/lib/TntUnicodeControls/License.txt b/src/lib/TntUnicodeControls/License.txt new file mode 100644 index 00000000..8ac7f75b --- /dev/null +++ b/src/lib/TntUnicodeControls/License.txt @@ -0,0 +1,11 @@ +TntWare Delphi Unicode Controls + http://www.tntware.com/delphicontrols/unicode/ + +Copyright (c) 2002-2007, Troy Wolbrink (www.tntware.com) + +License +Redistribution and use in binary forms, with or without modification, are permitted. Redistribution and use in source forms, with or without modification, are permitted provided that the redistributions of source code retain the above copyright. + +Disclaimer +This software is provided by the author "as is" and any express or implied warranties, including, but not limited to, the implied warranties of merchantability and fitness for a particular purpose are disclaimed. In no event shall the author be liable for any direct, indirect, incidental, special, exemplary, or consequential damages (including, but not limited to, procurement of substitute goods or services; loss of use, data, or profits; or business interruption) however caused and on any theory of liability, whether in contract, strict liability, or tort (including negligence or otherwise) arising in any way out of the use of this software, even if advised of the possibility of such damage. + diff --git a/src/lib/TntUnicodeControls/Readme.txt b/src/lib/TntUnicodeControls/Readme.txt new file mode 100644 index 00000000..a2d8f799 --- /dev/null +++ b/src/lib/TntUnicodeControls/Readme.txt @@ -0,0 +1,53 @@ + ** Tnt Delphi UNICODE Controls Project ** + +Website: http://tnt.ccci.org/delphi_unicode_controls/ +Email: troy.wolbrink@ccci.org + +These controls are provided as-is, with no implied warranty. They are freely available for you to use in your own projects. Please let me know if you have found them helpful. Also, please let me know if you find any bugs or other areas of needed improvement. + + +---Delphi Installation-------------------------- + +The most simple way to install these components is by opening the appropriate design package in Delphi and clicking on the big "Install" button. For instance, Delphi 5's design package is TntUnicodeVcl_D50.dpk. + +For BCB 2006 and newer, open the appropriate design package in the packages\bcbx\ folder using the Delphi personality. After compiling and installing, you should be able to use the components in both the Delphi and BCB personality. Remember to set the library path in menu "Tools->Options" for both the C++ Builder and the Delphi. + + +---A note on fonts---------------------- + +The default TFont uses "MS Sans Serif" which doesn't work well with most non-ANSI characters. I'd recommend using a TrueType font such as "Tahoma" if it is installed on the machine. To make TFont use a different font like "Tahoma" add this to the first line in the project: + + Graphics.DefFontData.Name := 'Tahoma'; + +You might have to include "Graphics" in the file's uses clauses. Furthermore, adding this line of code to the project will cause the changed setting to only be applied at runtime, not at design time. To make a designtime change, you'd have to add this line to the initialization section of a unit in a design package. + +Regarding the IDE, I use GExperts to change the font of the Object Inspector. The Wide String List editor uses the font used by the object inspector. + +Also keep in mind that the font used by certain message boxes come from that set by Windows' Display properties. + + +---Background---------------------------- + +Designing software for an international audience, I've always wanted to write a full UNICODE application. My approach so far, has been to write Unicode on the inside, and MBCS on the outside. This has always been frustrating, because (even on Windows NT/2000/XP which provide native Unicode window controls) the WideStrings inside my application and databases were always confined to an ANSI VCL. And, since the VCL was designed to wrap the low-level Windows details, why shouldn't the VCL hide the fact that sometimes native Unicode controls are not possible on the given version of Windows. I believe the VCL should be written with a Unicode interface, even if it must (at times) deal with an ANSI operating system. For example, TEdit should expose Text as a WideString, even if it has to convert the WideString to an AnsiString on the Windows 9X platform. + +In the past, the ANSI VCL may have made a little sense, considering that there were many more users of Windows 9X, than Windows NT. There would have been some performance penalty to use WideStrings on the Windows 9X platform. But with the faster computers of today, and with more people using platforms such as Windows 2000 and Windows XP, the ANSI VCL just doesn't make sense anymore. In fact, having to use the the ANSI VCL on Windows NT/2000/XP is slower because of the constant conversion to and from UNICODE inside Windows. + +My coding signature is Tnt. I will use this to denote my classes from others. + +For more information about me: <http://home.ccci.org/wolbrink/> +Some of my software projects (all written in Delphi). + TntMPD (contact manager for missionaries) + <http://www.tntmpd.com/> + Jesus Film Screen Saver + <http://home.ccci.org/wolbrink/screensaver.htm> + ActiveX SCR control + <http://tnt.ccci.org/download/activex_scr/ActiveXSCR.exe> + +---Design Goals---------------------------- + +I want the controls to work on Windows 95, 98, ME, NT, 2000, XP, etc. I want a single EXE for all platforms. Of course, full UNICODE support is only truly available on NT/2000/XP. In other words, the controls should automatically scale to take advantage of native Unicode support when possible. + +I want the controls to inherit from the Delphi VCL. I want to reuse as much code as possible. For the most part this makes sense. The only sticky part is where text messages get passed around. But I believe I've gotten past this through strategic subclassing at various points in the message flow chain. To give a rough comparison of why this is so important, check out the following chart which compares the lines of code in the VCL for a given control (4,397 in all), and the lines of code required in my descendent controls (655 in all). Besides saving lines of code, I get the advantage of automatically inheriting new features as new versions of Delphi come out. One such example is the AlphaBlending feature in the Delphi 6 TForm. Even though I use Delphi 5 now, I won't have to add any code to get this new feature. + +---More Interesting Information---------------------------- +Case Study: Porting an MFC Application to Unicode: It looks like the FrontPage 2002 team did the roughly the same thing to MFC as what I'm doing to the VCL. They did this with the same goal in mind: to support Unicode as much as possible depending on the support offered by Windows. Another goal was "Don’t abandon MFC; don’t rewrite app". Because they still want to support Windows 9X using the same worldwide EXE used everywhere. They couldn't just compile with the _UNICODE directive. They had to start with the ANSI MFC, strategically subclassing window procedures at just the right places. Hmmm... sounds familiar.
\ No newline at end of file diff --git a/src/lib/TntUnicodeControls/TntClasses.pas b/src/lib/TntUnicodeControls/TntClasses.pas new file mode 100644 index 00000000..be043421 --- /dev/null +++ b/src/lib/TntUnicodeControls/TntClasses.pas @@ -0,0 +1,1799 @@ + +{*****************************************************************************} +{ } +{ 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/TntCompilers.inc b/src/lib/TntUnicodeControls/TntCompilers.inc new file mode 100644 index 00000000..06f4d9ab --- /dev/null +++ b/src/lib/TntUnicodeControls/TntCompilers.inc @@ -0,0 +1,378 @@ +//---------------------------------------------------------------------------------------------------------------------- +// Include file to determine which compiler is currently being used to build the project/component. +// This file uses ideas from Brad Stowers DFS.inc file (www.delphifreestuff.com). +// +// Portions created by Mike Lischke are Copyright +// (C) 1999-2002 Dipl. Ing. Mike Lischke. All Rights Reserved. +//---------------------------------------------------------------------------------------------------------------------- +// The following symbols are defined: +// +// COMPILER_1 : Kylix/Delphi/BCB 1.x is the compiler. +// COMPILER_1_UP : Kylix/Delphi/BCB 1.x or higher is the compiler. +// COMPILER_2 : Kylix/Delphi 2.x or BCB 1.x is the compiler. +// COMPILER_2_UP : Kylix/Delphi 2.x or higher, or BCB 1.x or higher is the compiler. +// COMPILER_3 : Kylix/Delphi/BCB 3.x is the compiler. +// COMPILER_3_UP : Kylix/Delphi/BCB 3.x or higher is the compiler. +// COMPILER_4 : Kylix/Delphi/BCB 4.x is the compiler. +// COMPILER_4_UP : Kylix/Delphi/BCB 4.x or higher is the compiler. +// COMPILER_5 : Kylix/Delphi/BCB 5.x is the compiler. +// COMPILER_5_UP : Kylix/Delphi/BCB 5.x or higher is the compiler. +// COMPILER_6 : Kylix/Delphi/BCB 6.x is the compiler. +// COMPILER_6_UP : Kylix/Delphi/BCB 6.x or higher is the compiler. +// COMPILER_7 : Kylix/Delphi/BCB 7.x is the compiler. +// COMPILER_7_UP : Kylix/Delphi/BCB 7.x or higher is the compiler. +// +// Only defined if Windows is the target: +// CPPB : Any version of BCB is being used. +// CPPB_1 : BCB v1.x is being used. +// CPPB_3 : BCB v3.x is being used. +// CPPB_3_UP : BCB v3.x or higher is being used. +// CPPB_4 : BCB v4.x is being used. +// CPPB_4_UP : BCB v4.x or higher is being used. +// CPPB_5 : BCB v5.x is being used. +// CPPB_5_UP : BCB v5.x or higher is being used. +// CPPB_6 : BCB v6.x is being used. +// CPPB_6_UP : BCB v6.x or higher is being used. +// +// Only defined if Windows is the target: +// DELPHI : Any version of Delphi is being used. +// DELPHI_1 : Delphi v1.x is being used. +// DELPHI_2 : Delphi v2.x is being used. +// DELPHI_2_UP : Delphi v2.x or higher is being used. +// DELPHI_3 : Delphi v3.x is being used. +// DELPHI_3_UP : Delphi v3.x or higher is being used. +// DELPHI_4 : Delphi v4.x is being used. +// DELPHI_4_UP : Delphi v4.x or higher is being used. +// DELPHI_5 : Delphi v5.x is being used. +// DELPHI_5_UP : Delphi v5.x or higher is being used. +// DELPHI_6 : Delphi v6.x is being used. +// DELPHI_6_UP : Delphi v6.x or higher is being used. +// DELPHI_7 : Delphi v7.x is being used. +// DELPHI_7_UP : Delphi v7.x or higher is being used. +// +// Only defined if Linux is the target: +// KYLIX : Any version of Kylix is being used. +// KYLIX_1 : Kylix 1.x is being used. +// KYLIX_1_UP : Kylix 1.x or higher is being used. +// KYLIX_2 : Kylix 2.x is being used. +// KYLIX_2_UP : Kylix 2.x or higher is being used. +// KYLIX_3 : Kylix 3.x is being used. +// KYLIX_3_UP : Kylix 3.x or higher is being used. +// +// Only defined if Linux is the target: +// QT_CLX : Trolltech's QT library is being used. +//---------------------------------------------------------------------------------------------------------------------- + +{$ifdef Win32} + + {$ifdef VER180} + {$define COMPILER_10} + {$define DELPHI} + {$define DELPHI_10} + {$endif} + + {$ifdef VER170} + {$define COMPILER_9} + {$define DELPHI} + {$define DELPHI_9} + {$endif} + + {$ifdef VER150} + {$define COMPILER_7} + {$define DELPHI} + {$define DELPHI_7} + {$endif} + + {$ifdef VER140} + {$define COMPILER_6} + {$ifdef BCB} + {$define CPPB} + {$define CPPB_6} + {$else} + {$define DELPHI} + {$define DELPHI_6} + {$endif} + {$endif} + + {$ifdef VER130} + {$define COMPILER_5} + {$ifdef BCB} + {$define CPPB} + {$define CPPB_5} + {$else} + {$define DELPHI} + {$define DELPHI_5} + {$endif} + {$endif} + + {$ifdef VER125} + {$define COMPILER_4} + {$define CPPB} + {$define CPPB_4} + {$endif} + + {$ifdef VER120} + {$define COMPILER_4} + {$define DELPHI} + {$define DELPHI_4} + {$endif} + + {$ifdef VER110} + {$define COMPILER_3} + {$define CPPB} + {$define CPPB_3} + {$endif} + + {$ifdef VER100} + {$define COMPILER_3} + {$define DELPHI} + {$define DELPHI_3} + {$endif} + + {$ifdef VER93} + {$define COMPILER_2} // C++ Builder v1 compiler is really v2 + {$define CPPB} + {$define CPPB_1} + {$endif} + + {$ifdef VER90} + {$define COMPILER_2} + {$define DELPHI} + {$define DELPHI_2} + {$endif} + + {$ifdef VER80} + {$define COMPILER_1} + {$define DELPHI} + {$define DELPHI_1} + {$endif} + + {$ifdef FPC} + {.$define DELPHI} + {$endif} + + {$ifdef DELPHI_2} + {$define DELPHI_2_UP} + {$endif} + + {$ifdef DELPHI_3} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$endif} + + {$ifdef DELPHI_4} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$endif} + + {$ifdef DELPHI_5} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$endif} + + {$ifdef DELPHI_6} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$endif} + + {$ifdef DELPHI_7} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$endif} + + {$ifdef DELPHI_9} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$define DELPHI_9_UP} + {$endif} + + {$ifdef DELPHI_10} + {$define DELPHI_2_UP} + {$define DELPHI_3_UP} + {$define DELPHI_4_UP} + {$define DELPHI_5_UP} + {$define DELPHI_6_UP} + {$define DELPHI_7_UP} + {$define DELPHI_9_UP} + {$define DELPHI_10_UP} + {$endif} + + {$ifdef CPPB_3} + {$define CPPB_3_UP} + {$endif} + + {$ifdef CPPB_4} + {$define CPPB_3_UP} + {$define CPPB_4_UP} + {$endif} + + {$ifdef CPPB_5} + {$define CPPB_3_UP} + {$define CPPB_4_UP} + {$define CPPB_5_UP} + {$endif} + + {$ifdef CPPB_6} + {$define CPPB_3_UP} + {$define CPPB_4_UP} + {$define CPPB_5_UP} + {$define CPPB_6_UP} + {$endif} + + {$ifdef CPPB_3_UP} + // C++ Builder requires this if you use Delphi components in run-time packages. + {$ObjExportAll On} + {$endif} + +{$else (not Windows)} + // Linux is the target + {$define QT_CLX} + + {$define KYLIX} + {$define KYLIX_1} + {$define KYLIX_1_UP} + + {$ifdef VER150} + {$define COMPILER_7} + {$define KYLIX_3} + {$endif} + + {$ifdef VER140} + {$define COMPILER_6} + {$define KYLIX_2} + {$endif} + + {$ifdef KYLIX_2} + {$define KYLIX_2_UP} + {$endif} + + {$ifdef KYLIX_3} + {$define KYLIX_2_UP} + {$define KYLIX_3_UP} + {$endif} + +{$endif} + +// Compiler defines common to all platforms. +{$ifdef COMPILER_1} + {$define COMPILER_1_UP} +{$endif} + +{$ifdef COMPILER_2} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} +{$endif} + +{$ifdef COMPILER_3} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} +{$endif} + +{$ifdef COMPILER_4} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} +{$endif} + +{$ifdef COMPILER_5} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} +{$endif} + +{$ifdef COMPILER_6} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} +{$endif} + +{$ifdef COMPILER_7} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} + {$define COMPILER_7_UP} +{$endif} + +{$ifdef COMPILER_9} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} + {$define COMPILER_7_UP} + {$define COMPILER_9_UP} +{$endif} + +{$ifdef COMPILER_10} + {$define COMPILER_1_UP} + {$define COMPILER_2_UP} + {$define COMPILER_3_UP} + {$define COMPILER_4_UP} + {$define COMPILER_5_UP} + {$define COMPILER_6_UP} + {$define COMPILER_7_UP} + {$define COMPILER_9_UP} + {$define COMPILER_10_UP} +{$endif} + +//---------------------------------------------------------------------------------------------------------------------- + +{$ALIGN ON} +{$BOOLEVAL OFF} + +{$ifdef COMPILER_7_UP} + {$define THEME_7_UP} { Allows experimental theme support on pre-Delphi 7. } +{$endif} + +{$IFDEF COMPILER_6_UP} +{$WARN SYMBOL_PLATFORM OFF} { We are going to use Win32 specific symbols! } +{$ENDIF} + +{$IFDEF COMPILER_7_UP} +{$IFDEF FPC} + {$DEFINE UNSAFE_WARNINGS_OFF} +{$ENDIF} +{$ENDIF} + +{$IFDEF UNSAFE_WARNINGS_OFF} +{$WARN UNSAFE_CODE OFF} { We are not going to be "safe"! } +{$WARN UNSAFE_TYPE OFF} +{$WARN UNSAFE_CAST OFF} +{$ENDIF} + +{$IFDEF FPC} +{$HINTS OFF} +{$ENDIF} + +{$IFNDEF FPC} + // Delphi system function overrides might (not tested) cause problems on + // CPUs with code protection (NX-bit). So disable by default. + {.$DEFINE USE_SYSTEM_OVERRIDES} +{$ENDIF} + + diff --git a/src/lib/TntUnicodeControls/TntFormatStrUtils.pas b/src/lib/TntUnicodeControls/TntFormatStrUtils.pas new file mode 100644 index 00000000..c6b65082 --- /dev/null +++ b/src/lib/TntUnicodeControls/TntFormatStrUtils.pas @@ -0,0 +1,521 @@ + +{*****************************************************************************} +{ } +{ Tnt Delphi Unicode Controls } +{ http://www.tntware.com/delphicontrols/unicode/ } +{ Version: 2.3.0 } +{ } +{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } +{ } +{*****************************************************************************} + +unit TntFormatStrUtils; + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$INCLUDE TntCompilers.inc} + +interface + +// this unit provides functions to work with format strings + +uses + TntSysUtils; + +function GetCanonicalFormatStr(const _FormatString: WideString): WideString; + +{$IFNDEF FPC} +{$IFNDEF COMPILER_9_UP} +function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString; + const Args: array of const + {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString; +{$ENDIF} +{$ENDIF} +procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString); +function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean; + +type + EFormatSpecError = class(ETntGeneralError); + +implementation + +uses + SysUtils, Math, TntClasses; + +resourcestring + SInvalidFormatSpecifier = 'Invalid Format Specifier: %s'; + SMismatchedArgumentTypes = 'Argument types for index %d do not match. (%s <> %s)'; + SMismatchedArgumentCounts = 'Number of format specifiers do not match.'; + +type + TFormatSpecifierType = (fstInteger, fstFloating, fstPointer, fstString); + +function GetFormatSpecifierType(const FormatSpecifier: WideString): TFormatSpecifierType; +var + LastChar: WideChar; +begin + LastChar := TntWideLastChar(FormatSpecifier); + case LastChar of + 'd', 'D', 'u', 'U', 'x', 'X': + result := fstInteger; + 'e', 'E', 'f', 'F', 'g', 'G', 'n', 'N', 'm', 'M': + result := fstFloating; + 'p', 'P': + result := fstPointer; + 's', 'S': + result := fstString + else + raise ETntInternalError.CreateFmt('Internal Error: Unexpected format type (%s)', [LastChar]); + end; +end; + +type + TFormatStrParser = class(TObject) + private + ParsedString: TBufferedWideString; + PFormatString: PWideChar; + LastIndex: Integer; + ExplicitCount: Integer; + ImplicitCount: Integer; + procedure RaiseInvalidFormatSpecifier; + function ParseChar(c: WideChar): Boolean; + procedure ForceParseChar(c: WideChar); + function ParseDigit: Boolean; + function ParseInteger: Boolean; + procedure ForceParseType; + function PeekDigit: Boolean; + function PeekIndexSpecifier(out Index: Integer): Boolean; + public + constructor Create(const _FormatString: WideString); + destructor Destroy; override; + function ParseFormatSpecifier: Boolean; + end; + +constructor TFormatStrParser.Create(const _FormatString: WideString); +begin + inherited Create; + PFormatString := PWideChar(_FormatString); + ExplicitCount := 0; + ImplicitCount := 0; + LastIndex := -1; + ParsedString := TBufferedWideString.Create; +end; + +destructor TFormatStrParser.Destroy; +begin + FreeAndNil(ParsedString); + inherited; +end; + +procedure TFormatStrParser.RaiseInvalidFormatSpecifier; +begin + raise EFormatSpecError.CreateFmt(SInvalidFormatSpecifier, [ParsedString.Value + PFormatString]); +end; + +function TFormatStrParser.ParseChar(c: WideChar): Boolean; +begin + result := False; + if PFormatString^ = c then begin + result := True; + ParsedString.AddChar(c); + Inc(PFormatString); + end; +end; + +procedure TFormatStrParser.ForceParseChar(c: WideChar); +begin + if not ParseChar(c) then + RaiseInvalidFormatSpecifier; +end; + +function TFormatStrParser.PeekDigit: Boolean; +begin + result := False; + if (PFormatString^ <> #0) + and (PFormatString^ >= '0') + and (PFormatString^ <= '9') then + result := True; +end; + +function TFormatStrParser.ParseDigit: Boolean; +begin + result := False; + if PeekDigit then begin + result := True; + ForceParseChar(PFormatString^); + end; +end; + +function TFormatStrParser.ParseInteger: Boolean; +const + MAX_INT_DIGITS = 6; +var + digitcount: integer; +begin + digitcount := 0; + While ParseDigit do begin + inc(digitcount); + end; + result := (digitcount > 0); + if digitcount > MAX_INT_DIGITS then + RaiseInvalidFormatSpecifier; +end; + +procedure TFormatStrParser.ForceParseType; +begin + if PFormatString^ = #0 then + RaiseInvalidFormatSpecifier; + + case PFormatString^ of + 'd', 'u', 'x', 'e', 'f', 'g', 'n', 'm', 'p', 's', + 'D', 'U', 'X', 'E', 'F', 'G', 'N', 'M', 'P', 'S': + begin + // do nothing + end + else + RaiseInvalidFormatSpecifier; + end; + ForceParseChar(PFormatString^); +end; + +function TFormatStrParser.PeekIndexSpecifier(out Index: Integer): Boolean; +var + SaveParsedString: WideString; + SaveFormatString: PWideChar; +begin + SaveParsedString := ParsedString.Value; + SaveFormatString := PFormatString; + try + ParsedString.Clear; + Result := False; + Index := -1; + if ParseInteger then begin + Index := StrToInt(ParsedString.Value); + if ParseChar(':') then + Result := True; + end; + finally + ParsedString.Clear; + ParsedString.AddString(SaveParsedString); + PFormatString := SaveFormatString; + end; +end; + +function TFormatStrParser.ParseFormatSpecifier: Boolean; +var + ExplicitIndex: Integer; +begin + Result := False; + // Parse entire format specifier + ForceParseChar('%'); + if (PFormatString^ <> #0) + and (not ParseChar(' ')) + and (not ParseChar('%')) then begin + if PeekIndexSpecifier(ExplicitIndex) then begin + Inc(ExplicitCount); + LastIndex := Max(LastIndex, ExplicitIndex); + end else begin + Inc(ImplicitCount); + Inc(LastIndex); + ParsedString.AddString(IntToStr(LastIndex)); + ParsedString.AddChar(':'); + end; + if ParseChar('*') then + begin + Inc(ImplicitCount); + Inc(LastIndex); + ParseChar(':'); + end else if ParseInteger then + ParseChar(':'); + ParseChar('-'); + if ParseChar('*') then begin + Inc(ImplicitCount); + Inc(LastIndex); + end else + ParseInteger; + if ParseChar('.') then begin + if not ParseChar('*') then + ParseInteger; + end; + ForceParseType; + Result := True; + end; +end; + +//----------------------------------- + +function GetCanonicalFormatStr(const _FormatString: WideString): WideString; +var + PosSpec: Integer; +begin + with TFormatStrParser.Create(_FormatString) do + try + // loop until no more '%' + PosSpec := Pos('%', 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 new file mode 100644 index 00000000..b7cf2467 --- /dev/null +++ b/src/lib/TntUnicodeControls/TntSysUtils.pas @@ -0,0 +1,1753 @@ + +{*****************************************************************************} +{ } +{ 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 new file mode 100644 index 00000000..e613ce0c --- /dev/null +++ b/src/lib/TntUnicodeControls/TntSystem.pas @@ -0,0 +1,1427 @@ + +{*****************************************************************************} +{ } +{ 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 new file mode 100644 index 00000000..99f63aea --- /dev/null +++ b/src/lib/TntUnicodeControls/TntWideStrUtils.pas @@ -0,0 +1,455 @@ + +{*****************************************************************************} +{ } +{ 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 new file mode 100644 index 00000000..75132d22 --- /dev/null +++ b/src/lib/TntUnicodeControls/TntWideStrings.pas @@ -0,0 +1,846 @@ + +{*****************************************************************************} +{ } +{ 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 new file mode 100644 index 00000000..8fd7ec88 --- /dev/null +++ b/src/lib/TntUnicodeControls/TntWindows.pas @@ -0,0 +1,1501 @@ + +{*****************************************************************************} +{ } +{ 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. diff --git a/src/lib/ctypes/ctypes.pas b/src/lib/ctypes/ctypes.pas index 6cdf77fc..694552dc 100644 --- a/src/lib/ctypes/ctypes.pas +++ b/src/lib/ctypes/ctypes.pas @@ -1,72 +1,72 @@ -{
- This file is part of the Free Pascal run time library.
- Copyright (c) 2004 by Marco van de Voort, member of the
- Free Pascal development team
-
- Implements C types for in header conversions
-
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
-
- **********************************************************************}
-
-unit ctypes;
-
-interface
-
-type
- qword = int64; // Keep h2pas "uses ctypes" headers working with delphi.
-
- { the following type definitions are compiler dependant }
- { and system dependant }
-
- cint8 = shortint; pcint8 = ^cint8;
- cuint8 = byte; pcuint8 = ^cuint8;
- cchar = cint8; pcchar = ^cchar;
- cschar = cint8; pcschar = ^cschar;
- cuchar = cuint8; pcuchar = ^cuchar;
-
- cint16 = smallint; pcint16 = ^cint16;
- cuint16 = word; pcuint16 = ^cuint16;
- cshort = cint16; pcshort = ^cshort;
- csshort = cint16; pcsshort = ^csshort;
- cushort = cuint16; pcushort = ^cushort;
-
- cint32 = longint; pcint32 = ^cint32;
- cuint32 = longword; pcuint32 = ^cuint32;
- cint = cint32; pcint = ^cint; { minimum range is : 32-bit }
- csint = cint32; pcsint = ^csint; { minimum range is : 32-bit }
- cuint = cuint32; pcuint = ^cuint; { minimum range is : 32-bit }
- csigned = cint; pcsigned = ^csigned;
- cunsigned = cuint; pcunsigned = ^cunsigned;
-
- cint64 = int64; pcint64 = ^cint64;
- cuint64 = qword; pcuint64 = ^cuint64;
- clonglong = cint64; pclonglong = ^clonglong;
- cslonglong = cint64; pcslonglong = ^cslonglong;
- culonglong = cuint64; pculonglong = ^culonglong;
-
- cbool = longbool; pcbool = ^cbool;
-
-{$if defined(cpu64) and not(defined(win64) and defined(cpux86_64))}
- clong = int64; pclong = ^clong;
- cslong = int64; pcslong = ^cslong;
- culong = qword; pculong = ^culong;
-{$else}
- clong = longint; pclong = ^clong;
- cslong = longint; pcslong = ^cslong;
- culong = cardinal; pculong = ^culong;
-{$ifend}
-
- cfloat = single; pcfloat = ^cfloat;
- cdouble = double; pcdouble = ^cdouble;
- clongdouble = extended; pclongdouble = ^clongdouble;
-
-implementation
-
-end.
+{ + This file is part of the Free Pascal run time library. + Copyright (c) 2004 by Marco van de Voort, member of the + Free Pascal development team + + Implements C types for in header conversions + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + + **********************************************************************} + +unit ctypes; + +interface + +type + qword = int64; // Keep h2pas "uses ctypes" headers working with delphi. + + { the following type definitions are compiler dependant } + { and system dependant } + + cint8 = shortint; pcint8 = ^cint8; + cuint8 = byte; pcuint8 = ^cuint8; + cchar = cint8; pcchar = ^cchar; + cschar = cint8; pcschar = ^cschar; + cuchar = cuint8; pcuchar = ^cuchar; + + cint16 = smallint; pcint16 = ^cint16; + cuint16 = word; pcuint16 = ^cuint16; + cshort = cint16; pcshort = ^cshort; + csshort = cint16; pcsshort = ^csshort; + cushort = cuint16; pcushort = ^cushort; + + cint32 = longint; pcint32 = ^cint32; + cuint32 = longword; pcuint32 = ^cuint32; + cint = cint32; pcint = ^cint; { minimum range is : 32-bit } + csint = cint32; pcsint = ^csint; { minimum range is : 32-bit } + cuint = cuint32; pcuint = ^cuint; { minimum range is : 32-bit } + csigned = cint; pcsigned = ^csigned; + cunsigned = cuint; pcunsigned = ^cunsigned; + + cint64 = int64; pcint64 = ^cint64; + cuint64 = qword; pcuint64 = ^cuint64; + clonglong = cint64; pclonglong = ^clonglong; + cslonglong = cint64; pcslonglong = ^cslonglong; + culonglong = cuint64; pculonglong = ^culonglong; + + cbool = longbool; pcbool = ^cbool; + +{$if defined(cpu64) and not(defined(win64) and defined(cpux86_64))} + clong = int64; pclong = ^clong; + cslong = int64; pcslong = ^cslong; + culong = qword; pculong = ^culong; +{$else} + clong = longint; pclong = ^clong; + cslong = longint; pcslong = ^cslong; + culong = cardinal; pculong = ^culong; +{$ifend} + + cfloat = single; pcfloat = ^cfloat; + cdouble = double; pcdouble = ^cdouble; + clongdouble = extended; pclongdouble = ^clongdouble; + +implementation + +end. diff --git a/src/lib/ffmpeg/avformat.pas b/src/lib/ffmpeg/avformat.pas index 0ec2c118..e39416a1 100644 --- a/src/lib/ffmpeg/avformat.pas +++ b/src/lib/ffmpeg/avformat.pas @@ -1132,7 +1132,7 @@ function av_probe_input_format(pd: PAVProbeData; is_opened: cint): PAVInputForma * Allocates all the structures needed to read an input stream. * This does not open the needed codecs for decoding the stream[s]. *) -function av_open_input_stream(ic_ptr: PAVFormatContext; +function av_open_input_stream(var ic_ptr: PAVFormatContext; pb: PByteIOContext; filename: PAnsiChar; fmt: PAVInputFormat; ap: PAVFormatParameters): cint; cdecl; external av__format; diff --git a/src/lib/ffmpeg/avio.pas b/src/lib/ffmpeg/avio.pas index dc0a330b..c47bb618 100644 --- a/src/lib/ffmpeg/avio.pas +++ b/src/lib/ffmpeg/avio.pas @@ -108,14 +108,16 @@ type name: PAnsiChar; url_open: function (h: PURLContext; filename: {const} PAnsiChar; flags: cint): cint; cdecl; url_read: function (h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; + {$IF LIBAVFORMAT_VERSION >= 52034001} // 52.34.1 url_read_complete: function (h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; + {$IFEND} url_write: function (h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; url_seek: function (h: PURLContext; pos: cint64; whence: cint): cint64; cdecl; url_close: function (h: PURLContext): cint; cdecl; next: PURLProtocol; {$IF (LIBAVFORMAT_VERSION >= 52001000) and (LIBAVFORMAT_VERSION < 52004000)} // 52.1.0 .. 52.4.0 - url_read_play: function (h: PURLContext): cint; - url_read_pause: function (h: PURLContext): cint; + url_read_play: function (h: PURLContext): cint; cdecl; + url_read_pause: function (h: PURLContext): cint; cdecl; {$IFEND} {$IF LIBAVFORMAT_VERSION >= 52004000} // 52.4.0 url_read_pause: function (h: PURLContext; pause: cint): cint; cdecl; @@ -278,16 +280,19 @@ function av_protocol_next(p: PURLProtocol): PURLProtocol; (** * @deprecated Use av_register_protocol() instead. *) -function register_protocol (protocol: PURLProtocol): cint; +function register_protocol(protocol: PURLProtocol): cint; cdecl; external av__format; +(** Alias for register_protocol() *) +function av_register_protocol(protocol: PURLProtocol): cint; + cdecl; external av__format name 'register_protocol'; {$ELSE} -function av_register_protocol (protocol: PURLProtocol): cint; +function av_register_protocol(protocol: PURLProtocol): cint; cdecl; external av__format; {$IFEND} type - TReadWriteFunc = function (opaque: Pointer; buf: PByteArray; buf_size: cint): cint; cdecl; - TSeekFunc = function (opaque: Pointer; offset: cint64; whence: cint): cint64; cdecl; + TReadWriteFunc = function(opaque: Pointer; buf: PByteArray; buf_size: cint): cint; cdecl; + TSeekFunc = function(opaque: Pointer; offset: cint64; whence: cint): cint64; cdecl; function init_put_byte(s: PByteIOContext; buffer: PByteArray; diff --git a/src/lib/fft/UFFT.pas b/src/lib/fft/UFFT.pas index 6b094c98..5a056a8c 100644 --- a/src/lib/fft/UFFT.pas +++ b/src/lib/fft/UFFT.pas @@ -47,7 +47,7 @@ unit UFFT; {$IFDEF FPC} {$MODE Delphi} - {$H+} // Use AnsiString + {$H+} // Use long strings {$ENDIF} interface diff --git a/src/lib/freetype/demo/engine-test.bdsproj b/src/lib/freetype/demo/engine-test.bdsproj index 9547f18f..e5b3e97d 100644 --- a/src/lib/freetype/demo/engine-test.bdsproj +++ b/src/lib/freetype/demo/engine-test.bdsproj @@ -27,13 +27,13 @@ <Compiler Name="I">1</Compiler>
<Compiler Name="J">0</Compiler>
<Compiler Name="K">0</Compiler>
- <Compiler Name="L">1</Compiler>
- <Compiler Name="M">0</Compiler>
- <Compiler Name="N">1</Compiler>
- <Compiler Name="O">0</Compiler>
- <Compiler Name="P">1</Compiler>
- <Compiler Name="Q">0</Compiler>
- <Compiler Name="R">0</Compiler>
+ <Compiler Name="L">1</Compiler> + <Compiler Name="M">0</Compiler> + <Compiler Name="N">1</Compiler> + <Compiler Name="O">1</Compiler> + <Compiler Name="P">1</Compiler> + <Compiler Name="Q">0</Compiler> + <Compiler Name="R">0</Compiler> <Compiler Name="S">0</Compiler>
<Compiler Name="T">0</Compiler>
<Compiler Name="U">0</Compiler>
diff --git a/src/lib/freetype/demo/engine-test.dpr b/src/lib/freetype/demo/engine-test.dpr index 80177735..bbd7d890 100644 --- a/src/lib/freetype/demo/engine-test.dpr +++ b/src/lib/freetype/demo/engine-test.dpr @@ -27,7 +27,9 @@ uses ctypes in '../../ctypes/ctypes.pas', {$ENDIF} FreeType in '../freetype.pas', - UFont in '../../../base/UFont.pas', + UFont in 'UFont.pas', + //UFont in '../../../base/UFont.pas', + UUnicodeUtils in '../../../base/UUnicodeUtils.pas', math, sysutils; @@ -41,7 +43,7 @@ const //FONT_FILE = 'C:/Windows/Fonts/Arial.ttf'; //FONT_FILE = 'C:/Windows/Fonts/SimSun.ttf'; //FONT_FILE = 'eurostarregularextended.ttf'; - FONT_FILE = 'FreeSans.ttf'; + FONT_FILE = '../../../../game/fonts/FreeSans/FreeSans.ttf'; var OurFont: TScalableFont; @@ -129,11 +131,11 @@ begin // Really Nice Perspective Calculations glHint( GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST ); - //OurFont := TFTScalableFont.Create(FONT_FILE, 64); + OurFont := TFTScalableFont.Create(FONT_FILE, 64, 0.03); //OurFont := TFTFont.Create(FONT_FILE, 128); - OurFont := TFTScalableOutlineFont.Create(FONT_FILE, 64, 0.05); + //OurFont := TFTScalableOutlineFont.Create(FONT_FILE, 64, 0.03); //OurFont.UseKerning := false; - TFTScalableOutlineFont(OurFont).SetOutlineColor(1, 0, 0); + //TFTScalableOutlineFont(OurFont).SetOutlineColor(1, 0, 0, 1); //OurFont := TOutlineFont.Create(FONT_FILE, 32, 2); //OurFont.LineSpacing := OurFont.LineSpacing * 0.5; @@ -183,7 +185,7 @@ begin //OurFont.SetOutlineColor(0.5, 0.5, 0.5); //OurFont.ReflectionSpacing := -4; //OurFont.UseKerning := false; - OurFont.Height := 64;//cnt2; + OurFont.Height := 150;//cnt2; //OurFont.Reset; //OurFont.Aspect := 2; @@ -191,7 +193,7 @@ begin bounds := OurFont.BBox(msg); //glRectf(bounds.Left, OurFont.Ascender, bounds.Right, OurFont.Ascender-OurFont.Height); - glColor3f(1, 1, 1); + glColor4f(1, 1, 1, 1); //OurFont.ReflectionSpacing := 0; OurFont.Print(msg); diff --git a/src/lib/freetype/demo/engine-test.lpi b/src/lib/freetype/demo/engine-test.lpi index 6cbfe1eb..45483a56 100644 --- a/src/lib/freetype/demo/engine-test.lpi +++ b/src/lib/freetype/demo/engine-test.lpi @@ -28,14 +28,14 @@ </local>
</RunParams>
<Units Count="16">
- <Unit0>
- <Filename Value="engine-test.dpr"/>
- <IsPartOfProject Value="True"/>
- <CursorPos X="25" Y="135"/>
- <TopLine Value="118"/>
- <EditorIndex Value="0"/>
- <UsageCount Value="72"/>
- <Loaded Value="True"/>
+ <Unit0> + <Filename Value="engine-test.dpr"/> + <IsPartOfProject Value="True"/> + <CursorPos X="18" Y="25"/> + <TopLine Value="1"/> + <EditorIndex Value="0"/> + <UsageCount Value="72"/> + <Loaded Value="True"/> </Unit0>
<Unit1>
<Filename Value="JEDI-SDL\OpenGL\Pas\opengl12.pas"/>
@@ -139,13 +139,22 @@ <UnitName Value="UFont"/>
<CursorPos X="15" Y="1752"/>
<TopLine Value="1734"/>
- <UsageCount Value="10"/>
- </Unit15>
- </Units>
- <JumpHistory Count="0" HistoryIndex="-1"/>
- </ProjectOptions>
- <CompilerOptions>
- <Version Value="8"/>
+ <UsageCount Value="10"/> + </Unit15> + </Units> + <JumpHistory Count="2" HistoryIndex="1"> + <Position1> + <Filename Value="engine-test.dpr"/> + <Caret Line="52" Column="10" TopLine="37"/> + </Position1> + <Position2> + <Filename Value="engine-test.dpr"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position2> + </JumpHistory> + </ProjectOptions> + <CompilerOptions> + <Version Value="8"/> <PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="..\..\JEDI-SDL\SDL\Pas\"/>
diff --git a/src/lib/freetype/freetype.pas b/src/lib/freetype/freetype.pas index 6a9d2062..6aaa3b59 100644 --- a/src/lib/freetype/freetype.pas +++ b/src/lib/freetype/freetype.pas @@ -1,23 +1,42 @@ -//---------------------------------------------------------------------------- -// FreeType2 pascal header -//---------------------------------------------------------------------------- -// Anti-Grain Geometry - Version 2.4 (Public License) -// Copyright (C) 2002-2005 Maxim Shemanarev (http://www.antigrain.com) -// -// Anti-Grain Geometry - Version 2.4 Release Milano 3 (AggPas 2.4 RM3) -// Pascal Port By: Milan Marusinec alias Milano -// milan@marusinec.sk -// http://www.aggpas.org -// Copyright (c) 2005-2007 -// -// Permission to copy, use, modify, sell and distribute this software -// is granted provided this copyright notice appears in all copies. -// This software is provided "as is" without express or implied -// warranty, and with no claim as to its suitability for any purpose. -// -//---------------------------------------------------------------------------- -// Adapted by the UltraStar Deluxe Team -//---------------------------------------------------------------------------- +(***************************************************************************) +(* *) +(* freetype.h *) +(* *) +(* FreeType high-level API and common types (specification only). *) +(* *) +(* Copyright 1996-2001, 2002, 2003, 2004, 2005, 2006, 2007 by *) +(* David Turner, Robert Wilhelm, and Werner Lemberg. *) +(* *) +(* This file is part of the FreeType project, and may only be used, *) +(* modified, and distributed under the terms of the FreeType project *) +(* license, LICENSE.TXT. By continuing to use, modify, or distribute *) +(* this file you indicate that you have read the license and *) +(* understand and accept it fully. *) +(* *) +(***************************************************************************) + +(***************************************************************************) +(* Initial Pascal port by *) +(***************************************************************************) +(* Anti-Grain Geometry - Version 2.4 (Public License) *) +(* Copyright (C) 2002-2005 Maxim Shemanarev (http://www.antigrain.com) *) +(* *) +(* Anti-Grain Geometry - Version 2.4 Release Milano 3 (AggPas 2.4 RM3) *) +(* Pascal Port By: Milan Marusinec alias Milano *) +(* milan@marusinec.sk *) +(* http://www.aggpas.org *) +(* Copyright (c) 2005-2007 *) +(* *) +(* Permission to copy, use, modify, sell and distribute this software *) +(* is granted provided this copyright notice appears in all copies. *) +(* This software is provided "as is" without express or implied *) +(* warranty, and with no claim as to its suitability for any purpose. *) +(* *) +(***************************************************************************) + +(***************************************************************************) +(* Extended by the UltraStar Deluxe Team *) +(***************************************************************************) unit freetype; @@ -36,7 +55,7 @@ uses const {$IF Defined(MSWINDOWS)} - ft_lib = 'libfreetype-6.dll'; + ft_lib = 'freetype6.dll'; {$ELSEIF Defined(DARWIN)} ft_lib = 'libfreetype.dylib'; {$LINKLIB libfreetype} @@ -45,32 +64,24 @@ const {$IFEND} type - FT_Byte = cuchar; - FT_Short = csshort; - FT_UShort = cushort; - FT_Int = csint; - FT_UInt = cuint; - FT_Int16 = cint16; - FT_UInt16 = cuint16; - FT_Int32 = cint32; - FT_UInt32 = cuint32; - FT_Long = cslong; - FT_ULong = culong; - - FT_Fixed = cslong; - FT_Pos = cslong; - FT_Error = cint; - FT_F26Dot6 = cslong; - FT_String = cchar; - FT_Bool = cuchar; - - PFT_Byte = ^FT_Byte; - PFT_Short = ^FT_Short; - PFT_String = ^FT_String; - - - TByteArray = array [0 .. (MaxInt div SizeOf(byte))-1] of byte; - PByteArray = ^TByteArray; + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Library *) + (* *) + (* <Description> *) + (* A handle to a FreeType library instance. Each `library' is *) + (* completely independent from the others; it is the `root' of a set *) + (* of objects like fonts, faces, sizes, etc. *) + (* *) + (* It also embeds a memory manager (see @FT_Memory), as well as a *) + (* scan-line converter object (see @FT_Raster). *) + (* *) + (* <Note> *) + (* Library objects are normally created by @FT_Init_FreeType, and *) + (* destroyed with @FT_Done_FreeType. *) + (* *) + FT_Library = Pointer; (*************************************************************************) @@ -290,54 +301,6 @@ const FT_ENCODING_WANSUNG: FT_Encoding = ('w', 'a', 'n', 's'); FT_ENCODING_JOHAB: FT_Encoding = ('j', 'o', 'h', 'a'); - (*************************************************************************) - (* *) - (* <Enum> *) - (* FT_Glyph_Format *) - (* *) - (* <Description> *) - (* An enumeration type used to describe the format of a given glyph *) - (* image. Note that this version of FreeType only supports two image *) - (* formats, even though future font drivers will be able to register *) - (* their own format. *) - (* *) - (* <Values> *) - (* FT_GLYPH_FORMAT_NONE :: *) - (* The value 0 is reserved and does describe a glyph format. *) - (* *) - (* FT_GLYPH_FORMAT_COMPOSITE :: *) - (* The glyph image is a composite of several other images. This *) - (* format is _only_ used with @FT_LOAD_NO_RECURSE, and is used to *) - (* report compound glyphs (like accented characters). *) - (* *) - (* FT_GLYPH_FORMAT_BITMAP :: *) - (* The glyph image is a bitmap, and can be described as an *) - (* @FT_Bitmap. You generally need to access the `bitmap' field of *) - (* the @FT_GlyphSlotRec structure to read it. *) - (* *) - (* FT_GLYPH_FORMAT_OUTLINE :: *) - (* The glyph image is a vertorial outline made of line segments *) - (* and Bezier arcs; it can be described as an @FT_Outline; you *) - (* generally want to access the `outline' field of the *) - (* @FT_GlyphSlotRec structure to read it. *) - (* *) - (* FT_GLYPH_FORMAT_PLOTTER :: *) - (* The glyph image is a vectorial path with no inside/outside *) - (* contours. Some Type 1 fonts, like those in the Hershey family, *) - (* contain glyphs in this format. These are described as *) - (* @FT_Outline, but FreeType isn't currently capable of rendering *) - (* them correctly. *) - (* *) -type - FT_Glyph_Format = array[0..3] of char; -const - FT_GLYPH_FORMAT_NONE: FT_Glyph_Format = (#0, #0, #0, #0 ); - - FT_GLYPH_FORMAT_COMPOSITE: FT_Glyph_Format = ('c', 'o', 'm', 'p' ); - FT_GLYPH_FORMAT_BITMAP: FT_Glyph_Format = ('b', 'i', 't', 's' ); - FT_GLYPH_FORMAT_OUTLINE: FT_Glyph_Format = ('o', 'u', 't', 'l' ); - FT_GLYPH_FORMAT_PLOTTER: FT_Glyph_Format = ('p', 'l', 'o', 't' ); - (*************************************************************************) (* *) @@ -358,7 +321,7 @@ const const FT_STYLE_FLAG_ITALIC = 1 shl 0; FT_STYLE_FLAG_BOLD = 1 shl 1; - + (*************************************************************************** * @@ -567,7 +530,7 @@ const (* perform this pass. *) (* *) type - FT_Render_Mode = FT_Int; + FT_Render_Mode = cint; const FT_RENDER_MODE_NORMAL = 0; FT_RENDER_MODE_LIGHT = FT_RENDER_MODE_NORMAL + 1; @@ -579,63 +542,34 @@ const (*************************************************************************) (* *) - (* <Enum> *) - (* FT_Pixel_Mode *) + (* <Type> *) + (* FT_GlyphSlot *) (* *) (* <Description> *) - (* An enumeration type used to describe the format of pixels in a *) - (* given bitmap. Note that additional formats may be added in the *) - (* future. *) + (* A handle to a given `glyph slot'. A slot is a container where it *) + (* is possible to load any one of the glyphs contained in its parent *) + (* face. *) (* *) - (* <Values> *) - (* FT_PIXEL_MODE_NONE :: *) - (* Value 0 is reserved. *) - (* *) - (* FT_PIXEL_MODE_MONO :: *) - (* A monochrome bitmap, using 1 bit per pixel. Note that pixels *) - (* are stored in most-significant order (MSB), which means that *) - (* the left-most pixel in a byte has value 128. *) - (* *) - (* FT_PIXEL_MODE_GRAY :: *) - (* An 8-bit bitmap, generally used to represent anti-aliased glyph *) - (* images. Each pixel is stored in one byte. Note that the number *) - (* of value `gray' levels is stored in the `num_bytes' field of *) - (* the @FT_Bitmap structure (it generally is 256). *) - (* *) - (* FT_PIXEL_MODE_GRAY2 :: *) - (* A 2-bit/pixel bitmap, used to represent embedded anti-aliased *) - (* bitmaps in font files according to the OpenType specification. *) - (* We haven't found a single font using this format, however. *) - (* *) - (* FT_PIXEL_MODE_GRAY4 :: *) - (* A 4-bit/pixel bitmap, used to represent embedded anti-aliased *) - (* bitmaps in font files according to the OpenType specification. *) - (* We haven't found a single font using this format, however. *) - (* *) - (* FT_PIXEL_MODE_LCD :: *) - (* An 8-bit bitmap, used to represent RGB or BGR decimated glyph *) - (* images used for display on LCD displays; the bitmap is three *) - (* times wider than the original glyph image. See also *) - (* @FT_RENDER_MODE_LCD. *) - (* *) - (* FT_PIXEL_MODE_LCD_V :: *) - (* An 8-bit bitmap, used to represent RGB or BGR decimated glyph *) - (* images used for display on rotated LCD displays; the bitmap *) - (* is three times taller than the original glyph image. See also *) - (* @FT_RENDER_MODE_LCD_V. *) + (* In other words, each time you call @FT_Load_Glyph or *) + (* @FT_Load_Char, the slot's content is erased by the new glyph data, *) + (* i.e. the glyph's metrics, its image (bitmap or outline), and *) + (* other control information. *) + (* *) + (* <Also> *) + (* @FT_GlyphSlotRec details the publicly accessible glyph fields. *) (* *) type - FT_Pixel_Mode = byte; -const - FT_PIXEL_MODE_NONE = 0; - FT_PIXEL_MODE_MONO = FT_PIXEL_MODE_NONE + 1; - FT_PIXEL_MODE_GRAY = FT_PIXEL_MODE_MONO + 1; - FT_PIXEL_MODE_GRAY2 = FT_PIXEL_MODE_GRAY + 1; - FT_PIXEL_MODE_GRAY4 = FT_PIXEL_MODE_GRAY2 + 1; - FT_PIXEL_MODE_LCD = FT_PIXEL_MODE_GRAY4 + 1; - FT_PIXEL_MODE_LCD_V = FT_PIXEL_MODE_LCD + 1; + FT_GlyphSlot = ^FT_GlyphSlotRec; - FT_PIXEL_MODE_MAX = FT_PIXEL_MODE_LCD_V + 1; (* do not remove *) + +{$DEFINE TYPE_DECL} +{$I ftconfig.inc} +{$I fttypes.inc} +{$I ftimage.inc} +{$I ftglyph.inc} +{$I ftstroke.inc} +{$I ftoutln.inc} +{$UNDEF TYPE_DECL} (*************************************************************************) @@ -674,7 +608,6 @@ const (* vertAdvance :: *) (* Advance height for vertical layout. *) (* *) -type FT_Glyph_Metrics = record width , height : FT_Pos; @@ -759,140 +692,6 @@ type (*************************************************************************) (* *) - (* <Struct> *) - (* FT_Vector *) - (* *) - (* <Description> *) - (* A simple structure used to store a 2D vector; coordinates are of *) - (* the FT_Pos type. *) - (* *) - (* <Fields> *) - (* x :: The horizontal coordinate. *) - (* y :: The vertical coordinate. *) - (* *) - PFT_Vector = ^FT_Vector; - FT_Vector = record - x , - y : FT_Pos; - end; - - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_Outline *) - (* *) - (* <Description> *) - (* This structure is used to describe an outline to the scan-line *) - (* converter. *) - (* *) - (* <Fields> *) - (* n_contours :: The number of contours in the outline. *) - (* *) - (* n_points :: The number of points in the outline. *) - (* *) - (* points :: A pointer to an array of `n_points' FT_Vector *) - (* elements, giving the outline's point coordinates. *) - (* *) - (* tags :: A pointer to an array of `n_points' chars, giving *) - (* each outline point's type. If bit 0 is unset, the *) - (* point is `off' the curve, i.e. a Bezier control *) - (* point, while it is `on' when set. *) - (* *) - (* Bit 1 is meaningful for `off' points only. If set, *) - (* it indicates a third-order Bezier arc control point; *) - (* and a second-order control point if unset. *) - (* *) - (* contours :: An array of `n_contours' shorts, giving the end *) - (* point of each contour within the outline. For *) - (* example, the first contour is defined by the points *) - (* `0' to `contours[0]', the second one is defined by *) - (* the points `contours[0]+1' to `contours[1]', etc. *) - (* *) - (* flags :: A set of bit flags used to characterize the outline *) - (* and give hints to the scan-converter and hinter on *) - (* how to convert/grid-fit it. See FT_Outline_Flags. *) - (* *) - PFT_Outline = ^FT_Outline; - FT_Outline = record - n_contours : FT_Short; - n_points : FT_Short; - - points : PFT_Vector; - tags : PChar; - contours : PFT_Short; - - flags : FT_Int; - end; - - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_Bitmap *) - (* *) - (* <Description> *) - (* A structure used to describe a bitmap or pixmap to the raster. *) - (* Note that we now manage pixmaps of various depths through the *) - (* `pixel_mode' field. *) - (* *) - (* <Fields> *) - (* rows :: The number of bitmap rows. *) - (* *) - (* width :: The number of pixels in bitmap row. *) - (* *) - (* pitch :: The pitch's absolute value is the number of bytes *) - (* taken by one bitmap row, including padding. *) - (* However, the pitch is positive when the bitmap has *) - (* a `down' flow, and negative when it has an `up' *) - (* flow. In all cases, the pitch is an offset to add *) - (* to a bitmap pointer in order to go down one row. *) - (* *) - (* buffer :: A typeless pointer to the bitmap buffer. This *) - (* value should be aligned on 32-bit boundaries in *) - (* most cases. *) - (* *) - (* num_grays :: This field is only used with *) - (* `FT_PIXEL_MODE_GRAY'; it gives the number of gray *) - (* levels used in the bitmap. *) - (* *) - (* pixel_mode :: The pixel mode, i.e., how pixel bits are stored. *) - (* See @FT_Pixel_Mode for possible values. *) - (* *) - (* palette_mode :: This field is only used with paletted pixel modes; *) - (* it indicates how the palette is stored. *) - (* *) - (* palette :: A typeless pointer to the bitmap palette; only *) - (* used for paletted pixel modes. *) - (* *) - (* <Note> *) - (* For now, the only pixel mode supported by FreeType are mono and *) - (* grays. However, drivers might be added in the future to support *) - (* more `colorful' options. *) - (* *) - (* When using pixel modes pal2, pal4 and pal8 with a void `palette' *) - (* field, a gray pixmap with respectively 4, 16, and 256 levels of *) - (* gray is assumed. This, in order to be compatible with some *) - (* embedded bitmap formats defined in the TrueType specification. *) - (* *) - (* Note that no font was found presenting such embedded bitmaps, so *) - (* this is currently completely unhandled by the library. *) - (* *) - PFT_Bitmap = ^FT_Bitmap; - FT_Bitmap = record - rows , - width : FT_Int; - pitch : FT_Int; - buffer : PByteArray; - num_grays : FT_Short; - pixel_mode , - palette_mode : byte; - palette : pointer; - end; - - - (*************************************************************************) - (* *) (* <Type> *) (* FT_Face *) (* *) @@ -950,184 +749,11 @@ type PAFT_CharMap = ^FT_CharMap; AFT_CharMap = array[0..High(Word)] of FT_CharMap; - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_Library *) - (* *) - (* <Description> *) - (* A handle to a FreeType library instance. Each `library' is *) - (* completely independent from the others; it is the `root' of a set *) - (* of objects like fonts, faces, sizes, etc. *) - (* *) - (* It also embeds a memory manager (see @FT_Memory), as well as a *) - (* scan-line converter object (see @FT_Raster). *) - (* *) - (* <Note> *) - (* Library objects are normally created by @FT_Init_FreeType, and *) - (* destroyed with @FT_Done_FreeType. *) - (* *) - FT_Library = ^FT_LibraryRec; - FT_LibraryRec = record // internal - end; - (*************************************************************************) - (* *) - (* <Section> *) - (* glyph_management *) - (* *) - (* <Title> *) - (* Glyph Management *) - (* *) - (* <Abstract> *) - (* Generic interface to manage individual glyph data. *) - (* *) - (* <Description> *) - (* This section contains definitions used to manage glyph data *) - (* through generic FT_Glyph objects. Each of them can contain a *) - (* bitmap, a vector outline, or even images in other formats. *) - (* *) - (*************************************************************************) - (* forward declaration to a private type *) - PFT_Glyph_Class = ^FT_Glyph_Class; - FT_Glyph_Class = record // internal - end; - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_Glyph *) - (* *) - (* <Description> *) - (* Handle to an object used to model generic glyph images. It is a *) - (* pointer to the @FT_GlyphRec structure and can contain a glyph *) - (* bitmap or pointer. *) - (* *) - (* <Note> *) - (* Glyph objects are not owned by the library. You must thus release *) - (* them manually (through @FT_Done_Glyph) _before_ calling *) - (* @FT_Done_FreeType. *) - (* *) - FT_Glyph = ^FT_GlyphRec; - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_GlyphRec *) - (* *) - (* <Description> *) - (* The root glyph structure contains a given glyph image plus its *) - (* advance width in 16.16 fixed float format. *) - (* *) - (* <Fields> *) - (* library :: A handle to the FreeType library object. *) - (* *) - (* clazz :: A pointer to the glyph's class. Private. *) - (* *) - (* format :: The format of the glyph's image. *) - (* *) - (* advance :: A 16.16 vector that gives the glyph's advance width. *) - (* *) - FT_GlyphRec = record - library_: FT_Library; - clazz: PFT_Glyph_Class; - format: FT_Glyph_Format; - advance: FT_Vector; - end; - - - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_BitmapGlyph *) - (* *) - (* <Description> *) - (* A handle to an object used to model a bitmap glyph image. This is *) - (* a sub-class of @FT_Glyph, and a pointer to @FT_BitmapGlyphRec. *) - (* *) - FT_BitmapGlyph = ^FT_BitmapGlyphRec; - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_BitmapGlyphRec *) - (* *) - (* <Description> *) - (* A structure used for bitmap glyph images. This really is a *) - (* `sub-class' of `FT_GlyphRec'. *) - (* *) - (* <Fields> *) - (* root :: The root FT_Glyph fields. *) - (* *) - (* left :: The left-side bearing, i.e., the horizontal distance *) - (* from the current pen position to the left border of the *) - (* glyph bitmap. *) - (* *) - (* top :: The top-side bearing, i.e., the vertical distance from *) - (* the current pen position to the top border of the glyph *) - (* bitmap. This distance is positive for upwards-y! *) - (* *) - (* bitmap :: A descriptor for the bitmap. *) - (* *) - (* <Note> *) - (* You can typecast FT_Glyph to FT_BitmapGlyph if you have *) - (* glyph->format == FT_GLYPH_FORMAT_BITMAP. This lets you access *) - (* the bitmap's contents easily. *) - (* *) - (* The corresponding pixel buffer is always owned by the BitmapGlyph *) - (* and is thus created and destroyed with it. *) - (* *) - FT_BitmapGlyphRec = record - root: FT_GlyphRec; - left: FT_Int; - top: FT_Int; - bitmap: FT_Bitmap; - end; - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_OutlineGlyph *) - (* *) - (* <Description> *) - (* A handle to an object used to model an outline glyph image. This *) - (* is a sub-class of @FT_Glyph, and a pointer to @FT_OutlineGlyphRec. *) - (* *) - FT_OutlineGlyph = ^FT_OutlineGlyphRec; - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_OutlineGlyphRec *) - (* *) - (* <Description> *) - (* A structure used for outline (vectorial) glyph images. This *) - (* really is a `sub-class' of `FT_GlyphRec'. *) - (* *) - (* <Fields> *) - (* root :: The root FT_Glyph fields. *) - (* *) - (* outline :: A descriptor for the outline. *) - (* *) - (* <Note> *) - (* You can typecast FT_Glyph to FT_OutlineGlyph if you have *) - (* glyph->format == FT_GLYPH_FORMAT_OUTLINE. This lets you access *) - (* the outline's content easily. *) - (* *) - (* As the outline is extracted from a glyph slot, its coordinates are *) - (* expressed normally in 26.6 pixels, unless the flag *) - (* FT_LOAD_NO_SCALE was used in FT_Load_Glyph() or FT_Load_Char(). *) - (* *) - (* The outline's tables are always owned by the object and are *) - (* destroyed with it. *) - (* *) - FT_OutlineGlyphRec = record - root: FT_GlyphRec; - outline: FT_Outline; - end; - (*************************************************************************) (* *) @@ -1149,101 +775,6 @@ type (*************************************************************************) (* *) - (* <FuncType> *) - (* FT_Generic_Finalizer *) - (* *) - (* <Description> *) - (* Describes a function used to destroy the `client' data of any *) - (* FreeType object. See the description of the FT_Generic type for *) - (* details of usage. *) - (* *) - (* <Input> *) - (* The address of the FreeType object which is under finalization. *) - (* Its client data is accessed through its `generic' field. *) - (* *) - FT_Generic_Finalizer = procedure(AnObject : pointer ); cdecl; - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_Generic *) - (* *) - (* <Description> *) - (* Client applications often need to associate their own data to a *) - (* variety of FreeType core objects. For example, a text layout API *) - (* might want to associate a glyph cache to a given size object. *) - (* *) - (* Most FreeType object contains a `generic' field, of type *) - (* FT_Generic, which usage is left to client applications and font *) - (* servers. *) - (* *) - (* It can be used to store a pointer to client-specific data, as well *) - (* as the address of a `finalizer' function, which will be called by *) - (* FreeType when the object is destroyed (for example, the previous *) - (* client example would put the address of the glyph cache destructor *) - (* in the `finalizer' field). *) - (* *) - (* <Fields> *) - (* data :: A typeless pointer to any client-specified data. This *) - (* field is completely ignored by the FreeType library. *) - (* *) - (* finalizer :: A pointer to a `generic finalizer' function, which *) - (* will be called when the object is destroyed. If this *) - (* field is set to NULL, no code will be called. *) - (* *) - FT_Generic = record - data : pointer; - finalizer : FT_Generic_Finalizer; - end; - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_BBox *) - (* *) - (* <Description> *) - (* A structure used to hold an outline's bounding box, i.e., the *) - (* coordinates of its extrema in the horizontal and vertical *) - (* directions. *) - (* *) - (* <Fields> *) - (* xMin :: The horizontal minimum (left-most). *) - (* *) - (* yMin :: The vertical minimum (bottom-most). *) - (* *) - (* xMax :: The horizontal maximum (right-most). *) - (* *) - (* yMax :: The vertical maximum (top-most). *) - (* *) - PFT_BBox = ^FT_BBox; - FT_BBox = record - xMin, yMin : FT_Pos; - xMax, yMax : FT_Pos; - end; - - - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_GlyphSlot *) - (* *) - (* <Description> *) - (* A handle to a given `glyph slot'. A slot is a container where it *) - (* is possible to load any one of the glyphs contained in its parent *) - (* face. *) - (* *) - (* In other words, each time you call @FT_Load_Glyph or *) - (* @FT_Load_Char, the slot's content is erased by the new glyph data, *) - (* i.e. the glyph's metrics, its image (bitmap or outline), and *) - (* other control information. *) - (* *) - (* <Also> *) - (* @FT_GlyphSlotRec details the publicly accessible glyph fields. *) - (* *) - FT_GlyphSlot = ^FT_GlyphSlotRec; - - (*************************************************************************) - (* *) (* <Struct> *) (* FT_GlyphSlotRec *) (* *) @@ -1432,7 +963,7 @@ type subglyphs : FT_SubGlyph; control_data : pointer; - control_len : longint; + control_len : clong; lsb_delta: FT_Pos; rsb_delta: FT_Pos; @@ -1497,15 +1028,15 @@ type (* computations. *) (* *) FT_Size_Metrics = record - x_ppem , - y_ppem : FT_UShort; - x_scale , - y_scale : FT_Fixed; - - ascender , - descender : FT_Pos; - height : FT_Pos; - max_advance : FT_Pos; + x_ppem, (* horizontal pixels per EM *) + y_ppem: FT_UShort; (* vertical pixels per EM *) + x_scale, (* scaling values used to convert font *) + y_scale: FT_Fixed; (* units to 26.6 fractional pixels *) + + ascender, (* ascender in 26.6 frac. pixels *) + descender: FT_Pos; (* descender in 26.6 frac. pixels *) + height: FT_Pos; (* text height in 26.6 frac. pixels *) + max_advance: FT_Pos; (* max horizontal advance, in 26.6 pixels *) end; (*************************************************************************) @@ -1786,21 +1317,29 @@ type encoding_id : FT_UShort; end; + +{$I ftconfig.inc} +{$I fttypes.inc} +{$I ftimage.inc} +{$I ftglyph.inc} +{$I ftstroke.inc} +{$I ftoutln.inc} + + { GLOBAL PROCEDURES } (*************************************************************************) (* *) (* @macro: *) - (* FT_CURVE_TAG ( flag ) *) + (* FT_HAS_KERNING( face ) *) (* *) - function FT_CURVE_TAG(flag: byte): byte; - -const - FT_CURVE_TAG_ON = 1; - FT_CURVE_TAG_CONIC = 0; - FT_CURVE_TAG_CUBIC = 2; - + (* @description: *) + (* A macro that returns true whenever a face object contains kerning *) + (* data that can be accessed with @FT_Get_Kerning. *) + (* *) + function FT_HAS_KERNING(face : FT_Face ) : cbool; + (*************************************************************************) (* *) (* @macro: *) @@ -1813,16 +1352,6 @@ const (* *) function FT_IS_SCALABLE(face : FT_Face ) : cbool; - (*************************************************************************) - (* *) - (* @macro: *) - (* FT_HAS_KERNING( face ) *) - (* *) - (* @description: *) - (* A macro that returns true whenever a face object contains kerning *) - (* data that can be accessed with @FT_Get_Kerning. *) - (* *) - function FT_HAS_KERNING(face : FT_Face ) : cbool; (*************************************************************************) (* *) @@ -2284,216 +1813,12 @@ const pixel_height : FT_UInt ) : FT_Error; cdecl; external ft_lib name 'FT_Set_Pixel_Sizes'; - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Get_Glyph *) - (* *) - (* <Description> *) - (* A function used to extract a glyph image from a slot. *) - (* *) - (* <Input> *) - (* slot :: A handle to the source glyph slot. *) - (* *) - (* <Output> *) - (* aglyph :: A handle to the glyph object. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - function FT_Get_Glyph( - slot: FT_GlyphSlot; - out aglyph: FT_Glyph ): FT_Error; - cdecl; external ft_lib name 'FT_Get_Glyph'; - - (*************************************************************************) - (* *) - (* <Enum> *) - (* FT_Glyph_BBox_Mode *) - (* *) - (* <Description> *) - (* The mode how the values of @FT_Glyph_Get_CBox are returned. *) - (* *) - (* <Values> *) - (* FT_GLYPH_BBOX_UNSCALED :: *) - (* Return unscaled font units. *) - (* *) - (* FT_GLYPH_BBOX_SUBPIXELS :: *) - (* Return unfitted 26.6 coordinates. *) - (* *) - (* FT_GLYPH_BBOX_GRIDFIT :: *) - (* Return grid-fitted 26.6 coordinates. *) - (* *) - (* FT_GLYPH_BBOX_TRUNCATE :: *) - (* Return coordinates in integer pixels. *) - (* *) - (* FT_GLYPH_BBOX_PIXELS :: *) - (* Return grid-fitted pixel coordinates. *) - (* *) -type - FT_Glyph_BBox_Mode = FT_UInt; const - FT_GLYPH_BBOX_UNSCALED = 0; - FT_GLYPH_BBOX_SUBPIXELS = 0; - FT_GLYPH_BBOX_GRIDFIT = 1; - FT_GLYPH_BBOX_TRUNCATE = 2; - FT_GLYPH_BBOX_PIXELS = 3; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Glyph_Get_CBox *) - (* *) - (* <Description> *) - (* Return a glyph's `control box'. The control box encloses all the *) - (* outline's points, including Bézier control points. Though it *) - (* coincides with the exact bounding box for most glyphs, it can be *) - (* slightly larger in some situations (like when rotating an outline *) - (* which contains Bézier outside arcs). *) - (* *) - (* Computing the control box is very fast, while getting the bounding *) - (* box can take much more time as it needs to walk over all segments *) - (* and arcs in the outline. To get the latter, you can use the *) - (* `ftbbox' component which is dedicated to this single task. *) - (* *) - (* <Input> *) - (* glyph :: A handle to the source glyph object. *) - (* *) - (* mode :: The mode which indicates how to interpret the returned *) - (* bounding box values. *) - (* *) - (* <Output> *) - (* acbox :: The glyph coordinate bounding box. Coordinates are *) - (* expressed in 1/64th of pixels if it is grid-fitted. *) - (* *) - (* <Note> *) - (* Coordinates are relative to the glyph origin, using the Y-upwards *) - (* convention. *) - (* *) - (* If the glyph has been loaded with @FT_LOAD_NO_SCALE, `bbox_mode' *) - (* must be set to @FT_GLYPH_BBOX_UNSCALED to get unscaled font *) - (* units in 26.6 pixel format. The value @FT_GLYPH_BBOX_SUBPIXELS *) - (* is another name for this constant. *) - (* *) - (* Note that the maximum coordinates are exclusive, which means that *) - (* one can compute the width and height of the glyph image (be it in *) - (* integer or 26.6 pixels) as: *) - (* *) - (* { *) - (* width = bbox.xMax - bbox.xMin; *) - (* height = bbox.yMax - bbox.yMin; *) - (* } *) - (* *) - (* Note also that for 26.6 coordinates, if `bbox_mode' is set to *) - (* @FT_GLYPH_BBOX_GRIDFIT, the coordinates will also be grid-fitted, *) - (* which corresponds to: *) - (* *) - (* { *) - (* bbox.xMin = FLOOR(bbox.xMin); *) - (* bbox.yMin = FLOOR(bbox.yMin); *) - (* bbox.xMax = CEILING(bbox.xMax); *) - (* bbox.yMax = CEILING(bbox.yMax); *) - (* } *) - (* *) - (* To get the bbox in pixel coordinates, set `bbox_mode' to *) - (* @FT_GLYPH_BBOX_TRUNCATE. *) - (* *) - (* To get the bbox in grid-fitted pixel coordinates, set `bbox_mode' *) - (* to @FT_GLYPH_BBOX_PIXELS. *) - (* *) - procedure FT_Glyph_Get_CBox( glyph: FT_Glyph; - bbox_mode: FT_UInt; - out acbox: FT_BBox ); - cdecl; external ft_lib name 'FT_Glyph_Get_CBox'; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Glyph_To_Bitmap *) - (* *) - (* <Description> *) - (* Converts a given glyph object to a bitmap glyph object. *) - (* *) - (* <InOut> *) - (* the_glyph :: A pointer to a handle to the target glyph. *) - (* *) - (* <Input> *) - (* render_mode :: An enumeration that describe how the data is *) - (* rendered. *) - (* *) - (* origin :: A pointer to a vector used to translate the glyph *) - (* image before rendering. Can be 0 (if no *) - (* translation). The origin is expressed in *) - (* 26.6 pixels. *) - (* *) - (* destroy :: A boolean that indicates that the original glyph *) - (* image should be destroyed by this function. It is *) - (* never destroyed in case of error. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - (* <Note> *) - (* The glyph image is translated with the `origin' vector before *) - (* rendering. *) - (* *) - (* The first parameter is a pointer to a FT_Glyph handle, that will *) - (* be replaced by this function. Typically, you would use (omitting *) - (* error handling): *) - (* *) - (* *) - (* { *) - (* FT_Glyph glyph; *) - (* FT_BitmapGlyph glyph_bitmap; *) - (* *) - (* *) - (* // load glyph *) - (* error = FT_Load_Char( face, glyph_index, FT_LOAD_DEFAUT ); *) - (* *) - (* // extract glyph image *) - (* error = FT_Get_Glyph( face->glyph, &glyph ); *) - (* *) - (* // convert to a bitmap (default render mode + destroy old) *) - (* if ( glyph->format != FT_GLYPH_FORMAT_BITMAP ) *) - (* { *) - (* error = FT_Glyph_To_Bitmap( &glyph, FT_RENDER_MODE_DEFAULT, *) - (* 0, 1 ); *) - (* if ( error ) // glyph unchanged *) - (* ... *) - (* } *) - (* *) - (* // access bitmap content by typecasting *) - (* glyph_bitmap = (FT_BitmapGlyph)glyph; *) - (* *) - (* // do funny stuff with it, like blitting/drawing *) - (* ... *) - (* *) - (* // discard glyph image (bitmap or not) *) - (* FT_Done_Glyph( glyph ); *) - (* } *) - (* *) - (* *) - (* This function does nothing if the glyph format isn't scalable. *) - (* *) - function FT_Glyph_To_Bitmap(var the_glyph: FT_Glyph; - render_mode: FT_Render_Mode; - origin: PFT_Vector; - destroy: FT_Bool ): FT_Error; - cdecl; external ft_lib name 'FT_Glyph_To_Bitmap'; + FT_ANGLE_PI = 180 shl 16; + FT_ANGLE_2PI = FT_ANGLE_PI * 2; + FT_ANGLE_PI2 = FT_ANGLE_PI div 2; + FT_ANGLE_PI4 = FT_ANGLE_PI div 4; - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Done_Glyph *) - (* *) - (* <Description> *) - (* Destroys a given glyph. *) - (* *) - (* <Input> *) - (* glyph :: A handle to the target glyph object. *) - (* *) - procedure FT_Done_Glyph( glyph: FT_Glyph ); - cdecl; external ft_lib name 'FT_Done_Glyph'; implementation @@ -2504,17 +1829,17 @@ begin result := flag and 3; end; -{ FT_IS_SCALABLE } -function FT_IS_SCALABLE(face : FT_Face ) : cbool; -begin - result := cbool(face.face_flags and FT_FACE_FLAG_SCALABLE ); -end; - { FT_HAS_KERNING } function FT_HAS_KERNING(face : FT_Face ) : cbool; begin result := cbool(face.face_flags and FT_FACE_FLAG_KERNING ); end; +{ FT_IS_SCALABLE } +function FT_IS_SCALABLE(face : FT_Face ) : cbool; +begin + result := cbool(face.face_flags and FT_FACE_FLAG_SCALABLE ); +end; + end. diff --git a/src/lib/freetype/ftconfig.inc b/src/lib/freetype/ftconfig.inc new file mode 100644 index 00000000..100fb2e0 --- /dev/null +++ b/src/lib/freetype/ftconfig.inc @@ -0,0 +1,35 @@ +(***************************************************************************) +(* *) +(* ftconfig.h *) +(* *) +(* ANSI-specific configuration file (specification only). *) +(* *) +(* Copyright 1996-2001, 2002, 2003, 2004, 2006, 2007 by *) +(* David Turner, Robert Wilhelm, and Werner Lemberg. *) +(* *) +(* This file is part of the FreeType project, and may only be used, *) +(* modified, and distributed under the terms of the FreeType project *) +(* license, LICENSE.TXT. By continuing to use, modify, or distribute *) +(* this file you indicate that you have read the license and *) +(* understand and accept it fully. *) +(* *) +(***************************************************************************) +(***************************************************************************) +(* Pascal port by the UltraStar Deluxe Team *) +(***************************************************************************) + +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* IntN types *) + (* *) + (* Used to guarantee the size of some specific integers. *) + (* *) + FT_Int16 = cint16; + FT_UInt16 = cuint16; + FT_Int32 = cint32; + FT_UInt32 = cuint32; + +{$ENDIF TYPE_DECL} + diff --git a/src/lib/freetype/ftglyph.inc b/src/lib/freetype/ftglyph.inc new file mode 100644 index 00000000..0d4acc99 --- /dev/null +++ b/src/lib/freetype/ftglyph.inc @@ -0,0 +1,435 @@ +(***************************************************************************) +(* *) +(* ftglyph.h *) +(* *) +(* FreeType convenience functions to handle glyphs (specification). *) +(* *) +(* Copyright 1996-2001, 2002, 2003, 2006 by *) +(* David Turner, Robert Wilhelm, and Werner Lemberg. *) +(* *) +(* This file is part of the FreeType project, and may only be used, *) +(* modified, and distributed under the terms of the FreeType project *) +(* license, LICENSE.TXT. By continuing to use, modify, or distribute *) +(* this file you indicate that you have read the license and *) +(* understand and accept it fully. *) +(* *) +(***************************************************************************) +(***************************************************************************) +(* Pascal port by the UltraStar Deluxe Team *) +(***************************************************************************) + + + (*************************************************************************) + (* *) + (* This file contains the definition of several convenience functions *) + (* that can be used by client applications to easily retrieve glyph *) + (* bitmaps and outlines from a given face. *) + (* *) + (* These functions should be optional if you are writing a font server *) + (* or text layout engine on top of FreeType. However, they are pretty *) + (* handy for many other simple uses of the library. *) + (* *) + (*************************************************************************) + + (*************************************************************************) + (* *) + (* <Section> *) + (* glyph_management *) + (* *) + (* <Title> *) + (* Glyph Management *) + (* *) + (* <Abstract> *) + (* Generic interface to manage individual glyph data. *) + (* *) + (* <Description> *) + (* This section contains definitions used to manage glyph data *) + (* through generic FT_Glyph objects. Each of them can contain a *) + (* bitmap, a vector outline, or even images in other formats. *) + (* *) + (*************************************************************************) + +{$IFDEF TYPE_DECL} + + (* forward declaration to a private type *) + PFT_Glyph_Class = Pointer; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Glyph *) + (* *) + (* <Description> *) + (* Handle to an object used to model generic glyph images. It is a *) + (* pointer to the @FT_GlyphRec structure and can contain a glyph *) + (* bitmap or pointer. *) + (* *) + (* <Note> *) + (* Glyph objects are not owned by the library. You must thus release *) + (* them manually (through @FT_Done_Glyph) _before_ calling *) + (* @FT_Done_FreeType. *) + (* *) + FT_Glyph = ^FT_GlyphRec; + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_GlyphRec *) + (* *) + (* <Description> *) + (* The root glyph structure contains a given glyph image plus its *) + (* advance width in 16.16 fixed float format. *) + (* *) + (* <Fields> *) + (* library :: A handle to the FreeType library object. *) + (* *) + (* clazz :: A pointer to the glyph's class. Private. *) + (* *) + (* format :: The format of the glyph's image. *) + (* *) + (* advance :: A 16.16 vector that gives the glyph's advance width. *) + (* *) + FT_GlyphRec = record + library_: FT_Library; + clazz: PFT_Glyph_Class; + format: FT_Glyph_Format; + advance: FT_Vector; + end; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_BitmapGlyph *) + (* *) + (* <Description> *) + (* A handle to an object used to model a bitmap glyph image. This is *) + (* a sub-class of @FT_Glyph, and a pointer to @FT_BitmapGlyphRec. *) + (* *) + FT_BitmapGlyph = ^FT_BitmapGlyphRec; + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_BitmapGlyphRec *) + (* *) + (* <Description> *) + (* A structure used for bitmap glyph images. This really is a *) + (* `sub-class' of `FT_GlyphRec'. *) + (* *) + (* <Fields> *) + (* root :: The root FT_Glyph fields. *) + (* *) + (* left :: The left-side bearing, i.e., the horizontal distance *) + (* from the current pen position to the left border of the *) + (* glyph bitmap. *) + (* *) + (* top :: The top-side bearing, i.e., the vertical distance from *) + (* the current pen position to the top border of the glyph *) + (* bitmap. This distance is positive for upwards-y! *) + (* *) + (* bitmap :: A descriptor for the bitmap. *) + (* *) + (* <Note> *) + (* You can typecast FT_Glyph to FT_BitmapGlyph if you have *) + (* glyph->format == FT_GLYPH_FORMAT_BITMAP. This lets you access *) + (* the bitmap's contents easily. *) + (* *) + (* The corresponding pixel buffer is always owned by the BitmapGlyph *) + (* and is thus created and destroyed with it. *) + (* *) + FT_BitmapGlyphRec = record + root: FT_GlyphRec; + left: FT_Int; + top: FT_Int; + bitmap: FT_Bitmap; + end; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_OutlineGlyph *) + (* *) + (* <Description> *) + (* A handle to an object used to model an outline glyph image. This *) + (* is a sub-class of @FT_Glyph, and a pointer to @FT_OutlineGlyphRec. *) + (* *) + FT_OutlineGlyph = ^FT_OutlineGlyphRec; + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_OutlineGlyphRec *) + (* *) + (* <Description> *) + (* A structure used for outline (vectorial) glyph images. This *) + (* really is a `sub-class' of `FT_GlyphRec'. *) + (* *) + (* <Fields> *) + (* root :: The root FT_Glyph fields. *) + (* *) + (* outline :: A descriptor for the outline. *) + (* *) + (* <Note> *) + (* You can typecast FT_Glyph to FT_OutlineGlyph if you have *) + (* glyph->format == FT_GLYPH_FORMAT_OUTLINE. This lets you access *) + (* the outline's content easily. *) + (* *) + (* As the outline is extracted from a glyph slot, its coordinates are *) + (* expressed normally in 26.6 pixels, unless the flag *) + (* FT_LOAD_NO_SCALE was used in FT_Load_Glyph() or FT_Load_Char(). *) + (* *) + (* The outline's tables are always owned by the object and are *) + (* destroyed with it. *) + (* *) + FT_OutlineGlyphRec = record + root: FT_GlyphRec; + outline: FT_Outline; + end; + +{$ELSE TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Get_Glyph *) + (* *) + (* <Description> *) + (* A function used to extract a glyph image from a slot. *) + (* *) + (* <Input> *) + (* slot :: A handle to the source glyph slot. *) + (* *) + (* <Output> *) + (* aglyph :: A handle to the glyph object. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + function FT_Get_Glyph( + slot: FT_GlyphSlot; + out aglyph: FT_Glyph ): FT_Error; + cdecl; external ft_lib name 'FT_Get_Glyph'; + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Glyph_Copy *) + (* *) + (* <Description> *) + (* A function used to copy a glyph image. Note that the created *) + (* @FT_Glyph object must be released with @FT_Done_Glyph. *) + (* *) + (* <Input> *) + (* source :: A handle to the source glyph object. *) + (* *) + (* <Output> *) + (* target :: A handle to the target glyph object. 0~in case of *) + (* error. *) + (* *) + (* <Return> *) + (* FreeType error code. 0~means success. *) + (* *) + function FT_Glyph_Copy(source: FT_Glyph; + var target: FT_Glyph ): FT_Error; + cdecl; external ft_lib name 'FT_Glyph_Copy'; + +{$ENDIF TYPE_DECL} +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Enum> *) + (* FT_Glyph_BBox_Mode *) + (* *) + (* <Description> *) + (* The mode how the values of @FT_Glyph_Get_CBox are returned. *) + (* *) + (* <Values> *) + (* FT_GLYPH_BBOX_UNSCALED :: *) + (* Return unscaled font units. *) + (* *) + (* FT_GLYPH_BBOX_SUBPIXELS :: *) + (* Return unfitted 26.6 coordinates. *) + (* *) + (* FT_GLYPH_BBOX_GRIDFIT :: *) + (* Return grid-fitted 26.6 coordinates. *) + (* *) + (* FT_GLYPH_BBOX_TRUNCATE :: *) + (* Return coordinates in integer pixels. *) + (* *) + (* FT_GLYPH_BBOX_PIXELS :: *) + (* Return grid-fitted pixel coordinates. *) + (* *) + FT_Glyph_BBox_Mode = cint; +{$ELSE TYPE_DECL} +const + FT_GLYPH_BBOX_UNSCALED = 0; + FT_GLYPH_BBOX_SUBPIXELS = 0; + FT_GLYPH_BBOX_GRIDFIT = 1; + FT_GLYPH_BBOX_TRUNCATE = 2; + FT_GLYPH_BBOX_PIXELS = 3; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Glyph_Get_CBox *) + (* *) + (* <Description> *) + (* Return a glyph's `control box'. The control box encloses all the *) + (* outline's points, including Bézier control points. Though it *) + (* coincides with the exact bounding box for most glyphs, it can be *) + (* slightly larger in some situations (like when rotating an outline *) + (* which contains Bézier outside arcs). *) + (* *) + (* Computing the control box is very fast, while getting the bounding *) + (* box can take much more time as it needs to walk over all segments *) + (* and arcs in the outline. To get the latter, you can use the *) + (* `ftbbox' component which is dedicated to this single task. *) + (* *) + (* <Input> *) + (* glyph :: A handle to the source glyph object. *) + (* *) + (* mode :: The mode which indicates how to interpret the returned *) + (* bounding box values. *) + (* *) + (* <Output> *) + (* acbox :: The glyph coordinate bounding box. Coordinates are *) + (* expressed in 1/64th of pixels if it is grid-fitted. *) + (* *) + (* <Note> *) + (* Coordinates are relative to the glyph origin, using the Y-upwards *) + (* convention. *) + (* *) + (* If the glyph has been loaded with @FT_LOAD_NO_SCALE, `bbox_mode' *) + (* must be set to @FT_GLYPH_BBOX_UNSCALED to get unscaled font *) + (* units in 26.6 pixel format. The value @FT_GLYPH_BBOX_SUBPIXELS *) + (* is another name for this constant. *) + (* *) + (* Note that the maximum coordinates are exclusive, which means that *) + (* one can compute the width and height of the glyph image (be it in *) + (* integer or 26.6 pixels) as: *) + (* *) + (* { *) + (* width = bbox.xMax - bbox.xMin; *) + (* height = bbox.yMax - bbox.yMin; *) + (* } *) + (* *) + (* Note also that for 26.6 coordinates, if `bbox_mode' is set to *) + (* @FT_GLYPH_BBOX_GRIDFIT, the coordinates will also be grid-fitted, *) + (* which corresponds to: *) + (* *) + (* { *) + (* bbox.xMin = FLOOR(bbox.xMin); *) + (* bbox.yMin = FLOOR(bbox.yMin); *) + (* bbox.xMax = CEILING(bbox.xMax); *) + (* bbox.yMax = CEILING(bbox.yMax); *) + (* } *) + (* *) + (* To get the bbox in pixel coordinates, set `bbox_mode' to *) + (* @FT_GLYPH_BBOX_TRUNCATE. *) + (* *) + (* To get the bbox in grid-fitted pixel coordinates, set `bbox_mode' *) + (* to @FT_GLYPH_BBOX_PIXELS. *) + (* *) + procedure FT_Glyph_Get_CBox( glyph: FT_Glyph; + bbox_mode: FT_UInt; + out acbox: FT_BBox ); + cdecl; external ft_lib name 'FT_Glyph_Get_CBox'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Glyph_To_Bitmap *) + (* *) + (* <Description> *) + (* Converts a given glyph object to a bitmap glyph object. *) + (* *) + (* <InOut> *) + (* the_glyph :: A pointer to a handle to the target glyph. *) + (* *) + (* <Input> *) + (* render_mode :: An enumeration that describe how the data is *) + (* rendered. *) + (* *) + (* origin :: A pointer to a vector used to translate the glyph *) + (* image before rendering. Can be 0 (if no *) + (* translation). The origin is expressed in *) + (* 26.6 pixels. *) + (* *) + (* destroy :: A boolean that indicates that the original glyph *) + (* image should be destroyed by this function. It is *) + (* never destroyed in case of error. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + (* <Note> *) + (* The glyph image is translated with the `origin' vector before *) + (* rendering. *) + (* *) + (* The first parameter is a pointer to a FT_Glyph handle, that will *) + (* be replaced by this function. Typically, you would use (omitting *) + (* error handling): *) + (* *) + (* *) + (* { *) + (* FT_Glyph glyph; *) + (* FT_BitmapGlyph glyph_bitmap; *) + (* *) + (* *) + (* // load glyph *) + (* error = FT_Load_Char( face, glyph_index, FT_LOAD_DEFAUT ); *) + (* *) + (* // extract glyph image *) + (* error = FT_Get_Glyph( face->glyph, &glyph ); *) + (* *) + (* // convert to a bitmap (default render mode + destroy old) *) + (* if ( glyph->format != FT_GLYPH_FORMAT_BITMAP ) *) + (* { *) + (* error = FT_Glyph_To_Bitmap( &glyph, FT_RENDER_MODE_DEFAULT, *) + (* 0, 1 ); *) + (* if ( error ) // glyph unchanged *) + (* ... *) + (* } *) + (* *) + (* // access bitmap content by typecasting *) + (* glyph_bitmap = (FT_BitmapGlyph)glyph; *) + (* *) + (* // do funny stuff with it, like blitting/drawing *) + (* ... *) + (* *) + (* // discard glyph image (bitmap or not) *) + (* FT_Done_Glyph( glyph ); *) + (* } *) + (* *) + (* *) + (* This function does nothing if the glyph format isn't scalable. *) + (* *) + function FT_Glyph_To_Bitmap(var the_glyph: FT_Glyph; + render_mode: FT_Render_Mode; + origin: PFT_Vector; + destroy: FT_Bool ): FT_Error; + cdecl; external ft_lib name 'FT_Glyph_To_Bitmap'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Done_Glyph *) + (* *) + (* <Description> *) + (* Destroys a given glyph. *) + (* *) + (* <Input> *) + (* glyph :: A handle to the target glyph object. *) + (* *) + procedure FT_Done_Glyph( glyph: FT_Glyph ); + cdecl; external ft_lib name 'FT_Done_Glyph'; + +{$ENDIF TYPE_DECL} diff --git a/src/lib/freetype/ftimage.inc b/src/lib/freetype/ftimage.inc new file mode 100644 index 00000000..9255c422 --- /dev/null +++ b/src/lib/freetype/ftimage.inc @@ -0,0 +1,803 @@ +(***************************************************************************) +(* *) +(* ftimage.h *) +(* *) +(* FreeType glyph image formats and default raster interface *) +(* (specification). *) +(* *) +(* Copyright 1996-2001, 2002, 2003, 2004, 2005, 2006, 2007 by *) +(* David Turner, Robert Wilhelm, and Werner Lemberg. *) +(* *) +(* This file is part of the FreeType project, and may only be used, *) +(* modified, and distributed under the terms of the FreeType project *) +(* license, LICENSE.TXT. By continuing to use, modify, or distribute *) +(* this file you indicate that you have read the license and *) +(* understand and accept it fully. *) +(* *) +(***************************************************************************) +(***************************************************************************) +(* Pascal port by the UltraStar Deluxe Team *) +(***************************************************************************) + + (*************************************************************************) + (* *) + (* Note: A `raster' is simply a scan-line converter, used to render *) + (* FT_Outlines into FT_Bitmaps. *) + (* *) + (*************************************************************************) + +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Pos *) + (* *) + (* <Description> *) + (* The type FT_Pos is a 32-bit integer used to store vectorial *) + (* coordinates. Depending on the context, these can represent *) + (* distances in integer font units, or 16,16, or 26.6 fixed float *) + (* pixel coordinates. *) + (* *) + FT_Pos = cslong; + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Vector *) + (* *) + (* <Description> *) + (* A simple structure used to store a 2D vector; coordinates are of *) + (* the FT_Pos type. *) + (* *) + (* <Fields> *) + (* x :: The horizontal coordinate. *) + (* y :: The vertical coordinate. *) + (* *) + PFT_Vector = ^FT_Vector; + FT_Vector = record + x , + y : FT_Pos; + end; + + PFT_VectorArray = ^FT_VectorArray; + FT_VectorArray = array[0 .. (MaxInt div SizeOf(FT_Vector))-1] of FT_Vector; + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_BBox *) + (* *) + (* <Description> *) + (* A structure used to hold an outline's bounding box, i.e., the *) + (* coordinates of its extrema in the horizontal and vertical *) + (* directions. *) + (* *) + (* <Fields> *) + (* xMin :: The horizontal minimum (left-most). *) + (* *) + (* yMin :: The vertical minimum (bottom-most). *) + (* *) + (* xMax :: The horizontal maximum (right-most). *) + (* *) + (* yMax :: The vertical maximum (top-most). *) + (* *) + PFT_BBox = ^FT_BBox; + FT_BBox = record + xMin, yMin : FT_Pos; + xMax, yMax : FT_Pos; + end; + + + (*************************************************************************) + (* *) + (* <Enum> *) + (* FT_Pixel_Mode *) + (* *) + (* <Description> *) + (* An enumeration type used to describe the format of pixels in a *) + (* given bitmap. Note that additional formats may be added in the *) + (* future. *) + (* *) + (* <Values> *) + (* FT_PIXEL_MODE_NONE :: *) + (* Value 0 is reserved. *) + (* *) + (* FT_PIXEL_MODE_MONO :: *) + (* A monochrome bitmap, using 1 bit per pixel. Note that pixels *) + (* are stored in most-significant order (MSB), which means that *) + (* the left-most pixel in a byte has value 128. *) + (* *) + (* FT_PIXEL_MODE_GRAY :: *) + (* An 8-bit bitmap, generally used to represent anti-aliased glyph *) + (* images. Each pixel is stored in one byte. Note that the number *) + (* of value `gray' levels is stored in the `num_bytes' field of *) + (* the @FT_Bitmap structure (it generally is 256). *) + (* *) + (* FT_PIXEL_MODE_GRAY2 :: *) + (* A 2-bit/pixel bitmap, used to represent embedded anti-aliased *) + (* bitmaps in font files according to the OpenType specification. *) + (* We haven't found a single font using this format, however. *) + (* *) + (* FT_PIXEL_MODE_GRAY4 :: *) + (* A 4-bit/pixel bitmap, used to represent embedded anti-aliased *) + (* bitmaps in font files according to the OpenType specification. *) + (* We haven't found a single font using this format, however. *) + (* *) + (* FT_PIXEL_MODE_LCD :: *) + (* An 8-bit bitmap, used to represent RGB or BGR decimated glyph *) + (* images used for display on LCD displays; the bitmap is three *) + (* times wider than the original glyph image. See also *) + (* @FT_RENDER_MODE_LCD. *) + (* *) + (* FT_PIXEL_MODE_LCD_V :: *) + (* An 8-bit bitmap, used to represent RGB or BGR decimated glyph *) + (* images used for display on rotated LCD displays; the bitmap *) + (* is three times taller than the original glyph image. See also *) + (* @FT_RENDER_MODE_LCD_V. *) + (* *) + FT_Pixel_Mode = cint; +{$ELSE TYPE_DECL} +const + FT_PIXEL_MODE_NONE = 0; + FT_PIXEL_MODE_MONO = FT_PIXEL_MODE_NONE + 1; + FT_PIXEL_MODE_GRAY = FT_PIXEL_MODE_MONO + 1; + FT_PIXEL_MODE_GRAY2 = FT_PIXEL_MODE_GRAY + 1; + FT_PIXEL_MODE_GRAY4 = FT_PIXEL_MODE_GRAY2 + 1; + FT_PIXEL_MODE_LCD = FT_PIXEL_MODE_GRAY4 + 1; + FT_PIXEL_MODE_LCD_V = FT_PIXEL_MODE_LCD + 1; + + FT_PIXEL_MODE_MAX = FT_PIXEL_MODE_LCD_V + 1; (* do not remove *) +{$ENDIF TYPE_DECL} +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Bitmap *) + (* *) + (* <Description> *) + (* A structure used to describe a bitmap or pixmap to the raster. *) + (* Note that we now manage pixmaps of various depths through the *) + (* `pixel_mode' field. *) + (* *) + (* <Fields> *) + (* rows :: The number of bitmap rows. *) + (* *) + (* width :: The number of pixels in bitmap row. *) + (* *) + (* pitch :: The pitch's absolute value is the number of bytes *) + (* taken by one bitmap row, including padding. *) + (* However, the pitch is positive when the bitmap has *) + (* a `down' flow, and negative when it has an `up' *) + (* flow. In all cases, the pitch is an offset to add *) + (* to a bitmap pointer in order to go down one row. *) + (* *) + (* buffer :: A typeless pointer to the bitmap buffer. This *) + (* value should be aligned on 32-bit boundaries in *) + (* most cases. *) + (* *) + (* num_grays :: This field is only used with *) + (* `FT_PIXEL_MODE_GRAY'; it gives the number of gray *) + (* levels used in the bitmap. *) + (* *) + (* pixel_mode :: The pixel mode, i.e., how pixel bits are stored. *) + (* See @FT_Pixel_Mode for possible values. *) + (* *) + (* palette_mode :: This field is only used with paletted pixel modes; *) + (* it indicates how the palette is stored. *) + (* *) + (* palette :: A typeless pointer to the bitmap palette; only *) + (* used for paletted pixel modes. *) + (* *) + (* <Note> *) + (* For now, the only pixel mode supported by FreeType are mono and *) + (* grays. However, drivers might be added in the future to support *) + (* more `colorful' options. *) + (* *) + (* When using pixel modes pal2, pal4 and pal8 with a void `palette' *) + (* field, a gray pixmap with respectively 4, 16, and 256 levels of *) + (* gray is assumed. This, in order to be compatible with some *) + (* embedded bitmap formats defined in the TrueType specification. *) + (* *) + (* Note that no font was found presenting such embedded bitmaps, so *) + (* this is currently completely unhandled by the library. *) + (* *) + PFT_Bitmap = ^FT_Bitmap; + FT_Bitmap = record + rows: FT_Int; + width: FT_Int; + pitch: FT_Int; + buffer: PByteArray; + num_grays: FT_Short; + pixel_mode: byte; + palette_mode: byte; + palette: pointer; + end; + + + (*************************************************************************) + (* *) + (* <Section> *) + (* outline_processing *) + (* *) + (*************************************************************************) + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Outline *) + (* *) + (* <Description> *) + (* This structure is used to describe an outline to the scan-line *) + (* converter. *) + (* *) + (* <Fields> *) + (* n_contours :: The number of contours in the outline. *) + (* *) + (* n_points :: The number of points in the outline. *) + (* *) + (* points :: A pointer to an array of `n_points' FT_Vector *) + (* elements, giving the outline's point coordinates. *) + (* *) + (* tags :: A pointer to an array of `n_points' chars, giving *) + (* each outline point's type. If bit 0 is unset, the *) + (* point is `off' the curve, i.e. a Bezier control *) + (* point, while it is `on' when set. *) + (* *) + (* Bit 1 is meaningful for `off' points only. If set, *) + (* it indicates a third-order Bezier arc control point; *) + (* and a second-order control point if unset. *) + (* *) + (* contours :: An array of `n_contours' shorts, giving the end *) + (* point of each contour within the outline. For *) + (* example, the first contour is defined by the points *) + (* `0' to `contours[0]', the second one is defined by *) + (* the points `contours[0]+1' to `contours[1]', etc. *) + (* *) + (* flags :: A set of bit flags used to characterize the outline *) + (* and give hints to the scan-converter and hinter on *) + (* how to convert/grid-fit it. See FT_Outline_Flags. *) + (* *) + PFT_Outline = ^FT_Outline; + FT_Outline = record + n_contours: FT_Short; (* number of contours in glyph *) + n_points: FT_Short; (* number of points in the glyph *) + + points: PFT_VectorArray; (* the outline's points *) + tags: PByteArray; (* the points flags *) + contours: PFT_ShortArray; (* the contour end points *) + + flags: FT_Int; (* outline masks *) + end; + +{$ELSE TYPE_DECL} + + (*************************************************************************) + (* *) + (* @macro: *) + (* FT_CURVE_TAG ( flag ) *) + (* *) + function FT_CURVE_TAG(flag: byte): byte; + +const + FT_CURVE_TAG_ON = 1; + FT_CURVE_TAG_CONIC = 0; + FT_CURVE_TAG_CUBIC = 2; + + FT_CURVE_TAG_TOUCH_X = 8; // reserved for the TrueType hinter + FT_CURVE_TAG_TOUCH_Y = 16; // reserved for the TrueType hinter + + FT_CURVE_TAG_TOUCH_BOTH = ( FT_CURVE_TAG_TOUCH_X or + FT_CURVE_TAG_TOUCH_Y ); +{$ENDIF TYPE_DECL} +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Outline_MoveToFunc *) + (* *) + (* <Description> *) + (* A function pointer type used to describe the signature of a `move *) + (* to' function during outline walking/decomposition. *) + (* *) + (* A `move to' is emitted to start a new contour in an outline. *) + (* *) + (* <Input> *) + (* to :: A pointer to the target point of the `move to'. *) + (* *) + (* user :: A typeless pointer which is passed from the caller of the *) + (* decomposition function. *) + (* *) + (* <Return> *) + (* Error code. 0 means success. *) + (* *) + FT_Outline_MoveToFunc = function(to_: {const} PFT_Vector; + user: Pointer): cint; cdecl; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Outline_LineToFunc *) + (* *) + (* <Description> *) + (* A function pointer type used to describe the signature of a `line *) + (* to' function during outline walking/decomposition. *) + (* *) + (* A `line to' is emitted to indicate a segment in the outline. *) + (* *) + (* <Input> *) + (* to :: A pointer to the target point of the `line to'. *) + (* *) + (* user :: A typeless pointer which is passed from the caller of the *) + (* decomposition function. *) + (* *) + (* <Return> *) + (* Error code. 0 means success. *) + (* *) + FT_Outline_LineToFunc = function(to_: {const} PFT_Vector; + user: Pointer): cint; cdecl; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Outline_ConicToFunc *) + (* *) + (* <Description> *) + (* A function pointer type use to describe the signature of a `conic *) + (* to' function during outline walking/decomposition. *) + (* *) + (* A `conic to' is emitted to indicate a second-order Bézier arc in *) + (* the outline. *) + (* *) + (* <Input> *) + (* control :: An intermediate control point between the last position *) + (* and the new target in `to'. *) + (* *) + (* to :: A pointer to the target end point of the conic arc. *) + (* *) + (* user :: A typeless pointer which is passed from the caller of *) + (* the decomposition function. *) + (* *) + (* <Return> *) + (* Error code. 0 means success. *) + (* *) + FT_Outline_ConicToFunc = function(control: {const} PFT_Vector; + to_: {const} PFT_Vector; + user: Pointer): cint; cdecl; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Outline_CubicToFunc *) + (* *) + (* <Description> *) + (* A function pointer type used to describe the signature of a `cubic *) + (* to' function during outline walking/decomposition. *) + (* *) + (* A `cubic to' is emitted to indicate a third-order Bézier arc. *) + (* *) + (* <Input> *) + (* control1 :: A pointer to the first Bézier control point. *) + (* *) + (* control2 :: A pointer to the second Bézier control point. *) + (* *) + (* to :: A pointer to the target end point. *) + (* *) + (* user :: A typeless pointer which is passed from the caller of *) + (* the decomposition function. *) + (* *) + (* <Return> *) + (* Error code. 0 means success. *) + (* *) + FT_Outline_CubicToFunc = function( control1: {const} PFT_Vector; + control2: {const} PFT_Vector; + to_: {const} PFT_Vector; + user: Pointer ): cint; cdecl; + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Outline_Funcs *) + (* *) + (* <Description> *) + (* A structure to hold various function pointers used during outline *) + (* decomposition in order to emit segments, conic, and cubic Béziers, *) + (* as well as `move to' and `close to' operations. *) + (* *) + (* <Fields> *) + (* move_to :: The `move to' emitter. *) + (* *) + (* line_to :: The segment emitter. *) + (* *) + (* conic_to :: The second-order Bézier arc emitter. *) + (* *) + (* cubic_to :: The third-order Bézier arc emitter. *) + (* *) + (* shift :: The shift that is applied to coordinates before they *) + (* are sent to the emitter. *) + (* *) + (* delta :: The delta that is applied to coordinates before they *) + (* are sent to the emitter, but after the shift. *) + (* *) + (* <Note> *) + (* The point coordinates sent to the emitters are the transformed *) + (* version of the original coordinates (this is important for high *) + (* accuracy during scan-conversion). The transformation is simple: *) + (* *) + (* { *) + (* x' = (x << shift) - delta *) + (* y' = (x << shift) - delta *) + (* } *) + (* *) + (* Set the value of `shift' and `delta' to 0 to get the original *) + (* point coordinates. *) + (* *) + PFT_Outline_Funcs = ^FT_Outline_Funcs; + FT_Outline_Funcs = record + move_to: FT_Outline_MoveToFunc; + line_to: FT_Outline_LineToFunc; + conic_to: FT_Outline_ConicToFunc; + cubic_to: FT_Outline_CubicToFunc; + + shift: cint; + delta: FT_Pos; + end; + + + (*************************************************************************) + (* *) + (* <Enum> *) + (* FT_Glyph_Format *) + (* *) + (* <Description> *) + (* An enumeration type used to describe the format of a given glyph *) + (* image. Note that this version of FreeType only supports two image *) + (* formats, even though future font drivers will be able to register *) + (* their own format. *) + (* *) + (* <Values> *) + (* FT_GLYPH_FORMAT_NONE :: *) + (* The value 0 is reserved and does describe a glyph format. *) + (* *) + (* FT_GLYPH_FORMAT_COMPOSITE :: *) + (* The glyph image is a composite of several other images. This *) + (* format is _only_ used with @FT_LOAD_NO_RECURSE, and is used to *) + (* report compound glyphs (like accented characters). *) + (* *) + (* FT_GLYPH_FORMAT_BITMAP :: *) + (* The glyph image is a bitmap, and can be described as an *) + (* @FT_Bitmap. You generally need to access the `bitmap' field of *) + (* the @FT_GlyphSlotRec structure to read it. *) + (* *) + (* FT_GLYPH_FORMAT_OUTLINE :: *) + (* The glyph image is a vertorial outline made of line segments *) + (* and Bezier arcs; it can be described as an @FT_Outline; you *) + (* generally want to access the `outline' field of the *) + (* @FT_GlyphSlotRec structure to read it. *) + (* *) + (* FT_GLYPH_FORMAT_PLOTTER :: *) + (* The glyph image is a vectorial path with no inside/outside *) + (* contours. Some Type 1 fonts, like those in the Hershey family, *) + (* contain glyphs in this format. These are described as *) + (* @FT_Outline, but FreeType isn't currently capable of rendering *) + (* them correctly. *) + (* *) + FT_Glyph_Format = array[0..3] of char; +{$ELSE TYPE_DECL} +const + FT_GLYPH_FORMAT_NONE: FT_Glyph_Format = (#0, #0, #0, #0 ); + + FT_GLYPH_FORMAT_COMPOSITE: FT_Glyph_Format = ('c', 'o', 'm', 'p' ); + FT_GLYPH_FORMAT_BITMAP: FT_Glyph_Format = ('b', 'i', 't', 's' ); + FT_GLYPH_FORMAT_OUTLINE: FT_Glyph_Format = ('o', 'u', 't', 'l' ); + FT_GLYPH_FORMAT_PLOTTER: FT_Glyph_Format = ('p', 'l', 'o', 't' ); + +{$ENDIF TYPE_DECL} + + (*************************************************************************) + (*************************************************************************) + (*************************************************************************) + (***** *****) + (***** R A S T E R D E F I N I T I O N S *****) + (***** *****) + (*************************************************************************) + (*************************************************************************) + (*************************************************************************) + + + (*************************************************************************) + (* *) + (* A raster is a scan converter, in charge of rendering an outline into *) + (* a a bitmap. This section contains the public API for rasters. *) + (* *) + (* Note that in FreeType 2, all rasters are now encapsulated within *) + (* specific modules called `renderers'. See `freetype/ftrender.h' for *) + (* more details on renderers. *) + (* *) + (*************************************************************************) + + + (*************************************************************************) + (* *) + (* <Section> *) + (* raster *) + (* *) + (* <Title> *) + (* Scanline Converter *) + (* *) + (* <Abstract> *) + (* How vectorial outlines are converted into bitmaps and pixmaps. *) + (* *) + (* <Description> *) + (* This section contains technical definitions. *) + (* *) + (*************************************************************************) + +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Raster *) + (* *) + (* <Description> *) + (* A handle (pointer) to a raster object. Each object can be used *) + (* independently to convert an outline into a bitmap or pixmap. *) + (* *) + FT_Raster = Pointer; + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Span *) + (* *) + (* <Description> *) + (* A structure used to model a single span of gray (or black) pixels *) + (* when rendering a monochrome or anti-aliased bitmap. *) + (* *) + (* <Fields> *) + (* x :: The span's horizontal start position. *) + (* *) + (* len :: The span's length in pixels. *) + (* *) + (* coverage :: The span color/coverage, ranging from 0 (background) *) + (* to 255 (foreground). Only used for anti-aliased *) + (* rendering. *) + (* *) + (* <Note> *) + (* This structure is used by the span drawing callback type named *) + (* @FT_SpanFunc which takes the y-coordinate of the span as a *) + (* a parameter. *) + (* *) + (* The coverage value is always between 0 and 255. *) + (* *) + PFT_Span = ^FT_Span; + FT_Span = record + x: cshort; + len: cushort; + coverage: cuchar; + end; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_SpanFunc *) + (* *) + (* <Description> *) + (* A function used as a call-back by the anti-aliased renderer in *) + (* order to let client applications draw themselves the gray pixel *) + (* spans on each scan line. *) + (* *) + (* <Input> *) + (* y :: The scanline's y-coordinate. *) + (* *) + (* count :: The number of spans to draw on this scanline. *) + (* *) + (* spans :: A table of `count' spans to draw on the scanline. *) + (* *) + (* user :: User-supplied data that is passed to the callback. *) + (* *) + (* <Note> *) + (* This callback allows client applications to directly render the *) + (* gray spans of the anti-aliased bitmap to any kind of surfaces. *) + (* *) + (* This can be used to write anti-aliased outlines directly to a *) + (* given background bitmap, and even perform translucency. *) + (* *) + (* Note that the `count' field cannot be greater than a fixed value *) + (* defined by the `FT_MAX_GRAY_SPANS' configuration macro in *) + (* `ftoption.h'. By default, this value is set to 32, which means *) + (* that if there are more than 32 spans on a given scanline, the *) + (* callback is called several times with the same `y' parameter in *) + (* order to draw all callbacks. *) + (* *) + (* Otherwise, the callback is only called once per scan-line, and *) + (* only for those scanlines that do have `gray' pixels on them. *) + (* *) + FT_SpanFunc = procedure(y: cint; + count: cint; + spans: {const} PFT_Span; + user: Pointer ); cdecl; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Raster_BitTest_Func *) + (* *) + (* <Description> *) + (* THIS TYPE IS DEPRECATED. DO NOT USE IT. *) + (* *) + (* A function used as a call-back by the monochrome scan-converter *) + (* to test whether a given target pixel is already set to the drawing *) + (* `color'. These tests are crucial to implement drop-out control *) + (* per-se the TrueType spec. *) + (* *) + (* <Input> *) + (* y :: The pixel's y-coordinate. *) + (* *) + (* x :: The pixel's x-coordinate. *) + (* *) + (* user :: User-supplied data that is passed to the callback. *) + (* *) + (* <Return> *) + (* 1 if the pixel is `set', 0 otherwise. *) + (* *) + FT_Raster_BitTest_Func = function(y: cint; + x: cint; + user: Pointer): cint; cdecl; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Raster_BitSet_Func *) + (* *) + (* <Description> *) + (* THIS TYPE IS DEPRECATED. DO NOT USE IT. *) + (* *) + (* A function used as a call-back by the monochrome scan-converter *) + (* to set an individual target pixel. This is crucial to implement *) + (* drop-out control according to the TrueType specification. *) + (* *) + (* <Input> *) + (* y :: The pixel's y-coordinate. *) + (* *) + (* x :: The pixel's x-coordinate. *) + (* *) + (* user :: User-supplied data that is passed to the callback. *) + (* *) + (* <Return> *) + (* 1 if the pixel is `set', 0 otherwise. *) + (* *) + FT_Raster_BitSet_Func = procedure(y: cint; + x: cint; + user: Pointer ); cdecl; + + + (*************************************************************************) + (* *) + (* <Enum> *) + (* FT_RASTER_FLAG_XXX *) + (* *) + (* <Description> *) + (* A list of bit flag constants as used in the `flags' field of a *) + (* @FT_Raster_Params structure. *) + (* *) + (* <Values> *) + (* FT_RASTER_FLAG_DEFAULT :: This value is 0. *) + (* *) + (* FT_RASTER_FLAG_AA :: This flag is set to indicate that an *) + (* anti-aliased glyph image should be *) + (* generated. Otherwise, it will be *) + (* monochrome (1-bit). *) + (* *) + (* FT_RASTER_FLAG_DIRECT :: This flag is set to indicate direct *) + (* rendering. In this mode, client *) + (* applications must provide their own span *) + (* callback. This lets them directly *) + (* draw or compose over an existing bitmap. *) + (* If this bit is not set, the target *) + (* pixmap's buffer _must_ be zeroed before *) + (* rendering. *) + (* *) + (* Note that for now, direct rendering is *) + (* only possible with anti-aliased glyphs. *) + (* *) + (* FT_RASTER_FLAG_CLIP :: This flag is only used in direct *) + (* rendering mode. If set, the output will *) + (* be clipped to a box specified in the *) + (* `clip_box' field of the *) + (* @FT_Raster_Params structure. *) + (* *) + (* Note that by default, the glyph bitmap *) + (* is clipped to the target pixmap, except *) + (* in direct rendering mode where all spans *) + (* are generated if no clipping box is set. *) + (* *) +{$ELSE TYPE_DECL} +const + FT_RASTER_FLAG_DEFAULT = $0; + FT_RASTER_FLAG_AA = $1; + FT_RASTER_FLAG_DIRECT = $2; + FT_RASTER_FLAG_CLIP = $4; + +{$ENDIF TYPE_DECL} +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Raster_Params *) + (* *) + (* <Description> *) + (* A structure to hold the arguments used by a raster's render *) + (* function. *) + (* *) + (* <Fields> *) + (* target :: The target bitmap. *) + (* *) + (* source :: A pointer to the source glyph image (e.g., an *) + (* @FT_Outline). *) + (* *) + (* flags :: The rendering flags. *) + (* *) + (* gray_spans :: The gray span drawing callback. *) + (* *) + (* black_spans :: The black span drawing callback. *) + (* *) + (* bit_test :: The bit test callback. UNIMPLEMENTED! *) + (* *) + (* bit_set :: The bit set callback. UNIMPLEMENTED! *) + (* *) + (* user :: User-supplied data that is passed to each drawing *) + (* callback. *) + (* *) + (* clip_box :: An optional clipping box. It is only used in *) + (* direct rendering mode. Note that coordinates here *) + (* should be expressed in _integer_ pixels (and not in *) + (* 26.6 fixed-point units). *) + (* *) + (* <Note> *) + (* An anti-aliased glyph bitmap is drawn if the @FT_RASTER_FLAG_AA *) + (* bit flag is set in the `flags' field, otherwise a monochrome *) + (* bitmap is generated. *) + (* *) + (* If the @FT_RASTER_FLAG_DIRECT bit flag is set in `flags', the *) + (* raster will call the `gray_spans' callback to draw gray pixel *) + (* spans, in the case of an aa glyph bitmap, it will call *) + (* `black_spans', and `bit_test' and `bit_set' in the case of a *) + (* monochrome bitmap. This allows direct composition over a *) + (* pre-existing bitmap through user-provided callbacks to perform the *) + (* span drawing/composition. *) + (* *) + (* Note that the `bit_test' and `bit_set' callbacks are required when *) + (* rendering a monochrome bitmap, as they are crucial to implement *) + (* correct drop-out control as defined in the TrueType specification. *) + (* *) + PFT_Raster_Params = ^FT_Raster_Params; + FT_Raster_Params = record + target: {const} PFT_Bitmap; + source: {const} Pointer; + flags: cint; + gray_spans: FT_SpanFunc; + black_spans: FT_SpanFunc; + bit_test: FT_Raster_BitTest_Func; (* doesn't work! *) + bit_set: FT_Raster_BitSet_Func; (* doesn't work! *) + user: Pointer; + clip_box: FT_BBox; + end; + +{$ENDIF TYPE_DECL} + + diff --git a/src/lib/freetype/ftoutln.inc b/src/lib/freetype/ftoutln.inc new file mode 100644 index 00000000..997c6cb3 --- /dev/null +++ b/src/lib/freetype/ftoutln.inc @@ -0,0 +1,497 @@ +(***************************************************************************) +(* *) +(* ftoutln.h *) +(* *) +(* Support for the FT_Outline type used to store glyph shapes of *) +(* most scalable font formats (specification). *) +(* *) +(* Copyright 1996-2001, 2002, 2003, 2005, 2006, 2007 by *) +(* David Turner, Robert Wilhelm, and Werner Lemberg. *) +(* *) +(* This file is part of the FreeType project, and may only be used, *) +(* modified, and distributed under the terms of the FreeType project *) +(* license, LICENSE.TXT. By continuing to use, modify, or distribute *) +(* this file you indicate that you have read the license and *) +(* understand and accept it fully. *) +(* *) +(***************************************************************************) +(***************************************************************************) +(* Pascal port by the UltraStar Deluxe Team *) +(***************************************************************************) + + + (*************************************************************************) + (* *) + (* <Section> *) + (* outline_processing *) + (* *) + (* <Title> *) + (* Outline Processing *) + (* *) + (* <Abstract> *) + (* Functions to create, transform, and render vectorial glyph images. *) + (* *) + (* <Description> *) + (* This section contains routines used to create and destroy scalable *) + (* glyph images known as `outlines'. These can also be measured, *) + (* transformed, and converted into bitmaps and pixmaps. *) + (* *) + (* <Order> *) + (* FT_Outline *) + (* FT_OUTLINE_FLAGS *) + (* FT_Outline_New *) + (* FT_Outline_Done *) + (* FT_Outline_Copy *) + (* FT_Outline_Translate *) + (* FT_Outline_Transform *) + (* FT_Outline_Embolden *) + (* FT_Outline_Reverse *) + (* FT_Outline_Check *) + (* *) + (* FT_Outline_Get_CBox *) + (* FT_Outline_Get_BBox *) + (* *) + (* FT_Outline_Get_Bitmap *) + (* FT_Outline_Render *) + (* *) + (* FT_Outline_Decompose *) + (* FT_Outline_Funcs *) + (* FT_Outline_MoveTo_Func *) + (* FT_Outline_LineTo_Func *) + (* FT_Outline_ConicTo_Func *) + (* FT_Outline_CubicTo_Func *) + (* *) + (*************************************************************************) + +{$IFNDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Decompose *) + (* *) + (* <Description> *) + (* Walks over an outline's structure to decompose it into individual *) + (* segments and Bézier arcs. This function is also able to emit *) + (* `move to' and `close to' operations to indicate the start and end *) + (* of new contours in the outline. *) + (* *) + (* <Input> *) + (* outline :: A pointer to the source target. *) + (* *) + (* func_interface :: A table of `emitters', i.e,. function pointers *) + (* called during decomposition to indicate path *) + (* operations. *) + (* *) + (* <InOut> *) + (* user :: A typeless pointer which is passed to each *) + (* emitter during the decomposition. It can be *) + (* used to store the state during the *) + (* decomposition. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + function FT_Outline_Decompose( + outline: PFT_Outline; + func_interface: {const} PFT_Outline_Funcs; + user: Pointer): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Decompose'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_New *) + (* *) + (* <Description> *) + (* Creates a new outline of a given size. *) + (* *) + (* <Input> *) + (* library :: A handle to the library object from where the *) + (* outline is allocated. Note however that the new *) + (* outline will *not* necessarily be *freed*, when *) + (* destroying the library, by @FT_Done_FreeType. *) + (* *) + (* numPoints :: The maximal number of points within the outline. *) + (* *) + (* numContours :: The maximal number of contours within the outline. *) + (* *) + (* <Output> *) + (* anoutline :: A handle to the new outline. NULL in case of *) + (* error. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + (* <Note> *) + (* The reason why this function takes a `library' parameter is simply *) + (* to use the library's memory allocator. *) + (* *) + function FT_Outline_New( + library_: FT_Library; + numPoints: FT_UInt; + numContours: FT_Int; + anoutline: PFT_Outline): FT_Error; + cdecl; external ft_lib name 'FT_Outline_New'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Done *) + (* *) + (* <Description> *) + (* Destroys an outline created with @FT_Outline_New. *) + (* *) + (* <Input> *) + (* library :: A handle of the library object used to allocate the *) + (* outline. *) + (* *) + (* outline :: A pointer to the outline object to be discarded. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + (* <Note> *) + (* If the outline's `owner' field is not set, only the outline *) + (* descriptor will be released. *) + (* *) + (* The reason why this function takes an `library' parameter is *) + (* simply to use ft_mem_free(). *) + (* *) + function FT_Outline_Done(library_: FT_Library; + outline: PFT_Outline): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Done'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Check *) + (* *) + (* <Description> *) + (* Check the contents of an outline descriptor. *) + (* *) + (* <Input> *) + (* outline :: A handle to a source outline. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + function FT_Outline_Check( outline: PFT_Outline ): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Check'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Get_CBox *) + (* *) + (* <Description> *) + (* Returns an outline's `control box'. The control box encloses all *) + (* the outline's points, including Bézier control points. Though it *) + (* coincides with the exact bounding box for most glyphs, it can be *) + (* slightly larger in some situations (like when rotating an outline *) + (* which contains Bézier outside arcs). *) + (* *) + (* Computing the control box is very fast, while getting the bounding *) + (* box can take much more time as it needs to walk over all segments *) + (* and arcs in the outline. To get the latter, you can use the *) + (* `ftbbox' component which is dedicated to this single task. *) + (* *) + (* <Input> *) + (* outline :: A pointer to the source outline descriptor. *) + (* *) + (* <Output> *) + (* acbox :: The outline's control box. *) + (* *) + procedure FT_Outline_Get_CBox( + outline: {const} PFT_Outline; + acbox: PFT_BBox); + cdecl; external ft_lib name 'FT_Outline_Get_CBox'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Translate *) + (* *) + (* <Description> *) + (* Applies a simple translation to the points of an outline. *) + (* *) + (* <InOut> *) + (* outline :: A pointer to the target outline descriptor. *) + (* *) + (* <Input> *) + (* xOffset :: The horizontal offset. *) + (* *) + (* yOffset :: The vertical offset. *) + (* *) + procedure FT_Outline_Translate( + outline: {const} PFT_Outline; + xOffset: FT_Pos; + yOffset: FT_Pos); + cdecl; external ft_lib name 'FT_Outline_Translate'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Copy *) + (* *) + (* <Description> *) + (* Copies an outline into another one. Both objects must have the *) + (* same sizes (number of points & number of contours) when this *) + (* function is called. *) + (* *) + (* <Input> *) + (* source :: A handle to the source outline. *) + (* *) + (* <Output> *) + (* target :: A handle to the target outline. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + function FT_Outline_Copy( + source: {const} PFT_Outline; + target: PFT_Outline): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Copy'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Transform *) + (* *) + (* <Description> *) + (* Applies a simple 2x2 matrix to all of an outline's points. Useful *) + (* for applying rotations, slanting, flipping, etc. *) + (* *) + (* <InOut> *) + (* outline :: A pointer to the target outline descriptor. *) + (* *) + (* <Input> *) + (* matrix :: A pointer to the transformation matrix. *) + (* *) + (* <Note> *) + (* You can use @FT_Outline_Translate if you need to translate the *) + (* outline's points. *) + (* *) + procedure FT_Outline_Transform( + outline: {const} PFT_Outline; + matrix: {const} PFT_Matrix); + cdecl; external ft_lib name 'FT_Outline_Transform'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Embolden *) + (* *) + (* <Description> *) + (* Emboldens an outline. The new outline will be at most 4 times *) + (* `strength' pixels wider and higher. You may think of the left and *) + (* bottom borders as unchanged. *) + (* *) + (* Negative `strength' values to reduce the outline thickness are *) + (* possible also. *) + (* *) + (* <InOut> *) + (* outline :: A handle to the target outline. *) + (* *) + (* <Input> *) + (* strength :: How strong the glyph is emboldened. Expressed in *) + (* 26.6 pixel format. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + (* <Note> *) + (* The used algorithm to increase or decrease the thickness of the *) + (* glyph doesn't change the number of points; this means that certain *) + (* situations like acute angles or intersections are sometimes *) + (* handled incorrectly. *) + (* *) + (* Example call: *) + (* *) + (* { *) + (* FT_Load_Glyph( face, index, FT_LOAD_DEFAULT ); *) + (* if ( face->slot->format == FT_GLYPH_FORMAT_OUTLINE ) *) + (* FT_Outline_Embolden( &face->slot->outline, strength ); *) + (* } *) + (* *) + function FT_Outline_Embolden( + outline: PFT_Outline; + strength: FT_Pos): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Embolden'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Reverse *) + (* *) + (* <Description> *) + (* Reverses the drawing direction of an outline. This is used to *) + (* ensure consistent fill conventions for mirrored glyphs. *) + (* *) + (* <InOut> *) + (* outline :: A pointer to the target outline descriptor. *) + (* *) + (* <Note> *) + (* This functions toggles the bit flag @FT_OUTLINE_REVERSE_FILL in *) + (* the outline's `flags' field. *) + (* *) + (* It shouldn't be used by a normal client application, unless it *) + (* knows what it is doing. *) + (* *) + procedure FT_Outline_Reverse( outline: PFT_Outline ); + cdecl; external ft_lib name 'FT_Outline_Reverse'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Get_Bitmap *) + (* *) + (* <Description> *) + (* Renders an outline within a bitmap. The outline's image is simply *) + (* OR-ed to the target bitmap. *) + (* *) + (* <Input> *) + (* library :: A handle to a FreeType library object. *) + (* *) + (* outline :: A pointer to the source outline descriptor. *) + (* *) + (* <InOut> *) + (* abitmap :: A pointer to the target bitmap descriptor. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + (* <Note> *) + (* This function does NOT CREATE the bitmap, it only renders an *) + (* outline image within the one you pass to it! *) + (* *) + (* It will use the raster corresponding to the default glyph format. *) + (* *) + function FT_Outline_Get_Bitmap( + library_: FT_Library; + outline: PFT_Outline; + abitmap: {const} PFT_Bitmap): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Get_Bitmap'; + + + (*************************************************************************) + (* *) + (* <Function> *) + (* FT_Outline_Render *) + (* *) + (* <Description> *) + (* Renders an outline within a bitmap using the current scan-convert. *) + (* This functions uses an @FT_Raster_Params structure as an argument, *) + (* allowing advanced features like direct composition, translucency, *) + (* etc. *) + (* *) + (* <Input> *) + (* library :: A handle to a FreeType library object. *) + (* *) + (* outline :: A pointer to the source outline descriptor. *) + (* *) + (* <InOut> *) + (* params :: A pointer to an @FT_Raster_Params structure used to *) + (* describe the rendering operation. *) + (* *) + (* <Return> *) + (* FreeType error code. 0 means success. *) + (* *) + (* <Note> *) + (* You should know what you are doing and how @FT_Raster_Params works *) + (* to use this function. *) + (* *) + (* The field `params.source' will be set to `outline' before the scan *) + (* converter is called, which means that the value you give to it is *) + (* actually ignored. *) + (* *) + function FT_Outline_Render( + library_: FT_Library; + outline: PFT_Outline; + params: PFT_Raster_Params): FT_Error; + cdecl; external ft_lib name 'FT_Outline_Render'; + +{$ENDIF TYPE_DECL} + + (************************************************************************** + * + * @enum: + * FT_Orientation + * + * @description: + * A list of values used to describe an outline's contour orientation. + * + * The TrueType and Postscript specifications use different conventions + * to determine whether outline contours should be filled or unfilled. + * + * @values: + * FT_ORIENTATION_TRUETYPE :: + * According to the TrueType specification, clockwise contours must + * be filled, and counter-clockwise ones must be unfilled. + * + * FT_ORIENTATION_POSTSCRIPT :: + * According to the Postscript specification, counter-clockwise contours + * must be filled, and clockwise ones must be unfilled. + * + * FT_ORIENTATION_FILL_RIGHT :: + * This is identical to @FT_ORIENTATION_TRUETYPE, but is used to + * remember that in TrueType, everything that is to the right of + * the drawing direction of a contour must be filled. + * + * FT_ORIENTATION_FILL_LEFT :: + * This is identical to @FT_ORIENTATION_POSTSCRIPT, but is used to + * remember that in Postscript, everything that is to the left of + * the drawing direction of a contour must be filled. + * + * FT_ORIENTATION_NONE :: + * The orientation cannot be determined. That is, different parts of + * the glyph have different orientation. + * + *) +{$IFDEF TYPE_DECL} + FT_Orientation = cint; +{$ELSE TYPE_DECL} +const + FT_ORIENTATION_TRUETYPE = 0; + FT_ORIENTATION_POSTSCRIPT = 1; + FT_ORIENTATION_FILL_RIGHT = FT_ORIENTATION_TRUETYPE; + FT_ORIENTATION_FILL_LEFT = FT_ORIENTATION_POSTSCRIPT; + FT_ORIENTATION_NONE = FT_ORIENTATION_FILL_LEFT+1; + + (************************************************************************** + * + * @function: + * FT_Outline_Get_Orientation + * + * @description: + * This function analyzes a glyph outline and tries to compute its + * fill orientation (see @FT_Orientation). This is done by computing + * the direction of each global horizontal and/or vertical extrema + * within the outline. + * + * Note that this will return @FT_ORIENTATION_TRUETYPE for empty + * outlines. + * + * @input: + * outline :: + * A handle to the source outline. + * + * @return: + * The orientation. + * + *) + function FT_Outline_Get_Orientation( outline: PFT_Outline ): FT_Orientation; + cdecl; external ft_lib name 'FT_Outline_Get_Orientation'; + +{$ENDIF TYPE_DECL} + diff --git a/src/lib/freetype/ftstroke.inc b/src/lib/freetype/ftstroke.inc new file mode 100644 index 00000000..bf8a00ae --- /dev/null +++ b/src/lib/freetype/ftstroke.inc @@ -0,0 +1,711 @@ +{***************************************************************************} +{* *} +{* ftstroke.h *} +{* *} +{* FreeType path stroker (specification). *} +{* *} +{* Copyright 2002, 2003, 2004, 2005, 2006 by *} +{* David Turner, Robert Wilhelm, and Werner Lemberg. *} +{* *} +{* This file is part of the FreeType project, and may only be used, *} +{* modified, and distributed under the terms of the FreeType project *} +{* license, LICENSE.TXT. By continuing to use, modify, or distribute *} +{* this file you indicate that you have read the license and *} +{* understand and accept it fully. *} +{* *} +{***************************************************************************} +(***************************************************************************) +(* Pascal port by the UltraStar Deluxe Team *) +(***************************************************************************) + + {************************************************************************ + * + * @section: + * glyph_stroker + * + * @title: + * Glyph Stroker + * + * @abstract: + * Generating bordered and stroked glyphs. + * + * @description: + * This component generates stroked outlines of a given vectorial + * glyph. It also allows you to retrieve the `outside' and/or the + * `inside' borders of the stroke. + * + * This can be useful to generate `bordered' glyph, i.e., glyphs + * displayed with a coloured (and anti-aliased) border around their + * shape. + *} + +{$IFDEF TYPE_DECL} + + {************************************************************** + * + * @type: + * FT_Stroker + * + * @description: + * Opaque handler to a path stroker object. + *} + FT_Stroker = Pointer; + + + {************************************************************** + * + * @enum: + * FT_Stroker_LineJoin + * + * @description: + * These values determine how two joining lines are rendered + * in a stroker. + * + * @values: + * FT_STROKER_LINEJOIN_ROUND :: + * Used to render rounded line joins. Circular arcs are used + * to join two lines smoothly. + * + * FT_STROKER_LINEJOIN_BEVEL :: + * Used to render beveled line joins; i.e., the two joining lines + * are extended until they intersect. + * + * FT_STROKER_LINEJOIN_MITER :: + * Same as beveled rendering, except that an additional line + * break is added if the angle between the two joining lines + * is too closed (this is useful to avoid unpleasant spikes + * in beveled rendering). + *} + FT_Stroker_LineJoin = cint; +{$ELSE TYPE_DECL} +const + FT_STROKER_LINEJOIN_ROUND = 0; + FT_STROKER_LINEJOIN_BEVEL = 1; + FT_STROKER_LINEJOIN_MITER = 2; + +{$ENDIF TYPE_DECL} +{$IFDEF TYPE_DECL} + + {************************************************************** + * + * @enum: + * FT_Stroker_LineCap + * + * @description: + * These values determine how the end of opened sub-paths are + * rendered in a stroke. + * + * @values: + * FT_STROKER_LINECAP_BUTT :: + * The end of lines is rendered as a full stop on the last + * point itself. + * + * FT_STROKER_LINECAP_ROUND :: + * The end of lines is rendered as a half-circle around the + * last point. + * + * FT_STROKER_LINECAP_SQUARE :: + * The end of lines is rendered as a square around the + * last point. + *} + FT_Stroker_LineCap = cint; +{$ELSE TYPE_DECL} +const + FT_STROKER_LINECAP_BUTT = 0; + FT_STROKER_LINECAP_ROUND = 1; + FT_STROKER_LINECAP_SQUARE = 2; + +{$ENDIF TYPE_DECL} +{$IFDEF TYPE_DECL} + + {************************************************************** + * + * @enum: + * FT_StrokerBorder + * + * @description: + * These values are used to select a given stroke border + * in @FT_Stroker_GetBorderCounts and @FT_Stroker_ExportBorder. + * + * @values: + * FT_STROKER_BORDER_LEFT :: + * Select the left border, relative to the drawing direction. + * + * FT_STROKER_BORDER_RIGHT :: + * Select the right border, relative to the drawing direction. + * + * @note: + * Applications are generally interested in the `inside' and `outside' + * borders. However, there is no direct mapping between these and the + * `left' and `right' ones, since this really depends on the glyph's + * drawing orientation, which varies between font formats. + * + * You can however use @FT_Outline_GetInsideBorder and + * @FT_Outline_GetOutsideBorder to get these. + *} + FT_StrokerBorder = cint; +{$ELSE TYPE_DECL} +const + FT_STROKER_BORDER_LEFT = 0; + FT_STROKER_BORDER_RIGHT = 1; + + + {************************************************************** + * + * @function: + * FT_Outline_GetInsideBorder + * + * @description: + * Retrieve the @FT_StrokerBorder value corresponding to the + * `inside' borders of a given outline. + * + * @input: + * outline :: + * The source outline handle. + * + * @return: + * The border index. @FT_STROKER_BORDER_LEFT for empty or invalid + * outlines. + *} + function FT_Outline_GetInsideBorder( outline: PFT_Outline ): FT_StrokerBorder; + cdecl; external ft_lib name 'FT_Outline_GetInsideBorder'; + + + {************************************************************** + * + * @function: + * FT_Outline_GetOutsideBorder + * + * @description: + * Retrieve the @FT_StrokerBorder value corresponding to the + * `outside' borders of a given outline. + * + * @input: + * outline :: + * The source outline handle. + * + * @return: + * The border index. @FT_STROKER_BORDER_LEFT for empty or invalid + * outlines. + *} + function FT_Outline_GetOutsideBorder( outline: PFT_Outline ): FT_StrokerBorder; + cdecl; external ft_lib name 'FT_Outline_GetOutsideBorder'; + + + {************************************************************** + * + * @function: + * FT_Stroker_New + * + * @description: + * Create a new stroker object. + * + * @input: + * library :: + * FreeType library handle. + * + * @output: + * astroker :: + * A new stroker object handle. NULL in case of error. + * + * @return: + * FreeType error code. 0 means success. + *} + function FT_Stroker_New( + library_: FT_Library; + out astroker: FT_Stroker ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_New'; + + + {************************************************************** + * + * @function: + * FT_Stroker_Set + * + * @description: + * Reset a stroker object's attributes. + * + * @input: + * stroker :: + * The target stroker handle. + * + * radius :: + * The border radius. + * + * line_cap :: + * The line cap style. + * + * line_join :: + * The line join style. + * + * miter_limit :: + * The miter limit for the FT_STROKER_LINEJOIN_MITER style, + * expressed as 16.16 fixed point value. + * + * @note: + * The radius is expressed in the same units that the outline + * coordinates. + *} + procedure FT_Stroker_Set( + stroker: FT_Stroker; + radius: FT_Fixed; + line_cap: FT_Stroker_LineCap; + line_join: FT_Stroker_LineJoin; + miter_limit: FT_Fixed ); + cdecl; external ft_lib name 'FT_Stroker_Set'; + + + {************************************************************** + * + * @function: + * FT_Stroker_Rewind + * + * @description: + * Reset a stroker object without changing its attributes. + * You should call this function before beginning a new + * series of calls to @FT_Stroker_BeginSubPath or + * @FT_Stroker_EndSubPath. + * + * @input: + * stroker :: + * The target stroker handle. + *} + procedure FT_Stroker_Rewind( stroker: FT_Stroker ); + cdecl; external ft_lib name 'FT_Stroker_Rewind'; + + + {************************************************************** + * + * @function: + * FT_Stroker_ParseOutline + * + * @description: + * A convenience function used to parse a whole outline with + * the stroker. The resulting outline(s) can be retrieved + * later by functions like @FT_Stroker_GetCounts and @FT_Stroker_Export. + * + * @input: + * stroker :: + * The target stroker handle. + * + * outline :: + * The source outline. + * + * opened :: + * A boolean. If 1, the outline is treated as an open path instead + * of a closed one. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * If `opened' is 0 (the default), the outline is treated as a closed + * path, and the stroker will generate two distinct `border' outlines. + * + * If `opened' is 1, the outline is processed as an open path, and the + * stroker will generate a single `stroke' outline. + * + * This function calls @FT_Stroker_Rewind automatically. + *} + function FT_Stroker_ParseOutline( + stroker: FT_Stroker; + outline: PFT_Outline; + opened: FT_Bool): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_ParseOutline'; + + + {************************************************************** + * + * @function: + * FT_Stroker_BeginSubPath + * + * @description: + * Start a new sub-path in the stroker. + * + * @input: + * stroker :: + * The target stroker handle. + * + * to :: + * A pointer to the start vector. + * + * open :: + * A boolean. If 1, the sub-path is treated as an open one. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * This function is useful when you need to stroke a path that is + * not stored as an @FT_Outline object. + *} + function FT_Stroker_BeginSubPath( + stroker: FT_Stroker; + to_: PFT_Vector; + open: FT_Bool ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_BeginSubPath'; + + + {************************************************************** + * + * @function: + * FT_Stroker_EndSubPath + * + * @description: + * Close the current sub-path in the stroker. + * + * @input: + * stroker :: + * The target stroker handle. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * You should call this function after @FT_Stroker_BeginSubPath. + * If the subpath was not `opened', this function will `draw' a + * single line segment to the start position when needed. + *} + function FT_Stroker_EndSubPath( stroker: FT_Stroker ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_EndSubPath'; + + + {************************************************************** + * + * @function: + * FT_Stroker_LineTo + * + * @description: + * `Draw' a single line segment in the stroker's current sub-path, + * from the last position. + * + * @input: + * stroker :: + * The target stroker handle. + * + * to :: + * A pointer to the destination point. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * You should call this function between @FT_Stroker_BeginSubPath and + * @FT_Stroker_EndSubPath. + *} + function FT_Stroker_LineTo( + stroker: FT_Stroker; + to_: PFT_Vector ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_LineTo'; + + + {************************************************************** + * + * @function: + * FT_Stroker_ConicTo + * + * @description: + * `Draw' a single quadratic Bézier in the stroker's current sub-path, + * from the last position. + * + * @input: + * stroker :: + * The target stroker handle. + * + * control :: + * A pointer to a Bézier control point. + * + * to :: + * A pointer to the destination point. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * You should call this function between @FT_Stroker_BeginSubPath and + * @FT_Stroker_EndSubPath. + *} + function FT_Stroker_ConicTo( + stroker: FT_Stroker; + control: PFT_Vector; + to_: PFT_Vector ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_ConicTo'; + + + {************************************************************** + * + * @function: + * FT_Stroker_CubicTo + * + * @description: + * `Draw' a single cubic Bézier in the stroker's current sub-path, + * from the last position. + * + * @input: + * stroker :: + * The target stroker handle. + * + * control1 :: + * A pointer to the first Bézier control point. + * + * control2 :: + * A pointer to second Bézier control point. + * + * to :: + * A pointer to the destination point. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * You should call this function between @FT_Stroker_BeginSubPath and + * @FT_Stroker_EndSubPath. + *} + function FT_Stroker_CubicTo( + stroker: FT_Stroker; + control1: PFT_Vector; + control2: PFT_Vector; + to_: PFT_Vector ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_CubicTo'; + + + {************************************************************** + * + * @function: + * FT_Stroker_GetBorderCounts + * + * @description: + * Call this function once you have finished parsing your paths + * with the stroker. It will return the number of points and + * contours necessary to export one of the `border' or `stroke' + * outlines generated by the stroker. + * + * @input: + * stroker :: + * The target stroker handle. + * + * border :: + * The border index. + * + * @output: + * anum_points :: + * The number of points. + * + * anum_contours :: + * The number of contours. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * When an outline, or a sub-path, is `closed', the stroker generates + * two independent `border' outlines, named `left' and `right'. + * + * When the outline, or a sub-path, is `opened', the stroker merges + * the `border' outlines with caps. The `left' border receives all + * points, while the `right' border becomes empty. + * + * Use the function @FT_Stroker_GetCounts instead if you want to + * retrieve the counts associated to both borders. + *} + function FT_Stroker_GetBorderCounts( + stroker: FT_Stroker; + border: FT_StrokerBorder; + out anum_points: FT_UInt; + out anum_contours: FT_UInt ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_GetBorderCounts'; + + + {************************************************************** + * + * @function: + * FT_Stroker_ExportBorder + * + * @description: + * Call this function after @FT_Stroker_GetBorderCounts to + * export the corresponding border to your own @FT_Outline + * structure. + * + * Note that this function will append the border points and + * contours to your outline, but will not try to resize its + * arrays. + * + * @input: + * stroker :: + * The target stroker handle. + * + * border :: + * The border index. + * + * outline :: + * The target outline handle. + * + * @note: + * Always call this function after @FT_Stroker_GetBorderCounts to + * get sure that there is enough room in your @FT_Outline object to + * receive all new data. + * + * When an outline, or a sub-path, is `closed', the stroker generates + * two independent `border' outlines, named `left' and `right' + * + * When the outline, or a sub-path, is `opened', the stroker merges + * the `border' outlines with caps. The `left' border receives all + * points, while the `right' border becomes empty. + * + * Use the function @FT_Stroker_Export instead if you want to + * retrieve all borders at once. + *} + procedure FT_Stroker_ExportBorder( + stroker: FT_Stroker; + border: FT_StrokerBorder; + outline: PFT_Outline ); + cdecl; external ft_lib name 'FT_Stroker_ExportBorder'; + + + {************************************************************** + * + * @function: + * FT_Stroker_GetCounts + * + * @description: + * Call this function once you have finished parsing your paths + * with the stroker. It returns the number of points and + * contours necessary to export all points/borders from the stroked + * outline/path. + * + * @input: + * stroker :: + * The target stroker handle. + * + * @output: + * anum_points :: + * The number of points. + * + * anum_contours :: + * The number of contours. + * + * @return: + * FreeType error code. 0 means success. + *} + function FT_Stroker_GetCounts( + stroker: FT_Stroker; + out anum_points: FT_UInt; + out anum_contours: FT_UInt ): FT_Error; + cdecl; external ft_lib name 'FT_Stroker_GetCounts'; + + + {************************************************************** + * + * @function: + * FT_Stroker_Export + * + * @description: + * Call this function after @FT_Stroker_GetBorderCounts to + * export the all borders to your own @FT_Outline structure. + * + * Note that this function will append the border points and + * contours to your outline, but will not try to resize its + * arrays. + * + * @input: + * stroker :: + * The target stroker handle. + * + * outline :: + * The target outline handle. + *} + procedure FT_Stroker_Export( + stroker: FT_Stroker; + outline: PFT_Outline ); + cdecl; external ft_lib name 'FT_Stroker_Export'; + + + {************************************************************** + * + * @function: + * FT_Stroker_Done + * + * @description: + * Destroy a stroker object. + * + * @input: + * stroker :: + * A stroker handle. Can be NULL. + *} + procedure FT_Stroker_Done( stroker: FT_Stroker ); + cdecl; external ft_lib name 'FT_Stroker_Done'; + + + {************************************************************** + * + * @function: + * FT_Glyph_Stroke + * + * @description: + * Stroke a given outline glyph object with a given stroker. + * + * @inout: + * pglyph :: + * Source glyph handle on input, new glyph handle on output. + * + * @input: + * stroker :: + * A stroker handle. + * + * destroy :: + * A Boolean. If 1, the source glyph object is destroyed + * on success. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * The source glyph is untouched in case of error. + *} + function FT_Glyph_Stroke( + var glyph: FT_Glyph; + stroker: FT_Stroker; + destroy: FT_Bool ): FT_Error; + cdecl; external ft_lib name 'FT_Glyph_Stroke'; + + + {************************************************************** + * + * @function: + * FT_Glyph_StrokeBorder + * + * @description: + * Stroke a given outline glyph object with a given stroker, but + * only return either its inside or outside border. + * + * @inout: + * pglyph :: + * Source glyph handle on input, new glyph handle on output. + * + * @input: + * stroker :: + * A stroker handle. + * + * inside :: + * A Boolean. If 1, return the inside border, otherwise + * the outside border. + * + * destroy :: + * A Boolean. If 1, the source glyph object is destroyed + * on success. + * + * @return: + * FreeType error code. 0 means success. + * + * @note: + * The source glyph is untouched in case of error. + *} + function FT_Glyph_StrokeBorder( + var glyph: FT_Glyph; + stroker: FT_Stroker; + inside: FT_Bool; + destroy: FT_Bool ): FT_Error; + cdecl; external ft_lib name 'FT_Glyph_StrokeBorder'; + +{$ENDIF TYPE_DECL} + diff --git a/src/lib/freetype/fttypes.inc b/src/lib/freetype/fttypes.inc new file mode 100644 index 00000000..a64432e6 --- /dev/null +++ b/src/lib/freetype/fttypes.inc @@ -0,0 +1,311 @@ +(***************************************************************************) +(* *) +(* fttypes.h *) +(* *) +(* FreeType simple types definitions (specification only). *) +(* *) +(* Copyright 1996-2001, 2002, 2004, 2006, 2007 by *) +(* David Turner, Robert Wilhelm, and Werner Lemberg. *) +(* *) +(* This file is part of the FreeType project, and may only be used, *) +(* modified, and distributed under the terms of the FreeType project *) +(* license, LICENSE.TXT. By continuing to use, modify, or distribute *) +(* this file you indicate that you have read the license and *) +(* understand and accept it fully. *) +(* *) +(***************************************************************************) +(***************************************************************************) +(* Pascal port by the UltraStar Deluxe Team *) +(***************************************************************************) + + (*************************************************************************) + (* *) + (* <Section> *) + (* basic_types *) + (* *) + (* <Title> *) + (* Basic Data Types *) + (* *) + (* <Abstract> *) + (* The basic data types defined by the library. *) + (* *) + (* <Description> *) + (* This section contains the basic data types defined by FreeType 2, *) + (* ranging from simple scalar types to bitmap descriptors. More *) + (* font-specific structures are defined in a different section. *) + (* *) + (* <Order> *) + (* FT_Byte *) + (* FT_Bytes *) + (* FT_Char *) + (* FT_Int *) + (* FT_UInt *) + (* FT_Short *) + (* FT_UShort *) + (* FT_Long *) + (* FT_ULong *) + (* FT_Bool *) + (* FT_Offset *) + (* FT_PtrDist *) + (* FT_String *) + (* FT_Tag *) + (* FT_Error *) + (* FT_Fixed *) + (* FT_Pointer *) + (* FT_Pos *) + (* FT_Vector *) + (* FT_BBox *) + (* FT_Matrix *) + (* FT_FWord *) + (* FT_UFWord *) + (* FT_F2Dot14 *) + (* FT_UnitVector *) + (* FT_F26Dot6 *) + (* *) + (* *) + (* FT_Generic *) + (* FT_Generic_Finalizer *) + (* *) + (* FT_Bitmap *) + (* FT_Pixel_Mode *) + (* FT_Palette_Mode *) + (* FT_Glyph_Format *) + (* FT_IMAGE_TAG *) + (* *) + (*************************************************************************) + +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Bool *) + (* *) + (* <Description> *) + (* A typedef of unsigned char, used for simple booleans. As usual, *) + (* values 1 and 0 represent true and false, respectively. *) + (* *) + FT_Bool = cuchar; +{$ENDIF TYPE_DECL} +{$IFNDEF TYPE_DECL} +const + FT_FALSE = 0; + FT_TRUE = 1; +{$ENDIF !TYPE_DECL} +{$IFDEF TYPE_DECL} + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Byte *) + (* *) + (* <Description> *) + (* A simple typedef for the _unsigned_ char type. *) + (* *) + FT_Byte = cuchar; + PFT_Byte = ^FT_Byte; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_String *) + (* *) + (* <Description> *) + (* A simple typedef for the char type, usually used for strings. *) + (* *) + FT_String = cchar; + PFT_String = ^FT_String; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Short *) + (* *) + (* <Description> *) + (* A typedef for signed short. *) + (* *) + FT_Short = csshort; + PFT_Short = ^FT_Short; + + PFT_ShortArray = ^FT_ShortArray; + FT_ShortArray = array[0 .. (MaxInt div SizeOf(FT_Short))-1] of FT_Short; + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_UShort *) + (* *) + (* <Description> *) + (* A typedef for unsigned short. *) + (* *) + FT_UShort = cushort; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Int *) + (* *) + (* <Description> *) + (* A typedef for the int type. *) + (* *) + FT_Int = csint; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_UInt *) + (* *) + (* <Description> *) + (* A typedef for the unsigned int type. *) + (* *) + FT_UInt = cuint; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Long *) + (* *) + (* <Description> *) + (* A typedef for signed long. *) + (* *) + FT_Long = cslong; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_ULong *) + (* *) + (* <Description> *) + (* A typedef for unsigned long. *) + (* *) + FT_ULong = culong; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_F26Dot6 *) + (* *) + (* <Description> *) + (* A signed 26.6 fixed float type used for vectorial pixel *) + (* coordinates. *) + (* *) + FT_F26Dot6 = cslong; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Fixed *) + (* *) + (* <Description> *) + (* This type is used to store 16.16 fixed float values, like scaling *) + (* values or matrix coefficients. *) + (* *) + FT_Fixed = cslong; + + + (*************************************************************************) + (* *) + (* <Type> *) + (* FT_Error *) + (* *) + (* <Description> *) + (* The FreeType error code type. A value of 0 is always interpreted *) + (* as a successful operation. *) + (* *) + FT_Error = cint; + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Matrix *) + (* *) + (* <Description> *) + (* A simple structure used to store a 2x2 matrix. Coefficients are *) + (* in 16.16 fixed float format. The computation performed is: *) + (* *) + (* { *) + (* x' = x*xx + y*xy *) + (* y' = x*yx + y*yy *) + (* } *) + (* *) + (* <Fields> *) + (* xx :: Matrix coefficient. *) + (* *) + (* xy :: Matrix coefficient. *) + (* *) + (* yx :: Matrix coefficient. *) + (* *) + (* yy :: Matrix coefficient. *) + (* *) + PFT_Matrix = ^FT_Matrix; + FT_Matrix = record + xx, xy: FT_Fixed; + yx, yy: FT_Fixed; + end; + + + (*************************************************************************) + (* *) + (* <FuncType> *) + (* FT_Generic_Finalizer *) + (* *) + (* <Description> *) + (* Describes a function used to destroy the `client' data of any *) + (* FreeType object. See the description of the FT_Generic type for *) + (* details of usage. *) + (* *) + (* <Input> *) + (* The address of the FreeType object which is under finalization. *) + (* Its client data is accessed through its `generic' field. *) + (* *) + FT_Generic_Finalizer = procedure(AnObject : pointer ); cdecl; + + + (*************************************************************************) + (* *) + (* <Struct> *) + (* FT_Generic *) + (* *) + (* <Description> *) + (* Client applications often need to associate their own data to a *) + (* variety of FreeType core objects. For example, a text layout API *) + (* might want to associate a glyph cache to a given size object. *) + (* *) + (* Most FreeType object contains a `generic' field, of type *) + (* FT_Generic, which usage is left to client applications and font *) + (* servers. *) + (* *) + (* It can be used to store a pointer to client-specific data, as well *) + (* as the address of a `finalizer' function, which will be called by *) + (* FreeType when the object is destroyed (for example, the previous *) + (* client example would put the address of the glyph cache destructor *) + (* in the `finalizer' field). *) + (* *) + (* <Fields> *) + (* data :: A typeless pointer to any client-specified data. This *) + (* field is completely ignored by the FreeType library. *) + (* *) + (* finalizer :: A pointer to a `generic finalizer' function, which *) + (* will be called when the object is destroyed. If this *) + (* field is set to NULL, no code will be called. *) + (* *) + FT_Generic = record + data: pointer; + finalizer: FT_Generic_Finalizer; + end; + + + TByteArray = array [0 .. (MaxInt div SizeOf(byte))-1] of byte; + PByteArray = ^TByteArray; + +{$ENDIF TYPE_DECL} + diff --git a/src/lib/lib-info.txt b/src/lib/lib-info.txt index 59502c7a..0a184568 100644 --- a/src/lib/lib-info.txt +++ b/src/lib/lib-info.txt @@ -1,60 +1,60 @@ -bass:
-http://www.un4seen.com/ (2.4.2.1)
-- FPC Mac OS X compatibility fixes
-
-fft:
-translation of audacity's FFT.cpp by hennymcc (maybe replace this with FFTW?)
-
-ffmpeg:
-- http://www.iversenit.dk/dev/ffmpeg-headers/: 2006-10
-- several bugs were fixed
-- many IFDEFS were added to the header to support multiple versions of ffmpeg (starting with end of 2006) and not only one specific version. This is necessary as we cannot control which version is used on linux. We could ship the ffmpeg lib with USDX and link statically but a stripped down ffmpeg is 15MB in size and takes 5 minutes to compile (so static linkage is not a good option).
-- the headers were updated to reflect the changes in the ffmpeg C-headers (http://svn.mplayerhq.hu/ffmpeg/trunk/ and http://svn.mplayerhq.hu/mplayer/trunk/libswscale/)
-
-freeimage:
-- inserted by eddie. Some compatibility fixes for platforms different than mac os x.
-- not used anymore
-
-freetype:
-- based on the AggPas (http://aggpas.org/) headers
-- just a minimal header that contains only some of the freetype functions and types. Some functions and structures/constants/types needed for USDX were added.
-- some comments added
-
-jedi-sdl:
-JEDI-SDL v1.0 Final RC 2 (http://jedi-sdl.pascalgamedevelopment.com/)
-- 64bit compatibility patch (http://sourceforge.net/tracker/index.php?func=detail&aid=1902924&group_id=43805&atid=437446)
-- some Mac OS X patches from freepascal trunk
-- some additional patched (see *.patch)
-
-midi:
-taken from http://www.torry.net/authorsmore.php?id=1615 (TMidiPlayer)
-- FPC (Win32) compatibility fixes
-- Win32 only. Maybe use some timidity stuff under linux.
-
-libpng:
-autocreated H2Pas file taken from freepascal trunk
-- bug fixes (especially H2Pas related stuff like wrong file types)
-- delphi compatibility
-- comments added
-
-portaudio:
-translation of the (patched) audacity C headers by hennymcc.
-See http://audacity.cvs.sourceforge.net/viewvc/audacity/lib-src/portaudio-v19/include/?sortdir=down
-
-portmixer:
-translation of the (patched) audacity C headers by hennymcc.
-- Unlike portaudio portmixer is part of audacity and there is no linux package for it. If we want to use it for linux, we have to link it statically. Unfortunately it requires a patched version of portaudio (which is part of audacity and statically linked to) so we have to statically link portaudio too :(.
-
-projectM:
-translation of the original C++ headers and C-wrapper by hennymcc
-
-samplerate:
-translation of the original C headers by profoX/hennymcc
-
-sqlite:
-taken from http://www.itwriting.com/blog/a-simple-delphi-wrapper-for-sqlite-3
-- slightly patched: see *.patch files for what has been patched (e.g. Binding)
-
-zlib:
-taken from freepascal (slightly patched)
+bass: +http://www.un4seen.com/ (2.4.2.1) +- FPC Mac OS X compatibility fixes + +fft: +translation of audacity's FFT.cpp by hennymcc (maybe replace this with FFTW?) + +ffmpeg: +- http://www.iversenit.dk/dev/ffmpeg-headers/: 2006-10 +- several bugs were fixed +- many IFDEFS were added to the header to support multiple versions of ffmpeg (starting with end of 2006) and not only one specific version. This is necessary as we cannot control which version is used on linux. We could ship the ffmpeg lib with USDX and link statically but a stripped down ffmpeg is 15MB in size and takes 5 minutes to compile (so static linkage is not a good option). +- the headers were updated to reflect the changes in the ffmpeg C-headers (http://svn.mplayerhq.hu/ffmpeg/trunk/ and http://svn.mplayerhq.hu/mplayer/trunk/libswscale/) + +freeimage: +- inserted by eddie. Some compatibility fixes for platforms different than mac os x. +- not used anymore + +freetype: +- based on the AggPas (http://aggpas.org/) headers +- just a minimal header that contains only some of the freetype functions and types. Some functions and structures/constants/types needed for USDX were added. +- some comments added + +jedi-sdl: +JEDI-SDL v1.0 Final RC 2 (http://jedi-sdl.pascalgamedevelopment.com/) +- 64bit compatibility patch (http://sourceforge.net/tracker/index.php?func=detail&aid=1902924&group_id=43805&atid=437446) +- some Mac OS X patches from freepascal trunk +- some additional patched (see *.patch) + +midi: +taken from http://www.torry.net/authorsmore.php?id=1615 (TMidiPlayer) +- FPC (Win32) compatibility fixes +- Win32 only. Maybe use some timidity stuff under linux. + +libpng: +autocreated H2Pas file taken from freepascal trunk +- bug fixes (especially H2Pas related stuff like wrong file types) +- delphi compatibility +- comments added + +portaudio: +translation of the (patched) audacity C headers by hennymcc. +See http://audacity.cvs.sourceforge.net/viewvc/audacity/lib-src/portaudio-v19/include/?sortdir=down + +portmixer: +translation of the (patched) audacity C headers by hennymcc. +- Unlike portaudio portmixer is part of audacity and there is no linux package for it. If we want to use it for linux, we have to link it statically. Unfortunately it requires a patched version of portaudio (which is part of audacity and statically linked to) so we have to statically link portaudio too :(. + +projectM: +translation of the original C++ headers and C-wrapper by hennymcc + +samplerate: +translation of the original C headers by profoX/hennymcc + +sqlite: +taken from http://www.itwriting.com/blog/a-simple-delphi-wrapper-for-sqlite-3 +- slightly patched: see *.patch files for what has been patched (e.g. Binding) + +zlib: +taken from freepascal (slightly patched) - delphi compatibility
\ No newline at end of file diff --git a/src/lib/midi/CIRCBUF.PAS b/src/lib/midi/CIRCBUF.PAS index 77cb3643..3ceb4c6e 100644 --- a/src/lib/midi/CIRCBUF.PAS +++ b/src/lib/midi/CIRCBUF.PAS @@ -23,7 +23,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} Uses diff --git a/src/lib/midi/DELPHMCB.PAS b/src/lib/midi/DELPHMCB.PAS index e607627d..ef0d5451 100644 --- a/src/lib/midi/DELPHMCB.PAS +++ b/src/lib/midi/DELPHMCB.PAS @@ -13,7 +13,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses diff --git a/src/lib/midi/MIDIDEFS.PAS b/src/lib/midi/MIDIDEFS.PAS index fc8eed26..4afe56ef 100644 --- a/src/lib/midi/MIDIDEFS.PAS +++ b/src/lib/midi/MIDIDEFS.PAS @@ -13,7 +13,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses diff --git a/src/lib/midi/MIDITYPE.PAS b/src/lib/midi/MIDITYPE.PAS index b1ec1bdd..45b50820 100644 --- a/src/lib/midi/MIDITYPE.PAS +++ b/src/lib/midi/MIDITYPE.PAS @@ -10,7 +10,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses diff --git a/src/lib/midi/MidiFile.pas b/src/lib/midi/MidiFile.pas index 11b1ca0b..acf44c04 100644 --- a/src/lib/midi/MidiFile.pas +++ b/src/lib/midi/MidiFile.pas @@ -92,18 +92,18 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses Windows, - //Forms, Messages, Classes, {$IFDEF FPC} WinAllocation, {$ENDIF} - SysUtils; + SysUtils, + UPath; type TChunkType = (illegal, header, track); @@ -162,7 +162,7 @@ type procedure WndProc(var Msg : TMessage); protected { Protected declarations } - midiFile: file of byte; + midiFile: TBinaryFileStream; chunkType: TChunkType; chunkLength: integer; chunkData: PByte; @@ -177,7 +177,7 @@ type FBpm: integer; FBeatsPerMeasure: integer; FusPerTick: double; - FFilename: string; + FFilename: IPath; Tracks: TList; currentTrack: TMidiTrack; @@ -191,7 +191,7 @@ type currentPos: Double; // Current Position in ticks procedure OnTrackReady; - procedure setFilename(val: string); + procedure SetFilename(val: IPath); procedure ReadChunkHeader; procedure ReadChunkContent; procedure ReadChunk; @@ -221,7 +221,7 @@ type function Ready: boolean; published { Published declarations } - property Filename: string read FFilename write setFilename; + property Filename: IPath read FFilename write SetFilename; property NumberOfTracks: integer read numberTracks; property TicksPerQuarter: integer read deltaTicks; property FileFormat: TFileFormat read FFileFormat; @@ -463,7 +463,7 @@ begin result := Tracks.Items[index]; end; -procedure TMidifile.setFilename(val: string); +procedure TMidifile.SetFilename(val: IPath); begin FFilename := val; // ReadFile; @@ -586,7 +586,7 @@ procedure TMidifile.ReadChunkHeader; var theByte: array[0..7] of byte; begin - BlockRead(midiFile, theByte, 8); + midiFile.Read(theByte[0], 8); if (theByte[0] = $4D) and (theByte[1] = $54) then begin if (theByte[2] = $68) and (theByte[3] = $64) then @@ -608,7 +608,7 @@ begin if not (chunkData = nil) then FreeMem(chunkData); GetMem(chunkData, chunkLength + 10); - BlockRead(midiFile, chunkData^, chunkLength); + midiFile.Read(chunkData^, chunkLength); chunkIndex := chunkData; chunkEnd := PByte(integer(chunkIndex) + integer(chunkLength) - 1); end; @@ -848,12 +848,10 @@ begin Tracks.Clear; chunkType := illegal; - AssignFile(midiFile, FFilename); - FileMode := 0; - Reset(midiFile); - while not eof(midiFile) do + midiFile := TBinaryFileStream.Create(FFilename, fmOpenRead); + while (midiFile.Position < midiFile.Size) do ReadChunk; - CloseFile(midiFile); + FreeAndNil(midiFile); numberTracks := Tracks.Count; end; diff --git a/src/lib/midi/MidiScope.pas b/src/lib/midi/MidiScope.pas index 42fc65fc..afc20b0f 100644 --- a/src/lib/midi/MidiScope.pas +++ b/src/lib/midi/MidiScope.pas @@ -20,7 +20,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses diff --git a/src/lib/midi/Midicons.pas b/src/lib/midi/Midicons.pas index 35dbb5f3..72259beb 100644 --- a/src/lib/midi/Midicons.pas +++ b/src/lib/midi/Midicons.pas @@ -11,7 +11,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses Messages; diff --git a/src/lib/midi/Midiin.pas b/src/lib/midi/Midiin.pas index 21db0298..66e4f76d 100644 --- a/src/lib/midi/Midiin.pas +++ b/src/lib/midi/Midiin.pas @@ -103,7 +103,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses diff --git a/src/lib/midi/Midiout.pas b/src/lib/midi/Midiout.pas index 606d0dae..98e6e3fb 100644 --- a/src/lib/midi/Midiout.pas +++ b/src/lib/midi/Midiout.pas @@ -98,7 +98,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses diff --git a/src/lib/other/DirWatch.pas b/src/lib/other/DirWatch.pas index 9d395840..1e00ec5d 100644 --- a/src/lib/other/DirWatch.pas +++ b/src/lib/other/DirWatch.pas @@ -25,7 +25,7 @@ interface {$IFDEF FPC} {$MODE Delphi} - {$H+} // use AnsiString + {$H+} // use long strings {$ENDIF} uses diff --git a/src/lib/projectM/projectM.pas b/src/lib/projectM/projectM.pas index 4adba17d..533cb19b 100644 --- a/src/lib/projectM/projectM.pas +++ b/src/lib/projectM/projectM.pas @@ -2,7 +2,7 @@ unit projectM; {$IFDEF FPC} {$MODE DELPHI} - {$H+} (* use AnsiString *) + {$H+} (* use long strings *) {$PACKENUM 4} (* use 4-byte enums *) {$PACKRECORDS C} (* C/C++-compatible record packing *) {$ELSE} diff --git a/src/lib/zlib/zlib.pas b/src/lib/zlib/zlib.pas index 31d6a68b..8d09313f 100644 --- a/src/lib/zlib/zlib.pas +++ b/src/lib/zlib/zlib.pas @@ -14,7 +14,7 @@ interface {$ifdef FPC} {$mode objfpc} // Needed for array of const - {$H+} // use AnsiString + {$H+} // use long strings {$PACKRECORDS C} {$endif} |