////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Fonts routines: font check,search,embed to application from resource etc.  //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20160425 - Creation & test                                                 //
// 20160917 - TEmbeddedFont, TEmbeddedFontList, FullEmbeddedFontList          //
// 20231019 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_fonts; // Fonts routines.

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

{$WARN 5023 off : Unit "$1" not used in $2}
{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 {$IFDEF WINDOWS} jwawingdi, {$ENDIF}
 sysutils, classes, lmessages, lcltype,
 graphics, forms, controls, stdctrls, buttons, process,
 _crw_alloc, _crw_str, _crw_fio, _crw_dynar, _crw_spcfld, _crw_proc;

// Set Font.Name to default value.
procedure SetDefaultFontName(Font:TFont);
procedure SetDefaultMonoFontName(Font:TFont);
procedure SetDefaultSansFontName(Font:TFont);
procedure SetDefaultSerifFontName(Font:TFont);
procedure SetDefaultRomanFontName(Font:TFont);
procedure SetDefaultNarrowFontName(Font:TFont);

const // Constants for DefaultFontType.
 ft_Mono=0; ft_Sans=1; ft_Serif=2; ft_Roman=3; ft_Narrow=4;

var // Type of SetDefaultFontName.
 DefaultFontType : Integer = ft_Mono;

// Find available font name from font name list or return fallback value.
// Font.Name:=GetAvailableFontName(DefaultMonoFonts,FallbackMonoFont);
function GetAvailableFontName(FontNameList,Fallback:LongString):LongString;

const // List of popular Mono Fonts to use by default.
 DefaultMonoFonts = 'PT Mono, Consola Mono, Consolas, '
                  + 'Code New Roman, Source Code Pro, '
                  + 'Liberation Mono, DejaVu Sans Mono, '
                  + 'Droid Sans Mono, Roboto Mono, Fira Mono, '
                  + 'Ubuntu Mono, Cousine, Anonymous Pro, FreeMono'
                  + 'Courier New, Courier, Lucida Console, Fixedsys, Monospace';
 DefaultSansFonts = 'PT Sans, PT Astra Sans, Sans, Liberation Sans, '
                  + 'DejaVu Sans, Droid Sans, FreeSans, Fira Sans, Source Sans Pro, '
                  + 'Arial, Verdana, Tahoma, Lucida Sans, Microsoft Sans Serif, MS Sans Serif';
 DefaultSerifFonts = 'PT Serif, PT Astra Serif, Serif, Liberation Serif, '
                  + 'DejaVu Serif, Droid Serif, FreeSerif, Source Serif Pro'
                  + 'Microsoft Sans Serif, MS Serif';
 DefaultRomanFonts = 'PT Astra Serif, Times New Roman, Roman, '
                  + 'Code New Roman, Royal Times New Roman, MS Serif';
 DefaultNarrowFonts = 'PT Sans Narrow, Liberation Sans Narrow, Arial Narrow, '
                    + 'Microsoft Sans Serif, MS Sans Serif';

const // Fallback font if none found.
 FallbackMonoFont   = {$IFDEF WINDOWS} 'Courier New'    {$ELSE} 'Monospace' {$ENDIF};
 FallbackSansFont   = {$IFDEF WINDOWS} 'MS Sans Serif'  {$ELSE} 'Sans'      {$ENDIF};
 FallbackSerifFont  = {$IFDEF WINDOWS} 'MS Serif'       {$ELSE} 'Serif'     {$ENDIF};
 FallbackRomanFont  = {$IFDEF WINDOWS} 'MS Serif'       {$ELSE} 'Serif'     {$ENDIF};
 FallbackNarrowFont = {$IFDEF WINDOWS} 'MS Sans Serif'  {$ELSE} 'Serif'     {$ENDIF};

 // Name:PT_Mono\Size:10\Color:Black\Style:[Bold]
function GetFontStyleAsText(Font:TFont):LongString;
function GetFontStylesAsText(Styles:TFontStyles):LongString;
function GetSetFontParams(Font:TFont; Params:LongString):LongString;

 //
 // GetSystemFontsPath               - return Fonts system directory, like c:\Windows\Fonts.
 //                                  - that is special system directory by CSIDL_FONTS.
 //
function  GetSystemFontsPath:LongString;

 //
 // GetSystemFontsAsText(Charset,Pitch,Name) - enumerate system fonts and returns CR,LF delimited
 //                                   - list of system fonts by given charset, pitch and name.
 //                                   - name parameter specifies search pattern for font face name.
 //                                   - all fonts started from this pattern will be enumerated.
 // TheSystemFonts(Charset,Pitch)     - fast buffered version of GetSystemFontsAsText which return
 //                                   - CR,LF delimited list of system fonts from buffer after 1st
 //                                   - call. On 1st call GetSystemFontsAsText uses for enumeration.
 // TheSystemFontsReset               - clear TheSystemFonts's buffers to update list of fonts.
 // TheSystemFontsFree                - free TheSystemFontsFree's buffers.
 //
function  GetSystemFontsAsText(Charset:Integer=DEFAULT_CHARSET; Pitch:Integer=DEFAULT_PITCH; const Name:LongString=''):LongString;
function  TheSystemFonts(Charset:Integer=DEFAULT_CHARSET; Pitch:Integer=DEFAULT_PITCH):LongString;
procedure TheSystemFontsReset;
procedure TheSystemFontsFree;

 //
 // SystemFontsFound(Charset,Pitch,Name) - search fonts with given charset, pitch and name.
 //                                    - return true if specified font found. name parameter may be
 //                                    - empty, it means "any name".
 //
function SystemFontsFound(Charset:Integer=DEFAULT_CHARSET; Pitch:Integer=DEFAULT_PITCH; const Name:LongString=''):Integer;

{$IFDEF UNIX}
 // Get Unix system font (using fc-list tool) with filters.
 // Any filter may be empty, which means any value.
 // aFile is wanted font filename. aLang is wanted languages as 'ru,en'.
 // aStyle is wanted styles as 'Bold,Italic,Condensed,Oblique,Black,Book,Regular,Demi,Light,ExtraLight,Medium,Roman,Thin'.
 // aSpacing is wanted font spacing as '0,90,100,110' means (proportional,dual,mono,charcell).
 // aSpacing is wanted font family (substring) as 'PT Mono'.
function GetUnixSystemFontsAsText(const aFile,aLang,aStyle,aSpacing,aName:LongString):LongString;
{$ENDIF ~UNIX}

{$IFDEF WINDOWS}

 //
 // GetTextFaceName(dc)               - return current font uses by device context dc.
 // PostBroadcastFontChange           - post WM_FONTCHANGE broadcast to update system fonts.
 // AddSystemFont(FontPath,Post)      - add    font resource file FontPath and post message.
 // RemoveSystemFont(FontPath,Post)   - remove font resource file FontPath and post message.
 //
function  GetTextFaceName(dc:HDC):LongString;
procedure PostBroadcastFontChange;
function  AddSystemFont(const FontPath:LongString; Post:Boolean=False):Integer;
function  RemoveSystemFont(const FontPath:LongString; Post:Boolean=False):Integer;

 ///////////////////////////////////////////////////////////////////////////////
 // TEmbeddedFont class uses to embed required fonts to application.
 // Usually not uses by itself but uses as FullEmbeddedFontList member.
 ///////////////////////////////////////////////////////////////////////////////
type
 TEmbeddedFont = class(TMasterObject)
 private
  myNickName     : LongString;
  myFontData     : LongString;
  myFontName     : LongString;
  myFontSource   : LongString;
  myFontTarget   : LongString;
  myFontHand     : THandle;
  myEmbedded     : DWORD;
 private
  function    GetNickName:LongString;
  function    GetFontData:LongString;
  function    GetFontName:LongString;
  function    GetFontFamily:LongString;
  function    GetFontSource:LongString;
  function    GetFontTarget:LongString;
  function    GetFontHand:THandle;
  function    GetEmbedded:DWORD;
 public
  constructor Create(const aNickName,aFontName,aFontSource,aFontTarget:LongString; aEmbed:Boolean=False);
  destructor  Destroy; override;
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
 public
  procedure   SmartEmbed(Charset:Integer=1; Pitch:Integer=0);     // Embed font if one not found in system
  function    FontEmbed:Integer;                                  // Embed font from resource or file
  procedure   FontFree;                                           // Free (unuse) embedded font
  function    DataLoad:Boolean;                                   // Load FontData from file
  procedure   DataFree;                                           // Free FontData
  function    FontOk:Boolean;                                     // Font is embedded
  function    DataOk:Boolean;                                     // FontData is loaded
  function    Found(Charset:Integer=1; Pitch:Integer=0):Cardinal; // Count system fonts by family
  function    FontSave(Add:Boolean=False;Post:Boolean=False):Integer; // Save font file to system directory
 public
  property    NickName   : LongString    read  GetNickName;       // Nickname to identify font
  property    FontData   : LongString    read  GetFontData;       // Font raw data buffer
  property    FontSource : LongString    read  GetFontSource;     // Source font file
  property    FontTarget : LongString    read  GetFontTarget;     // Target font file
  property    FontName   : LongString    read  GetFontName;       // Font full name (with bold,italic,..)
  property    FontFamily : LongString    read  GetFontFamily;     // Font family name (skip bold, italic,..)
  property    FontHand   : THandle       read  GetFontHand;       // Font embed handle
  property    Embedded   : DWORD         read  GetEmbedded;       // Count of embedded fonts
 end;

 ///////////////////////////////////////////////////////////////////////////////
 // TEmbeddedFontList uses as container and master for embedded fonts.
 // Fonts to embed can be located in TTF, OTF or FON files on hard disk.
 // ReadIniFile(IniFile) uses to load fonts and embed it by FontEmbed call.
 // FullEmbeddedFontList contains all EmbeddedFont objects and uses as general
 // master to manipulate embedded fonts.
 // IniFile contains embedded font list described like that (PT fonts family):
 //  [EmbeddedFontList]
 //  EmbeddedFont = FONT_TTF_PTM55F
 //  EmbeddedFont = FONT_TTF_PTM75F
 //  EmbeddedFont = FONT_TTF_PTN57F
 //  EmbeddedFont = FONT_TTF_PTN77F
 //  EmbeddedFont = FONT_TTF_PTS55F
 //  EmbeddedFont = FONT_TTF_PTS56F
 //  EmbeddedFont = FONT_TTF_PTS75F
 //  EmbeddedFont = FONT_TTF_PTS76F
 //  EmbeddedFont = FONT_TTF_PTF55F
 //  EmbeddedFont = FONT_TTF_PTF56F
 //  EmbeddedFont = FONT_TTF_PTF75F
 //  EmbeddedFont = FONT_TTF_PTF76F
 //  [EmbeddedFontName]
 //  FONT_TTF_PTM55F = PT Mono
 //  FONT_TTF_PTM75F = PT Mono Bold
 //  FONT_TTF_PTN57F = PT Sans Narrow
 //  FONT_TTF_PTN77F = PT Sans Narrow Bold
 //  FONT_TTF_PTS55F = PT Sans
 //  FONT_TTF_PTS56F = PT Sans Italic
 //  FONT_TTF_PTS75F = PT Sans Bold
 //  FONT_TTF_PTS76F = PT Sans Bold Italic
 //  FONT_TTF_PTF55F = PT Serif
 //  FONT_TTF_PTF56F = PT Serif Italic
 //  FONT_TTF_PTF75F = PT Serif Bold
 //  FONT_TTF_PTF76F = PT Serif Bold Italic
 //  [EmbeddedFontTarget]
 //  FONT_TTF_PTM55F = PTM55F.ttf
 //  FONT_TTF_PTM75F = PTM75F.ttf
 //  FONT_TTF_PTN57F = PTN57F.ttf
 //  FONT_TTF_PTN77F = PTN77F.ttf
 //  FONT_TTF_PTS55F = PTS55F.ttf
 //  FONT_TTF_PTS56F = PTS56F.ttf
 //  FONT_TTF_PTS75F = PTS75F.ttf
 //  FONT_TTF_PTS76F = PTS76F.ttf
 //  FONT_TTF_PTF55F = PTF55F.ttf
 //  FONT_TTF_PTF56F = PTF56F.ttf
 //  FONT_TTF_PTF75F = PTF75F.ttf
 //  FONT_TTF_PTF76F = PTF76F.ttf
 //  [EmbeddedFontSource]
 //  FONT_TTF_PTM55F = Resource\Fonts\www.paratype.ru\PTMono\PTM55F.ttf
 //  FONT_TTF_PTM75F = Resource\Fonts\www.paratype.ru\PTMono\PTM75F.ttf
 //  FONT_TTF_PTN57F = Resource\Fonts\www.paratype.ru\PTSans\PTN57F.ttf
 //  FONT_TTF_PTN77F = Resource\Fonts\www.paratype.ru\PTSans\PTN77F.ttf
 //  FONT_TTF_PTS55F = Resource\Fonts\www.paratype.ru\PTSans\PTS55F.ttf
 //  FONT_TTF_PTS56F = Resource\Fonts\www.paratype.ru\PTSans\PTS56F.ttf
 //  FONT_TTF_PTS75F = Resource\Fonts\www.paratype.ru\PTSans\PTS75F.ttf
 //  FONT_TTF_PTS76F = Resource\Fonts\www.paratype.ru\PTSans\PTS76F.ttf
 //  FONT_TTF_PTF55F = Resource\Fonts\www.paratype.ru\PTSerif\PTF55F.ttf
 //  FONT_TTF_PTF56F = Resource\Fonts\www.paratype.ru\PTSerif\PTF56F.ttf
 //  FONT_TTF_PTF75F = Resource\Fonts\www.paratype.ru\PTSerif\PTF75F.ttf
 //  FONT_TTF_PTF76F = Resource\Fonts\www.paratype.ru\PTSerif\PTF76F.ttf
 ///////////////////////////////////////////////////////////////////////////////
 // Fonts also can be embedded in EXE file via resources. In this case INI file
 // [EmbeddedFontSource] section should contain EXE file name as source file,
 // [EmbeddedFontList] should contain names of resource linked to EXE file.
 // For example, to embed PT fonts as resources, include resource file:
 //  {$R ptfonts.res}
 // Next command use for ptfonts.res compilation:
 //  brcc32 ptfonts.rc
 // This is example of ptfonts.rc file content:
 //  #pragma code_page(1251)
 //  LANGUAGE LANG_NEUTRAL, SUBLANG_NEUTRAL
 //  FONT_TTF_PTM55F RCDATA Resource\Fonts\www.paratype.ru\PTMono\PTM55F.ttf
 //  FONT_TTF_PTM75F RCDATA Resource\Fonts\www.paratype.ru\PTMono\PTM75F.ttf
 //  FONT_TTF_PTN57F RCDATA Resource\Fonts\www.paratype.ru\PTSans\PTN57F.ttf
 //  FONT_TTF_PTN77F RCDATA Resource\Fonts\www.paratype.ru\PTSans\PTN77F.ttf
 //  FONT_TTF_PTS55F RCDATA Resource\Fonts\www.paratype.ru\PTSans\PTS55F.ttf
 //  FONT_TTF_PTS56F RCDATA Resource\Fonts\www.paratype.ru\PTSans\PTS56F.ttf
 //  FONT_TTF_PTS75F RCDATA Resource\Fonts\www.paratype.ru\PTSans\PTS75F.ttf
 //  FONT_TTF_PTS76F RCDATA Resource\Fonts\www.paratype.ru\PTSans\PTS76F.ttf
 //  FONT_TTF_PTF55F RCDATA Resource\Fonts\www.paratype.ru\PTSerif\PTF55F.ttf
 //  FONT_TTF_PTF56F RCDATA Resource\Fonts\www.paratype.ru\PTSerif\PTF56F.ttf
 //  FONT_TTF_PTF75F RCDATA Resource\Fonts\www.paratype.ru\PTSerif\PTF75F.ttf
 //  FONT_TTF_PTF76F RCDATA Resource\Fonts\www.paratype.ru\PTSerif\PTF76F.ttf
 // IniFile contains embedded font list described like that (PT fonts family):
 //  [EmbeddedFontList]
 //  EmbeddedFont = FONT_TTF_PTM55F
 //  EmbeddedFont = FONT_TTF_PTM75F
 //  EmbeddedFont = FONT_TTF_PTN57F
 //  EmbeddedFont = FONT_TTF_PTN77F
 //  EmbeddedFont = FONT_TTF_PTS55F
 //  EmbeddedFont = FONT_TTF_PTS56F
 //  EmbeddedFont = FONT_TTF_PTS75F
 //  EmbeddedFont = FONT_TTF_PTS76F
 //  EmbeddedFont = FONT_TTF_PTF55F
 //  EmbeddedFont = FONT_TTF_PTF56F
 //  EmbeddedFont = FONT_TTF_PTF75F
 //  EmbeddedFont = FONT_TTF_PTF76F
 //  [EmbeddedFontName]
 //  FONT_TTF_PTM55F = PT Mono
 //  FONT_TTF_PTM75F = PT Mono Bold
 //  FONT_TTF_PTN57F = PT Sans Narrow
 //  FONT_TTF_PTN77F = PT Sans Narrow Bold
 //  FONT_TTF_PTS55F = PT Sans
 //  FONT_TTF_PTS56F = PT Sans Italic
 //  FONT_TTF_PTS75F = PT Sans Bold
 //  FONT_TTF_PTS76F = PT Sans Bold Italic
 //  FONT_TTF_PTF55F = PT Serif
 //  FONT_TTF_PTF56F = PT Serif Italic
 //  FONT_TTF_PTF75F = PT Serif Bold
 //  FONT_TTF_PTF76F = PT Serif Bold Italic
 //  [EmbeddedFontTarget]
 //  FONT_TTF_PTM55F = PTM55F.ttf
 //  FONT_TTF_PTM75F = PTM75F.ttf
 //  FONT_TTF_PTN57F = PTN57F.ttf
 //  FONT_TTF_PTN77F = PTN77F.ttf
 //  FONT_TTF_PTS55F = PTS55F.ttf
 //  FONT_TTF_PTS56F = PTS56F.ttf
 //  FONT_TTF_PTS75F = PTS75F.ttf
 //  FONT_TTF_PTS76F = PTS76F.ttf
 //  FONT_TTF_PTF55F = PTF55F.ttf
 //  FONT_TTF_PTF56F = PTF56F.ttf
 //  FONT_TTF_PTF75F = PTF75F.ttf
 //  FONT_TTF_PTF76F = PTF76F.ttf
 //  [EmbeddedFontSource]
 //  FONT_TTF_PTM55F = Crw32.exe
 //  FONT_TTF_PTM75F = Crw32.exe
 //  FONT_TTF_PTN57F = Crw32.exe
 //  FONT_TTF_PTN77F = Crw32.exe
 //  FONT_TTF_PTS55F = Crw32.exe
 //  FONT_TTF_PTS56F = Crw32.exe
 //  FONT_TTF_PTS75F = Crw32.exe
 //  FONT_TTF_PTS76F = Crw32.exe
 //  FONT_TTF_PTF55F = Crw32.exe
 //  FONT_TTF_PTF56F = Crw32.exe
 //  FONT_TTF_PTF75F = Crw32.exe
 //  FONT_TTF_PTF76F = Crw32.exe
 ///////////////////////////////////////////////////////////////////////////////
type
 TEmbeddedFontList=class(TObjectStorage)
 private
  function    GetEmbeddedFont(i:LongInt):TEmbeddedFont;
  procedure   PutEmbeddedFont(i:LongInt; f:TEmbeddedFont);
  function    GetEmbedded:Integer;
 public
  constructor Create(aOwns:Boolean);
  destructor  Destroy; override;
 public
  function    ReadIniFile(const IniFile   : LongString;
                          const ThePrefix : LongString = 'EmbeddedFont';
                          const SecList   : LongString = '[EmbeddedFontList]';
                          const SecName   : LongString = '[EmbeddedFontName]';
                          const SecSource : LongString = '[EmbeddedFontSource]';
                          const SecTarget : LongString = '[EmbeddedFontTarget]'
                                        ) : Integer;
  procedure   SmartEmbed(Charset:Integer=1; Pitch:Integer=0);      // Embed fonts which not found in system
  function    Found(Charset:Integer=1; Pitch:Integer=0):Integer;   // Count fonts by families
  function    FontSave(Add:Boolean=False;Post:Boolean=False):Integer; // Save fonts to system directory
  function    FontEmbed:Integer;                                   // Embed all fonts from resource
  procedure   FontFree;                                            // Free all embedded fonts
  procedure   FontKill;                                            // Kill all embedded font objects
  procedure   DataFree;                                            // Free all font data buffers
 public
  property    EmbeddedFont[i:LongInt]:TEmbeddedFont read GetEmbeddedFont write PutEmbeddedFont; default;
  property    Embedded:Integer read GetEmbedded;                   // Count embedded fonts
 end;

function  NewEmbeddedFontList(aOwns:Boolean=true):TEmbeddedFontList;
procedure Kill(var TheObject:TEmbeddedFontList); overload;

function FullEmbeddedFontList:TEmbeddedFontList; // Contains all embedded fonts

{$ENDIF ~WINDOWS}

implementation

function GetAvailableFontName(FontNameList,Fallback:LongString):LongString;
var i:Integer; S:LongString; Delims:TCharSet;
begin
 Result:=Fallback; Delims:=[#0..#31,',',';'];
 for i:=1 to WordCount(FontNameList,Delims) do begin
  S:=Trim(ExtractWord(i,FontNameList,Delims));
  if (S<>'') and (Screen.Fonts.IndexOf(S)>=0) then begin
   Result:=S;
   Break;
  end;
 end;
end;

procedure SetDefaultFontName(Font:TFont);
begin
 if (Font=nil) then Exit;
 case DefaultFontType of
  0: SetDefaultMonoFontName(Font);
  1: SetDefaultSansFontName(Font);
  2: SetDefaultSerifFontName(Font);
  3: SetDefaultRomanFontName(Font);
  4: SetDefaultNarrowFontName(Font);
 end;
end;

procedure SetDefaultMonoFontName(Font:TFont);
begin
 if (Font=nil) then Exit;
 Font.Name:=GetAvailableFontName(DefaultMonoFonts,FallbackMonoFont);
end;

procedure SetDefaultSansFontName(Font:TFont);
begin
 if (Font=nil) then Exit;
 Font.Name:=GetAvailableFontName(DefaultSansFonts,FallbackSansFont);
end;

procedure SetDefaultSerifFontName(Font:TFont);
begin
 if (Font=nil) then Exit;
 Font.Name:=GetAvailableFontName(DefaultSerifFonts,FallbackSerifFont);
end;

procedure SetDefaultRomanFontName(Font:TFont);
begin
 if (Font=nil) then Exit;
 Font.Name:=GetAvailableFontName(DefaultRomanFonts,FallbackRomanFont);
end;

procedure SetDefaultNarrowFontName(Font:TFont);
begin
 if (Font=nil) then Exit;
 Font.Name:=GetAvailableFontName(DefaultNarrowFonts,FallbackNarrowFont);
end;

function GetFontStylesAsText(Styles:TFontStyles):LongString;
begin
 Result:='';
 if (Styles=[]) then begin Result:='[]'; Exit; end;
 if (fsBold in Styles) then Result:=Result+' Bold';
 if (fsItalic in Styles) then Result:=Result+' Italic';
 if (Result='') then Result:='Normal';
 if (fsStrikeOut in Styles) then Result:=Result+' StrikeOut';
 if (fsUnderline in Styles) then Result:=Result+' Underline';
 Result:='['+StringReplace(Trim(Result),' ',',',[rfReplaceAll])+']';
end;

function GetFontStyleAsText(Font:TFont):LongString;
begin
 Result:='';
 if (Font=nil) then Exit;
 Result:=GetFontStylesAsText(Font.Style);
end;

function GetSetFontParams(Font:TFont; Params:LongString):LongString;
var Lines:TStrings; s:LongString;
begin
 Result:='';
 try
  Lines:=TStringList.Create;
  try
   Params:=Trim(Params);
   if (Params<>'') then begin
    Params:=StringReplace(Params,'_',' ',[rfReplaceAll]);
    Params:=StringReplace(Params,':','=',[rfReplaceAll]);
    Params:=StringReplace(Params,'\',EOL,[rfReplaceAll]);
    Lines.Text:=AdjustLineBreaks(Params);
   end;
   if (Font<>nil) then begin
    s:=Trim(Lines.Values['Name']);  if (s<>'') then Font.Name:=s;
    s:=Trim(Lines.Values['Size']);  if (s<>'') then Font.Size:=StrToIntDef(s,Font.Size);
    s:=Trim(Lines.Values['Color']); if (s<>'') then Font.Color:=StrToIntDef(s,Font.Color);
    s:=Trim(Lines.Values['Style']);
    if (s<>'') then begin
     if (WordIndex('Bold',s,[','])>0) then Font.Style:=Font.Style+[fsBold] else Font.Style:=Font.Style-[fsBold];
     if (WordIndex('Italic',s,[','])>0) then Font.Style:=Font.Style+[fsItalic] else Font.Style:=Font.Style-[fsItalic];
     if (WordIndex('StrikeOut',s,[','])>0) then Font.Style:=Font.Style+[fsStrikeOut] else Font.Style:=Font.Style-[fsStrikeOut];
     if (WordIndex('Underline',s,[','])>0) then Font.Style:=Font.Style+[fsUnderline] else Font.Style:=Font.Style-[fsUnderline];

    end;
    Lines.Clear;
    Lines.Values['Name']:=Font.Name;
    Lines.Values['Size']:=IntToStr(Font.Size);
    Lines.Values['Color']:=ColorToString(Font.Color);
    Lines.Values['Style']:=GetFontStyleAsText(Font);
   end;
   Result:=Trim(Lines.Text);
   Result:=StringReplace(Result,' ','_',[rfReplaceAll]);
   Result:=StringReplace(Result,'=',':',[rfReplaceAll]);
   Result:=StringReplace(Result,EOL,'\',[rfReplaceAll]);
  finally
   Lines.Free;
  end;
 except
  on E:Exception do BugReport(E,Application,'GetSetFontParams');
 end;
end;

function GetSystemFontsPath:LongString;
begin
 Result:=GetSpecialShellFolderPath(CSIDL_FONTS);
end;

{$IFDEF UNIX}
type TFSRec=record aFile,aLang,aStyle,aSpacing,aName:LongString; List:TStringList; end;
function fsIterator(n:SizeInt; Line:LongString; Custom:Pointer):Boolean;
var filename,family,lang,style,spacing:LongString; i,m:Integer;
const sep=':';
begin
 Result:=true;
 if Assigned(Custom) and (Line<>'') then
 with TFSRec(Custom^) do begin
  family:=Trim(ExtractWord(2,Line,[sep]));
  if (family='') then Exit;
  if (aFile<>'') then begin
   filename:=Trim(ExtractWord(1,Line,[sep]));
   if not SameText(ExtractFileNameExt(aFile),ExtractFileNameExt(filename))
   then Exit;
  end;
  if (aStyle<>'') then begin
   style:=Trim(CookieScan(Line,'style',Ord(sep))); m:=0;
   if (style<>'') then begin
    for i:=1 to WordCount(aStyle,ScanSpaces) do
    if (WordIndex(ExtractWord(i,aStyle,ScanSpaces),style,ScanSpaces)>0)
    then begin inc(m); Break; end;
    if (m=0) then Exit;
   end else Exit;
  end;
  if (aSpacing<>'') then begin
   spacing:=TrimDef(CookieScan(Line,'spacing',Ord(sep)),'0'); m:=0;
   if (spacing<>'') then begin
    for i:=1 to WordCount(aSpacing,ScanSpaces) do
    if (WordIndex(ExtractWord(i,aSpacing,ScanSpaces),spacing,ScanSpaces)>0)
    then begin inc(m); Break; end;
    if (m=0) then Exit;
   end else Exit;
  end;
  if (aLang<>'') then begin
   lang:=Trim(CookieScan(Line,'lang',Ord(sep))); m:=0;
   if (lang<>'') then begin
    lang:='|'+lang+'|';
    for i:=1 to WordCount(aLang,ScanSpaces) do
    if (PosI('|'+ExtractWord(i,aLang,ScanSpaces)+'|',lang)>0)
    then begin inc(m); Break; end;
    if (m=0) then Exit;
   end else Exit;
  end;
  if (aName<>'') then begin
   m:=Ord(PosI(aName,family));
   if HasChars(family,[' ']) then
   m:=m+Ord(PosI(aName,StringReplace(family,' ','',[rfReplaceAll])))
       +Ord(PosI(aName,StringReplace(family,' ','_',[rfReplaceAll])));
   if (m=0) then Exit;
  end;
  List.Add(family);
 end;
end;
function GetUnixSystemFontsAsText(const aFile,aLang,aStyle,aSpacing,aName:LongString):LongString;
const cmd='fc-list : file family style spacing lang';
var outstr:LongString; FSRec:TFSRec;
begin
 Result:='';
 try
  if RunCommand(cmd,outstr) then begin
   FSRec:=Default(TFSRec);
   try
    FSRec.aFile:=StringBuffer(Trim(aFile));
    FSRec.aLang:=StringBuffer(Trim(aLang));
    FSRec.aStyle:=StringBuffer(Trim(aStyle));
    FSRec.aSpacing:=StringBuffer(Trim(aSpacing));
    FSRec.aName:=StringBuffer(Trim(aName));
    FSRec.List:=TStringList.Create;
    FSRec.List.Duplicates:=dupIgnore;
    FSRec.List.Sorted:=true;
    ForEachStringLine(outstr,fsIterator,@FSRec);
    Result:=FSRec.List.Text;
   finally
    FSRec.List.Free;
    FSRec.aFile:='';
    FSRec.aLang:='';
    FSRec.aStyle:='';
    FSRec.aSpacing:='';
    FSRec.aName:='';
   end;
  end;
 except
  on E:Exception do BugReport(E,nil,'GetSystemFontsAsTextUnix');
 end;
end;
function GetSystemFontsAsText(Charset,Pitch:Integer; const Name:LongString):LongString;
var lang,spacing:LongString;
begin
 lang:='';
 case Charset of
  ANSI_CHARSET        : lang:='';
  DEFAULT_CHARSET     : lang:='';
  SYMBOL_CHARSET      : lang:='';
  FCS_ISO_10646_1     : lang:='';                    // Unicode;
  FCS_ISO_8859_1      : lang:='';                    //  ISO Latin-1 (Western Europe);
  FCS_ISO_8859_2      : lang:='';                    //  ISO Latin-2 (Eastern Europe);
  FCS_ISO_8859_3      : lang:='';                    //  ISO Latin-3 (Southern Europe);
  FCS_ISO_8859_4      : lang:='';                    //  ISO Latin-4 (Northern Europe);
  FCS_ISO_8859_5      : lang:='ru';                  //  ISO Cyrillic;
  FCS_ISO_8859_6      : lang:='';                    //  ISO Arabic;
  FCS_ISO_8859_7      : lang:='';                    //  ISO Greek;
  FCS_ISO_8859_8      : lang:='';                    //  ISO Hebrew;
  FCS_ISO_8859_9      : lang:='';                    //  ISO Latin-5 (Turkish);
  FCS_ISO_8859_10     : lang:='';                    //  ISO Latin-6 (Nordic);
  FCS_ISO_8859_15     : lang:='';                    //  ISO Latin-9, or Latin-0 (Revised Western-European);
  MAC_CHARSET         : lang:='';
  SHIFTJIS_CHARSET    : lang:='';
  HANGEUL_CHARSET     : lang:='';
  JOHAB_CHARSET       : lang:='';
  GB2312_CHARSET      : lang:='';
  CHINESEBIG5_CHARSET : lang:='';
  GREEK_CHARSET       : lang:='';
  TURKISH_CHARSET     : lang:='';
  VIETNAMESE_CHARSET  : lang:='';
  HEBREW_CHARSET      : lang:='';
  ARABIC_CHARSET      : lang:='';
  BALTIC_CHARSET      : lang:='';
  RUSSIAN_CHARSET     : lang:='ru';
  THAI_CHARSET        : lang:='';
  EASTEUROPE_CHARSET  : lang:='';
  OEM_CHARSET         : lang:='ru,en';
 end;
 spacing:='';
 case Pitch of
  DEFAULT_PITCH  : spacing:='';
  FIXED_PITCH    : spacing:='100';
  VARIABLE_PITCH : spacing:='0,90,110';
  MONO_FONT      : spacing:='100';
 end;
 Result:=GetUnixSystemFontsAsText('',lang,'',spacing,Name);
end;
function SystemFontsFound(Charset:Integer=DEFAULT_CHARSET; Pitch:Integer=DEFAULT_PITCH; const Name:LongString=''):Integer;
begin
 Result:=ForEachStringLine(GetSystemFontsAsText(CharSet,Pitch,Name),nil,nil);
end;
{$ENDIF ~UNIX}

function AllocMem(Size:Cardinal):Pointer;
begin
 Result:=nil;
 if (Size>0) then
 try
  GetMem(Result,Size);
  ZeroMemory(Result,Size);
 except
  on E:Exception do BugReport(E,nil,'AllocMem');
 end;
end;

{$IFDEF WINDOWS}
procedure HandleException(E:Exception);
begin
 if E is Exception then BugReport(E);
end;

function ReallocMem(var P:Pointer; Size,Copy:Cardinal):Boolean;
var T,S:Pointer;
begin
 Result:=False;
 try
  T:=AllocMem(Size);
  if Assigned(T) then begin
   if (Copy>Size) then Copy:=Size;
   if not Assigned(P) then Copy:=0;
   if (Copy>0) then SafeMove(P^,T^,Copy);
   S:=P; P:=T; FreeMem(S);
   Result:=True;
  end;
 except
  on E:Exception do BugReport(E,nil,'ReallocMem');
 end;
end;

type
 TFontFaceName = array[0..LF_FACESIZE-1] of AnsiChar; // Like TLogFont.lfFaceName
 TFontItemsBuf = array[0..1] of TFontFaceName;
 TFontIndexBuf = array[0..1] of Integer;
 TEnumFontsRec = record
  Match:TFontFaceName;
  Pitch:Integer;
  List:record
   Size,Count:Integer;
   Items:^TFontItemsBuf;
   Index:^TFontIndexBuf;
  end;
 end;

function FindFontsProc(var LogFont:TLogFont; var TextMetric:TTextMetric; FontType:Integer; Data:Pointer):Integer; stdcall;
begin
 Result:=1;
 if Assigned(Data) then
 with TEnumFontsRec(Data^) do
 try
  if (Pitch=DEFAULT_PITCH) or (Pitch=(LogFont.lfPitchAndFamily and $F)) then
  if (StrLen(Match)=0) or (AnsiStrIComp(Match,LogFont.lfFaceName)=0) then Inc(List.Count);
 except
  on E:Exception do begin HandleException(E); Result:=0; end;
 end;
end;

function EnumFontsProc(var LogFont:TLogFont; var TextMetric:TTextMetric; FontType:Integer; Data:Pointer):Integer; stdcall;
var NewSize:Integer;
begin
 Result:=1;
 if Assigned(Data) then
 with TEnumFontsRec(Data^) do
 try
  if (List.Count>=List.Size) then begin
   NewSize:=List.Size*2; if NewSize=0 then NewSize:=1024;
   if ReallocMem(Pointer(List.Index),SizeOf(List.Index[0])*NewSize,SizeOf(List.Index[0])*List.Size) then
   if ReallocMem(Pointer(List.Items),SizeOf(List.Items[0])*NewSize,SizeOf(List.Items[0])*List.Size) then
   List.Size:=NewSize;
  end;
  if (List.Count>=List.Size) then Result:=0 else
  if (Pitch=DEFAULT_PITCH) or (Pitch=(LogFont.lfPitchAndFamily and $F)) then
  if (StrLen(Match)=0) or (AnsiStrLIComp(Match,LogFont.lfFaceName,StrLen(Match))=0) then
  if (List.Count=0) or (AnsiStrIComp(List.Items[List.Count-1],LogFont.lfFaceName)<>0) then begin
   StrLCopy(List.Items[List.Count],LogFont.lfFaceName,SizeOf(List.Items[0]));
   List.Index[List.Count]:=List.Count;
   Inc(List.Count);
  end;
 except
  on E:Exception do begin HandleException(E); Result:=0; end;
 end;
end;

procedure QuickSort(const Rec:TEnumFontsRec; L,R:Integer);
var I,J,M,T:Integer;
begin
 repeat
  I:=L; J:=R; M:=Rec.List.Index[(L+R) shr 1];
  repeat
   while AnsiStrIComp(Rec.List.Items[Rec.List.Index[I]],Rec.List.Items[M])<0 do Inc(I);
   while AnsiStrIComp(Rec.List.Items[Rec.List.Index[J]],Rec.List.Items[M])>0 do Dec(J);
   if I<=J then begin
    T:=Rec.List.Index[I]; Rec.List.Index[I]:=Rec.List.Index[J]; Rec.List.Index[J]:=T;
    Inc(I); Dec(J);
   end;
  until I>J;
  if L<J then QuickSort(Rec,L,J);
  L:=I;
 until I>=R;
end;

function GetSystemFontsAsText(Charset,Pitch:Integer; const Name:LongString):LongString;
var dc:HDC; LFont:TLogFont; Rec:TEnumFontsRec; i:Integer;
begin
 Result:='';
 try
  dc:=GetDC(0);
  if (dc<>0) then
  try
   ZeroMemory(@Rec,SizeOf(Rec)); Rec.Pitch:=Pitch;
   if Length(Trim(Name))>0 then StrLCopy(Rec.Match,PChar(SysUtils.Trim(Name)),SizeOf(Rec.Match));
   ZeroMemory(@LFont,SizeOf(LFont)); LFont.lfCharset:=Charset;
   EnumFontFamiliesEx(dc,@LFont,@EnumFontsProc,PointerToPtrInt(@Rec),0);
   if Rec.List.Count>0 then begin
    if Rec.List.Count>1 then QuickSort(Rec,0,Rec.List.Count-1);
    for i:=0 to Rec.List.Count-1 do Result:=Result+(Rec.List.Items[Rec.List.Index[i]]+EOL);
   end;
  finally
   ReleaseDC(0,dc);
   if Assigned(Rec.List.Index) then FreeMem(Rec.List.Index);
   if Assigned(Rec.List.Items) then FreeMem(Rec.List.Items);
  end;
 except
  on E:Exception do begin HandleException(E); Result:=''; end;
 end;
end;

function SystemFontsFound(Charset,Pitch:Integer; const Name:LongString):Integer;
var dc:HDC; LFont:TLogFont; Rec:TEnumFontsRec;
begin
 Result:=0;
 try
  dc:=GetDC(0);
  if (dc<>0) then
  try
   ZeroMemory(@Rec,SizeOf(Rec)); Rec.Pitch:=Pitch;
   if Length(Trim(Name))>0 then StrLCopy(Rec.Match,PChar(SysUtils.Trim(Name)),SizeOf(Rec.Match));
   ZeroMemory(@LFont,SizeOf(LFont)); LFont.lfCharset:=Charset;
   EnumFontFamiliesEx(dc,@LFont,@FindFontsProc,PointerToPtrInt(@Rec),0);
   Result:=Rec.List.Count;
  finally
   ReleaseDC(0,dc);
  end;
 except
  on E:Exception do begin HandleException(E); Result:=0; end;
 end;
end;

function GetTextFaceName(dc:HDC):LongString;
var Buff:TFontFaceName;
begin
 if GetTextFace(dc,SizeOf(Buff),Buff)>0 then Result:=Buff else Result:='';
end;

procedure PostBroadcastFontChange;
begin
 PostMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);
end;

function AddSystemFont(const FontPath:LongString; Post:Boolean=False):Integer;
begin
 Result:=0;
 if Length(Trim(FontPath))>0 then
 if FileExists(FontPath) then Result:=AddFontResource(PChar(FontPath));
 if Result>0 then if Post then PostBroadcastFontChange;
end;

function RemoveSystemFont(const FontPath:LongString; Post:Boolean=False):Integer;
begin
 Result:=0;
 if Length(Trim(FontPath))>0 then
 if RemoveFontResource(PChar(FontPath)) then Result:=1;
 if Result>0 then if Post then PostBroadcastFontChange;
end;

////////////////
// TEmbeddedFont
////////////////

constructor TEmbeddedFont.Create(const aNickName,aFontName,aFontSource,aFontTarget:LongString; aEmbed:Boolean=False);
begin
 inherited Create;
 myNickName:=Trim(aNickName);
 myFontName:=Trim(aFontName);
 myFontSource:=Trim(aFontSource);
 myFontTarget:=Trim(ExtractFileNameExt(aFontTarget));
 if aEmbed then SmartEmbed;
end;

destructor TEmbeddedFont.Destroy;
begin
 FontFree;
 DataFree;
 myNickName:='';
 myFontData:='';
 myFontName:='';
 myFontSource:='';
 myFontTarget:='';
 inherited Destroy;
end;

procedure TEmbeddedFont.AfterConstruction;
begin
 inherited AfterConstruction;
 FullEmbeddedFontList.Add(Self);
end;

procedure TEmbeddedFont.BeforeDestruction;
begin
 FullEmbeddedFontList.Remove(Self);
 inherited BeforeDestruction;
end;

procedure DeleteStr(var S:LongString; const T:LongString);
var p:Integer;
begin
 p:=Pos(T,S); if p>0 then Delete(S,p,Length(T));
end;

function TEmbeddedFont.GetFontFamily:LongString;
begin
 Result:=FontName;
 DeleteStr(Result,' Oblique');
 DeleteStr(Result,' Italic');
 DeleteStr(Result,' Курсив');
 DeleteStr(Result,' Полужирный');
 DeleteStr(Result,' Обычный');
 DeleteStr(Result,' Bold');
 Result:=SysUtils.Trim(Result);
end;

function TEmbeddedFont.GetNickName:LongString;
begin
 if Assigned(Self) then Result:=myNickName else Result:='';
end;

function TEmbeddedFont.GetFontData:LongString;
begin
 if Assigned(Self) then Result:=myFontData else Result:='';
end;

function TEmbeddedFont.GetFontName:LongString;
begin
 if Assigned(Self) then Result:=myFontName else Result:='';
end;

function TEmbeddedFont.GetFontSource:LongString;
begin
 if Assigned(Self) then Result:=myFontSource else Result:='';
end;

function TEmbeddedFont.GetFontTarget:LongString;
begin
 if Assigned(Self) then Result:=AddBackSlash(GetSystemFontsPath)+myFontTarget else Result:='';
end;

function TEmbeddedFont.GetFontHand:THandle;
begin
 if Assigned(Self) then Result:=myFontHand else Result:=0;
end;

function TEmbeddedFont.GetEmbedded:DWORD;
begin
 if Assigned(Self) then Result:=myEmbedded else Result:=0;
end;

function TEmbeddedFont.FontOk:Boolean;
begin
 if Assigned(Self) then Result:=(FontHand<>0) and (Embedded>0) else Result:=False;
end;

function TEmbeddedFont.DataOk:Boolean;
begin
 if Assigned(Self) then Result:=Length(myFontData)>0 else Result:=False;
end;

function TEmbeddedFont.Found(Charset:Integer=1; Pitch:Integer=0):Cardinal;
begin
 if Assigned(Self) then Result:=SystemFontsFound(Charset,Pitch,FontFamily) else Result:=0;
end;

procedure TEmbeddedFont.SmartEmbed(Charset:Integer=1; Pitch:Integer=0);
begin
 if Assigned(Self) then if Found(Charset,Pitch)=0 then FontEmbed;
end;

function TEmbeddedFont.DataLoad:Boolean;
const
 FontFizeSizeLoLimit = 1024;
 FontFileSizeHiLimit = 1024*1024*32;
var
 ResInfo:THandle; ResHand:THandle; ResData:PChar;
 ResSize,Count:Integer; ModuleName:LongString; Instance:LongWord;
begin
 Result:=False;
 if Assigned(Self) then
 if not DataOk then
 try
  DataFree;
  ResHand:=0;
  if IsSameText(ExtractFileExt(FontSource),'.EXE')
  or IsSameText(ExtractFileExt(FontSource),'.DLL') then
  try
   ModuleName:=ExtractFileNameExt(FontSource);
   Instance:=GetModuleHandle(PChar(ModuleName));
   if Instance=0 then Instance:=SafeLoadLibrary(PChar(FontSource));
   if Instance<>0 then begin
    ResInfo:=FindResource(Instance,PChar(NickName),RT_RCDATA);
    if ResInfo<>0 then ResHand:=LoadResource(Instance,ResInfo);
    if ResHand<>0 then begin
     ResData:=LockResource(ResHand);
     ResSize:=SizeOfResource(Instance,ResInfo);
     if (ResData<>nil) and (ResSize>0) then SetString(myFontData,ResData,ResSize);
    end;
   end;
  finally
   if ResHand<>0 then begin
    UnlockResource(ResHand);
    FreeResource(ResHand);
   end;
  end;
  if IsSameText(ExtractFileExt(FontSource),'.TTF')
  or IsSameText(ExtractFileExt(FontSource),'.OTF')
  or IsSameText(ExtractFileExt(FontSource),'.FON') then begin
   ResSize:=GetFileSize(FontSource);
   if (ResSize>=FontFizeSizeLoLimit) then
   if (ResSize<=FontFileSizeHiLimit) then begin
    SetLength(myFontData,ResSize);
    Count:=ReadFileToBuffer(FontSource,PChar(myFontData),Length(myFontData));
    if Count<>ResSize then myFontData:='';
   end;
  end;
  if not DataOk then DataFree;
  Result:=DataOk;
 except
  on E:Exception do HandleException(E);
 end;
end;

function TEmbeddedFont.FontEmbed:Integer;
begin
 Result:=0;
 if Assigned(Self) then
 if not FontOk then begin
  FontFree; DataLoad;
  if DataOk then myFontHand:=AddFontMemResourceEx(PChar(FontData),Length(FontData),nil,@myEmbedded);
  if not FontOk then FontFree;
  Result:=Embedded;
 end;
end;

procedure TEmbeddedFont.DataFree;
begin
 if Assigned(Self) then myFontData:='';
end;

procedure TEmbeddedFont.FontFree;
begin
 if Assigned(Self) then begin
  if FontHand<>0 then RemoveFontMemResourceEx(FontHand);
  myFontHand:=0; myEmbedded:=0;
 end;
end;

function TEmbeddedFont.FontSave(Add:Boolean=False;Post:Boolean=False):Integer;
begin
 Result:=0;
 if Assigned(Self) then if DataOk then
 if Length(FontTarget)>0 then if not FileExists(FontTarget) then
 try
  if (WriteBufferToFile(FontTarget,FontData)>0) then Result:=1;
  if Result>0 then if Add then AddSystemFont(FontTarget,Post);
 except
  on E:Exception do HandleException(E);
 end;
end;

////////////////////
// TEmbeddedFontList
////////////////////
function TEmbeddedFontList.GetEmbeddedFont(i:LongInt):TEmbeddedFont;
begin
 Result:=TEmbeddedFont(Items[i]);
end;

procedure TEmbeddedFontList.PutEmbeddedFont(i:LongInt; f:TEmbeddedFont);
begin
 Items[i]:=TObject(f);
end;

constructor TEmbeddedFontList.Create(aOwns:Boolean);
begin
 inherited Create(aOwns);
end;

destructor  TEmbeddedFontList.Destroy;
begin
 inherited Destroy;
end;

procedure TEmbeddedFontList.SmartEmbed(Charset:Integer=1; Pitch:Integer=0);
var i:Integer;
begin
 if Assigned(Self) then for i:=0 to Count-1 do Self[i].SmartEmbed(Charset,Pitch);
end;

function TEmbeddedFontList.Found(Charset:Integer=1; Pitch:Integer=0):Integer;
var i:Integer;
begin
 Result:=0;
 if Assigned(Self) then for i:=0 to Count-1 do Inc(Result,Ord(Self[i].Found(Charset,Pitch)>0));
end;

function TEmbeddedFontList.GetEmbedded:Integer;
var i:Integer;
begin
 Result:=0;
 if Assigned(Self) then for i:=0 to Count-1 do Inc(Result,Self[i].Embedded);
end;

function TEmbeddedFontList.FontSave(Add:Boolean=False;Post:Boolean=False):Integer;
var i:Integer;
begin
 Result:=0;
 if Assigned(Self) then for i:=0 to Count-1 do Inc(Result,Self[i].FontSave(Add));
 if Result>0 then if Add then if Post then PostBroadcastFontChange;
end;

function TEmbeddedFontList.FontEmbed:Integer;
var i:Integer;
begin
 Result:=0;
 if Assigned(Self) then for i:=0 to Count-1 do Inc(Result,Self[i].FontEmbed);
end;


procedure TEmbeddedFontList.DataFree;
var i:Integer;
begin
 if Assigned(Self) then for i:=0 to Count-1 do Self[i].DataFree;
end;

procedure TEmbeddedFontList.FontFree;
var i:Integer;
begin
 if Assigned(Self) then for i:=0 to Count-1 do Self[i].FontFree;
end;

procedure TEmbeddedFontList.FontKill;
var i:Integer;
begin
 if Assigned(Self) then
 for i:=Count-1 downto 0 do begin
  Self[i].Free; Delete(i);
 end;
end;

function TEmbeddedFontList.ReadIniFile(const IniFile   : LongString;
                                       const ThePrefix : LongString = 'EmbeddedFont';
                                       const SecList   : LongString = '[EmbeddedFontList]';
                                       const SecName   : LongString = '[EmbeddedFontName]';
                                       const SecSource : LongString = '[EmbeddedFontSource]';
                                       const SecTarget : LongString = '[EmbeddedFontTarget]'
                                                     ) : Integer;
var i:Integer; List:TText; Nick,Name,Source,Target:LongString; Font:TEmbeddedFont;
begin
 Result:=0;
 try
  List:=ExtractEnumWordList(SysIniFile,SecList,ThePrefix,efConfig);
  try
   for i:=0 to List.Count-1 do begin
    Nick:=Trim(List[i]); Name:=''; Source:=''; Target:='';
    if Length(Nick)>0 then
    if ReadIniFileString(SysIniFile,SecName,Nick+'%s',Name,efConfigNC) then
    if ReadIniFilePath(SysIniFile,SecTarget,Nick,GetSystemFontsPath,Target) then
    if ReadIniFilePath(SysIniFile,SecSource,Nick,HomeDir,Source) then begin
     Font:=TEmbeddedFont.Create(Nick,Name,Source,Target);
     if Font.Ok then Inc(Result);
    end;
   end;
  finally
   Kill(List);
  end;
 except
  on E:Exception do HandleException(E);
 end;
end;
 
function NewEmbeddedFontList(aOwns:Boolean):TEmbeddedFontList;
begin
 Result:=nil;
 try
  Result:=TEmbeddedFontList.Create(aOwns);
 except
  on E:Exception do HandleException(E);
 end;
end;

procedure Kill(var TheObject:TEmbeddedFontList); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do HandleException(E);
 end;
end;
{$ENDIF ~WINDOWS}

type
 TSysFontsList = array[ANSI_CHARSET..OEM_CHARSET] of array[DEFAULT_PITCH..VARIABLE_PITCH] of LongString;
var
 TheFonts : ^TSysFontsList = nil;

procedure TheSystemFontsReset;
var Charset,Pitch:Integer;
begin
 if not Assigned(TheFonts) then 
 try
  TheFonts:=AllocMem(SizeOf(TheFonts^));
  if Assigned(TheFonts) then
  for Charset:=ANSI_CHARSET to OEM_CHARSET do
  for Pitch:=DEFAULT_PITCH to VARIABLE_PITCH do
  TheFonts[Charset][Pitch]:='';
 except
  on E:Exception do BugReport(E,nil,'TheSystemFontsReset');
 end;
end;

procedure TheSystemFontsFree;
begin
 if Assigned(TheFonts) then
 try
  TheSystemFontsReset;
  FreeMem(TheFonts);
 except
  on E:Exception do BugReport(E,nil,'TheSystemFontsFree');
 end;
 TheFonts:=nil;
end;

function TheSystemFonts(Charset,Pitch:Integer):LongString;
begin
 Result:='';
 try
  if not Assigned(TheFonts)
  then TheSystemFontsReset;
  if Assigned(TheFonts) then begin
   if (Pitch<DEFAULT_PITCH) or (Pitch>VARIABLE_PITCH) then Pitch:=DEFAULT_PITCH;
   if (Charset<ANSI_CHARSET) or (Charset>OEM_CHARSET) then Charset:=DEFAULT_CHARSET;
   if Length(TheFonts[Charset][Pitch])=0 then TheFonts[Charset][Pitch]:=GetSystemFontsAsText(Charset,Pitch);
   Result:=TheFonts[Charset][Pitch];
  end;
 except
  on E:Exception do BugReport(E,nil,'TheSystemFonts');
 end;
end;

{$IFDEF WINDOWS}
const
 TheFullEmbeddedFontList : TEmbeddedFontList = nil;

function FullEmbeddedFontList:TEmbeddedFontList;
begin
 if not Assigned(TheFullEmbeddedFontList) then
 try
  TheFullEmbeddedFontList:=NewEmbeddedFontList(false);
  TheFullEmbeddedFontList.Master:=@TheFullEmbeddedFontList;
 except
  on E:Exception do BugReport(E,nil,'FullEmbeddedFontList');
 end;
 Result:=TheFullEmbeddedFontList;
end;
{$ENDIF ~WINDOWS}

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_fonts;
begin
 TheSystemFontsReset;
 {$IFDEF WINDOWS}
 TheFullEmbeddedFontList.Ok;
 {$ENDIF ~WINDOWS}
end;

procedure Free_crw_fonts;
begin
 {$IFDEF WINDOWS}
 ResourceLeakageLog(Format('%-60s = %d',['FullEmbeddedFontList.Count', TheFullEmbeddedFontList.Count]));
 Kill(TheFullEmbeddedFontList);
 {$ENDIF ~WINDOWS}
 TheSystemFontsFree;
end;

initialization

 Init_crw_fonts;

finalization

 Free_crw_fonts;

end.

//////////////
// END OF FILE
//////////////

