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
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;
--
_______________________________________________
Lazarus mailing list
Lazarus@lists.lazarus.freepascal.org
http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus
