377 lines
9.5 KiB
ObjectPascal
377 lines
9.5 KiB
ObjectPascal
{******************************************}
|
|
{ }
|
|
{ FastReport FMX v2.0 }
|
|
{ Search for Linux fonts }
|
|
{ }
|
|
{ Copyright (c) 1998-2020 }
|
|
{ by Alexander Syrykh, }
|
|
{ Fast Reports Inc. }
|
|
{ }
|
|
{******************************************}
|
|
unit FMX.frxLinuxFonts;
|
|
{$I fmx.inc}
|
|
{$I frx.inc}
|
|
interface
|
|
|
|
uses System.Classes, System.UITypes, System.SysUtils, FMX.Types
|
|
{$IFDEF DELPHI19}
|
|
, FMX.Graphics
|
|
{$ENDIF};
|
|
|
|
type
|
|
TfrxFontsList = class
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function GetFontPath(AFont: TFont; FontName: String; SkipList: TList): String;
|
|
end;
|
|
|
|
function frxPosixFonts: TfrxFontsList;
|
|
function frxPosixFontsDirs: TStringList;
|
|
|
|
implementation
|
|
|
|
uses System.Types, System.IOUtils, FMX.frxTrueTypeCollection, FMX.frxTrueTypeFont, FMX.frxNameTableClass, FMX.frxXML, System.Generics.Collections;
|
|
|
|
const DefFontsSubs: String =
|
|
'<?xml version="1.1" encoding="utf-8"?>' +
|
|
'<SUBFONTS Clear="True">' +
|
|
'<FONT NAME="Arial" SUBNAME="Liberation Sans"/>' +
|
|
'<FONT NAME="MS Sans Serif" SUBNAME="Liberation Sans"/>' +
|
|
'<FONT NAME="Arimo" SUBNAME="Liberation Sans"/>' +
|
|
'<FONT NAME="Times New Roman" SUBNAME="Liberation Serif"/>' +
|
|
'<FONT NAME="Tinos" SUBNAME="Liberation Serif"/>' +
|
|
'<FONT NAME="Courier New" SUBNAME="Liberation Mono"/>' +
|
|
'<FONT NAME="Tahoma" SUBNAME="DejaVu Sans"/>' +
|
|
'<FONT NAME="Verdana" SUBNAME="DejaVu Sans"/>' +
|
|
'</SUBFONTS>';
|
|
|
|
XMLConfName: String = 'SubFonts.xml';
|
|
type
|
|
TfrxFontItem = class
|
|
private
|
|
FStylesFonts: TStringList;
|
|
public
|
|
constructor Create(const Path: String; Style: TFontStyles);
|
|
procedure AddFont(const Path: String; Style: TFontStyles);
|
|
function Find(Style: TFontStyles): Integer;
|
|
function FindPath(Style: TFontStyles): String;
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
TfrxFontsCollection = class(TStringList)
|
|
private
|
|
FSUBList: TDictionary<String, String>;
|
|
public
|
|
destructor Destroy; override;
|
|
procedure AfterConstruction; override;
|
|
procedure ClearSubList;
|
|
procedure LoadSubstitutionConfig(Stream: TStream); overload;
|
|
procedure LoadSubstitutionConfig(const FileName: String); overload;
|
|
procedure AddFont(const FamilyName: String; const Path: String; Style: TFontStyles);
|
|
function FindFont(Font: TFont): String;
|
|
end;
|
|
|
|
var
|
|
FLFonts: TfrxFontsList = nil;
|
|
FontCollection: TfrxFontsCollection;
|
|
FontDirs: TStringList;
|
|
|
|
{TfrxFontsList}
|
|
constructor TfrxFontsList.Create;
|
|
|
|
procedure AddFonts(const aPath: String);
|
|
var
|
|
i: Integer;
|
|
skip_list: TList;
|
|
ttf: TrueTypeFont;
|
|
fs: TFontStyles;
|
|
FontData: TMemoryStream;
|
|
TrueTypeTables: TrueTypeCollection;
|
|
begin
|
|
|
|
skip_list := TList.Create;
|
|
TrueTypeTables := TrueTypeCollection.Create;
|
|
FontData := TMemoryStream.Create;
|
|
try
|
|
try
|
|
FontData.LoadFromFile(aPath);
|
|
FontData.Position := 0;
|
|
TrueTypeTables.Initialize(FontData.Memory, FontData.Size);
|
|
except
|
|
Exit;
|
|
end;
|
|
skip_list.Add(Pointer(TablesID.EmbedBitmapLocation));
|
|
skip_list.Add(Pointer(TablesID.EmbededBitmapData));
|
|
skip_list.Add(Pointer(TablesID.HorizontakDeviceMetrix));
|
|
skip_list.Add(Pointer(TablesID.VerticalDeviceMetrix));
|
|
skip_list.Add(Pointer(TablesID.DigitalSignature));
|
|
skip_list.Add(Pointer(TablesID.HorizontalHeader));
|
|
skip_list.Add(Pointer(TablesID.GlyphSubstitution));
|
|
skip_list.Add(Pointer(TablesID.IndexToLocation));
|
|
skip_list.Add(Pointer(TablesID.Glyph));
|
|
skip_list.Add(Pointer(TablesID.KerningTable));
|
|
skip_list.Add(Pointer(TablesID.CMAP));
|
|
skip_list.Add(Pointer(TablesID.Postscript));
|
|
skip_list.Add(Pointer(TablesID.HorizontalMetrix));
|
|
skip_list.Add(Pointer(TablesID.PreProgram));
|
|
skip_list.Add(Pointer(TablesID.MaximumProfile));
|
|
|
|
for i := 0 to TrueTypeTables.fonts_collection.Count - 1 do
|
|
begin
|
|
fs := [];
|
|
ttf := TrueTypeFont(TrueTypeTables.fonts_collection[i]);
|
|
if not ttf.IsLoaded then
|
|
ttf.PrepareFont(skip_list);
|
|
|
|
if ttf.windows_metrix.win_metrix.fsSelection and 32 = 32 then
|
|
Include(fs, TFontStyle.fsBold);
|
|
if ttf.windows_metrix.win_metrix.fsSelection and 1 = 1 then
|
|
Include(fs, TFontStyle.fsItalic);
|
|
FontCollection.AddFont(ttf.Names.Item[NameID.FamilyName], aPath, fs);
|
|
end;
|
|
|
|
finally
|
|
TrueTypeTables.Free;
|
|
skip_list.Free;
|
|
FontData.Free;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure InitFonts;
|
|
var
|
|
i: Integer;
|
|
|
|
procedure AddFolder(AFolder: string);
|
|
var
|
|
files: TStringDynArray;
|
|
j: integer;
|
|
begin
|
|
AFolder := ExpandFileName(AFolder);
|
|
if (length(AFolder) <> 0) and (AFolder[length(AFolder)] <> PathDelim) then
|
|
AFolder := AFolder + PathDelim;
|
|
try
|
|
if TDirectory.Exists(AFolder) then
|
|
files := TDirectory.GetFiles(AFolder, '*.ttf', TSearchOption.soAllDirectories);
|
|
for j := 0 to Length(files) - 1 do
|
|
AddFonts(files[j]);
|
|
finally
|
|
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
for i:= 0 to frxPosixFontsDirs.Count - 1 do
|
|
AddFolder(frxPosixFontsDirs[i]);
|
|
end;
|
|
|
|
var
|
|
s: TStringStream;
|
|
fName: String;
|
|
begin
|
|
FontCollection := TfrxFontsCollection.Create(True);
|
|
s := TStringStream.Create(DefFontsSubs);
|
|
try
|
|
s.Position := 0;
|
|
FontCollection.LoadSubstitutionConfig(s);
|
|
finally
|
|
s.Free;
|
|
end;
|
|
|
|
fName := ExtractFilePath(ParamStr(0)) + XMLConfName;
|
|
if FileExists(fName) then
|
|
FontCollection.LoadSubstitutionConfig(fName);
|
|
|
|
InitFonts;
|
|
end;
|
|
|
|
destructor TfrxFontsList.Destroy;
|
|
begin
|
|
FreeAndNil(FontCollection);
|
|
end;
|
|
|
|
function TfrxFontsList.GetFontPath(AFont: TFont; FontName: String; SkipList: TList): String;
|
|
var
|
|
Font: TFont;
|
|
begin
|
|
Result := '';
|
|
Result := FontCollection.FindFont(AFont);
|
|
if (Result = '') then
|
|
begin
|
|
Font := TFont.Create;
|
|
try
|
|
Font.Assign(AFont);
|
|
Font.Family := 'FreeSans';
|
|
Result := FontCollection.FindFont(Font);
|
|
finally
|
|
Font.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function frxPosixFonts: TfrxFontsList;
|
|
begin
|
|
if FLFonts = nil then
|
|
FLFonts := TfrxFontsList.Create;
|
|
Result := FLFonts;
|
|
end;
|
|
|
|
{ TfrxFontItem }
|
|
|
|
procedure TfrxFontItem.AddFont(const Path: String; Style: TFontStyles);
|
|
begin
|
|
if Find(Style)= -1 then
|
|
FStylesFonts.AddObject(Path, TObject(Byte(Style)));
|
|
end;
|
|
|
|
constructor TfrxFontItem.Create(const Path: String; Style: TFontStyles);
|
|
begin
|
|
FStylesFonts := TStringList.Create;
|
|
AddFont(Path, Style);
|
|
end;
|
|
|
|
destructor TfrxFontItem.Destroy;
|
|
begin
|
|
FreeAndNil(FStylesFonts);
|
|
inherited;
|
|
end;
|
|
|
|
function TfrxFontItem.Find(Style: TFontStyles): Integer;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := -1;
|
|
for i := 0 to FStylesFonts.Count - 1 do
|
|
if Byte(FStylesFonts.Objects[i]) = Byte(Style) then
|
|
begin
|
|
Result := i;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
function TfrxFontItem.FindPath(Style: TFontStyles): String;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := '';
|
|
Style := Style - [TFontStyle.fsUnderline, TFontStyle.fsStrikeOut];
|
|
i := Find(Style);
|
|
if i > -1 then Result := FStylesFonts[i];
|
|
end;
|
|
|
|
{ TfrxFontsCollection }
|
|
|
|
procedure TfrxFontsCollection.AddFont(const FamilyName, Path: String;
|
|
Style: TFontStyles);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := IndexOf(FamilyName);
|
|
if i < 0 then
|
|
AddObject(FamilyName, TfrxFontItem.Create(Path, Style))
|
|
else
|
|
TfrxFontItem(Objects[i]).AddFont(Path, Style);
|
|
end;
|
|
|
|
procedure TfrxFontsCollection.AfterConstruction;
|
|
begin
|
|
inherited;
|
|
FSUBList := TDictionary<String, String>.Create;
|
|
end;
|
|
|
|
procedure TfrxFontsCollection.ClearSubList;
|
|
begin
|
|
FSUBList.Clear;
|
|
end;
|
|
|
|
destructor TfrxFontsCollection.Destroy;
|
|
begin
|
|
FreeAndNil(FSUBList);
|
|
inherited;
|
|
end;
|
|
|
|
function TfrxFontsCollection.FindFont(Font: TFont): String;
|
|
var
|
|
i: Integer;
|
|
FName: String;
|
|
begin
|
|
Result := '';
|
|
if not FSUBList.TryGetValue(Font.Family, FName) then
|
|
FName := Font.Family;
|
|
i := IndexOf(FName);
|
|
if i < 0 then Exit;
|
|
Result := TfrxFontItem(Objects[i]).FindPath(Font.Style);
|
|
end;
|
|
|
|
procedure TfrxFontsCollection.LoadSubstitutionConfig(Stream: TStream);
|
|
var
|
|
XMLDoc: TfrxXMLDocument;
|
|
Item: TfrxXMLItem;
|
|
I: Integer;
|
|
s1, s2: String;
|
|
begin
|
|
XMLDoc := TfrxXMLDocument.Create;
|
|
try
|
|
XMLDoc.LoadFromStream(Stream);
|
|
Item := XMLDoc.Root;
|
|
i := XMLDoc.Root.Find('SUBFONTS');
|
|
if i <> -1 then
|
|
Item := XMLDoc.Root.Items[i];
|
|
if Item = nil then Exit;
|
|
if UpperCase(Item.Prop['Clear']) = 'TRUE' then
|
|
ClearSubList;
|
|
for I := 0 to Item.Count - 1 do
|
|
begin
|
|
s1 := Item[i].Prop['NAME'];
|
|
s2 := Item[i].Prop['SUBNAME'];
|
|
if (s1 <> '') and (s2 <> '') then
|
|
FSUBList.AddOrSetValue(s1, s2);
|
|
end;
|
|
finally
|
|
XMLDoc.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxFontsCollection.LoadSubstitutionConfig(const FileName: String);
|
|
var
|
|
s: TFileStream;
|
|
begin
|
|
s := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
|
|
try
|
|
s.Position := 0;
|
|
LoadSubstitutionConfig(s);
|
|
finally
|
|
s.Free;
|
|
end;
|
|
end;
|
|
|
|
function frxPosixFontsDirs: TStringList;
|
|
|
|
procedure FillFontPathes(var AList: TStringList); //TODO: Rewrite to parse '/etc/fonts/fonts.conf'
|
|
begin
|
|
{$IFDEF LINUX}
|
|
AList.Add('/usr/share/cups/fonts/');
|
|
AList.Add('/usr/share/fonts/');
|
|
AList.Add('/usr/local/lib/X11/fonts/');
|
|
AList.Add( ExtractFilePath(ParamStr(0))+ 'fonts/');
|
|
{$ENDIF}
|
|
end;
|
|
|
|
begin
|
|
if FontDirs = nil then
|
|
begin
|
|
FontDirs := TStringList.Create;
|
|
FillFontPathes(FontDirs);
|
|
end;
|
|
Result := FontDirs;
|
|
end;
|
|
|
|
initialization
|
|
|
|
finalization
|
|
FreeAndNil(FLFonts);
|
|
FreeAndNil(FontDirs);
|
|
|
|
end.
|