erabo/spiegel-keyman
1
0
Fork 0
mirror of https://github.com/keymanapp/keyman.git synced 2026-08-06 08:55:34 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions 13
spiegel-keyman/common/windows/delphi/charmap/UnicodeData.pas

1858 lines
57 KiB
ObjectPascal
Raw Blame History

(*
Name: UnicodeData
Copyright: Copyright (C) SIL International.
Documentation:
Description:
Create Date: 1 Aug 2006
Modified Date: 10 Jun 2014
Authors: mcdurdin
Related Files:
Dependencies:
Bugs:
Todo:
Notes:
History: 01 Aug 2006 - mcdurdin - Rework for Keyman Developer 7 Character map
23 Aug 2006 - mcdurdin - Add ShortName property and FindDataByName function
23 Aug 2006 - mcdurdin - Add GetUnicodeRangeFromFilter function
14 Sep 2006 - mcdurdin - Moved to new location
06 Oct 2006 - mcdurdin - Add font ranges
06 Oct 2006 - mcdurdin - Fix CRLF issue with importing text files
06 Oct 2006 - mcdurdin - Optimize cached characters in database
04 Jan 2007 - mcdurdin - Don't change space to underscore when filtering block names
23 Aug 2007 - mcdurdin - I1014 - Fix character map database rebuild
12 Mar 2010 - mcdurdin - I1891 - Improve character search
12 Mar 2010 - mcdurdin - I2210 - Filter should support numeric ranges better
18 Mar 2011 - mcdurdin - I2794 - Fix memory leaks
18 Mar 2011 - mcdurdin - I2476 - Keyman Developer 8.0 cannot build character map database
18 Mar 2011 - mcdurdin - I2299 - Keyman Developer tries to write to UnicodeData.mdb which is stored in Program Files
25 Mar 2011 - mcdurdin - I2845 - After fixing Developer Unicode data references, BuildUniData fails due to path overrides
04 May 2012 - mcdurdin - I3308 - V9.0 - Start to move towards Delphi namespaces
04 May 2012 - mcdurdin - I3306 - V9.0 - Remove TntControls
04 May 2012 - mcdurdin - I3310 - V9.0 - Unicode in Delphi fixes
08 Jun 2012 - mcdurdin - I3310 - V9.0 - Unicode in Delphi fixes
26 Jun 2012 - mcdurdin - I3379 - KM9 - Remove old Winapi references now in Delphi libraries
08 Oct 2012 - mcdurdin - I3465 - V9.0 - Filtering is not working in character map
10 Jun 2014 - mcdurdin - I4257 - V9.0 - Add ethnologue language codes to unicodedata.mdb
*)
unit UnicodeData; // I3308 // I3306
interface
uses
System.Classes,
System.Contnrs,
System.SysUtils,
Winapi.Windows,
ADODB_TLB,
ADOX_TLB,
TTInfo;
//UfrmUnicodeDataStatus;
type
TUnicodeCharacter = record
CodeValue: Integer; // 0 means record not found
CharacterName: WideString;
{ GeneralCategory: string;
CanonicalCombiningClasses: Integer;
BidirectionalCategory: string;
CharacterDecompositionMapping: string; // '' is not specified
DecimalDigitValue: Integer; // -1 is not specified
DigitValue: Integer; // -1 is not specified
NumericValue: string; // -1 is not specified
Mirrored: Boolean;
Unicode10Name: string; // '' is not specified
_10646Comment: string; // '' is not specified
UpperCaseMapping: Integer; // 0 is not specified
LowerCaseMapping: Integer; // 0 is not specified
TitleCaseMapping: Integer; // 0 is not specified
}
end;
{TUnicodeChar = record
Char: DWord; //array[0..2] of WideChar;
end;}
//TUnicodeCharArray = array[0..1000000] of TUnicodeChar;
//PUnicodeCharArray = ^TUnicodeCharArray;//
TIntegerArray = array[0..1000000] of Integer;
PIntegerArray = ^TIntegerArray;
TUnicodeBlock = class
private
FName: WideString;
FBlockID: Integer;
FEndChar: Integer;
FCacheCharData: PIntegerArray;
FTag: Integer;
FCacheCharCount: Integer;
FStartChar: Integer;
FShortName: WideString;
public
destructor Destroy; override;
property BlockID: Integer read FBlockID;
property Name: WideString read FName;
property ShortName: WideString read FShortName;
property StartChar: Integer read FStartChar;
property EndChar: Integer read FEndChar;
property CacheCharCount: Integer read FCacheCharCount;
property CacheCharData: PIntegerArray read FCacheCharData;
property Tag: Integer read FTag write FTag;
end;
TUnicodeBlockList = class(TObjectList)
private
FName: WideString;
FShortName: WideString;
function GetItem(Index: Integer): TUnicodeBlock;
procedure SetItem(Index: Integer; const Value: TUnicodeBlock);
public
property Name: WideString read FName;
property ShortName: WideString read FShortName;
property Items[Index: Integer]: TUnicodeBlock read GetItem write SetItem; default;
end;
TUnicodeDataError = (
udeCouldNotDeleteDatabaseForRebuild,
udeCouldNotCreateDatabase);
TUnicodeData = class;
IUnicodeDataUIManager = interface
procedure UDUI_Error(Sender: TUnicodeData; Error: TUnicodeDataError; const Details: WideString);
procedure UDUI_UpdateStatus(const Msg: WideString; Pos, Max: Integer);
function UDUI_StartRebuild(Callback: TNotifyEvent; AskFirst: Boolean): Boolean;
function UDUI_ShouldStartRebuildOnError(const Msg: WideString): Boolean;
end;
TUnicodeData = class
private
FBlocks: TUnicodeBlockList;
FUnicodeSourcePath: WideString;
FRefs: Integer;
FDatabase: ADODB_TLB.Connection; // DaoDatabase;
FDisabled: Boolean;
FRebuilt: Boolean;
FUnicodeDataUIManager: IUnicodeDataUIManager;
FADBPath: string;
FFontRanges: TTTCMapTable;
FFontName: WideString;
FForceDBPathToAppDataOnBuild: Boolean; // I2845
procedure DoError(ErrorCode: TUnicodeDataError; const Details: WideString = '');
function ShouldBuildDatabase: Boolean;
procedure CallbackBuildDatabase(Sender: TObject);
procedure ImportBlocks;
procedure ImportChars;
procedure LoadBlocks;
function IsHangulCode(code: Integer; var ch: TUnicodeCharacter): Boolean;
function IsCJKCode(code: Integer; var ch: TUnicodeCharacter): Boolean;
function IsHangulName(aname: string; var ch: TUnicodeCharacter): Boolean;
function IsCJKName(aname: string; var ch: TUnicodeCharacter): Boolean;
procedure LoadDatabase;
procedure CloseDatabase;
function IsSpecialChar(ch: Integer): Boolean;
procedure CleanupFilter(var filter: WideString; FBlock: Boolean);
function UpdateBlockAndGetID(ch: Integer): Integer;
procedure ImportUniHan;
procedure BuildFontCharTable(const AFontName: WideString);
procedure SetFontName(const Value: WideString);
procedure SetDBPathToAppData;
public
constructor Create(const SourcePath: WideString; AUnicodeDataUIManager: IUnicodeDataUIManager; const ADBPath: string = ''; AForceDBPathToAppDataOnBuild: Boolean = True); // I2845
destructor Destroy; override;
function DBPath: string;
procedure BuildDatabase(const ASourcePath: WideString = '');
function FindDataByCode(code: Integer): TUnicodeCharacter;
function FindDataByName(aname: WideString): TUnicodeCharacter;
function GetSearchBlocks(filter: WideString): TUnicodeBlockList;
procedure RefreshOptions;
property Rebuilt: Boolean read FRebuilt;
property Blocks: TUnicodeBlockList read FBlocks;
property FontName: WideString read FFontName write SetFontName;
property UnicodeDataUIManager: IUnicodeDataUIManager read FUnicodeDataUIManager;
end;
TUnicodeDataFormat = class
{
class function GeneralCategory(GC: string): string;
class function CanonicalCombiningClass(CCC: Integer): string;
class function BidirectionalCategory(BC: string): string;
class function CharacterDecompositionMapping(CDM: string): string;
class function DecimalDigitValue(DDV: Integer): string;
class function DigitValue(DV: Integer): string;
class function NumericValue(NV: string): string;
class function Mirrored(M: Boolean): string;
class function Unicode10Name(U1N: string): string;
class function _10646Comment(_1C: string): string;
class function UpperCaseMapping(UCM: Integer): string;
class function LowerCaseMapping(LCM: Integer): string;
class function TitleCaseMapping(LCM: Integer): string;
}
class function CleanCharacterName(nm: AnsiString): AnsiString; // I3310
end;
const
SKRebuildDatabase = 'Keyman Developer has a Unicode character database, for use in the Character Map, '+
'that needs to be built. This may take up to a minute to complete.'#13#10#13#10+
'Do you want to do this now?';
var
FUnicodeData: TUnicodeData = nil;
procedure CreateUnicodeData(const SourcePath: WideString; AUnicodeDataUIManager: IUnicodeDataUIManager; const ADBPath: string = '');
procedure FreeUnicodeData;
function GetUnicodeRangeFromFilter(filter: WideString; var RangeStart, RangeStop: Integer): Boolean;
const
UnicodeDataTxtName = 'UnicodeData.txt';
UnicodeDataMdbName = 'unicodedata.mdb';
implementation
uses
System.AnsiStrings,
System.StrUtils,
System.Variants,
Winapi.ShlObj,
RegistryKeys,
Unicode,
utilstr,
utilsystem;
var
_: Variant;
procedure CreateUnicodeData(const SourcePath: WideString; AUnicodeDataUIManager: IUnicodeDataUIManager; const ADBPath: string = '');
begin
if not Assigned(FUnicodeData) then FUnicodeData := TUnicodeData.Create(SourcePath, AUnicodeDataUIManager, ADBPath);
Inc(FUnicodeData.FRefs);
end;
procedure FreeUnicodeData;
begin
if not Assigned(FUnicodeData) then Exit;
Dec(FUnicodeData.FRefs);
if FUnicodeData.FRefs = 0 then FreeAndNil(FUnicodeData);
end;
function StrTok(var str: ansistring; const tok: AnsiChar; var val: ansistring): Boolean; // I3310
var
n: Integer;
begin
if str = '' then
Result := False
else
begin
Result := True;
n := Pos(tok, str);
if n = 0 then
begin
val := str;
str := '';
end
else
begin
val := Copy(str, 1, n-1);
Delete(str, 1, n);
end;
end;
end;
{-------------------------------------------------------------------------------
- TUnicodeData: Read character properties from database or thru algorithm -
------------------------------------------------------------------------------}
procedure TUnicodeData.BuildDatabase(const ASourcePath: WideString = '');
var
OldSourcePath: WideString;
begin
OldSourcePath := FUnicodeSourcePath;
if ASourcePath <> '' then
FUnicodeSourcePath := ASourcePath;
if FUnicodeDataUIManager.UDUI_StartRebuild(CallbackBuildDatabase, False) then
FRebuilt := True;
if ASourcePath <> '' then
FUnicodeSourcePath := OldSourcePath;
end;
procedure ReadStreamLine(fs: TFileStream; var s: ansistring); // I3310
var
ch: array[0..100] of ansiChar;
str: shortstring;
{nCR,} iCR, iLF, n: Integer;
const
chcr: shortstring = #13;
chlf: shortstring = #10;
begin
s := '';
while fs.Position < fs.Size do
begin
n := fs.Read(ch, 100);
str := Copy(ch, 1, n);
//nCR := 0;
iCR := Pos(chcr, str); // I3310
//if iCR > 0 then
//begin
//Delete(str, iCR, 1);
//Inc(nCR);
//end;
iLF := Pos(chlf, str); // I3310
if iLF > 0 then
begin
s := s + Copy(str, 1, iLF-1);
if iCR = iLF then Inc(iLF);
fs.Seek(-(Length(str)-iLF), soFromCurrent);
s := System.AnsiStrings.AnsiReplaceText(s, #13, ''); // I3310 // I3310
Exit;
end;
s := s + str;
end;
end;
procedure TUnicodeData.CallbackBuildDatabase(Sender: TObject);
const
SQL_Create_eBlock =
'CREATE TABLE eBlock (' +
' BlockID INT IDENTITY(1,1) CONSTRAINT PrimaryKey PRIMARY KEY,' +
' StartChar INT NOT NULL,' +
' EndChar INT NOT NULL,' +
' Name VARCHAR(240) NOT NULL,' +
' CacheCharCount INT NULL,' +
' CacheCharData IMAGE NULL)';
SQL_Create_eCharacter =
'CREATE TABLE eCharacter ('+
' CharacterID INT IDENTITY(1,1) CONSTRAINT PrimaryKey PRIMARY KEY,'+
' BlockID INT NOT NULL,'+
' CodeValue INT NOT NULL,'+
' NameIsDescription BIT,'+
' CharacterName VARCHAR(240) NOT NULL,'+
{ ' GeneralCategory VARCHAR(2),'+
' CanonicalCombiningClasses INT NOT NULL,'+
' BidirectionalCategory VARCHAR(3) NOT NULL,'+
' CharacterDecompositionMapping VARCHAR(255),'+
' DecimalDigitValue INT,'+
' DigitValue INT,'+
' NumericValue VARCHAR(20),'+
' Mirrored BIT,'+
' Unicode10Name VARCHAR(240),'+
' A10646Comment VARCHAR(255),'+
' UpperCaseMapping INT,'+
' LowerCaseMapping INT,'+
' TitleCaseMapping INT,' +}
' CONSTRAINT FK_Character_Block FOREIGN KEY (BlockID) REFERENCES eBlock (BlockID))';
SQL_Create_ByCodeValue =
'CREATE UNIQUE INDEX ByCodeValue ON eCharacter (CodeValue) WITH DISALLOW NULL';
SQL_Create_ByCharacterName =
'CREATE INDEX ByCharacterName ON eCharacter (CharacterName) WITH DISALLOW NULL';
SQL_Create_qCharacterByCode =
'CREATE PROCEDURE qCharacterByCode (prmCode INT) AS SELECT * FROM eCharacter WHERE CodeValue = prmCode;';
SQL_Create_qCharacterByName =
'CREATE PROCEDURE qCharacterByName (prmName VARCHAR(240)) AS SELECT * FROM eCharacter WHERE CharacterName Like prmName;';
SQL_Create_qBlocks =
'CREATE PROCEDURE qBlocks AS SELECT * FROM eBlock ORDER BY StartChar;';
SQL_Create_qFilterCharacters =
'CREATE PROCEDURE qFilterCharacters (prmFilter VARCHAR(240)) AS '+
' SELECT CodeValue FROM eCharacter WHERE CharacterName LIKE prmFilter ORDER BY CodeValue';
SQL_Create_qFilterCharactersBlock =
'CREATE PROCEDURE qFilterCharactersBlock (prmFilter VARCHAR(240)) AS '+
' SELECT CodeValue FROM eCharacter INNER JOIN eBlock ON eCharacter.BlockID = eBlock.BlockID WHERE eBlock.Name LIKE prmFilter ORDER BY CodeValue';
SQL_Create_qFilterCharactersRange =
'CREATE PROCEDURE qFilterCharactersRange (prmStart INT, prmStop INT) AS '+
' SELECT CodeValue FROM eCharacter WHERE (CodeValue >= prmStart AND CodeValue <= prmStop) ORDER BY CodeValue';
SQL_Create_qFilterCharactersSingle =
'CREATE PROCEDURE qFilterCharactersSingle (prmCode INT) AS '+
' SELECT CodeValue FROM eCharacter WHERE CodeValue = prmCode';
// Language table // I4257
SQL_Create_eLanguage =
'CREATE TABLE eLanguage ( '+
' LanguageCode CHAR(3) NOT NULL CONSTRAINT LanguagePrimaryKey PRIMARY KEY, ' +
' Name VARCHAR(128) NOT NULL, ' +
' Country CHAR(2) NOT NULL, '+
' Status CHAR NOT NULL)';
SQL_Create_LanguageByCodeValue =
'CREATE UNIQUE INDEX LanguageByCodeValue ON eLanguage (LanguageCode) WITH DISALLOW NULL';
SQL_Create_LanguageByName =
'CREATE INDEX LanguageByName ON eLanguage (Name) WITH DISALLOW NULL';
SQL_Create_qLanguageByCode =
'CREATE PROCEDURE qLanguageByCode (prmCode CHAR(3)) AS SELECT * FROM eLanguage WHERE LanguageCode = prmCode;';
SQL_Create_qLanguagesByName =
'CREATE PROCEDURE qLanguagesByName (prmName VARCHAR(128)) AS SELECT * FROM eLanguage WHERE Name Like prmName;';
var
//s: string;
//val: array[0..14] of string;
//i: Integer;
vRecords: OleVariant;
FCatalog: ADOX_TLB.Catalog;
begin
CloseDatabase;
if FForceDBPathToAppDataOnBuild then SetDBPathToAppData; // I2476, I2299, I2845
if FileExists(DBPath+UnicodeDataMdbName) then
if not System.SysUtils.DeleteFile(DBPath+UnicodeDataMdbName) then
begin
DoError(udeCouldNotDeleteDatabaseForRebuild);
//WideShowMessage('Could not delete database '''+DBPath+UnicodeDataMdbName+''': '+SysErrorMessage(GetLastError));
Exit;
end;
{ Create the database }
FUnicodeDataUIManager.UDUI_UpdateStatus('Creating database', 0, 0);
try
FCatalog := CoCatalog.Create;
FCatalog.Create('Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DBPath+UnicodeDataMdbName);
FCatalog := nil;
FDatabase := CoConnection.Create;
{$R-} {$WARNINGS OFF} // Constant expr violates subrange bounds for adConnectUnspecified
FDatabase.Open('Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DBPath+UnicodeDataMdbName, '', '', adConnectUnspecified);
{$R+} {$WARNINGS ON} // Constant expr violates subrange bounds for adConnectUnspecified
FDatabase.Execute(SQL_Create_eBlock, vRecords, adExecuteNoRecords);
FDatabase.Execute(SQL_Create_eCharacter, vRecords, adExecuteNoRecords);
FDatabase.Execute(SQL_Create_ByCodeValue, vRecords, adExecuteNoRecords);
FDatabase.Execute(SQL_Create_ByCharacterName, vRecords, adExecuteNoRecords);
FDatabase.Execute(SQL_Create_qCharacterByCode, vRecords, adExecuteNoRecords);
FDatabase.Execute(SQL_Create_qCharacterByName, vRecords, adExecuteNoRecords);
FDatabase.Execute(SQL_Create_qBlocks, vRecords, adExecuteNoRecords);
FDatabase.Execute(SQL_Create_qFilterCharacters, vRecords, adExecuteNoRecords);
FDatabase.Execute(SQL_Create_qFilterCharactersBlock, vRecords, adExecuteNoRecords);
FDatabase.Execute(SQL_Create_qFilterCharactersRange, vRecords, adExecuteNoRecords);
FDatabase.Execute(SQL_Create_qFilterCharactersSingle, vRecords, adExecuteNoRecords);
FDatabase.Execute(SQL_Create_eLanguage, vRecords, adExecuteNoRecords); // I4257
FDatabase.Execute(SQL_Create_LanguageByCodeValue, vRecords, adExecuteNoRecords); // I4257
FDatabase.Execute(SQL_Create_LanguageByName, vRecords, adExecuteNoRecords); // I4257
FDatabase.Execute(SQL_Create_qLanguageByCode, vRecords, adExecuteNoRecords); // I4257
FDatabase.Execute(SQL_Create_qLanguagesByName, vRecords, adExecuteNoRecords); // I4257
except
on E:Exception do
begin
try
FDatabase.Close;
except
;
end;
FDatabase := nil;
System.SysUtils.DeleteFile(DBPath+UnicodeDataMdbName);
DoError(udeCouldNotCreateDatabase);
FDisabled := True;
Exit;
end;
end;
FUnicodeDataUIManager.UDUI_UpdateStatus('Filling database', 0, 0);
{ Fill the database }
//oldpos := 0;
try
ImportBlocks;
ImportChars;
ImportUnihan;
except
on E:Exception do
begin
DoError(udeCouldNotCreateDatabase, E.Message);
FDisabled := True;
end;
end;
end;
procedure TUnicodeData.SetFontName(const Value: WideString);
begin
FFontName := Value;
BuildFontCharTable(FFontName);
end;
function TUnicodeData.ShouldBuildDatabase: Boolean;
var
txtdate, datdate: TDateTime;
begin
Result := False;
if not FileAge(FUnicodeSourcePath+UnicodeDataTxtName, txtdate) then Exit; // UnicodeData.txt does not exist
if FileAge(DBPath+UnicodeDataMdbName, datdate) then
if datdate >= txtdate then Exit;
Result := True; // The txt file is newer than the dat file, or the dat file does not exist
end;
constructor TUnicodeData.Create(const SourcePath: WideString; AUnicodeDataUIManager: IUnicodeDataUIManager; const ADBPath: string = ''; AForceDBPathToAppDataOnBuild: Boolean = True); // I2845
begin
inherited Create;
FADBPath := ADBPath;
FForceDBPathToAppDataOnBuild := AForceDBPathToAppDataOnBuild; // I2845
FUnicodeDataUIManager := AUnicodeDataUIManager;
FUnicodeSourcePath := IncludeTrailingPathDelimiter(SourcePath);
FBlocks := TUnicodeBlockList.Create;
//if not CanUseDatabases then Exit;
RefreshOptions;
end;
procedure TUnicodeData.ImportBlocks;
var
fs: TFileStream;
s: ansistring;
range, rname: ansistring;
FUnicodeSourceFile: string;
//ur: TUnicodeBlock;
n: Integer;
eblock: ADODB_TLB.Recordset;
begin
FUnicodeSourceFile := FUnicodeSourcePath + 'blocks.txt';
fs := TFileStream.Create(FUnicodeSourceFile, fmOpenRead); //DBPath+UnicodeDataTxtName, fmOpenRead);
with fs do
try
eblock := CoRecordset.Create;
eblock.Open('eBlock', FDatabase, adOpenForwardOnly, adLockOptimistic, adCmdTable);// Execute('eCharacter', vRecords, adCmdTable);
try
while Position < Size do
begin
ReadStreamLine(fs, s);
n := System.AnsiStrings.PosEx('#', s); // I3310 // I3310
if n > 0 then Delete(s,n,Length(s));
if System.AnsiStrings.Trim(s) = '' then Continue; // I3310 // I3310
if not StrTok(s, ';', range) then Continue;
if not StrTok(s, ';', rname) then Continue;
range := System.AnsiStrings.Trim(range); // I3310 // I3310
rname := System.AnsiStrings.Trim(rname); // I3310 // I3310
n := System.AnsiStrings.PosEx('..', range); if n = 0 then Continue; // I3310 // I3310
eblock.AddNew(_, _);
eblock.Collect['StartChar'] := StrToInt(String_AtoU('$'+Copy(range,1,n-1))); // I3310 // I3310
eblock.Collect['EndChar'] := StrToInt(String_AtoU('$'+Copy(range,n+2,Length(range)))); // I3310 // I3310
eblock.Collect['Name'] := String_AtoU(rname); // I3310 // I3310
eblock.Update(_, _);
end;
finally
eblock := nil;
end;
finally
fs.Free;
end;
LoadBlocks;
end;
function TUnicodeData.IsSpecialChar(ch: Integer): Boolean;
begin
Result :=
({(ch >= $0000) and} (ch <= $001F)) or // Controls 15.1
((ch >= $0080) and (ch <= $009F)) or // Controls 15.1
((ch >= $D800) and (ch <= $DFFF)) or // Surrogates 15.5
((ch >= $FE00) and (ch <= $FE0F)) or // Variation selectors 15.x
((ch >= $E0100) and (ch <= $E01EF)) or // Variation selectors 15.x
(((ch and $FFFF) = $FFFE) or ((ch and $FFFF) = $FFFF)) or // Non-characters U+[??]FFFE/FFFF 15.8
((ch >= $FDD0) and (ch <= $FDEE)) or // non-characters within Arabic Presentations Forms A block 15.8
((ch >= $FFF0) and (ch <= $FFFF)) or // Specials 15.9
(ch = $FEFF) or // BOM reversed 15.9
((ch >= $E0000) and (ch <= $E007F)); // TAG characters 15.10
end;
function TUnicodeData.UpdateBlockAndGetID(ch: Integer): Integer;
var
i: Integer;
begin
for i := 0 to FBlocks.Count - 1 do
if (FBlocks[i].StartChar <= ch) and (ch <= FBlocks[i].EndChar) then
begin
Result := FBlocks[i].BlockID;
if (FBlocks[i].FCacheCharCount mod 1000) = 0 then
begin
ReallocMem(FBlocks[i].FCacheCharData, (FBlocks[i].FCacheCharCount + 1000) * SizeOf(Integer));
end;
//SetLength(FBlocks[i].FCacheCharData, FBlocks[i].FCacheCharCount + 1000);
Inc(FBlocks[i].FCacheCharCount);
FBlocks[i].FCacheCharData[FBlocks[i].CacheCharCount-1] := ch;
Exit;
end;
Result := 0;
end;
procedure TUnicodeData.ImportChars;
var
fs: TFileStream;
echar, eblocks: ADODB_TLB.RecordSet;
s: ansistring;
val: array[0..14] of ansistring;
oldpos, ch, i: Integer;
b: Variant;
p: PByte;
begin
fs := TFileStream.Create(FUnicodeSourcePath + 'unicodedata.txt', fmOpenRead); //DBPath+UnicodeDataTxtName, fmOpenRead);
with fs do
try
{ Import the charaters }
oldpos := 0;
echar := CoRecordset.Create;
echar.Open('eCharacter', FDatabase, adOpenForwardOnly, adLockOptimistic, adCmdTable);// Execute('eCharacter', vRecords, adCmdTable);
try
while Position < Size do
begin
ReadStreamLine(fs, s);
for i := 0 to 14 do
StrTok(s, ';', val[i]);
if Copy(val[1], 1, 1) = '<' then Continue; // not a code point, control or similar
ch := StrToInt(String_AtoU('$'+val[0])); // I3310 // I3310
if IsSpecialChar(ch) then Continue;
echar.AddNew(_, _);
echar.Collect['CodeValue'] := ch;
echar.Collect['BlockID'] := UpdateBlockAndGetID(ch);
echar.Collect['CharacterName'] := String_AtoU(TUnicodeDataFormat.CleanCharacterName(Copy(val[1], 1, 240))); // I3310 // I3310
echar.Collect['NameIsDescription'] := False;
{
echar.Collect['GeneralCategory'] := Copy(val[2], 1, 2);
echar.Collect['CanonicalCombiningClasses'] := StrToInt(val[3]);
echar.Collect['BidirectionalCategory'] := Copy(val[4], 1, 3);
if val[5] <> '' then echar.Collect['CharacterDecompositionMapping'] := Copy(val[5], 1, 255);
if val[6] <> '' then echar.Collect['DecimalDigitValue'] := StrToInt(val[6]);
if val[7] <> '' then echar.Collect['DigitValue'] := StrToInt(val[7]);
if val[8] <> '' then echar.Collect['NumericValue'] := Copy(val[8], 1, 20);
if val[9] = '' then val[9] := 'N';
echar.Collect['Mirrored'] := UpCase(val[9][1]) = 'Y';
if val[10] <> '' then echar.Collect['Unicode10Name'] := Copy(val[10], 1, 240);
if val[11] <> '' then echar.Collect['A10646Comment'] := Copy(val[11], 1, 255);
if val[12] <> '' then echar.Collect['UpperCaseMapping'] := StrToInt('$'+val[12]);
if val[13] <> '' then echar.Collect['LowerCaseMapping'] := StrToInt('$'+val[13]);
if val[14] <> '' then echar.Collect['TitleCaseMapping'] := StrToInt('$'+val[14]);
}
echar.Update(_, _);
if Position - oldpos > Size div 200 then
begin
FUnicodeDataUIManager.UDUI_UpdateStatus('Filling database (U+'+String_AtoU(val[0])+')', Position, Size); // I3310 // I3310
oldpos := Position;
end;
end;
finally
echar := nil;
end;
{ Save the block cache data }
eblocks := CoRecordset.Create;
eblocks.Open('eBlock', FDatabase, adOpenForwardOnly, adLockOptimistic, adCmdTable);
try
while not eblocks.EOF do
begin
for i := 0 to FBlocks.Count - 1 do
if FBlocks[i].BlockID = eblocks.Collect['BlockID'] then
begin
eblocks.Collect['CacheCharCount'] := FBlocks[i].CacheCharCount;
{aADOStream := CoStream.Create;
aADOStream.Type_ := adTypeBinary;
aADOStream.Open(EmptyParam, adModeUnknown, adOpenStreamUnspecified, '', '');}
b := VarArrayCreate([0,(FBlocks[i].CacheCharCount)*SizeOf(Integer)-1], varByte);
p := PByte(VarArrayLock(b));
CopyMemory(p, FBlocks[i].CacheCharData, (FBlocks[i].CacheCharCount)*SizeOf(Integer));
VarArrayUnlock(b);
eblocks.Fields['CacheCharData'].AppendChunk(b);// AppendChunk(b);
//eblocks.Collect['CacheCharData'] := IntArrayToStr(FBlocks[i].CacheCharData);
Break;
end;
eblocks.MoveNext;
end;
finally
eblocks := nil;
end;
finally
fs.Free;
end;
end;
procedure TUnicodeData.ImportUniHan;
var
fs: TFileStream;
echar, eblocks: ADODB_TLB.RecordSet;
t, s: ansistring;
val: array[0..14] of ansistring;
oldpos, ch, i: Integer;
curch: Integer;
ft, fdesc: WideString;
fch: WideChar;
fdefinition: WideString;
b: Variant;
p: PByte;
begin
curch := 0;
if not FileExists(FUnicodeSourcePath + 'unihan.txt') then Exit; { Unihan is optional }
fs := TFileStream.Create(FUnicodeSourcePath + 'unihan.txt', fmOpenRead); //DBPath+UnicodeDataTxtName, fmOpenRead);
with fs do
try
{ Import the charaters }
oldpos := 0;
echar := CoRecordset.Create;
echar.Open('eCharacter', FDatabase, adOpenForwardOnly, adLockOptimistic, adCmdTable);// Execute('eCharacter', vRecords, adCmdTable);
try
while Position < Size do
begin
ReadStreamLine(fs, s);
if (Copy(s,1,1) = '#') or (s = '') then Continue;
t := s;
for i := 0 to 2 do
StrTok(s, #9, val[i]);
if Copy(val[0],1,2) <> 'U+' then
begin
writeln('Invalid Line: '+t);
ExitCode := 3;
Exit;
end;
{ File format is UTF-8 }
Delete(val[0], 1, 2);
ch := StrToInt('$'+String_AtoU(val[0])); // I3310 // I3310
if curch <> ch then
begin
if curch <> 0 then
begin
if ft <> ''
then fdesc := ft + '; ' + fdefinition
else fdesc := fdefinition;
if Length(fdesc) > 237
then echar.Collect['CharacterName'] := Copy(fdesc,1,237)+'...'
else echar.Collect['CharacterName'] := fdesc;
try
echar.Update(_, _);
except
on E:Exception do
begin
echar.CancelUpdate;
writeln('Error adding U+'+IntToHex(curch,4)+': '+E.Message);
end;
end;
end;
echar.AddNew(_, _);
echar.Collect['CodeValue'] := ch;
echar.Collect['BlockID'] := UpdateBlockAndGetID(ch);
echar.Collect['NameIsDescription'] := True; { Disables the drag and drop of character name }
curch := ch;
fdefinition := ''; fdesc := ''; ft := '';
end;
fch := #0;
if val[1] = 'kCantonese' then fch := 'C'
else if val[1] = 'kDefinition' then
fdefinition := UTF8ToString(val[2]) // I3310
else if val[1] = 'kHangul' then
fch := 'H'
else if val[1] = 'kJapaneseKun' then
fch := 'J'
else if val[1] = 'kKorean' then
fch := 'K'
else if val[1] = 'kMandarin' then
fch := 'M'
else if val[1] = 'kVietnamese' then
fch := 'V';
if fch <> #0 then
begin
if ft <> '' then ft := ft + ' ';
ft := ft + fch + ':'+UTF8ToString(val[2]); // I3310
end;
if Position - oldpos > Size div 1000 then
begin
FUnicodeDataUIManager.UDUI_UpdateStatus('Filling database from Unihan (U+'+String_AtoU(val[0])+')', Position, Size); // I3310 // I3310
oldpos := Position;
end;
end;
finally
echar := nil;
end;
{ Save the block cache data }
eblocks := CoRecordset.Create;
eblocks.Open('eBlock', FDatabase, adOpenForwardOnly, adLockOptimistic, adCmdTable);
try
while not eblocks.EOF do
begin
for i := 0 to FBlocks.Count - 1 do
if FBlocks[i].BlockID = eblocks.Collect['BlockID'] then
begin
eblocks.Collect['CacheCharCount'] := FBlocks[i].CacheCharCount;
b := VarArrayCreate([0,(FBlocks[i].CacheCharCount)*SizeOf(Integer)-1], varByte);
p := PByte(VarArrayLock(b));
CopyMemory(p, @FBlocks[i].CacheCharData, (FBlocks[i].CacheCharCount)*SizeOf(Integer));
VarArrayUnlock(b);
eblocks.Fields['CacheCharData'].AppendChunk(b);// AppendChunk(b);
//eblocks.Collect['CacheCharData'] := IntArrayToStr(FBlocks[i].CacheCharData);
Break;
end;
eblocks.MoveNext;
end;
finally
eblocks := nil;
end;
finally
fs.Free;
end;
end;
(*
function TUnicodeData.IntArrayToStr(v: TIntegerArray): Variant;
var
i: Integer;
s: string;
begin
s := '';
for i := 0 to High(v) do
begin
s := s + IntToHex(v[i], 8);
end;
Result := s;
{ TVarData(Result).VType := varInteger;
TVarData(Result).VAny
Result := VarArrayCreate([Low(v)+1, High(v)+1], varInteger);
for i := Low(v) to High(v) do
Result[i+1] := v[i];}
end;
function TUnicodeData.VarStrToIntArray(v: Variant): TIntegerArray;
var
i: Integer;
s: string;
begin
s := v;
SetLength(Result, Length(s) div 8);
for i := 0 to (Length(s) div 8) - 1 do
begin
Result[i] := StrToInt('$'+Copy(s,i*8+1,8));
end;
{ SetLength(Result, VarArrayHighBound(v, 1) - VarArrayLowBound(v, 1) + 1);
for i := Low(Result) to High(Result) do
Result[i] := v[i+1];}
end;
*)
procedure TUnicodeData.LoadBlocks;
var
rec: ADODB_TLB.Recordset;
vRecords: OleVariant;
ub: TUnicodeBlock;
b: OleVariant;
p: PByte;
begin
if not Assigned(FDatabase) then Exit;
FBlocks.Clear;
rec := FDatabase.Execute('qBlocks', vRecords, adCmdStoredProc);
try
while not rec.EOF do
begin
ub := TUnicodeBlock.Create;
ub.FBlockID := rec.Collect['BlockID'];
ub.FName := rec.Collect['Name'];
ub.FShortName := ub.FName;
ub.FStartChar := rec.Collect['StartChar'];
ub.FEndChar := rec.Collect['EndChar'];
if not VarIsNull(rec.Collect['CacheCharCount']) then
begin
ub.FCacheCharCount := rec.Collect['CacheCharCount'];
if ub.FCacheCharCount > 0 then
begin
b := rec.Fields['CacheCharData'].GetChunk(ub.FCacheCharCount*SizeOf(Integer));
p := PByte(VarArrayLock(b));
ub.FCacheCharData := AllocMem(ub.CacheCharCount * SizeOf(Integer));
//SetLength(ub.FCacheCharData, ub.FCacheCharCount);
CopyMemory(ub.FCacheCharData, p, ub.FCacheCharCount*SizeOf(Integer));
VarArrayUnlock(b);
end
else
ub.FCacheCharData := nil;
//SetLength(ub.FCacheCharData, 0);
//ub.FCacheCharData := VarStrToIntArray(rec.Collect['CacheCharData']);
//SetLength(ub.CacheCharData, ub.CacheCharCount);
end;
FBlocks.Add(ub);
rec.MoveNext;
end;
finally
rec := nil;
end;
end;
procedure TUnicodeData.LoadDatabase;
begin
CloseDatabase;
if ShouldBuildDatabase then
begin
UnicodeDataUIManager.UDUI_StartRebuild(CallbackBuildDatabase, True);
Exit;
end;
if FileExists(DBPath+UnicodeDataMdbName) then
begin
try
FDatabase := CoConnection.Create;
{$R-} {$WARNINGS OFF} // Constant expr violates subrange bounds for adConnectUnspecified
FDatabase.Open('Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DBPath+UnicodeDataMdbName, '', '', adConnectUnspecified);
{$R+} {$WARNINGS ON} // Constant expr violates subrange bounds for adConnectUnspecified
//FDatabase := dbEngine.OpenDatabase(DBPath+UnicodeDataMdbName, _, False, _);
LoadBlocks;
except
on E:Exception do
begin
FDatabase := nil;
FBlocks.Clear;
if FUnicodeDataUIManager.UDUI_ShouldStartRebuildOnError(E.Message) then
BuildDatabase;
end;
end;
end;
end;
procedure TUnicodeData.RefreshOptions;
begin
{with TKeymanDeveloperOptions.Create do
try
Read;
FDisabled := CharMapDisableDatabaseLookups;
finally
Free;
end;}
FDisabled := False;
if FDisabled
then CloseDatabase
else LoadDatabase;
end;
procedure TUnicodeData.CloseDatabase;
begin
if Assigned(FDatabase) then FDatabase.Close;
FDatabase := nil;
end;
destructor TUnicodeData.Destroy;
begin
try
CloseDatabase;
except
;
end;
FBlocks.Free;
FFontRanges.Free;
inherited Destroy;
end;
procedure TUnicodeData.DoError(ErrorCode: TUnicodeDataError; const Details: WideString = '');
begin
FUnicodeDataUIManager.UDUI_Error(Self, ErrorCode, Details);
end;
procedure TUnicodeData.SetDBPathToAppData; // I2476, I2299
begin
FADBPath := GetFolderPath(CSIDL_APPDATA) + SFolderSharedDatabases + '\';
ForceDirectories(FADBPath);
end;
function TUnicodeData.DBPath: string;
var
FAppDataPath: string;
begin
FAppDataPath := GetFolderPath(CSIDL_APPDATA) + SFolderSharedDatabases + '\'; // I2476, I2299
if FADBPath <> '' then
Result := FADBPath
else if FileExists(FAppDataPath+UnicodeDataMdbName) then // I2476, I2299
Result := FAppDataPath
else if FileExists(FUnicodeSourcePath+UnicodeDataMdbName) then
Result := FUnicodeSourcePath
else
begin
Result := GetFolderPath(CSIDL_APPDATA) + SFolderSharedDatabases + '\';
ForceDirectories(Result);
end;
end;
function FillData(rec: ADODB_TLB.Recordset): TUnicodeCharacter; //rec: DaoRecordset): TUnicodeCharacter;
begin
Result.CodeValue := rec.Collect['CodeValue'];
Result.CharacterName := rec.Collect['CharacterName'];
{
Result.GeneralCategory := rec.Collect['GeneralCategory'];
Result.CanonicalCombiningClasses := rec.Collect['CanonicalCombiningClasses'];
Result.BidirectionalCategory := rec.Collect['BidirectionalCategory'];
if not VarIsNull(rec.Collect['CharacterDecompositionMapping'])
then Result.CharacterDecompositionMapping := rec.Collect['CharacterDecompositionMapping']
else Result.CharacterDecompositionMapping := '';
if not VarIsNull(rec.Collect['DecimalDigitValue'])
then Result.DecimalDigitValue := rec.Collect['DecimalDigitValue']
else Result.DecimalDigitValue := -1;
if not VarIsNull(rec.Collect['DigitValue'])
then Result.DigitValue := rec.Collect['DigitValue']
else Result.DigitValue := -1;
if not VarIsNull(rec.Collect['NumericValue'])
then Result.NumericValue := rec.Collect['NumericValue']
else Result.NumericValue := '';
Result.Mirrored := rec.Collect['Mirrored'];
if not VarIsNull(rec.Collect['Unicode10Name'])
then Result.Unicode10Name := rec.Collect['Unicode10Name']
else Result.Unicode10Name := '';
if not VarIsNull(rec.Collect['A10646Comment'])
then Result._10646Comment := rec.Collect['A10646Comment']
else Result._10646Comment := '';
if not VarIsNull(rec.Collect['UpperCaseMapping'])
then Result.UpperCaseMapping := rec.Collect['UpperCaseMapping']
else Result.UpperCaseMapping := 0;
if not VarIsNull(rec.Collect['LowerCaseMapping'])
then Result.LowerCaseMapping := rec.Collect['LowerCaseMapping']
else Result.LowerCaseMapping := 0;
if not VarIsNull(rec.Collect['TitleCaseMapping'])
then Result.TitleCaseMapping := rec.Collect['TitleCaseMapping']
else Result.TitleCaseMapping := 0;
}
end;
function TUnicodeData.FindDataByCode(code: Integer): TUnicodeCharacter;
var
//rec: DaoRecordset;
rec: ADODB_TLB.Recordset;
vRecords: OleVariant;
begin
Result.CodeValue := 0;
if FDisabled then Exit;
if IsHangulCode(code, Result) then Exit;
if not Assigned(FDatabase) then Exit;
rec := FDatabase.Execute('EXECUTE qCharacterByCode '+IntToStr(code), vRecords, adCmdText);
try
if not rec.EOF then
Result := FillData(rec)
else
if IsCJKCode(code, Result) then Exit
else
begin
Result.CodeValue := code;
Result.CharacterName := '';
end;
finally
rec := nil;
end;
end;
function TUnicodeData.FindDataByName(aname: WideString): TUnicodeCharacter;
var
rec: ADODB_TLB.Recordset;
vRecords: OleVariant;
begin
Result.CodeValue := 0;
CleanupFilter(aname, False);
if FDisabled then Exit;
if IsHangulName(aname, Result) then Exit;
if IsCJKName(aname, Result) then Exit;
if not Assigned(FDatabase) then Exit;
rec := FDatabase.Execute('qCharacterByName '+QuotedStr(aname+'%'), vRecords, adCmdStoredProc); // I3310 // I3465
try
if not rec.EOF then
Result := FillData(rec);
finally
rec := nil;
end;
end;
procedure TUnicodeData.CleanupFilter(var filter: WideString; FBlock: Boolean);
var
I: Integer;
begin
{ Replace *, # and ? with appropriate search characters }
I := 1;
while I <= length(filter) do
begin
if filter[i] = '*' then filter[i] := '%'
else if (filter[i] = '_') then
begin
if FBlock then
filter[I] := ' '
else
begin
filter[I] := '[';
Insert('_]', filter, I+1);
Inc(I, 2);
end;
end
else if (filter[i] = ' ') then
begin
if not FBlock then filter[i] := '%'
end
else if (filter[i] = '#') or (filter[i] = '?') then filter[i] := '_';
Inc(I);
end;
{ Detect end-of-line delimiter }
I := Pos('$', filter);
if I > 0
then Delete(filter, I, Length(filter))
else filter := filter + '%';
{ Detect beginning-of-line delimiter }
if Copy(filter, 1, 1) = '^'
then Delete(filter, 1, 1)
else filter := '%' + filter;
end;
function GetUnicodeRangeFromFilter(filter: WideString; var RangeStart, RangeStop: Integer): Boolean; // I2210
function UnicodeCharToValue(v: WideString): Integer;
begin
if Copy(v, 1, 2) = 'U+' then Result := StrToIntDef('$'+Copy(v,3,10), 0)
else if Length(v) < 2 then Result := 0
else Result := StrToIntDef('$'+v, 0);
end;
var
filterStart, filterStop: WideString;
n: Integer;
FRange: Boolean;
begin
filter := Trim(UpperCase(filter));
n := Pos('-', filter);
if n > 0 then
begin
//[U+]xxxx-[U+]yyyy
filterStart := Trim(Copy(filter, 1, n-1));
filterStop := Trim(Copy(filter, n+1, Length(filter)));
FRange := True;
end
else
begin
//[U+]xxxx
filterStart := filter;
filterStop := filter;
FRange := False;
end;
RangeStart := UnicodeCharToValue(filterStart);
RangeStop := UnicodeCharToValue(filterStop);
if FRange and (RangeStop > 0) and (filterStart = '') then RangeStart := $20
else if FRange and (filterStop = '') and (RangeStart > 0) then RangeStop := $10FFFF;
Result := (RangeStart > 0);
end;
function TUnicodeData.GetSearchBlocks(filter: WideString): TUnicodeBlockList;
var
//rec: DaoRecordset;
rec: ADODB_TLB.Recordset;
vRecords: OleVariant;
cmd: WideString;
FontCmapIndex, RangeStart, RangeStop: Integer;
FCurrentFont, FRange, FBlock: Boolean;
origfilter: WideString;
CodeValue: Integer;
ub: TUnicodeBlock;
nBlock: Integer;
begin
Result := nil;
if FDisabled then Exit;
if not Assigned(FDatabase) then Exit;
filter := Trim(filter);
FBlock := False;
FRange := False;
FCurrentFont := False;
RangeStart := 0;
RangeStop := 0;
ub := nil;
if Copy(Filter, 1, 1) = '>' then
begin
Delete(filter, 1, 1);
FCurrentFont := Assigned(FFontRanges);
if FCurrentFont and (filter = '') then
begin
{ All characters from current font - no database search required }
Result := TUnicodeBlockList.Create;
Result.FName := FFontName+', all characters';
Result.FShortName := '>';
FontCmapIndex := 0;
if FontCmapIndex >= FFontRanges.Count then Exit;
nBlock := 0;
while FontCmapIndex < FFontRanges.Count do
begin
for CodeValue := FFontRanges.Item[FontCmapIndex].StartCode to FFontRanges.Item[FontCmapIndex].EndCode do
begin
if not Assigned(ub) or (ub.EndChar < CodeValue) then
begin
while (nBlock < FBlocks.Count) and (FBlocks[nBlock].EndChar < CodeValue) do Inc(nBlock);
if nBlock = FBlocks.Count then Break;
ub := TUnicodeBlock.Create;
ub.FName := FBlocks[nBlock].Name;
ub.FShortName := FBlocks[nBlock].ShortName;
ub.FBlockID := FBlocks[nBlock].BlockID;
ub.FEndChar := FBlocks[nBlock].EndChar;
ub.FStartChar := FBlocks[nBlock].StartChar;
ub.FCacheCharCount := 0;
Result.Add(ub);
end;
if (ub.FCacheCharCount mod 100) = 0 then
begin
ReallocMem(ub.FCacheCharData, (ub.FCacheCharCount+100) * SizeOf(Integer));
end;
ub.FCacheCharData[ub.FCacheCharCount] := CodeValue;
Inc(ub.FCacheCharCount);
end;
Inc(FontCmapIndex);
end;
Exit;
end;
end;
if GetUnicodeRangeFromFilter(filter, RangeStart, RangeStop) then
begin
FRange := True;
if RangeStart = 0 then origfilter := '(invalid range)'
else
begin
origfilter := 'U+'+IntToHex(RangeStart, 4);
if RangeStop <> 0 then origfilter := origfilter+' - U+'+IntToHex(RangeStop,4);
end;
end
else
begin
if Copy(filter, 1, 1) = '<' then
begin
Delete(filter,1,1);
FBlock := True;
end;
origfilter := filter;
CleanupFilter(filter, FBlock);
end;
if FBlock then
cmd := WideFormat('qFilterCharactersBlock %s', [QuotedStr(filter)]) // I3310 // I3465
else if FRange then
begin
if RangeStop = 0 then
cmd := WideFormat('qFilterCharactersRange %d, %d', [RangeStart, RangeStart])
else if RangeStart = 0 then
Exit
else
cmd := WideFormat('qFilterCharactersRange %d, %d', [RangeStart, RangeStop])
end
else
cmd := WideFormat('qFilterCharacters %s', [QuotedStr(filter)]); // I3310 // I3465
try
rec := FDatabase.Execute(cmd, vRecords, adCmdStoredProc or adAsyncFetch); // or adAsyncExecute);
except
Exit; { ignore invalid filters for now }
end;
try
Result := TUnicodeBlockList.Create;
if FBlock then Result.FName := 'Blocks matching '+origfilter
else if FRange then Result.FName := 'Unicode range '+origfilter
else Result.FName := 'Characters matching '+origfilter;
if FBlock
then Result.FShortName := '<'+origfilter
else Result.FShortName := origfilter;
if FCurrentFont then
begin
if origfilter = '' then Result.FName := FFontName+', all characters'
else if FBlock then Result.FName := FFontName+', blocks matching '+origfilter
else if FRange then Result.FName := FFontName+', unicode range '+origfilter
else Result.FName := FFontName+', characters matching '+origfilter;
Result.FShortName := '>' + Result.FShortName;
end;
FontCmapIndex := 0;
if FCurrentFont and (FontCmapIndex >= FFontRanges.Count) then Exit;
nBlock := 0;
//Result.FBlockID := 0;
//Result.FCacheCharCount := 0;
while not rec.EOF do
begin
CodeValue := rec.Collect['CodeValue'];
if FCurrentFont then
begin
{ Filter by current font }
while (CodeValue > FFontRanges.Item[FontCmapIndex].EndCode) do
begin
Inc(FontCmapIndex);
if FontCmapIndex >= FFontRanges.Count then Exit;
{ No more characters in current font, so just exit }
end;
if CodeValue < FFontRanges.Item[FontCmapIndex].StartCode then
begin
rec.MoveNext;
Continue;
end;
end;
if not Assigned(ub) or (ub.EndChar < CodeValue) then
begin
while (nBlock < FBlocks.Count) and (FBlocks[nBlock].EndChar < CodeValue) do Inc(nBlock);
if nBlock = FBlocks.Count then Break;
ub := TUnicodeBlock.Create;
ub.FName := FBlocks[nBlock].Name;
ub.FShortName := FBlocks[nBlock].ShortName;
ub.FBlockID := FBlocks[nBlock].BlockID;
ub.FEndChar := FBlocks[nBlock].EndChar;
ub.FStartChar := FBlocks[nBlock].StartChar;
ub.FCacheCharCount := 0;
Result.Add(ub);
end;
if (ub.FCacheCharCount mod 100) = 0 then
begin
ReallocMem(ub.FCacheCharData, (ub.FCacheCharCount+100) * SizeOf(Integer));
end;
ub.FCacheCharData[ub.FCacheCharCount] := CodeValue;
Inc(ub.FCacheCharCount);
rec.MoveNext;
end;
finally
rec := nil;
end;
end;
{-------------------------------------------------------------------------------
- Algorithms for finding CJK and Hangul character properties -
------------------------------------------------------------------------------}
{ CJK Unified Ideographs }
procedure FillCJK(code: Integer; var ch: TUnicodeCharacter);
begin
ch.CodeValue := code;
ch.CharacterName := 'CJK_UNIFIED_IDEOGRAPH_' + IntToHex(code, 4);
{ ch.GeneralCategory := 'Lo';
ch.CanonicalCombiningClasses := 0;
ch.BidirectionalCategory := 'L';
ch.CharacterDecompositionMapping := '';
ch.DecimalDigitValue := -1;
ch.DigitValue := -1;
ch.NumericValue := '';
ch.Mirrored := False;
ch.Unicode10Name := '';
ch._10646Comment := 'Details generated by algorithm';
ch.UpperCaseMapping := 0;
ch.LowerCaseMapping := 0;
ch.TitleCaseMapping := 0;}
end;
const
CJKUnifiedBase = $4E00;
CJKUnifiedFinal = $BFFF;
function TUnicodeData.IsCJKCode(code: Integer; var ch: TUnicodeCharacter): Boolean;
begin
Result := (code >= CJKUnifiedBase) and (code <= CJKUnifiedFinal);
if Result then FillCJK(code, ch);
end;
function TUnicodeData.IsCJKName(aname: string; var ch: TUnicodeCharacter): Boolean;
begin
Result := False;
if UpperCase(Copy(aname, 1, 22)) <> 'CJK_UNIFIED_IDEOGRAPH_' then Exit;
Delete(aname, 1, 22);
if Length(aname) <> 4 then Exit;
ch.CodeValue := StrToIntDef('$'+aname, 0);
if ch.CodeValue = 0 then Exit;
FillCJK(ch.CodeValue, ch);
Result := True;
end;
{ Hangul }
const
HangulSBase = $AC00;
HangulLBase = $1100;
HangulVBase = $1161;
HangulTBase = $11A7;
HangulLCount = 19;
HangulVCount = 21;
HangulTCount = 28;
HangulNCount = HangulVCount * HangulTCount; // 588
HangulSCount = HangulLCount * HangulNCount; // 11172
const
Hangul_JAMO_L_TABLE: array[0..HangulLCount-1] of string = (
'G', 'GG', 'N', 'D', 'DD', 'R', 'M', 'B', 'BB',
'S', 'SS', '', 'J', 'JJ', 'C', 'K', 'T', 'P', 'H');
Hangul_JAMO_V_TABLE: array[0..HangulVCount-1] of string = (
'A', 'AE', 'YA', 'YAE', 'EO', 'E', 'YEO', 'YE', 'O',
'WA', 'WAE', 'OE', 'YO', 'U', 'WEO', 'WE', 'WI',
'YU', 'EU', 'YI', 'I');
Hangul_JAMO_T_TABLE: array[0..HangulTCount-1] of string = (
'', 'G', 'GG', 'GS', 'N', 'NJ', 'NH', 'D', 'L', 'LG', 'LM',
'LB', 'LS', 'LT', 'LP', 'LH', 'M', 'B', 'BS',
'S', 'SS', 'NG', 'J', 'C', 'K', 'T', 'P', 'H');
function HangulDecompose(s: Integer): string;
var
SIndex, L, V, T: Integer;
begin
SIndex := s - HangulSBase;
if (SIndex < 0) or (SIndex >= HangulSCount) then
begin
Result := '';
Exit;
end;
L := HangulLBase + SIndex div HangulNCount;
V := HangulVBase + (SIndex mod HangulNCount) div HangulTCount;
T := HangulTBase + SIndex mod HangulTCount;
Result := IntToHex(L, 4) + ' ' + IntToHex(V, 4);
if T <> HangulTBase then Result := Result + IntToHex(T, 4);
end;
function HangulName(s: Integer): string;
var
SIndex, LIndex, VIndex, TIndex: Integer;
begin
SIndex := s - HangulSBase;
if (SIndex < 0) or (SIndex >= HangulSCount) then
begin
Result := '';
Exit;
end;
LIndex := SIndex div HangulNCount;
VIndex := (SIndex mod HangulNCount) div HangulTCount;
TIndex := SIndex mod HangulTCount;
Result := 'HANGUL_SYLLABLE_' + Hangul_JAMO_L_TABLE[LIndex]
+ Hangul_JAMO_V_TABLE[VIndex] + Hangul_JAMO_T_TABLE[TIndex];
end;
procedure FillHangul(code: Integer; var ch: TUnicodeCharacter);
begin
ch.CodeValue := code;
ch.CharacterName := HangulName(code);
{ ch.GeneralCategory := 'Lo';
ch.CanonicalCombiningClasses := 0;
ch.BidirectionalCategory := 'L';
ch.CharacterDecompositionMapping := HangulDecompose(code);
ch.DecimalDigitValue := -1;
ch.DigitValue := -1;
ch.NumericValue := '';
ch.Mirrored := False;
ch.Unicode10Name := '';
ch._10646Comment := 'Details generated by algorithm';
ch.UpperCaseMapping := 0;
ch.LowerCaseMapping := 0;
ch.TitleCaseMapping := 0;}
end;
function TUnicodeData.IsHangulCode(code: Integer; var ch: TUnicodeCharacter): Boolean;
begin
Result := (code >= HangulSBase) and (code < HangulSBase + HangulSCount);
if Result then
begin
FillHangul(code, ch);
end;
end;
function TUnicodeData.IsHangulName(aname: string; var ch: TUnicodeCharacter): Boolean;
var
code, i, LIndex, VIndex, TIndex: Integer;
L, V, T: string;
begin
Result := False;
if Copy(UpperCase(aname), 1, 16) = 'HANGUL_SYLLABLE_' then
begin
Delete(aname, 1, 16);
if Length(aname) < 1 then Exit;
{ Find initial }
L := Copy(aname, 1, 2);
if Length(L) > 1 then if L[1] <> L[2] then Delete(L,2,1); // Only doubles allowed
if Pos(L[1],'GNDRMBSJCKTPH') = 0 then
LIndex := 11
else
begin
LIndex := -1;
for i := 0 to High(Hangul_JAMO_L_TABLE) do
if Hangul_JAMO_L_TABLE[i] = L then begin LIndex := i; Break; end;
Delete(aname, 1, Length(L));
end;
if LIndex = -1 then Exit;
{ Find vowel }
V := Copy(aname, 1, 3);
if Length(V) >= 3 then if Pos(V[3], 'AEIOUWY') = 0 then Delete(V,3,1);
if Length(V) >= 2 then if Pos(V[2], 'AEIOUWY') = 0 then Delete(V,2,1);
VIndex := -1;
for i := 0 to High(Hangul_JAMO_V_TABLE) do
if Hangul_JAMO_V_TABLE[i] = V then begin VIndex := i; Break; end;
if VIndex = -1 then Exit;
Delete(aname, 1, Length(V));
{ Find final }
TIndex := -1;
T := aname;
for i := 0 to High(Hangul_JAMO_T_TABLE) do
if Hangul_JAMO_T_TABLE[i] = T then begin TIndex := i; Break; end;
if TIndex = -1 then Exit;
{ Composition }
code := (HangulSBase + (LIndex * HangulVCount + VIndex) * HangulTCount) + TIndex;
Result := True;
FillHangul(code, ch);
end;
end;
{ Font Data Filling }
procedure TUnicodeData.BuildFontCharTable(const AFontName: WideString);
begin
if AFontName = '' then
FreeAndNil(FFontRanges)
else
with TTTInfoFromFont.Create(AFontName) do
try
if not Assigned(CMapTable) then
begin
{ We need to build a new ansi character map from the current character set - get char set info from font }
FFontRanges := TTTCMapTable.Create;
//FFontRanges.BuildFromCodePage(CP_ACP);
end
else
begin
FFontRanges := TTTCMapTable.Create;
FFontRanges.Assign(CMapTable);
end;
finally
Free;
end;
end;
{-------------------------------------------------------------------------------
- TUnicodeDataFormat: Formatting functions for Unicode data -
------------------------------------------------------------------------------}
class function TUnicodeDataFormat.CleanCharacterName(nm: AnsiString): AnsiString; // I3310
var
i: Integer;
begin
for i := 1 to Length(nm) do
begin
case nm[i] of
'a'..'z': nm[i] := Upcase(nm[i]);
'A'..'Z', '0'..'9', '-', '_': ;
else nm[i] := '_';
end;
end;
Result := nm;
end;
(*class function TUnicodeDataFormat.GeneralCategory(GC: string): string;
const
GeneralCategories: array[0..30, 0..1] of string = (
('Lu', 'Letter, Uppercase'),
('Ll', 'Letter, Lowercase'),
('Lt', 'Letter, Titlecase'),
('Lm', 'Letter, Modifier'),
('Lo', 'Letter, Other'),
('Mn', 'Mark, Non-Spacing'),
('Mc', 'Mark, Spacing Combining'),
('Me', 'Mark, Enclosing'),
('Nd', 'Number, Decimal Digit'),
('Nl', 'Number, Letter'),
('No', 'Number, Other'),
('Pc', 'Punctuation, Connector'),
('Pd', 'Punctuation, Dash'),
('Ps', 'Punctuation, Open'),
('Pe', 'Punctuation, Close'),
('Pi', 'Punctuation, Initial quote'),
('Pf', 'Punctuation, Final quote'),
('Po', 'Punctuation, Other'),
('Sm', 'Symbol, Math'),
('Sc', 'Symbol, Currency'),
('Sk', 'Symbol, Modifier'),
('So', 'Symbol, Other'),
('Zs', 'Separator, Space'),
('Zl', 'Separator, Line'),
('Zp', 'Separator, Paragraph'),
('Cc', 'Other, Control'),
('Cf', 'Other, Format'),
('Cs', 'Other, Surrogate'),
('Co', 'Other, Private Use'),
('Cn', 'Other, Not Assigned'),
('L&', 'Letter, Uppercase, Lowercase or Titlecase'));
var
i: Integer;
begin
for i := 0 to High(GeneralCategories) do
if GeneralCategories[i, 0] = GC then
begin
Result := GeneralCategories[i, 1];
Exit;
end;
Result := 'Unknown ('+GC+')';
end;
class function TUnicodeDataFormat.CanonicalCombiningClass(CCC: Integer): string;
begin
case CCC of
0: Result := 'Spacing, split, enclosing, reordrant, and Tibetan subjoined';
1: Result := 'Overlays and interior';
7: Result := 'Nuktas';
8: Result := 'Hiragana/Katakana voicing marks';
9: Result := 'Viramas';
10: Result := 'Start of fixed position classes';
199: Result := 'End of fixed position classes';
200: Result := 'Below left attached';
202: Result := 'Below attached';
204: Result := 'Below right attached';
208: Result := 'Left attached (reordrant around single base character)';
210: Result := 'Right attached';
212: Result := 'Above left attached';
214: Result := 'Above attached';
216: Result := 'Above right attached';
218: Result := 'Below left';
220: Result := 'Below';
222: Result := 'Below right';
224: Result := 'Left (reordrant around single base character)';
226: Result := 'Right';
228: Result := 'Above left';
230: Result := 'Above';
232: Result := 'Above right';
233: Result := 'Double below';
234: Result := 'Double above';
240: Result := 'Below (iota subscript)';
else Result := 'Unknown ('+IntToStr(CCC)+')';
end;
end;
class function TUnicodeDataFormat.BidirectionalCategory(BC: string): string;
const
BidiCats: array[0..18, 0..1] of string = (
('L', 'Left-to-Right'),
('LRE', 'Left-to-Right Embedding'),
('LRO', 'Left-to-Right Override'),
('R', 'Right-to-Left'),
('AL', 'Right-to-Left Arabic'),
('RLE', 'Right-to-Left Embedding'),
('RLO', 'Right-to-Left Override'),
('PDF', 'Pop Directional Format'),
('EN', 'European Number'),
('ES', 'European Number Separator'),
('ET', 'European Number Terminator'),
('AN', 'Arabic Number'),
('CS', 'Common Number Separator'),
('NSM', 'Non-Spacing Mark'),
('BN', 'Boundary Neutral'),
('B', 'Paragraph Separator'),
('S', 'Segment Separator'),
('WS', 'Whitespace'),
('ON', 'Other Neutrals'));
var
i: Integer;
begin
for i := 0 to High(BiDiCats) do
if BiDiCats[i, 0] = BC then
begin
Result := BiDiCats[i, 1];
Exit;
end;
Result := 'Unknown ('+BC+')';
end;
class function TUnicodeDataFormat.CharacterDecompositionMapping(CDM: string): string;
begin
Result := CDM;
end;
class function TUnicodeDataFormat.DecimalDigitValue(DDV: Integer): string;
begin
if DDV >= 0
then Result := IntToStr(DDV)
else Result := '';
end;
class function TUnicodeDataFormat.DigitValue(DV: Integer): string;
begin
if DV >= 0
then Result := IntToStr(DV)
else Result := '';
end;
class function TUnicodeDataFormat.NumericValue(NV: string): string;
begin
Result := Trim(NV);
end;
class function TUnicodeDataFormat.Mirrored(M: Boolean): string;
begin
if M
then Result := 'Yes'
else Result := 'No';
end;
class function TUnicodeDataFormat._10646Comment(_1C: string): string;
begin
Result := Trim(_1C);
end;
class function TUnicodeDataFormat.Unicode10Name(U1N: string): string;
begin
Result := Trim(U1N);
end;
class function TUnicodeDataFormat.UpperCaseMapping(UCM: Integer): string;
begin
if UCM > 0
then Result := 'U+'+IntToHex(UCM,4)
else Result := '';
end;
class function TUnicodeDataFormat.LowerCaseMapping(LCM: Integer): string;
begin
if LCM > 0
then Result := 'U+'+IntToHex(LCM,4)
else Result := '';
end;
class function TUnicodeDataFormat.TitleCaseMapping(LCM: Integer): string;
begin
if LCM > 0
then Result := 'U+'+IntToHex(LCM,4)
else Result := '';
end;*)
{ TUnicodeBlockList }
function TUnicodeBlockList.GetItem(Index: Integer): TUnicodeBlock;
begin
Result := inherited GetItem(Index) as TUnicodeBlock;
end;
procedure TUnicodeBlockList.SetItem(Index: Integer; const Value: TUnicodeBlock);
begin
inherited SetItem(Index, Value);
end;
{ TUnicodeBlock }
destructor TUnicodeBlock.Destroy;
begin
if Assigned(FCacheCharData) then // I2794
FreeMem(FCacheCharData);
FCacheCharData := nil;
inherited Destroy;
end;
initialization
with TVarData(_) do begin
vType:= varError;
vError:= Integer($80020004); {DISP_E_PARAMNOTFOUND}
end;
end.
Reference in a new issue View git blame Copy permalink