{******************************************}
{                                          }
{           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.