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.freepascal.org/pipermail/lazarus/attachments/20160409/17e59e8b/attachment.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 FFileInfonil 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;