[Lazarus] PDF generator: please test

[Ondrej Pokorny]

I started testing.

1. Why does TFPFontCacheItem.GetFontData create and load TTFFileInfo 
every time it is called? As a result TTFFileInfo is created and loaded 
every time TextWidth is called - there's no way to go around this. The 
TTFFileInfo should be cached IMO.
Please consider the attached patch.

2. Is gTTFontCache/uFontCacheList really needed? fcl-pdf doesn't use it. 
The user should create such a variable by himself, IMO.

3. WriteText in combination with custom TTF font doesn't print anything. 
There should be an exception when calling WriteText with custom TTF font 
or the call should be redirected to WriteUTF8Text automatically. (See 
demo code below.)

4. I cannot make TFPFontCacheItem.TextWidth work. (I was able to make 
"TextWidth" work, though.) Could you please check the code below to see 
what I am doing wrong? I want to draw a rectangle around text. (I just 
added a procedure to the example project):

procedure TPDFTestApp.TextBox(D: TPDFDocument; APage: integer);
var
   P : TPDFPage;
   FtTitle: integer;
   xFontCache: TFPFontCacheList;
   xFont: TFPFontCacheItem;
   xWidth, xHeight, xDesc: Extended;
const
   cFontSize = 50;
begin
   P := D.Pages[APage];

   FtTitle := D.AddFont('FreeSans.ttf', 'FreeSans', clGreen);

   P.SetFont(FtTitle, cFontSize);
   P.SetColor(clBlack, false);
   P.WriteText(25, 0, 'Sample Text'); // DOESN'T WORK !!!
   P.WriteUTF8Text(25, 20, 'Sample Text');

   xFontCache := TFPFontCacheList.Create;
   try
     xFont := TFPFontCacheItem.Create('fonts\FreeSans.ttf');
     xFontCache.Add(xFont);
     xWidth := xFont.TextWidth('Sample Text', cFontSize) * 25.4 / 72; // 
25.4 / 72 = conversion PDFTomm (?)
     xHeight := xFont.GetFontData.CapHeight * cFontSize * xFontCache.DPI 
/ (72 * xFont.GetFontData.Head.UnitsPerEm) * 25.4 / 72;
     xDesc := xFont.GetFontData.Descender * cFontSize * xFontCache.DPI / 
(72 * xFont.GetFontData.Head.UnitsPerEm) * 25.4 / 72;
   finally
     xFontCache.Free;
   end;

   P.SetColor(clRed, true);
   P.SetColor($37b344, false); // some green color
   P.SetPenStyle(ppsDashDot);
   P.DrawRect(25, 20-xDesc, xWidth, xHeight, 1, False, True);
end;

Ondrej
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.lazarus-ide.org/pipermail/lazarus/attachments/20160409/17e59e8b/attachment-0003.html>
-------------- next part --------------
Index: fpttf.pp
===================================================================
--- fpttf.pp	(revision 33453)
+++ fpttf.pp	(working copy)
@@ -43,11 +43,13 @@
     FFamilyName: String;
     FFileName: String;
     FStyleFlags: LongWord;
+    FFileInfo: TTFFileInfo;
     FOwner: TFPFontCacheList; // reference to FontCacheList that owns this instance
     function    GetIsBold: boolean;
     function    GetIsFixedWidth: boolean;
     function    GetIsItalic: boolean;
     function    GetIsRegular: boolean;
+    procedure   SetFileName(const AFileName: String);
     procedure   SetIsBold(AValue: boolean);
     procedure   SetIsFixedWidth(AValue: boolean);
     procedure   SetIsItalic(AValue: boolean);
@@ -54,11 +56,12 @@
     procedure   SetIsRegular(AValue: boolean);
   public
     constructor Create(const AFilename: String);
-    { Returns the actual TTF font file information. Caller needs to free the returned instance. }
+    destructor  Destroy; override;
+    { Returns the actual TTF font file information. }
     function    GetFontData: TTFFileInfo;
     { Result is in pixels }
     function    TextWidth(AStr: string; APointSize: single): single;
-    property    FileName: String read FFileName write FFileName;
+    property    FileName: String read FFileName write SetFileName;
     property    FamilyName: String read FFamilyName write FFamilyName;
     { A bitmasked value describing the full font style }
     property    StyleFlags: LongWord read FStyleFlags write FStyleFlags;
@@ -147,6 +150,14 @@
   Result := (FStyleFlags and FP_FONT_STYLE_REGULAR) <> 0;
 end;
 
+procedure TFPFontCacheItem.SetFileName(const AFileName: String);
+begin
+  if FFileName = AFileName then Exit;
+  FFileName := AFileName;
+  if FFileInfo<>nil then
+    FreeAndNil(FFileInfo);
+end;
+
 procedure TFPFontCacheItem.SetIsBold(AValue: boolean);
 begin
   if AValue then
@@ -192,14 +203,25 @@
   FStyleFlags := FP_FONT_STYLE_REGULAR;
 end;
 
+destructor TFPFontCacheItem.Destroy;
+begin
+  FFileInfo.Free;
+
+  inherited Destroy;
+end;
+
 function TFPFontCacheItem.GetFontData: TTFFileInfo;
 begin
+  if FFileInfo <> nil then
+    Exit(FFileInfo);
+
   if FileName = '' then
     raise ETTF.Create(rsNoFontFileName);
   if FileExists(FileName) then
   begin
-    Result := TTFFileInfo.Create;
-    Result.LoadFromFile(FileName);
+    FFileInfo := TTFFileInfo.Create;
+    FFileInfo.LoadFromFile(FileName);
+    Result := FFileInfo;
   end
   else
     Result := nil;
@@ -262,25 +284,21 @@
     sl.Free;
   {$ENDIF}
 
-  try
-    lWidth := 0;
-    for i := 1 to Length(AStr) do
-    begin
-      c := AStr[i];
-      lGIndex := lFntInfo.GetGlyphIndex(Ord(c));
-      lWidth := lWidth + lFntInfo.GetAdvanceWidth(lGIndex);
-    end;
+  lWidth := 0;
+  for i := 1 to Length(AStr) do
+  begin
+    c := AStr[i];
+    lGIndex := lFntInfo.GetGlyphIndex(Ord(c));
+    lWidth := lWidth + lFntInfo.GetAdvanceWidth(lGIndex);
+  end;
 
-    if APointSize = 0.0 then
-      Result := lWidth
-    else
-    begin
-      { Converting Font Units to Pixels. The formula is:
-        pixels = glyph_units * pointSize * resolution / ( 72 points per inch * THead.UnitsPerEm )  }
-      Result := lWidth * APointSize * FOwner.DPI / (72 * lFntInfo.Head.UnitsPerEm);
-    end;
-  finally
-    lFntInfo.Free;
+  if APointSize = 0.0 then
+    Result := lWidth
+  else
+  begin
+    { Converting Font Units to Pixels. The formula is:
+      pixels = glyph_units * pointSize * resolution / ( 72 points per inch * THead.UnitsPerEm )  }
+    Result := lWidth * APointSize * FOwner.DPI / (72 * lFntInfo.Head.UnitsPerEm);
   end;
 end;