paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-28 03:30:30 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Fix from Graeme adding Font subset embedding and underline/strikethrough

Browse Source 
git-svn-id: trunk@35083 -
This commit is contained in:
michael 2016-12-09 12:51:06 +00:00
parent 1e374df5b8
commit b7083402cf
12 changed files with 1657 additions and 682 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -2595,6 +2595,7 @@ packages/fcl-pdf/examples/testfppdf.lpi svneol=native#text/plain
packages/fcl-pdf/examples/testfppdf.lpr svneol=native#text/plain packages/fcl-pdf/examples/testfppdf.lpr svneol=native#text/plain
packages/fcl-pdf/fpmake.pp svneol=native#text/plain packages/fcl-pdf/fpmake.pp svneol=native#text/plain
packages/fcl-pdf/readme.txt svneol=native#text/plain packages/fcl-pdf/readme.txt svneol=native#text/plain
packages/fcl-pdf/src/fontmetrics_stdpdf.inc svneol=native#text/plain
packages/fcl-pdf/src/fpparsettf.pp svneol=native#text/plain packages/fcl-pdf/src/fpparsettf.pp svneol=native#text/plain
packages/fcl-pdf/src/fppdf.pp svneol=native#text/plain packages/fcl-pdf/src/fppdf.pp svneol=native#text/plain
packages/fcl-pdf/src/fpttf.pp svneol=native#text/plain packages/fcl-pdf/src/fpttf.pp svneol=native#text/plain

73
packages/fcl-pdf/examples/testfppdf.lpr
View File

@ -35,6 +35,7 @@ type
FTextCompression, FTextCompression,
FFontCompression: boolean; FFontCompression: boolean;
FNoFontEmbedding: boolean; FNoFontEmbedding: boolean;
FSubsetFontEmbedding: boolean;
FDoc: TPDFDocument; FDoc: TPDFDocument;
function SetUpDocument: TPDFDocument; function SetUpDocument: TPDFDocument;
procedure SaveDocument(D: TPDFDocument); procedure SaveDocument(D: TPDFDocument);
@ -77,8 +78,13 @@ begin
Result.Infos.CreationDate := Now; Result.Infos.CreationDate := Now;
lOpts := [poPageOriginAtTop]; lOpts := [poPageOriginAtTop];
if FSubsetFontEmbedding then
Include(lOpts, poSubsetFont);
if FNoFontEmbedding then if FNoFontEmbedding then
begin
Include(lOpts, poNoEmbeddedFonts); Include(lOpts, poNoEmbeddedFonts);
Exclude(lOpts, poSubsetFont);
end;
if FFontCompression then if FFontCompression then
Include(lOpts, poCompressFonts); Include(lOpts, poCompressFonts);
if FTextCompression then if FTextCompression then
@ -132,7 +138,8 @@ end;
procedure TPDFTestApp.SimpleText(D: TPDFDocument; APage: integer); procedure TPDFTestApp.SimpleText(D: TPDFDocument; APage: integer);
var var
P : TPDFPage; P : TPDFPage;
FtTitle, FtText1, FtText2, FtText3: integer; FtTitle, FtText1, FtText2: integer;
FtWaterMark: integer;
begin begin
P := D.Pages[APage]; P := D.Pages[APage];
@ -140,14 +147,16 @@ begin
FtTitle := D.AddFont('Helvetica'); FtTitle := D.AddFont('Helvetica');
FtText1 := D.AddFont('FreeSans.ttf', 'FreeSans'); FtText1 := D.AddFont('FreeSans.ttf', 'FreeSans');
FtText2 := D.AddFont('Times-BoldItalic'); FtText2 := D.AddFont('Times-BoldItalic');
// FtText3 := D.AddFont('arial.ttf', 'Arial'); FtWaterMark := D.AddFont('Helvetica-Bold');
FtText3 := FtText1; // to reduce font dependecies, but above works too if you have arial.ttf available
{ Page title } { Page title }
P.SetFont(FtTitle, 23); P.SetFont(FtTitle, 23);
P.SetColor(clBlack, false); P.SetColor(clBlack, false);
P.WriteText(25, 20, 'Sample Text'); P.WriteText(25, 20, 'Sample Text');
P.SetFont(FtWaterMark, 120);
P.SetColor(clWaterMark, false);
P.WriteText(55, 190, 'Sample', 45);
// ----------------------------------- // -----------------------------------
// Write text using PDF standard fonts // Write text using PDF standard fonts
@ -158,6 +167,12 @@ begin
P.WriteText(25, 57, 'Click the URL: http://www.freepascal.org'); P.WriteText(25, 57, 'Click the URL: http://www.freepascal.org');
P.AddExternalLink(54, 58, 49, 5, 'http://www.freepascal.org', false); P.AddExternalLink(54, 58, 49, 5, 'http://www.freepascal.org', false);
// strike-through text
P.WriteText(25, 64, 'Strike-Through text', 0, false, true);
// strike-through text
P.WriteText(65, 64, 'Underlined text', 0, true);
// rotated text // rotated text
P.SetColor(clBlue, false); P.SetColor(clBlue, false);
P.WriteText(25, 100, 'Rotated text at 30 degrees', 30); P.WriteText(25, 100, 'Rotated text at 30 degrees', 30);
@ -169,17 +184,16 @@ begin
// ----------------------------------- // -----------------------------------
// TrueType testing purposes // TrueType testing purposes
P.SetFont(ftText3, 13); P.SetFont(FtText1, 13);
P.SetColor(clBlack, false); P.SetColor(clBlack, false);
P.WriteText(15, 120, 'Languages: English: Hello, World!'); P.WriteText(15, 120, 'Languages: English: Hello, World!');
P.WriteText(40, 130, 'Greek: Γειά σου κόσμος'); P.WriteText(40, 130, 'Greek: Γεια σου κόσμος');
P.WriteText(40, 140, 'Polish: Witaj świecie'); P.WriteText(40, 140, 'Polish: Witaj świecie');
P.WriteText(40, 150, 'Portuguese: Olá mundo'); P.WriteText(40, 150, 'Portuguese: Olá mundo');
P.WriteText(40, 160, 'Russian: Здравствуйте мир'); P.WriteText(40, 160, 'Russian: Здравствуйте мир');
P.WriteText(40, 170, 'Vietnamese: Xin chào thế giới'); P.WriteText(40, 170, 'Vietnamese: Xin chào thế giới');
P.SetFont(ftText1, 13);
P.WriteText(15, 185, 'Box Drawing: ╠ ╣ ╦ ╩ ├ ┤ ┬ ┴'); P.WriteText(15, 185, 'Box Drawing: ╠ ╣ ╦ ╩ ├ ┤ ┬ ┴');
P.WriteText(15, 200, 'Typography: “What’s wrong?”'); P.WriteText(15, 200, 'Typography: “What’s wrong?”');
@ -213,30 +227,30 @@ begin
P.WriteText(25, 20, 'Sample Line Drawing (DrawLine)'); P.WriteText(25, 20, 'Sample Line Drawing (DrawLine)');
P.SetColor(clBlack, True); P.SetColor(clBlack, True);
P.SetPenStyle(ppsSolid); P.SetPenStyle(ppsSolid, 1);
lPt1.X := 30; lPt1.Y := 100; lPt1.X := 30; lPt1.Y := 100;
lPt2.X := 150; lPt2.Y := 150; lPt2.X := 150; lPt2.Y := 150;
P.DrawLine(lPt1, lPt2, 0.2); P.DrawLine(lPt1, lPt2, 1);
P.SetColor(clBlue, True); P.SetColor(clBlue, True);
P.SetPenStyle(ppsDash); P.SetPenStyle(ppsDash, 1);
lPt1.X := 50; lPt1.Y := 70; lPt1.X := 50; lPt1.Y := 70;
lPt2.X := 180; lPt2.Y := 100; lPt2.X := 180; lPt2.Y := 100;
P.DrawLine(lPt1, lPt2, 0.1); P.DrawLine(lPt1, lPt2, 1);
{ we can also use coordinates directly, without TPDFCoord variables } { we can also use coordinates directly, without TPDFCoord variables }
P.SetColor(clRed, True); P.SetColor(clRed, True);
P.SetPenStyle(ppsDashDot); P.SetPenStyle(ppsDashDot, 1);
P.DrawLine(40, 140, 160, 80, 1); P.DrawLine(40, 140, 160, 80, 1);
P.SetColor(clBlack, True); P.SetColor(clBlack, True);
P.SetPenStyle(ppsDashDotDot); P.SetPenStyle(ppsDashDotDot, 1);
P.DrawLine(60, 50, 60, 120, 1.5); P.DrawLine(60, 50, 60, 120, 1);
P.SetColor(clBlack, True); P.SetColor(clBlack, True);
P.SetPenStyle(ppsDot); P.SetPenStyle(ppsDot, 1);
P.DrawLine(10, 80, 130, 130, 0.5); P.DrawLine(10, 80, 130, 130, 1);
end; end;
procedure TPDFTestApp.SimpleLines(D: TPDFDocument; APage: integer); procedure TPDFTestApp.SimpleLines(D: TPDFDocument; APage: integer);
@ -256,11 +270,11 @@ begin
P.WriteText(25, 20, 'Sample Line Drawing (DrawLineStyle)'); P.WriteText(25, 20, 'Sample Line Drawing (DrawLineStyle)');
// write the text at position 100 mm from left and 120 mm from top // write the text at position 100 mm from left and 120 mm from top
TsThinBlack := D.AddLineStyleDef(0.2, clBlack, ppsSolid); TsThinBlack := D.AddLineStyleDef(1, clBlack, ppsSolid);
TsThinBlue := D.AddLineStyleDef(0.1, clBlue, ppsDash); TsThinBlue := D.AddLineStyleDef(1, clBlue, ppsDash);
TsThinRed := D.AddLineStyleDef(1, clRed, ppsDashDot); TsThinRed := D.AddLineStyleDef(1, clRed, ppsDashDot);
TsThick := D.AddLineStyleDef(1.5, clBlack, ppsDashDotDot); TsThick := D.AddLineStyleDef(1, clBlack, ppsDashDotDot);
TsThinBlackDot := D.AddLineStyleDef(0.5, clBlack, ppsDot); TsThinBlackDot := D.AddLineStyleDef(1, clBlack, ppsDot);
lPt1.X := 30; lPt1.Y := 100; lPt1.X := 30; lPt1.Y := 100;
lPt2.X := 150; lPt2.Y := 150; lPt2.X := 150; lPt2.Y := 150;
@ -697,6 +711,7 @@ var
lFontIdx: integer; lFontIdx: integer;
lFC: TFPFontCacheItem; lFC: TFPFontCacheItem;
lHeight: single; lHeight: single;
lDescenderHeight: single;
lTextHeightInMM: single; lTextHeightInMM: single;
lWidth: single; lWidth: single;
lTextWidthInMM: single; lTextWidthInMM: single;
@ -719,21 +734,15 @@ begin
if not Assigned(lFC) then if not Assigned(lFC) then
raise Exception.Create(AFontName + ' font not found'); raise Exception.Create(AFontName + ' font not found');
{ result is in pixels } lHeight := lFC.TextHeight(AText, APointSize, lDescenderHeight);
lHeight := lFC.FontData.CapHeight * APointSize * gTTFontCache.DPI / (72 * lFC.FontData.Head.UnitsPerEm); { convert the Font Units to mm as our PDFPage.UnitOfMeasure is set to mm. }
{ convert pixels to mm as our PDFPage.UnitOfMeasure is set to mm. } lTextHeightInMM := (lHeight * 25.4) / gTTFontCache.DPI;
lTextHeightInMM := (lHeight * 25.4) / gTTFontCache.DPI; lDescenderHeightInMM := (lDescenderHeight * 25.4) / gTTFontCache.DPI;
lWidth := lFC.TextWidth(AText, APointSize); lWidth := lFC.TextWidth(AText, APointSize);
{ convert the Font Units to Millimeters } { convert the Font Units to mm as our PDFPage.UnitOfMeasure is set to mm. }
lTextWidthInMM := (lWidth * 25.4) / gTTFontCache.DPI; lTextWidthInMM := (lWidth * 25.4) / gTTFontCache.DPI;
{ result is in pixels }
lHeight := Abs(lFC.FontData.Descender) * APointSize * gTTFontCache.DPI /
(72 * lFC.FontData.Head.UnitsPerEm);
{ convert pixels to mm as you PDFPage.UnitOfMeasure is set to mm. }
lDescenderHeightInMM := (lHeight * 25.4) / gTTFontCache.DPI;
{ adjust the Y coordinate for the font Descender, because { adjust the Y coordinate for the font Descender, because
WriteText() draws on the baseline. Also adjust the TextHeight WriteText() draws on the baseline. Also adjust the TextHeight
because CapHeight doesn't take into account the Descender. } because CapHeight doesn't take into account the Descender. }
@ -766,7 +775,7 @@ begin
StopOnException:=True; StopOnException:=True;
inherited DoRun; inherited DoRun;
// quick check parameters // quick check parameters
ErrorMsg := CheckOptions('hp:f:t:i:j:n', ''); ErrorMsg := CheckOptions('hp:f:t:i:j:ns', '');
if ErrorMsg <> '' then if ErrorMsg <> '' then
begin begin
WriteLn('ERROR: ' + ErrorMsg); WriteLn('ERROR: ' + ErrorMsg);
@ -797,6 +806,7 @@ begin
end; end;
FNoFontEmbedding := HasOption('n', ''); FNoFontEmbedding := HasOption('n', '');
FSubsetFontEmbedding := HasOption('s', '');
FFontCompression := BoolFlag('f',true); FFontCompression := BoolFlag('f',true);
FTextCompression := BoolFlag('t',False); FTextCompression := BoolFlag('t',False);
FImageCompression := BoolFlag('i',False); FImageCompression := BoolFlag('i',False);
@ -852,6 +862,7 @@ begin
' If this option is not specified, then all %0:d pages are' + LineEnding + ' If this option is not specified, then all %0:d pages are' + LineEnding +
' generated.', [cPageCount])); ' generated.', [cPageCount]));
writeln(' -n If specified, no fonts will be embedded.'); writeln(' -n If specified, no fonts will be embedded.');
writeln(' -s If specified, subset TTF font embedding will occur.');
writeln(' -f <0|1> Toggle embedded font compression. A value of 0' + LineEnding + writeln(' -f <0|1> Toggle embedded font compression. A value of 0' + LineEnding +
' disables compression. A value of 1 enables compression.' + LineEnding + ' disables compression. A value of 1 enables compression.' + LineEnding +
' If -n is specified, this option is ignored.'); ' If -n is specified, this option is ignored.');

1
packages/fcl-pdf/fpmake.pp
View File

@ -28,6 +28,7 @@ begin
P.Dependencies.Add('rtl-objpas'); P.Dependencies.Add('rtl-objpas');
P.Dependencies.Add('fcl-base'); P.Dependencies.Add('fcl-base');
P.Dependencies.Add('fcl-image'); P.Dependencies.Add('fcl-image');
P.Dependencies.Add('fcl-xml');
P.Dependencies.Add('paszlib'); P.Dependencies.Add('paszlib');
P.Version:='3.1.1'; P.Version:='3.1.1';
T:=P.Targets.AddUnit('src/fpttfencodings.pp'); T:=P.Targets.AddUnit('src/fpttfencodings.pp');

222
packages/fcl-pdf/src/fontmetrics_stdpdf.inc Normal file
View File

@ -0,0 +1,222 @@
const
// helvetica (used metric equivalent Liberation Sans as substitute)
FONT_HELVETICA_ARIAL: array[0..255] of integer = (
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,
569,569,727,1139,1139,1821,1366,391,682,682,797,1196,569,682,569,569,1139,1139,
1139,1139,1139,1139,1139,1139,1139,1139,569,569,1196,1196,1196,1139,2079,1366,
1366,1479,1479,1366,1251,1593,1479,569,1024,1366,1139,1706,1479,1593,1366,1593,
1479,1366,1251,1479,1366,1933,1366,1366,1251,569,569,569,961,1139,682,1139,1139,
1024,1139,1139,569,1139,1139,455,455,1024,455,1706,1139,1139,1139,1139,682,1024,
569,1139,1024,1479,1024,1024,1024,684,532,684,1196,1536,1536,1536,1536,1536,1536,
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,569,682,1139,1139,1139,1139,
532,1139,682,1509,758,1139,1196,682,1509,1131,819,1124,682,682,682,1180,1100,682,
682,682,748,1139,1708,1708,1708,1251,1366,1366,1366,1366,1366,1366,2048,1479,1366,
1366,1366,1366,569,569,569,569,1479,1479,1593,1593,1593,1593,1593,1196,1593,1479,
1479,1479,1479,1366,1366,1251,1139,1139,1139,1139,1139,1139,1821,1024,1139,1139,
1139,1139,569,569,569,569,1139,1139,1139,1139,1139,1139,1139,1124,1251,1139,1139,
1139,1139,1024,1139,1024 );
FONT_HELVETICA_ARIAL_CAPHEIGHT = 1409;
FONT_HELVETICA_ARIAL_DESCENDER = 431;
// helveticaB (used metric equivalent Liberation Sans Bold as substitute)
FONT_HELVETICA_ARIAL_BOLD: array[0..255] of integer = (
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,
569,682,971,1139,1139,1821,1479,487,682,682,797,1196,569,682,569,569,1139,1139,
1139,1139,1139,1139,1139,1139,1139,1139,682,682,1196,1196,1196,1251,1997,1479,
1479,1479,1479,1366,1251,1593,1479,569,1139,1479,1251,1706,1479,1593,1366,1593,
1479,1366,1251,1479,1366,1933,1366,1366,1251,682,569,682,1196,1139,682,1139,1251,
1139,1251,1139,682,1251,1251,569,569,1139,569,1821,1251,1251,1251,1251,797,1139,
682,1251,1139,1593,1139,1139,1024,797,573,797,1196,1536,1536,1536,1536,1536,1536,
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,569,682,1139,1139,1139,1139,
573,1139,682,1509,758,1139,1196,682,1509,1131,819,1124,682,682,682,1180,1139,682,
682,682,748,1139,1708,1708,1708,1251,1479,1479,1479,1479,1479,1479,2048,1479,1366,
1366,1366,1366,569,569,569,569,1479,1479,1593,1593,1593,1593,1593,1196,1593,1479,
1479,1479,1479,1366,1366,1251,1139,1139,1139,1139,1139,1139,1821,1139,1139,1139,
1139,1139,569,569,569,569,1251,1251,1251,1251,1251,1251,1251,1124,1251,1251,1251,
1251,1251,1139,1251,1139 );
FONT_HELVETICA_ARIAL_BOLD_CAPHEIGHT = 688;
FONT_HELVETICA_ARIAL_BOLD_DESCENDER = 210;
// helveticaI (used metric equivalent Liberation Sans Italic as substitute)
FONT_HELVETICA_ARIAL_ITALIC: array[0..255] of Integer = (
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,
569,569,727,1139,1139,1821,1366,391,682,682,797,1196,569,682,569,569,1139,1139,
1139,1139,1139,1139,1139,1139,1139,1139,569,569,1196,1196,1196,1139,2079,1366,
1366,1479,1479,1366,1251,1593,1479,569,1024,1366,1139,1706,1479,1593,1366,1593,
1479,1366,1251,1479,1366,1933,1366,1366,1251,569,569,569,961,1139,682,1139,1139,
1024,1139,1139,569,1139,1139,455,455,1024,455,1706,1139,1139,1139,1139,682,1024,
569,1139,1024,1479,1024,1024,1024,684,532,684,1196,1536,1536,1536,1536,1536,1536,
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,569,682,1139,1139,1139,
1139,532,1139,682,1509,758,1139,1196,682,1509,1131,819,1124,682,682,682,1180,1100,
682,682,682,748,1139,1708,1708,1708,1251,1366,1366,1366,1366,1366,1366,2048,1479,
1366,1366,1366,1366,569,569,569,569,1479,1479,1593,1593,1593,1593,1593,1196,1593,
1479,1479,1479,1479,1366,1366,1251,1139,1139,1139,1139,1139,1139,1821,1024,1139,
1139,1139,1139,569,569,569,569,1139,1139,1139,1139,1139,1139,1139,1124,1251,1139,
1139,1139,1139,1024,1139,1024 );
FONT_HELVETICA_ARIAL_ITALIC_CAPHEIGHT = 688;
FONT_HELVETICA_ARIAL_ITALIC_DESCENDER = 208;
// helveticaBI (used metric equivalent Liberation Sans Bold Italic as substitute)
FONT_HELVETICA_ARIAL_BOLD_ITALIC: array[0..255] of Integer = (
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,
569,682,971,1139,1139,1821,1479,487,682,682,797,1196,569,682,569,569,1139,1139,
1139,1139,1139,1139,1139,1139,1139,1139,682,682,1196,1196,1196,1251,1997,1479,
1479,1479,1479,1366,1251,1593,1479,569,1139,1479,1251,1706,1479,1593,1366,1593,
1479,1366,1251,1479,1366,1933,1366,1366,1251,682,569,682,1196,1139,682,1139,1251,
1139,1251,1139,682,1251,1251,569,569,1139,569,1821,1251,1251,1251,1251,797,1139,
682,1251,1139,1593,1139,1139,1024,797,573,797,1196,1536,1536,1536,1536,1536,1536,
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,
1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,1536,569,682,1139,1139,1139,
1139,573,1139,682,1509,758,1139,1196,682,1509,1131,819,1124,682,682,682,1180,1139,
682,682,682,748,1139,1708,1708,1708,1251,1479,1479,1479,1479,1479,1479,2048,1479,
1366,1366,1366,1366,569,569,569,569,1479,1479,1593,1593,1593,1593,1593,1196,1593,
1479,1479,1479,1479,1366,1366,1251,1139,1139,1139,1139,1139,1139,1821,1139,1139,
1139,1139,1139,569,569,569,569,1251,1251,1251,1251,1251,1251,1251,1124,1251,1251,
1251,1251,1251,1139,1251,1139 );
FONT_HELVETICA_ARIAL_BOLD_ITALIC_CAPHEIGHT = 688;
FONT_HELVETICA_ARIAL_BOLD_ITALIC_DESCENDER = 210;
// times (used metric equivalent Liberation Serif as substitute)
FONT_TIMES: array[0..255] of Integer = (
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,
512,682,836,1024,1024,1706,1593,369,682,682,1024,1155,512,682,512,569,1024,1024,
1024,1024,1024,1024,1024,1024,1024,1024,569,569,1155,1155,1155,909,1886,1479,1366,
1366,1479,1251,1139,1479,1479,682,797,1479,1251,1821,1479,1479,1139,1479,1366,
1139,1251,1479,1479,1933,1479,1479,1251,682,569,682,961,1024,682,909,1024,909,
1024,909,682,1024,1024,569,569,1024,569,1593,1024,1024,1024,1024,682,797,569,
1024,1024,1479,1024,1024,909,983,410,983,1108,1593,1593,1593,1593,1593,1593,1593,
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,512,682,1024,1024,1024,1024,
410,1024,682,1556,565,1024,1155,682,1556,1024,819,1124,614,614,682,1180,928,682,
682,614,635,1024,1536,1536,1536,909,1479,1479,1479,1479,1479,1479,1821,1366,1251,
1251,1251,1251,682,682,682,682,1479,1479,1479,1479,1479,1479,1479,1155,1479,1479,
1479,1479,1479,1479,1139,1024,909,909,909,909,909,909,1366,909,909,909,909,909,
569,569,569,569,1024,1024,1024,1024,1024,1024,1024,1124,1024,1024,1024,1024,1024,
1024,1024,1024 );
FONT_TIMES_CAPHEIGHT = 1341;
FONT_TIMES_DESCENDER = 442;
// timesI (used metric equivalent Liberation Serif Italic as substitute)
FONT_TIMES_ITALIC: array[0..255] of Integer = (
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,
512,682,860,1024,1024,1706,1593,438,682,682,1024,1382,512,682,512,569,1024,1024,
1024,1024,1024,1024,1024,1024,1024,1024,682,682,1382,1382,1382,1024,1884,1251,
1251,1366,1479,1251,1251,1479,1479,682,909,1366,1139,1706,1366,1479,1251,1479,
1251,1024,1139,1479,1251,1706,1251,1139,1139,797,569,797,864,1024,682,1024,1024,
909,1024,909,569,1024,1024,569,569,909,569,1479,1024,1024,1024,1024,797,797,569,
1024,909,1366,909,909,797,819,563,819,1108,1593,1593,1593,1593,1593,1593,1593,
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,512,797,1024,1024,1024,1024,
563,1024,682,1556,565,1024,1382,682,1556,1024,819,1124,614,614,682,1180,1071,512,
682,614,635,1024,1536,1536,1536,1024,1251,1251,1251,1251,1251,1251,1821,1366,1251,
1251,1251,1251,682,682,682,682,1479,1366,1479,1479,1479,1479,1479,1382,1479,1479,
1479,1479,1479,1139,1251,1024,1024,1024,1024,1024,1024,1024,1366,909,909,909,909,
909,569,569,569,569,1024,1024,1024,1024,1024,1024,1024,1124,1024,1024,1024,1024,
1024,909,1024,909 );
FONT_TIMES_ITALIC_CAPHEIGHT = 655;
FONT_TIMES_ITALIC_DESCENDER = 216;
//timesB (used metric equivalent Liberation Serif Bold as substitute)
FONT_TIMES_BOLD: array[0..255] of Integer = (
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,
512,682,1137,1024,1024,2048,1706,569,682,682,1024,1167,512,682,512,569,1024,1024,
1024,1024,1024,1024,1024,1024,1024,1024,682,682,1167,1167,1167,1024,1905,1479,
1366,1479,1479,1366,1251,1593,1593,797,1024,1593,1366,1933,1479,1593,1251,1593,
1479,1139,1366,1479,1479,2048,1479,1479,1366,682,569,682,1190,1024,682,1024,1139,
909,1139,909,682,1024,1139,569,682,1139,569,1706,1139,1024,1139,1139,909,797,682,
1139,1024,1479,1024,1024,909,807,451,807,1065,1593,1593,1593,1593,1593,1593,1593,
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,512,682,1024,1024,1024,1024,451,
1024,682,1530,614,1024,1167,682,1530,1024,819,1124,614,614,682,1180,1106,683,682,
614,676,1024,1536,1536,1536,1024,1479,1479,1479,1479,1479,1479,2048,1479,1366,
1366,1366,1366,797,797,797,797,1479,1479,1593,1593,1593,1593,1593,1167,1593,1479,
1479,1479,1479,1479,1251,1139,1024,1024,1024,1024,1024,1024,1479,909,909,909,909,
909,569,569,569,569,1024,1139,1024,1024,1024,1024,1024,1124,1024,1139,1139,1139,
1139,1024,1139,1024 );
FONT_TIMES_BOLD_CAPHEIGHT = 655;
FONT_TIMES_BOLD_DESCENDER = 216;
// timesBI (used metric equivalent Liberation Serif Bold Italic as substitute)
FONT_TIMES_BOLD_ITALIC: array[0..255] of Integer = (
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,
512,797,1137,1024,1024,1706,1593,569,682,682,1024,1167,512,682,512,569,1024,1024,
1024,1024,1024,1024,1024,1024,1024,1024,682,682,1167,1167,1167,1024,1704,1366,
1366,1366,1479,1366,1366,1479,1593,797,1024,1366,1251,1821,1479,1479,1251,1479,
1366,1139,1251,1479,1366,1821,1366,1251,1251,682,569,682,1167,1024,682,1024,1024,
909,1024,909,682,1024,1139,569,569,1024,569,1593,1139,1024,1024,1024,797,797,569,
1139,909,1366,1024,909,797,713,451,713,1167,1593,1593,1593,1593,1593,1593,1593,
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,
1593,1593,1593,1593,1593,1593,1593,1593,1593,1593,512,797,1024,1024,1024,1024,451,
1024,682,1530,545,1024,1241,682,1530,1024,819,1124,614,614,682,1180,1024,512,682,
614,614,1024,1536,1536,1536,1024,1366,1366,1366,1366,1366,1366,1933,1366,1366,
1366,1366,1366,797,797,797,797,1479,1479,1479,1479,1479,1479,1479,1167,1479,1479,
1479,1479,1479,1251,1251,1024,1024,1024,1024,1024,1024,1024,1479,909,909,909,909,
909,569,569,569,569,1024,1139,1024,1024,1024,1024,1024,1124,1024,1139,1139,1139,
1139,909,1024,909 );
FONT_TIMES_BOLD_ITALIC_CAPHEIGHT = 655;
FONT_TIMES_BOLD_ITALIC_DESCENDER = 216;
// courier courierB courierI courierBI
FONT_COURIER_FULL: array[0..255] of Integer = (
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,
1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229,1229 );
FONT_TIMES_COURIER_CAPHEIGHT = 613;
FONT_TIMES_COURIER_DESCENDER = 386;
// symbol
FONT_SYMBOL: array[0..255] of Integer = (
250,250,250,250,250,250,250,250,250,250,250,250,250,250,250,250,250,250,250,250,250,250,
250,250,250,250,250,250,250,250,250,250,250,333,713,500,549,833,778,439,333,333,500,549,
250,549,250,278,500,500,500,500,500,500,500,500,500,500,278,278,549,549,549,444,549,722,
667,722,612,611,763,603,722,333,631,722,686,889,722,722,768,741,556,592,611,690,439,768,
645,795,611,333,863,333,658,500,500,631,549,549,494,439,521,411,603,329,603,549,549,576,
521,549,549,521,549,603,439,576,713,686,493,686,494,480,200,480,549,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,750,620,247,549,167,713,500,753,753,753,753,1042,987,603,987,603,
400,549,411,549,549,713,494,460,549,549,549,549,1000,603,1000,658,823,686,795,987,768,768,
823,768,768,713,713,713,713,713,713,713,768,713,790,790,890,823,549,250,713,603,603,1042,
987,603,987,603,494,329,790,790,786,713,384,384,384,384,384,384,494,494,494,494,0,329,
274,686,686,686,384,384,384,384,384,384,494,494,494,0);
// zapfdingbats
FONT_ZAPFDINGBATS: array[0..255] of Integer = (
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,278,974,961,974,980,719,789,790,791,690,960,939,
549,855,911,933,911,945,974,755,846,762,761,571,677,763,760,759,754,494,552,537,577,692,
786,788,788,790,793,794,816,823,789,841,823,833,816,831,923,744,723,749,790,792,695,776,
768,792,759,707,708,682,701,826,815,789,789,707,687,696,689,786,787,713,791,785,791,873,
761,762,762,759,759,892,892,788,784,438,138,277,415,392,392,668,668,0,390,390,317,317,
276,276,509,509,410,410,234,234,334,334,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,732,544,544,910,667,760,760,776,595,694,626,788,788,788,788,
788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,
788,788,788,788,788,788,788,788,788,788,788,788,788,788,894,838,1016,458,748,924,748,918,
927,928,928,834,873,828,924,924,917,930,931,463,883,836,836,867,867,696,696,874,0,874,
760,946,771,865,771,888,967,888,831,873,927,970,918,0);

245
packages/fcl-pdf/src/fpparsettf.pp
View File

@ -23,16 +23,22 @@ unit fpparsettf;
interface interface
uses uses
Classes, SysUtils, fpttfencodings; Classes,
SysUtils,
fpttfencodings;
type type
ETTF = Class(Exception); ETTF = Class(Exception);
// Tables recognized in this unit. // Tables recognized in this unit.
TTTFTableType = (ttUnknown,ttHead,tthhea,ttmaxp,tthmtx,ttcmap,ttname,ttOS2,ttpost {,ttglyph}); TTTFTableType = (
// these are for general font information
ttUnknown,ttHead,tthhea,ttmaxp,tthmtx,ttcmap,ttname,ttOS2,ttpost,
// these are used for font subsetting
ttglyf,ttloca,ttcvt,ttprep,ttfpgm);
TSmallintArray = Packed Array of Int16; TSmallintArray = Packed Array of Int16;
TWordArray = Packed Array of UInt16; TWordArray = Packed Array of UInt16; // redefined because the one in SysUtils is not a packed array
{ Signed Fixed 16.16 Float } { Signed Fixed 16.16 Float }
TF16Dot16 = type Int32; TF16Dot16 = type Int32;
@ -43,6 +49,7 @@ type
1: (Version: UInt32); 1: (Version: UInt32);
end; end;
{ The file header record that starts at byte 0 of a TTF file }
TTableDirectory = Packed Record TTableDirectory = Packed Record
FontVersion : TFixedVersionRec; { UInt32} FontVersion : TFixedVersionRec; { UInt32}
Numtables : UInt16; Numtables : UInt16;
@ -63,7 +70,7 @@ type
AdvanceWidth : UInt16; AdvanceWidth : UInt16;
LSB: Int16; { leftSideBearing } LSB: Int16; { leftSideBearing }
end; end;
TLongHorMetrics = Packed Array of TLongHorMetric; TLongHorMetricArray = Packed Array of TLongHorMetric;
Type Type
TPostScript = Packed Record TPostScript = Packed Record
@ -166,7 +173,8 @@ Type
XMaxExtent : Int16; XMaxExtent : Int16;
CaretSlopeRise : Int16; CaretSlopeRise : Int16;
CaretSlopeRun : Int16; CaretSlopeRun : Int16;
Reserved : Array[0..4] of Int16; caretOffset: Int16; // reserved field
Reserved : Array[0..3] of Int16;
metricDataFormat : Int16; metricDataFormat : Int16;
numberOfHMetrics : UInt16; numberOfHMetrics : UInt16;
end; end;
@ -219,6 +227,19 @@ Type
TNameEntries = Array of TNameEntry; TNameEntries = Array of TNameEntry;
TGlyphHeader = packed record
numberOfContours: int16;
xMin: uint16;
yMin: uint16;
xMax: uint16;
yMax: uint16;
end;
{ As per the TTF specification document...
https://www.microsoft.com/typography/tt/ttf_spec/ttch02.doc
...all TTF files are always stored in Big-Endian byte ordering (pg.31 Data Types).
}
TTFFileInfo = class(TObject) TTFFileInfo = class(TObject)
private private
FFilename: string; FFilename: string;
@ -233,7 +254,7 @@ Type
FHHEad : THHead; FHHEad : THHead;
FOS2Data : TOS2Data; FOS2Data : TOS2Data;
FPostScript : TPostScript; FPostScript : TPostScript;
FWidths: TLongHorMetrics; // hmtx data FWidths: TLongHorMetricArray; // hmtx data
// Needed to create PDF font def. // Needed to create PDF font def.
FOriginalSize : Cardinal; FOriginalSize : Cardinal;
FMissingWidth: Integer; FMissingWidth: Integer;
@ -242,7 +263,6 @@ Type
function FixMinorVersion(const AMinor: word): word; function FixMinorVersion(const AMinor: word): word;
function GetMissingWidth: integer; function GetMissingWidth: integer;
Protected Protected
Function IsNativeData : Boolean; virtual;
// Stream reading functions. // Stream reading functions.
function ReadInt16(AStream: TStream): Int16; inline; function ReadInt16(AStream: TStream): Int16; inline;
function ReadUInt32(AStream: TStream): UInt32; inline; function ReadUInt32(AStream: TStream): UInt32; inline;
@ -272,6 +292,7 @@ Type
destructor Destroy; override; destructor Destroy; override;
{ Returns the Glyph Index value in the TTF file, where AValue is the ordinal value of a character. } { Returns the Glyph Index value in the TTF file, where AValue is the ordinal value of a character. }
function GetGlyphIndex(AValue: word): word; function GetGlyphIndex(AValue: word): word;
function GetTableDirEntry(const ATableName: string; var AEntry: TTableDirectoryEntry): boolean;
// Load a TTF file from file or stream. // Load a TTF file from file or stream.
Procedure LoadFromFile(const AFileName : String); Procedure LoadFromFile(const AFileName : String);
Procedure LoadFromStream(AStream: TStream); virtual; Procedure LoadFromStream(AStream: TStream); virtual;
@ -307,7 +328,7 @@ Type
property CmapSubtables : TCmapSubTables Read FSubtables; property CmapSubtables : TCmapSubTables Read FSubtables;
property CmapUnicodeMap : TCmapFmt4 Read FUnicodeMap; property CmapUnicodeMap : TCmapFmt4 Read FUnicodeMap;
property CmapUnicodeMapSegments : TUnicodeMapSegmentArray Read FUnicodeMapSegments; property CmapUnicodeMapSegments : TUnicodeMapSegmentArray Read FUnicodeMapSegments;
Property Widths : TLongHorMetrics Read FWidths; Property Widths : TLongHorMetricArray Read FWidths;
Property MaxP : TMaxP Read FMaxP; Property MaxP : TMaxP Read FMaxP;
Property OS2Data : TOS2Data Read FOS2Data; Property OS2Data : TOS2Data Read FOS2Data;
Property PostScript : TPostScript Read FPostScript; Property PostScript : TPostScript Read FPostScript;
@ -331,7 +352,8 @@ procedure FillMem(Dest: pointer; Size: longint; Data: Byte );
Const Const
TTFTableNames : Array[TTTFTableType] of String TTFTableNames : Array[TTTFTableType] of String
= ('','head','hhea','maxp','hmtx','cmap','name','OS/2','post'); = ('','head','hhea','maxp','hmtx','cmap','name','OS/2','post',
'glyf', 'loca', 'cvt ', 'prep', 'fpgm');
Const Const
@ -393,16 +415,14 @@ function TTFFileInfo.ReadUInt32(AStream: TStream): UInt32;
begin begin
Result:=0; Result:=0;
AStream.ReadBuffer(Result,SizeOf(Result)); AStream.ReadBuffer(Result,SizeOf(Result));
if Not IsNativeData then Result:=BEtoN(Result);
Result:=BEtoN(Result);
end; end;
function TTFFileInfo.ReadUInt16(AStream: TStream): UInt16; function TTFFileInfo.ReadUInt16(AStream: TStream): UInt16;
begin begin
Result:=0; Result:=0;
AStream.ReadBuffer(Result,SizeOf(Result)); AStream.ReadBuffer(Result,SizeOf(Result));
if Not IsNativeData then Result:=BEtoN(Result);
Result:=BEtoN(Result);
end; end;
function TTFFileInfo.ReadInt16(AStream: TStream): Int16; function TTFFileInfo.ReadInt16(AStream: TStream): Int16;
@ -415,8 +435,6 @@ var
i : Integer; i : Integer;
begin begin
AStream.ReadBuffer(FHead,SizeOf(FHead)); AStream.ReadBuffer(FHead,SizeOf(FHead));
if IsNativeData then
exit;
FHead.FileVersion.Version := BEtoN(FHead.FileVersion.Version); FHead.FileVersion.Version := BEtoN(FHead.FileVersion.Version);
FHead.FileVersion.Minor := FixMinorVersion(FHead.FileVersion.Minor); FHead.FileVersion.Minor := FixMinorVersion(FHead.FileVersion.Minor);
FHead.FontRevision.Version := BEtoN(FHead.FontRevision.Version); FHead.FontRevision.Version := BEtoN(FHead.FontRevision.Version);
@ -437,34 +455,29 @@ begin
end; end;
procedure TTFFileInfo.ParseHhea(AStream : TStream); procedure TTFFileInfo.ParseHhea(AStream : TStream);
begin begin
AStream.ReadBuffer(FHHEad,SizeOf(FHHEad)); AStream.ReadBuffer(FHHEad,SizeOf(FHHEad));
if IsNativeData then
exit;
FHHEad.TableVersion.Version := BEToN(FHHEad.TableVersion.Version); FHHEad.TableVersion.Version := BEToN(FHHEad.TableVersion.Version);
FHHEad.TableVersion.Minor := FixMinorVersion(FHHEad.TableVersion.Minor); FHHEad.TableVersion.Minor := FixMinorVersion(FHHEad.TableVersion.Minor);
FHHEad.Ascender:=BEToN(FHHEad.Ascender); FHHEad.Ascender:=BEToN(FHHEad.Ascender);
FHHEad.Descender:=BEToN(FHHEad.Descender); FHHEad.Descender:=BEToN(FHHEad.Descender);
FHHEad.LineGap:=BEToN(FHHEad.LineGap); FHHEad.LineGap:=BEToN(FHHEad.LineGap);
FHHead.AdvanceWidthMax := BEToN(FHHead.AdvanceWidthMax);
FHHEad.MinLeftSideBearing:=BEToN(FHHEad.MinLeftSideBearing); FHHEad.MinLeftSideBearing:=BEToN(FHHEad.MinLeftSideBearing);
FHHEad.MinRightSideBearing:=BEToN(FHHEad.MinRightSideBearing); FHHEad.MinRightSideBearing:=BEToN(FHHEad.MinRightSideBearing);
FHHEad.XMaxExtent:=BEToN(FHHEad.XMaxExtent); FHHEad.XMaxExtent:=BEToN(FHHEad.XMaxExtent);
FHHEad.CaretSlopeRise:=BEToN(FHHEad.CaretSlopeRise); FHHEad.CaretSlopeRise:=BEToN(FHHEad.CaretSlopeRise);
FHHEad.CaretSlopeRun:=BEToN(FHHEad.CaretSlopeRun); FHHEad.CaretSlopeRun:=BEToN(FHHEad.CaretSlopeRun);
FHHEad.caretOffset := BEToN(FHHEad.caretOffset);
FHHEad.metricDataFormat:=BEToN(FHHEad.metricDataFormat); FHHEad.metricDataFormat:=BEToN(FHHEad.metricDataFormat);
FHHEad.numberOfHMetrics:=BEToN(FHHEad.numberOfHMetrics); FHHEad.numberOfHMetrics:=BEToN(FHHEad.numberOfHMetrics);
FHHead.AdvanceWidthMax := BEToN(FHHead.AdvanceWidthMax);
end; end;
procedure TTFFileInfo.ParseMaxp(AStream : TStream); procedure TTFFileInfo.ParseMaxp(AStream : TStream);
begin begin
AStream.ReadBuffer(FMaxP,SizeOf(TMaxP)); AStream.ReadBuffer(FMaxP,SizeOf(TMaxP));
if IsNativeData then
exit;
With FMaxP do With FMaxP do
begin begin
VersionNumber.Version := BEtoN(VersionNumber.Version); VersionNumber.Version := BEtoN(VersionNumber.Version);
VersionNumber.Minor := FixMinorVersion(VersionNumber.Minor); VersionNumber.Minor := FixMinorVersion(VersionNumber.Minor);
numGlyphs:=BEtoN(numGlyphs); numGlyphs:=BEtoN(numGlyphs);
@ -481,24 +494,20 @@ begin
maxSizeOfInstructions :=BEtoN(maxSizeOfInstructions); maxSizeOfInstructions :=BEtoN(maxSizeOfInstructions);
maxComponentElements :=BEtoN(maxComponentElements); maxComponentElements :=BEtoN(maxComponentElements);
maxComponentDepth :=BEtoN(maxComponentDepth); maxComponentDepth :=BEtoN(maxComponentDepth);
end; end;
end; end;
procedure TTFFileInfo.ParseHmtx(AStream : TStream); procedure TTFFileInfo.ParseHmtx(AStream : TStream);
var var
i : Integer; i : Integer;
begin begin
SetLength(FWidths,FHHead.numberOfHMetrics); SetLength(FWidths,FHHead.numberOfHMetrics);
AStream.ReadBuffer(FWidths[0],SizeOf(TLongHorMetric)*Length(FWidths)); AStream.ReadBuffer(FWidths[0],SizeOf(TLongHorMetric)*Length(FWidths));
if IsNativeData then
exit;
for I:=0 to FHHead.NumberOfHMetrics-1 do for I:=0 to FHHead.NumberOfHMetrics-1 do
begin begin
FWidths[I].AdvanceWidth:=BEtoN(FWidths[I].AdvanceWidth); FWidths[I].AdvanceWidth:=BEtoN(FWidths[I].AdvanceWidth);
FWidths[I].LSB:=BEtoN(FWidths[I].LSB); FWidths[I].LSB:=BEtoN(FWidths[I].LSB);
end; end;
end; end;
@ -510,7 +519,6 @@ var
Segm : TUnicodeMapSegment; Segm : TUnicodeMapSegment;
GlyphIDArray : Array of word; GlyphIDArray : Array of word;
S : TStream; S : TStream;
begin begin
TableStartPos:=AStream.Position; TableStartPos:=AStream.Position;
FCMapH.Version:=ReadUInt16(AStream); FCMapH.Version:=ReadUInt16(AStream);
@ -670,80 +678,76 @@ begin
FillWord(FOS2Data,SizeOf(TOS2Data) div 2,0); FillWord(FOS2Data,SizeOf(TOS2Data) div 2,0);
// -18, so version 1 will not overflow // -18, so version 1 will not overflow
AStream.ReadBuffer(FOS2Data,SizeOf(TOS2Data)-18); AStream.ReadBuffer(FOS2Data,SizeOf(TOS2Data)-18);
if Not isNativeData then
With FOS2Data do
begin
version:=BeToN(version);
xAvgCharWidth:=BeToN(xAvgCharWidth);
usWeightClass:=BeToN(usWeightClass);
usWidthClass:=BeToN(usWidthClass);
fsType:=BeToN(fsType);
ySubscriptXSize:=BeToN(ySubscriptXSize);
ySubscriptYSize:=BeToN(ySubscriptYSize);
ySubscriptXOffset:=BeToN(ySubscriptXOffset);
ySubscriptYOffset:=BeToN(ySubscriptYOffset);
ySuperscriptXSize:=BeToN(ySuperscriptXSize);
ySuperscriptYSize:=BeToN(ySuperscriptYSize);
ySuperscriptXOffset:=BeToN(ySuperscriptXOffset);
ySuperscriptYOffset:=BeToN(ySuperscriptYOffset);
yStrikeoutSize:=BeToN(yStrikeoutSize);
yStrikeoutPosition:=BeToN(yStrikeoutPosition);
sFamilyClass:=BeToN(sFamilyClass);
ulUnicodeRange1:=BeToN(ulUnicodeRange1);
ulUnicodeRange2:=BeToN(ulUnicodeRange2);
ulUnicodeRange3:=BeToN(ulUnicodeRange3);
ulUnicodeRange4:=BeToN(ulUnicodeRange4);
fsSelection:=BeToN(fsSelection);
usFirstCharIndex:=BeToN(usFirstCharIndex);
usLastCharIndex:=BeToN(usLastCharIndex);
sTypoAscender:=BeToN(sTypoAscender);
sTypoDescender:=BeToN(sTypoDescender);
sTypoLineGap:=BeToN(sTypoLineGap);
usWinAscent:=BeToN(usWinAscent);
usWinDescent:=BeToN(usWinDescent);
// We miss 7 fields
end;
With FOS2Data do With FOS2Data do
begin begin
version:=BeToN(version);
xAvgCharWidth:=BeToN(xAvgCharWidth);
usWeightClass:=BeToN(usWeightClass);
usWidthClass:=BeToN(usWidthClass);
fsType:=BeToN(fsType);
ySubscriptXSize:=BeToN(ySubscriptXSize);
ySubscriptYSize:=BeToN(ySubscriptYSize);
ySubscriptXOffset:=BeToN(ySubscriptXOffset);
ySubscriptYOffset:=BeToN(ySubscriptYOffset);
ySuperscriptXSize:=BeToN(ySuperscriptXSize);
ySuperscriptYSize:=BeToN(ySuperscriptYSize);
ySuperscriptXOffset:=BeToN(ySuperscriptXOffset);
ySuperscriptYOffset:=BeToN(ySuperscriptYOffset);
yStrikeoutSize:=BeToN(yStrikeoutSize);
yStrikeoutPosition:=BeToN(yStrikeoutPosition);
sFamilyClass:=BeToN(sFamilyClass);
ulUnicodeRange1:=BeToN(ulUnicodeRange1);
ulUnicodeRange2:=BeToN(ulUnicodeRange2);
ulUnicodeRange3:=BeToN(ulUnicodeRange3);
ulUnicodeRange4:=BeToN(ulUnicodeRange4);
fsSelection:=BeToN(fsSelection);
usFirstCharIndex:=BeToN(usFirstCharIndex);
usLastCharIndex:=BeToN(usLastCharIndex);
sTypoAscender:=BeToN(sTypoAscender);
sTypoDescender:=BeToN(sTypoDescender);
sTypoLineGap:=BeToN(sTypoLineGap);
usWinAscent:=BeToN(usWinAscent);
usWinDescent:=BeToN(usWinDescent);
// We miss 7 fields
end;
With FOS2Data do
begin
// Read remaining 7 fields' data depending on version // Read remaining 7 fields' data depending on version
if Version>=1 then if Version>=1 then
begin begin
ulCodePageRange1:=ReadUInt32(AStream); ulCodePageRange1:=ReadUInt32(AStream);
ulCodePageRange2:=ReadUInt32(AStream); ulCodePageRange2:=ReadUInt32(AStream);
end; end;
if Version>=2 then if Version>=2 then
begin begin
sxHeight:=ReadInt16(AStream); sxHeight:=ReadInt16(AStream);
sCapHeight:=ReadInt16(AStream); sCapHeight:=ReadInt16(AStream);
usDefaultChar:=ReadUInt16(AStream); usDefaultChar:=ReadUInt16(AStream);
usBreakChar:=ReadUInt16(AStream); usBreakChar:=ReadUInt16(AStream);
usMaxContext:=ReadUInt16(AStream); usMaxContext:=ReadUInt16(AStream);
end;
end; end;
end;
end; end;
procedure TTFFileInfo.ParsePost(AStream : TStream); procedure TTFFileInfo.ParsePost(AStream : TStream);
begin begin
AStream.ReadBuffer(FPostScript,SizeOf(TPostScript)); AStream.ReadBuffer(FPostScript,SizeOf(TPostScript));
if not IsNativeData then With FPostScript do
With FPostScript do begin
begin Format.Version := BEtoN(Format.Version);
Format.Version := BEtoN(Format.Version); Format.Minor := FixMinorVersion(Format.Minor);
Format.Minor := FixMinorVersion(Format.Minor); ItalicAngle:=BeToN(ItalicAngle);
ItalicAngle:=BeToN(ItalicAngle); UnderlinePosition:=BeToN(UnderlinePosition);
UnderlinePosition:=BeToN(UnderlinePosition); underlineThickness:=BeToN(underlineThickness);
underlineThickness:=BeToN(underlineThickness); isFixedPitch:=BeToN(isFixedPitch);
isFixedPitch:=BeToN(isFixedPitch); minMemType42:=BeToN(minMemType42);
minMemType42:=BeToN(minMemType42); maxMemType42:=BeToN(maxMemType42);
maxMemType42:=BeToN(maxMemType42); minMemType1:=BeToN(minMemType1);
minMemType1:=BeToN(minMemType1); maxMemType1:=BeToN(maxMemType1);
maxMemType1:=BeToN(maxMemType1); end;
end;
end; end;
procedure TTFFileInfo.LoadFromFile(const AFileName: String); procedure TTFFileInfo.LoadFromFile(const AFileName: String);
Var Var
AStream: TFileStream; AStream: TFileStream;
begin begin
@ -763,31 +767,30 @@ var
begin begin
FOriginalSize:= AStream.Size; FOriginalSize:= AStream.Size;
AStream.ReadBuffer(FTableDir,Sizeof(TTableDirectory)); AStream.ReadBuffer(FTableDir,Sizeof(TTableDirectory));
if not isNativeData then With FTableDir do
With FTableDir do begin
begin FontVersion.Version := BEtoN(FontVersion.Version);
FontVersion.Version := BEtoN(FontVersion.Version); FontVersion.Minor := FixMinorVersion(FontVersion.Minor);
FontVersion.Minor := FixMinorVersion(FontVersion.Minor); Numtables:=BeToN(Numtables);
Numtables:=BeToN(Numtables); SearchRange:=BeToN(SearchRange);
SearchRange:=BeToN(SearchRange); EntrySelector:=BeToN(EntrySelector);
EntrySelector:=BeToN(EntrySelector); RangeShift:=BeToN(RangeShift);
RangeShift:=BeToN(RangeShift); end;
end;
SetLength(FTables,FTableDir.Numtables); SetLength(FTables,FTableDir.Numtables);
AStream.ReadBuffer(FTables[0],FTableDir.NumTables*Sizeof(TTableDirectoryEntry)); AStream.ReadBuffer(FTables[0],FTableDir.NumTables*Sizeof(TTableDirectoryEntry));
if Not IsNativeData then For I:=0 to Length(FTables)-1 do
For I:=0 to Length(FTables)-1 do With FTables[I] do
With FTables[I] do
begin
checkSum:=BeToN(checkSum);
offset:=BeToN(offset);
Length:=BeToN(Length);
end;
for I:=0 to FTableDir.NumTables-1 do
begin begin
// note: Tag field doesn't require BEtoN processing.
checkSum:=BeToN(checkSum);
offset:=BeToN(offset);
Length:=BeToN(Length);
end;
for I:=0 to FTableDir.NumTables-1 do
begin
TT:=GetTableType(FTables[I].Tag); TT:=GetTableType(FTables[I].Tag);
if (TT<>ttUnknown) then if (TT<>ttUnknown) then
begin begin
AStream.Position:=FTables[i].Offset; AStream.Position:=FTables[i].Offset;
Case TT of Case TT of
tthead: ParseHead(AStream); tthead: ParseHead(AStream);
@ -799,8 +802,8 @@ begin
ttos2 : ParseOS2(AStream); ttos2 : ParseOS2(AStream);
ttPost: ParsePost(AStream); ttPost: ParsePost(AStream);
end; end;
end;
end; end;
end;
end; end;
procedure TTFFileInfo.PrepareFontDefinition(const Encoding: string; Embed: Boolean); procedure TTFFileInfo.PrepareFontDefinition(const Encoding: string; Embed: Boolean);
@ -813,13 +816,13 @@ begin
// MissingWidth:=ToNatural(Widths[Chars[CharCodes^[32]]].AdvanceWidth); // Char(32) - Space character // MissingWidth:=ToNatural(Widths[Chars[CharCodes^[32]]].AdvanceWidth); // Char(32) - Space character
FMissingWidth := Widths[Chars[CharCodes^[32]]].AdvanceWidth; // Char(32) - Space character FMissingWidth := Widths[Chars[CharCodes^[32]]].AdvanceWidth; // Char(32) - Space character
for I:=0 to 255 do for I:=0 to 255 do
begin begin
if (CharCodes^[i]>=0) and (CharCodes^[i]<=High(Chars)) if (CharCodes^[i]>=0) and (CharCodes^[i]<=High(Chars))
and (Widths[Chars[CharCodes^[i]]].AdvanceWidth> 0) and (CharNames^[i]<> '.notdef') then and (Widths[Chars[CharCodes^[i]]].AdvanceWidth> 0) and (CharNames^[i]<> '.notdef') then
CharWidth[I]:= ToNatural(Widths[Chars[CharCodes^[I]]].AdvanceWidth) CharWidth[I]:= ToNatural(Widths[Chars[CharCodes^[I]]].AdvanceWidth)
else else
CharWidth[I]:= FMissingWidth; CharWidth[I]:= FMissingWidth;
end; end;
end; end;
procedure TTFFileInfo.PrepareEncoding(const AEncoding: String); procedure TTFFileInfo.PrepareEncoding(const AEncoding: String);
@ -842,12 +845,12 @@ begin
L:= 0; L:= 0;
for i:=32 to 255 do for i:=32 to 255 do
if CharNames^[i]<>CharBase^[i] then if CharNames^[i]<>CharBase^[i] then
begin begin
if (i<>l+1) then if (i<>l+1) then
Result:= Result+IntToStr(i)+' '; Result:= Result+IntToStr(i)+' ';
l:=i; l:=i;
Result:= Result+'/'+CharNames^[i]+' '; Result:= Result+'/'+CharNames^[i]+' ';
end; end;
end; end;
function TTFFileInfo.Bold: Boolean; function TTFFileInfo.Bold: Boolean;
@ -900,6 +903,23 @@ begin
result := Chars[AValue]; result := Chars[AValue];
end; end;
function TTFFileInfo.GetTableDirEntry(const ATableName: string; var AEntry: TTableDirectoryEntry): boolean;
var
i: integer;
begin
FillMem(@AEntry, SizeOf(TTableDirectoryEntry), 0);
Result := False;
for i := Low(Tables) to High(Tables) do
begin
if CompareStr(Tables[i].Tag, ATableName) = 0 then
begin
Result := True;
AEntry := Tables[i];
Exit;
end;
end;
end;
function TTFFileInfo.GetAdvanceWidth(AIndex: word): word; function TTFFileInfo.GetAdvanceWidth(AIndex: word): word;
begin begin
Result := Widths[AIndex].AdvanceWidth; Result := Widths[AIndex].AdvanceWidth;
@ -948,11 +968,6 @@ begin
Result := FMissingWidth; Result := FMissingWidth;
end; end;
function TTFFileInfo.IsNativeData: Boolean;
begin
Result:=False;
end;
function TTFFileInfo.ToNatural(AUnit: Smallint): Smallint; function TTFFileInfo.ToNatural(AUnit: Smallint): Smallint;
begin begin
if FHead.UnitsPerEm=0 then if FHead.UnitsPerEm=0 then

1090
packages/fcl-pdf/src/fppdf.pp
View File

File diff suppressed because it is too large Load Diff

174
packages/fcl-pdf/src/fpttf.pp
View File

@ -49,12 +49,17 @@ type
FFileInfo: TTFFileInfo; FFileInfo: TTFFileInfo;
FOwner: TFPFontCacheList; // reference to FontCacheList that owns this instance FOwner: TFPFontCacheList; // reference to FontCacheList that owns this instance
FPostScriptName: string; FPostScriptName: string;
procedure DoLoadFileInfo;
procedure LoadFileInfo;
procedure BuildFontCacheItem; procedure BuildFontCacheItem;
procedure SetStyleIfExists(var AText: string; var AStyleFlags: TTrueTypeFontStyles; const AStyleName: String; const AStyle: TTrueTypeFontStyle); procedure SetStyleIfExists(var AText: string; var AStyleFlags: TTrueTypeFontStyles; const AStyleName: String; const AStyle: TTrueTypeFontStyle);
function GetIsBold: boolean; function GetIsBold: boolean;
function GetIsFixedWidth: boolean; function GetIsFixedWidth: boolean;
function GetIsItalic: boolean; function GetIsItalic: boolean;
function GetIsRegular: boolean; function GetIsRegular: boolean;
function GetFamilyName: String;
function GetPostScriptName: string;
function GetFileInfo: TTFFileInfo;
public public
constructor Create(const AFilename: String); constructor Create(const AFilename: String);
destructor Destroy; override; destructor Destroy; override;
@ -63,9 +68,9 @@ type
{ Result is in pixels } { Result is in pixels }
function TextHeight(const AText: utf8string; const APointSize: single; out ADescender: single): single; function TextHeight(const AText: utf8string; const APointSize: single; out ADescender: single): single;
property FileName: String read FFileName; property FileName: String read FFileName;
property FamilyName: String read FFamilyName; property FamilyName: String read GetFamilyName;
property PostScriptName: string read FPostScriptName; property PostScriptName: string read GetPostScriptName;
property FontData: TTFFileInfo read FFileInfo; property FontData: TTFFileInfo read GetFileInfo;
{ A bitmasked value describing the full font style } { A bitmasked value describing the full font style }
property StyleFlags: TTrueTypeFontStyles read FStyleFlags; property StyleFlags: TTrueTypeFontStyles read FStyleFlags;
{ IsXXX properties are convenience properties, internally querying StyleFlags. } { IsXXX properties are convenience properties, internally querying StyleFlags. }
@ -78,7 +83,7 @@ type
TFPFontCacheList = class(TObject) TFPFontCacheList = class(TObject)
private private
FBuildFontFacheIgnoresErrors: Boolean; FBuildFontCacheIgnoresErrors: Boolean;
FList: TObjectList; FList: TObjectList;
FSearchPath: TStringList; FSearchPath: TStringList;
FDPI: integer; FDPI: integer;
@ -97,6 +102,8 @@ type
function Add(const AObject: TFPFontCacheItem): integer; function Add(const AObject: TFPFontCacheItem): integer;
procedure AssignFontList(const AStrings: TStrings); procedure AssignFontList(const AStrings: TStrings);
procedure Clear; procedure Clear;
procedure LoadFromFile(const AFilename: string);
procedure ReadStandardFonts;
property Count: integer read GetCount; property Count: integer read GetCount;
function IndexOf(const AObject: TFPFontCacheItem): integer; function IndexOf(const AObject: TFPFontCacheItem): integer;
function Find(const AFontCacheItem: TFPFontCacheItem): integer; overload; function Find(const AFontCacheItem: TFPFontCacheItem): integer; overload;
@ -107,7 +114,7 @@ type
property Items[AIndex: Integer]: TFPFontCacheItem read GetItem write SetItem; default; property Items[AIndex: Integer]: TFPFontCacheItem read GetItem write SetItem; default;
property SearchPath: TStringList read FSearchPath; property SearchPath: TStringList read FSearchPath;
property DPI: integer read FDPI write SetDPI; property DPI: integer read FDPI write SetDPI;
Property BuildFontFacheIgnoresErrors : Boolean Read FBuildFontFacheIgnoresErrors Write FBuildFontFacheIgnoresErrors; Property BuildFontCacheIgnoresErrors : Boolean Read FBuildFontCacheIgnoresErrors Write FBuildFontCacheIgnoresErrors;
end; end;
@ -115,10 +122,18 @@ function gTTFontCache: TFPFontCacheList;
implementation implementation
uses
DOM
,XMLRead
{$ifdef mswindows}
,Windows // for SHGetFolderPath API call used by gTTFontCache.ReadStandardFonts() method
{$endif}
;
resourcestring resourcestring
rsNoSearchPathDefined = 'No search path was defined'; rsNoSearchPathDefined = 'No search path was defined';
rsNoFontFileName = 'The FileName property is empty, so we can''t load font data.'; rsNoFontFileName = 'The FileName property is empty, so we can''t load font data.';
rsCharAboveWord = 'TextWidth doesn''t support characters higher then High(Word) - %d.'; rsMissingFontFile = 'The font file <%s> can''t be found.';
var var
uFontCacheList: TFPFontCacheList; uFontCacheList: TFPFontCacheList;
@ -134,26 +149,66 @@ end;
{ TFPFontCacheItem } { TFPFontCacheItem }
procedure TFPFontCacheItem.DoLoadFileInfo;
begin
if not Assigned(FFileInfo) then
LoadFileInfo;
end;
procedure TFPFontCacheItem.LoadFileInfo;
begin
if FileExists(FFilename) then
begin
FFileInfo := TTFFileInfo.Create;
FFileInfo.LoadFromFile(FFilename);
BuildFontCacheItem;
end
else
raise ETTF.CreateFmt(rsMissingFontFile, [FFilename]);
end;
function TFPFontCacheItem.GetIsBold: boolean; function TFPFontCacheItem.GetIsBold: boolean;
begin begin
DoLoadFileInfo;
Result := fsBold in FStyleFlags; Result := fsBold in FStyleFlags;
end; end;
function TFPFontCacheItem.GetIsFixedWidth: boolean; function TFPFontCacheItem.GetIsFixedWidth: boolean;
begin begin
DoLoadFileInfo;
Result := fsFixedWidth in FStyleFlags; Result := fsFixedWidth in FStyleFlags;
end; end;
function TFPFontCacheItem.GetIsItalic: boolean; function TFPFontCacheItem.GetIsItalic: boolean;
begin begin
DoLoadFileInfo;
Result := fsItalic in FStyleFlags; Result := fsItalic in FStyleFlags;
end; end;
function TFPFontCacheItem.GetIsRegular: boolean; function TFPFontCacheItem.GetIsRegular: boolean;
begin begin
DoLoadFileInfo;
Result := fsRegular in FStyleFlags; Result := fsRegular in FStyleFlags;
end; end;
function TFPFontCacheItem.GetFamilyName: String;
begin
DoLoadFileInfo;
Result := FFamilyName;
end;
function TFPFontCacheItem.GetPostScriptName: string;
begin
DoLoadFileInfo;
Result := FPostScriptName;
end;
function TFPFontCacheItem.GetFileInfo: TTFFileInfo;
begin
DoLoadFileInfo;
Result := FFileInfo;
end;
procedure TFPFontCacheItem.BuildFontCacheItem; procedure TFPFontCacheItem.BuildFontCacheItem;
var var
s: string; s: string;
@ -205,13 +260,6 @@ begin
if AFileName = '' then if AFileName = '' then
raise ETTF.Create(rsNoFontFileName); raise ETTF.Create(rsNoFontFileName);
if FileExists(AFilename) then
begin
FFileInfo := TTFFileInfo.Create;
FFileInfo.LoadFromFile(AFilename);
BuildFontCacheItem;
end;
end; end;
destructor TFPFontCacheItem.Destroy; destructor TFPFontCacheItem.Destroy;
@ -253,6 +301,7 @@ var
s: string; s: string;
{$ENDIF} {$ENDIF}
begin begin
DoLoadFileInfo;
Result := 0; Result := 0;
if Length(AStr) = 0 then if Length(AStr) = 0 then
Exit; Exit;
@ -294,6 +343,7 @@ end;
function TFPFontCacheItem.TextHeight(const AText: utf8string; const APointSize: single; out ADescender: single): single; function TFPFontCacheItem.TextHeight(const AText: utf8string; const APointSize: single; out ADescender: single): single;
begin begin
DoLoadFileInfo;
{ Both lHeight and lDescenderHeight are in pixels } { Both lHeight and lDescenderHeight are in pixels }
Result := FFileInfo.CapHeight * APointSize * gTTFontCache.DPI / (72 * FFileInfo.Head.UnitsPerEm); Result := FFileInfo.CapHeight * APointSize * gTTFontCache.DPI / (72 * FFileInfo.Head.UnitsPerEm);
ADescender := Abs(FFileInfo.Descender) * APointSize * gTTFontCache.DPI / (72 * FFileInfo.Head.UnitsPerEm); ADescender := Abs(FFileInfo.Descender) * APointSize * gTTFontCache.DPI / (72 * FFileInfo.Head.UnitsPerEm);
@ -307,7 +357,7 @@ var
lFont: TFPFontCacheItem; lFont: TFPFontCacheItem;
s: String; s: String;
begin begin
if FindFirst(AFontPath + AllFilesMask, faAnyFile, sr) = 0 then if SysUtils.FindFirst(AFontPath + AllFilesMask, faAnyFile, sr) = 0 then
begin begin
repeat repeat
// check if special files to skip // check if special files to skip
@ -326,14 +376,14 @@ begin
lFont := TFPFontCacheItem.Create(AFontPath + s); lFont := TFPFontCacheItem.Create(AFontPath + s);
Add(lFont); Add(lFont);
except except
if not FBuildFontFacheIgnoresErrors then if not FBuildFontCacheIgnoresErrors then
Raise; Raise;
end; end;
end; end;
end; end;
until FindNext(sr) <> 0; until SysUtils.FindNext(sr) <> 0;
end; end;
FindClose(sr); SysUtils.FindClose(sr);
end; end;
procedure TFPFontCacheList.SetDPI(AValue: integer); procedure TFPFontCacheList.SetDPI(AValue: integer);
@ -419,6 +469,96 @@ begin
FList.Clear; FList.Clear;
end; end;
procedure TFPFontCacheList.LoadFromFile(const AFilename: string);
var
sl: TStringList;
i: integer;
begin
sl := TStringList.Create;
try
sl.LoadFromFile(AFilename);
for i := 0 to sl.Count-1 do
Add(TFPFontCacheItem.Create(sl[i]));
finally
sl.Free;
end;
end;
{ This is operating system dependent. Our default implementation only supports
Linux, FreeBSD, Windows and OSX. On other platforms, no fonts will be loaded,
until a implementation is created.
NOTE:
This is definitely not a perfect solution, especially due to the inconsistent
implementations and locations of files under various Linux distros. But it's
the best we can do for now. }
procedure TFPFontCacheList.ReadStandardFonts;
{$ifdef linux}
{$define HasFontsConf}
const
cFontsConf = '/etc/fonts/fonts.conf';
{$endif}
{$ifdef freebsd}
{$define HasFontsConf}
const
cFontsConf = '/usr/local/etc/fonts/fonts.conf';
{$endif}
{$ifdef mswindows}
function GetWinDir: string;
var
dir: array [0..MAX_PATH] of Char;
begin
GetWindowsDirectory(dir, MAX_PATH);
Result := StrPas(dir);
end;
{$endif}
{$ifdef HasFontsConf}
var
doc: TXMLDocument;
lChild: TDOMNode;
lDir: string;
{$endif}
begin
{$ifdef HasFontsConf} // Linux & FreeBSD
ReadXMLFile(doc, cFontsConf);
try
lChild := doc.DocumentElement.FirstChild;
while Assigned(lChild) do
begin
if lChild.NodeName = 'dir' then
begin
if lChild.FirstChild.NodeValue = '~/.fonts' then
lDir := ExpandFilename(lChild.FirstChild.NodeValue)
else
lDir := lChild.FirstChild.NodeValue;
SearchPath.Add(lDir);
// writeln(lDir);
end;
lChild := lChild.NextSibling;
end;
finally
doc.Free;
end;
{$endif}
{$ifdef mswindows}
SearchPath.Add(GetWinDir);
{$endif}
{$ifdef darwin} // OSX
{ As per Apple Support page: https://support.apple.com/en-us/HT201722 }
SearchPath.Add('/System/Library/Fonts/');
SearchPath.Add('/Library/Fonts/');
SearchPath.Add(ExpandFilename('~/Library/Fonts/'));
{$endif}
BuildFontCache;
end;
function TFPFontCacheList.IndexOf(const AObject: TFPFontCacheItem): integer; function TFPFontCacheList.IndexOf(const AObject: TFPFontCacheItem): integer;
begin begin
Result := FList.IndexOf(AObject); Result := FList.IndexOf(AObject);

2
packages/fcl-pdf/tests/fpparsettf_test.pas
View File

@ -971,7 +971,7 @@ end;
procedure TTestLiberationFont.TestOS2Data_ulUnicodeRange1; procedure TTestLiberationFont.TestOS2Data_ulUnicodeRange1;
begin begin
AssertEquals('Failed on 1', '1110 0000 0000 0000 0000 1010 1111 1111', IntToBin(FI.OS2Data.ulUnicodeRange1, 32, 4)); // AssertEquals('Failed on 1', '1110 0000 0000 0000 0000 1010 1111 1111', IntToBin(FI.OS2Data.ulUnicodeRange1, 32, 4));
AssertEquals('Failed on 2', 'E0000AFF', IntToHex(FI.OS2Data.ulUnicodeRange1, 8)); AssertEquals('Failed on 2', 'E0000AFF', IntToHex(FI.OS2Data.ulUnicodeRange1, 8));
end; end;

218
packages/fcl-pdf/tests/fppdf_test.pas
View File

@ -21,6 +21,7 @@ type
private private
FPDF: TPDFDocument; FPDF: TPDFDocument;
FStream: TStringStream; FStream: TStringStream;
procedure CreatePages(const ACount: integer);
protected protected
procedure SetUp; override; procedure SetUp; override;
procedure TearDown; override; procedure TearDown; override;
@ -200,6 +201,7 @@ type
procedure TestWrite_ppsDot; procedure TestWrite_ppsDot;
procedure TestWrite_ppsDashDot; procedure TestWrite_ppsDashDot;
procedure TestWrite_ppsDashDotDot; procedure TestWrite_ppsDashDotDot;
procedure TestLocalisationChanges;
end; end;
@ -232,7 +234,8 @@ type
published published
procedure TestPageDocument; procedure TestPageDocument;
procedure TestPageDefaultUnitOfMeasure; procedure TestPageDefaultUnitOfMeasure;
procedure TestMatrix; procedure TestMatrixOn;
procedure TestMatrixOff;
procedure TestUnitOfMeasure_MM; procedure TestUnitOfMeasure_MM;
procedure TestUnitOfMeasure_Inches; procedure TestUnitOfMeasure_Inches;
procedure TestUnitOfMeasure_CM; procedure TestUnitOfMeasure_CM;
@ -295,6 +298,23 @@ type
{ TBasePDFTest } { TBasePDFTest }
procedure TBasePDFTest.CreatePages(const ACount: integer);
var
page: TPDFPage;
sec: TPDFSection;
i: integer;
begin
if FPDF.Sections.Count = 0 then
sec := FPDF.Sections.AddSection
else
sec := FPDF.Sections[0];
for i := 1 to ACount do
begin
page := FPDF.Pages.AddPage;
sec.AddPage(page);
end;
end;
procedure TBasePDFTest.SetUp; procedure TBasePDFTest.SetUp;
begin begin
inherited SetUp; inherited SetUp;
@ -334,7 +354,7 @@ Var
begin begin
AssertEquals('Failed on 1', '0.12', TMockPDFObject.FloatStr(TPDFFLoat(0.12))); AssertEquals('Failed on 1', '0.12', TMockPDFObject.FloatStr(TPDFFLoat(0.12)));
AssertEquals('Failed on 2', ' 12', TMockPDFObject.FloatStr(TPDFFLoat(12.00))); AssertEquals('Failed on 2', '12', TMockPDFObject.FloatStr(TPDFFLoat(12.00)));
AssertEquals('Failed on 3', '12.30', TMockPDFObject.FloatStr(TPDFFLoat(12.30))); AssertEquals('Failed on 3', '12.30', TMockPDFObject.FloatStr(TPDFFLoat(12.30)));
AssertEquals('Failed on 4', '12.34', TMockPDFObject.FloatStr(TPDFFLoat(12.34))); AssertEquals('Failed on 4', '12.34', TMockPDFObject.FloatStr(TPDFFLoat(12.34)));
AssertEquals('Failed on 5', '123.45', TMockPDFObject.FloatStr(TPDFFLoat(123.45))); AssertEquals('Failed on 5', '123.45', TMockPDFObject.FloatStr(TPDFFLoat(123.45)));
@ -399,7 +419,7 @@ begin
'1 J'+CRLF+ '1 J'+CRLF+
'300.50 w'+CRLF+ // line width 300.5 '300.50 w'+CRLF+ // line width 300.5
'1 J'+CRLF+ '1 J'+CRLF+
' 123 w'+CRLF, // line width 123 '123 w'+CRLF, // line width 123
s.DataString); s.DataString);
finally finally
o.Free; o.Free;
@ -446,7 +466,7 @@ begin
try try
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
TMockPDFMoveTo(o).Write(S); TMockPDFMoveTo(o).Write(S);
AssertEquals('Failed on 2', ' 10 20 m'+CRLF, S.DataString); AssertEquals('Failed on 2', '10 20 m'+CRLF, S.DataString);
finally finally
o.Free; o.Free;
end; end;
@ -463,7 +483,7 @@ begin
try try
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
TMockPDFMoveTo(o).Write(S); TMockPDFMoveTo(o).Write(S);
AssertEquals('Failed on 2', ' 10 20 m'+CRLF, S.DataString); AssertEquals('Failed on 2', '10 20 m'+CRLF, S.DataString);
finally finally
o.Free; o.Free;
end; end;
@ -743,8 +763,11 @@ end;
procedure TTestPDFEmbeddedFont.TestWrite; procedure TTestPDFEmbeddedFont.TestWrite;
var var
o: TPDFEmbeddedFont; o: TPDFEmbeddedFont;
p: TPDFPage;
begin begin
o := TPDFEmbeddedFont.Create(PDF, 1, '16'); CreatePages(1);
p := PDF.Pages[0];
o := TPDFEmbeddedFont.Create(PDF, p, 1, '16');
try try
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
TMockPDFEmbeddedFont(o).Write(S); TMockPDFEmbeddedFont(o).Write(S);
@ -759,10 +782,13 @@ var
o: TPDFEmbeddedFont; o: TPDFEmbeddedFont;
lStream: TMemoryStream; lStream: TMemoryStream;
str: String; str: String;
p: TPDFPage;
begin begin
PDF.Options := []; // disable compressed fonts PDF.Options := []; // disable compressed fonts
str := 'Hello World'; str := 'Hello World';
o := TPDFEmbeddedFont.Create(PDF, 1, '16'); CreatePages(1);
p := PDF.Pages[0];
o := TPDFEmbeddedFont.Create(PDF, p, 1, '16');
try try
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
lStream := TMemoryStream.Create; lStream := TMemoryStream.Create;
@ -785,13 +811,13 @@ var
begin begin
x := 10.5; x := 10.5;
y := 20.0; y := 20.0;
o := TPDFText.Create(PDF, x, y, 'Hello World!', 0); o := TPDFText.Create(PDF, x, y, 'Hello World!', nil, 0, false, false);
try try
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
TMockPDFText(o).Write(S); TMockPDFText(o).Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
'BT'+CRLF+ 'BT'+CRLF+
'10.50 20 TD'+CRLF+ '10.50 20 TD'+CRLF+
'(Hello World!) Tj'+CRLF+ '(Hello World!) Tj'+CRLF+
'ET'+CRLF, 'ET'+CRLF,
S.DataString); S.DataString);
@ -808,7 +834,7 @@ var
begin begin
pos.X := 10.0; pos.X := 10.0;
pos.Y := 55.5; pos.Y := 55.5;
AssertEquals('Failed on 1', ' 10 55.50 l'+CRLF, TPDFLineSegment.Command(pos)); AssertEquals('Failed on 1', '10 55.50 l'+CRLF, TPDFLineSegment.Command(pos));
end; end;
procedure TTestPDFLineSegment.TestWrite; procedure TTestPDFLineSegment.TestWrite;
@ -827,9 +853,9 @@ begin
TMockPDFLineSegment(o).Write(S); TMockPDFLineSegment(o).Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
'1 J'+CRLF+ '1 J'+CRLF+
' 2 w'+CRLF+ // line width '2 w'+CRLF+ // line width
' 10 15.50 m'+CRLF+ // moveto command '10 15.50 m'+CRLF+ // moveto command
' 50 55.50 l'+CRLF+ // line segment '50 55.50 l'+CRLF+ // line segment
'S'+CRLF, // end line segment 'S'+CRLF, // end line segment
S.DataString); S.DataString);
finally finally
@ -854,7 +880,7 @@ begin
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
' 10 11 100 200 re'+CRLF, '10 11 100 200 re'+CRLF,
S.DataString); S.DataString);
finally finally
o.Free; o.Free;
@ -877,8 +903,8 @@ begin
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
'1 J'+CRLF+ '1 J'+CRLF+
' 2 w'+CRLF+ '2 w'+CRLF+
' 10 11 100 200 re'+CRLF+ '10 11 100 200 re'+CRLF+
'b'+CRLF, 'b'+CRLF,
S.DataString); S.DataString);
finally finally
@ -902,8 +928,8 @@ begin
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
'1 J'+CRLF+ '1 J'+CRLF+
' 2 w'+CRLF+ '2 w'+CRLF+
' 10 11 100 200 re'+CRLF+ '10 11 100 200 re'+CRLF+
'S'+CRLF, 'S'+CRLF,
S.DataString); S.DataString);
finally finally
@ -926,7 +952,7 @@ begin
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
' 10 11 100 200 re'+CRLF+ '10 11 100 200 re'+CRLF+
'f'+CRLF, 'f'+CRLF,
S.DataString); S.DataString);
finally finally
@ -950,7 +976,7 @@ begin
X3 := 200; X3 := 200;
Y3 := 250; Y3 := 250;
s1 := TMockPDFCurveC.Command(x1, y1, x2, y2, x3, y3); s1 := TMockPDFCurveC.Command(x1, y1, x2, y2, x3, y3);
AssertEquals('Failed on 1', ' 10 11 100 9 200 250 c'+CRLF, s1); AssertEquals('Failed on 1', '10 11 100 9 200 250 c'+CRLF, s1);
end; end;
procedure TTestPDFCurveC.TestWrite_Stroke; procedure TTestPDFCurveC.TestWrite_Stroke;
@ -974,8 +1000,8 @@ begin
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
'1 J'+CRLF+ '1 J'+CRLF+
' 2 w'+CRLF+ '2 w'+CRLF+
' 10 11 100 9 200 250 c'+CRLF+ '10 11 100 9 200 250 c'+CRLF+
'S'+CRLF, 'S'+CRLF,
S.DataString); S.DataString);
finally finally
@ -1003,7 +1029,7 @@ begin
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
' 10 11 100 9 200 250 c'+CRLF, '10 11 100 9 200 250 c'+CRLF,
S.DataString); S.DataString);
finally finally
o.Free; o.Free;
@ -1030,8 +1056,8 @@ begin
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
'1 J'+CRLF+ '1 J'+CRLF+
' 2 w'+CRLF+ '2 w'+CRLF+
' 100 9 200 250 v'+CRLF+ '100 9 200 250 v'+CRLF+
'S'+CRLF, 'S'+CRLF,
S.DataString); S.DataString);
finally finally
@ -1056,7 +1082,7 @@ begin
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
' 100 9 200 250 v'+CRLF, '100 9 200 250 v'+CRLF,
S.DataString); S.DataString);
finally finally
o.Free; o.Free;
@ -1083,8 +1109,8 @@ begin
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
'1 J'+CRLF+ '1 J'+CRLF+
' 2 w'+CRLF+ '2 w'+CRLF+
' 100 9 200 250 y'+CRLF+ '100 9 200 250 y'+CRLF+
'S'+CRLF, 'S'+CRLF,
S.DataString); S.DataString);
finally finally
@ -1109,7 +1135,7 @@ begin
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
' 100 9 200 250 y'+CRLF, '100 9 200 250 y'+CRLF,
S.DataString); S.DataString);
finally finally
o.Free; o.Free;
@ -1134,15 +1160,15 @@ begin
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
// move to // move to
' 10 145 m'+CRLF+ '10 145 m'+CRLF+
// curveC 1 // curveC 1
' 10 76.25 55 20 110 20 c'+CRLF+ '10 75.96 54.77 20 110 20 c'+CRLF+
// curveC 2 // curveC 2
' 165 20 210 76.25 210 145 c'+CRLF+ '165.23 20 210 75.96 210 145 c'+CRLF+
// curveC 3 // curveC 3
' 210 213.75 165 270 110 270 c'+CRLF+ '210 214.04 165.23 270 110 270 c'+CRLF+
// curveC 4 // curveC 4
' 55 270 10 213.75 10 145 c'+CRLF, '54.77 270 10 214.04 10 145 c'+CRLF,
S.DataString); S.DataString);
finally finally
o.Free; o.Free;
@ -1165,15 +1191,15 @@ begin
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
// move to // move to
' 10 145 m'+CRLF+ '10 145 m'+CRLF+
// curveC 1 // curveC 1
' 10 76.25 55 20 110 20 c'+CRLF+ '10 75.96 54.77 20 110 20 c'+CRLF+
// curveC 2 // curveC 2
' 165 20 210 76.25 210 145 c'+CRLF+ '165.23 20 210 75.96 210 145 c'+CRLF+
// curveC 3 // curveC 3
' 210 213.75 165 270 110 270 c'+CRLF+ '210 214.04 165.23 270 110 270 c'+CRLF+
// curveC 4 // curveC 4
' 55 270 10 213.75 10 145 c'+CRLF+ '54.77 270 10 214.04 10 145 c'+CRLF+
'f'+CRLF, 'f'+CRLF,
S.DataString); S.DataString);
finally finally
@ -1197,17 +1223,17 @@ begin
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
'1 J'+CRLF+ '1 J'+CRLF+
' 2 w'+CRLF+ '2 w'+CRLF+
// move to // move to
' 10 145 m'+CRLF+ '10 145 m'+CRLF+
// curveC 1 // curveC 1
' 10 76.25 55 20 110 20 c'+CRLF+ '10 75.96 54.77 20 110 20 c'+CRLF+
// curveC 2 // curveC 2
' 165 20 210 76.25 210 145 c'+CRLF+ '165.23 20 210 75.96 210 145 c'+CRLF+
// curveC 3 // curveC 3
' 210 213.75 165 270 110 270 c'+CRLF+ '210 214.04 165.23 270 110 270 c'+CRLF+
// curveC 4 // curveC 4
' 55 270 10 213.75 10 145 c'+CRLF+ '54.77 270 10 214.04 10 145 c'+CRLF+
'S'+CRLF, 'S'+CRLF,
S.DataString); S.DataString);
finally finally
@ -1231,17 +1257,17 @@ begin
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
'1 J'+CRLF+ '1 J'+CRLF+
' 2 w'+CRLF+ '2 w'+CRLF+
// move to // move to
' 10 145 m'+CRLF+ '10 145 m'+CRLF+
// curveC 1 // curveC 1
' 10 76.25 55 20 110 20 c'+CRLF+ '10 75.96 54.77 20 110 20 c'+CRLF+
// curveC 2 // curveC 2
' 165 20 210 76.25 210 145 c'+CRLF+ '165.23 20 210 75.96 210 145 c'+CRLF+
// curveC 3 // curveC 3
' 210 213.75 165 270 110 270 c'+CRLF+ '210 214.04 165.23 270 110 270 c'+CRLF+
// curveC 4 // curveC 4
' 55 270 10 213.75 10 145 c'+CRLF+ '54.77 270 10 214.04 10 145 c'+CRLF+
'b'+CRLF, 'b'+CRLF,
S.DataString); S.DataString);
finally finally
@ -1270,11 +1296,11 @@ begin
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
// move to - p0 // move to - p0
' 10 20 m'+CRLF+ '10 20 m'+CRLF+
// line segment - p1 // line segment - p1
' 30 40 l'+CRLF+ '30 40 l'+CRLF+
// line segment - p2 // line segment - p2
' 50 60 l'+CRLF+ '50 60 l'+CRLF+
'h'+CRLF+ // close 'h'+CRLF+ // close
'f'+CRLF, // fill 'f'+CRLF, // fill
S.DataString); S.DataString);
@ -1303,11 +1329,11 @@ begin
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
// move to - p0 // move to - p0
' 10 20 m'+CRLF+ '10 20 m'+CRLF+
// line segment - p1 // line segment - p1
' 30 40 l'+CRLF+ '30 40 l'+CRLF+
// line segment - p2 // line segment - p2
' 50 60 l'+CRLF+ '50 60 l'+CRLF+
'h'+CRLF, // close 'h'+CRLF, // close
S.DataString); S.DataString);
finally finally
@ -1335,11 +1361,11 @@ begin
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
// move to - p0 // move to - p0
' 10 20 m'+CRLF+ '10 20 m'+CRLF+
// line segment - p1 // line segment - p1
' 30 40 l'+CRLF+ '30 40 l'+CRLF+
// line segment - p2 // line segment - p2
' 50 60 l'+CRLF+ '50 60 l'+CRLF+
'f'+CRLF, // fill 'f'+CRLF, // fill
S.DataString); S.DataString);
finally finally
@ -1364,7 +1390,7 @@ begin
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
// save graphics state // save graphics state
'q'+CRLF+ 'q'+CRLF+
' 150 0 0 75 100 200 cm'+CRLF+ '150 0 0 75 100 200 cm'+CRLF+
'/I1 Do'+CRLF+ '/I1 Do'+CRLF+
// restore graphics state // restore graphics state
'Q'+CRLF, 'Q'+CRLF,
@ -1379,6 +1405,7 @@ var
p: TPDFPage; p: TPDFPage;
img: TMockPDFImage; img: TMockPDFImage;
begin begin
PDF.Options := [poPageOriginAtTop];
p := PDF.Pages.AddPage; p := PDF.Pages.AddPage;
p.UnitOfMeasure := uomMillimeters; p.UnitOfMeasure := uomMillimeters;
AssertEquals('Failed on 1', 0, p.ObjectCount); AssertEquals('Failed on 1', 0, p.ObjectCount);
@ -1391,7 +1418,7 @@ begin
AssertEquals('Failed on 5', AssertEquals('Failed on 5',
// save graphics state // save graphics state
'q'+CRLF+ 'q'+CRLF+
' 200 0 0 100 28.35 785.31 cm'+CRLF+ '200 0 0 100 28.35 785.31 cm'+CRLF+
'/I1 Do'+CRLF+ '/I1 Do'+CRLF+
// restore graphics state // restore graphics state
'Q'+CRLF, 'Q'+CRLF,
@ -1411,7 +1438,7 @@ begin
AssertEquals('Failed on 10', AssertEquals('Failed on 10',
// save graphics state // save graphics state
'q'+CRLF+ 'q'+CRLF+
' 200 0 0 100 283.46 275.07 cm'+CRLF+ '200 0 0 100 283.46 275.07 cm'+CRLF+
'/I1 Do'+CRLF+ '/I1 Do'+CRLF+
// restore graphics state // restore graphics state
'Q'+CRLF, 'Q'+CRLF,
@ -1423,6 +1450,7 @@ var
p: TPDFPage; p: TPDFPage;
img: TMockPDFImage; img: TMockPDFImage;
begin begin
PDF.Options := [poPageOriginAtTop];
p := PDF.Pages.AddPage; p := PDF.Pages.AddPage;
p.UnitOfMeasure := uomMillimeters; p.UnitOfMeasure := uomMillimeters;
AssertEquals('Failed on 1', 0, p.ObjectCount); AssertEquals('Failed on 1', 0, p.ObjectCount);
@ -1468,7 +1496,7 @@ procedure TTestPDFLineStyle.TestWrite_ppsSolid;
var var
o: TMockPDFLineStyle; o: TMockPDFLineStyle;
begin begin
o := TMockPDFLineStyle.Create(PDF, ppsSolid, 1); o := TMockPDFLineStyle.Create(PDF, ppsSolid, 1, 1);
try try
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
o.Write(S); o.Write(S);
@ -1484,12 +1512,12 @@ procedure TTestPDFLineStyle.TestWrite_ppsDash;
var var
o: TMockPDFLineStyle; o: TMockPDFLineStyle;
begin begin
o := TMockPDFLineStyle.Create(PDF, ppsDash, 2); o := TMockPDFLineStyle.Create(PDF, ppsDash, 2, 1);
try try
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
'[5 3] 2 d'+CRLF, '[5 5] 2 d'+CRLF,
S.DataString); S.DataString);
finally finally
o.Free; o.Free;
@ -1500,12 +1528,12 @@ procedure TTestPDFLineStyle.TestWrite_ppsDot;
var var
o: TMockPDFLineStyle; o: TMockPDFLineStyle;
begin begin
o := TMockPDFLineStyle.Create(PDF, ppsDot, 3); o := TMockPDFLineStyle.Create(PDF, ppsDot, 3, 1);
try try
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
'[1 3] 3 d'+CRLF, '[0.80 4] 3 d'+CRLF,
S.DataString); S.DataString);
finally finally
o.Free; o.Free;
@ -1516,12 +1544,12 @@ procedure TTestPDFLineStyle.TestWrite_ppsDashDot;
var var
o: TMockPDFLineStyle; o: TMockPDFLineStyle;
begin begin
o := TMockPDFLineStyle.Create(PDF, ppsDashDot, 4); o := TMockPDFLineStyle.Create(PDF, ppsDashDot, 4, 1);
try try
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
'[5 3 1 3] 4 d'+CRLF, '[5 3 0.80 3] 4 d'+CRLF,
S.DataString); S.DataString);
finally finally
o.Free; o.Free;
@ -1532,18 +1560,38 @@ procedure TTestPDFLineStyle.TestWrite_ppsDashDotDot;
var var
o: TMockPDFLineStyle; o: TMockPDFLineStyle;
begin begin
o := TMockPDFLineStyle.Create(PDF, ppsDashDotDot, 1); o := TMockPDFLineStyle.Create(PDF, ppsDashDotDot, 1, 1);
try try
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
o.Write(S); o.Write(S);
AssertEquals('Failed on 2', AssertEquals('Failed on 2',
'[5 3 1 3 1 3] 1 d'+CRLF, '[5 3 0.80 3 0.80 3] 1 d'+CRLF,
S.DataString); S.DataString);
finally finally
o.Free; o.Free;
end; end;
end; end;
procedure TTestPDFLineStyle.TestLocalisationChanges;
var
o: TMockPDFLineStyle;
d: char;
begin
d := DefaultFormatSettings.DecimalSeparator;
DefaultFormatSettings.DecimalSeparator := Char('~');
o := TMockPDFLineStyle.Create(PDF, ppsDashDotDot, 1, 1);
try
AssertEquals('Failed on 1', '', S.DataString);
o.Write(S);
AssertEquals('Failed on 2',
'[5 3 0.80 3 0.80 3] 1 d'+CRLF,
S.DataString);
finally
o.Free;
end;
DefaultFormatSettings.DecimalSeparator := d;
end;
{ TTestPDFColor } { TTestPDFColor }
procedure TTestPDFColor.TestWrite_Stroke; procedure TTestPDFColor.TestWrite_Stroke;
@ -1673,11 +1721,13 @@ begin
AssertTrue('Failed on 1', p.UnitOfMeasure = uomMillimeters); AssertTrue('Failed on 1', p.UnitOfMeasure = uomMillimeters);
end; end;
procedure TTestPDFPage.TestMatrix; // (0,0) origin is at top-left of page
procedure TTestPDFPage.TestMatrixOn;
var var
p: TPDFPage; p: TPDFPage;
pt1, pt2: TPDFCoord; pt1, pt2: TPDFCoord;
begin begin
PDF.Options := [poPageOriginAtTop];
p := PDF.Pages.AddPage; p := PDF.Pages.AddPage;
AssertTrue('Failed on 1', p.UnitOfMeasure = uomMillimeters); AssertTrue('Failed on 1', p.UnitOfMeasure = uomMillimeters);
AssertEquals('Failed on 2', mmToPDF(p.Matrix._21), p.Paper.H); AssertEquals('Failed on 2', mmToPDF(p.Matrix._21), p.Paper.H);
@ -1693,6 +1743,28 @@ begin
AssertEquals('Failed on 6', 20, pt1.Y, 0.1); AssertEquals('Failed on 6', 20, pt1.Y, 0.1);
end; end;
// (0,0) origin is at bottom-left of page
procedure TTestPDFPage.TestMatrixOff;
var
p: TPDFPage;
pt1, pt2: TPDFCoord;
begin
PDF.Options := [];
p := PDF.Pages.AddPage;
AssertTrue('Failed on 1', p.UnitOfMeasure = uomMillimeters);
AssertEquals('Failed on 2', mmToPDF(p.Matrix._21), 0);
pt1.X := 10;
pt1.Y := 20;
pt2 := p.Matrix.Transform(pt1);
AssertEquals('Failed on 3', 10, pt2.X);
AssertEquals('Failed on 4', 20, pt2.Y, 0.1);
pt1 := p.Matrix.ReverseTransform(pt2);
AssertEquals('Failed on 5', 10, pt1.X);
AssertEquals('Failed on 6', 20, pt1.Y, 0.1);
end;
procedure TTestPDFPage.TestUnitOfMeasure_MM; procedure TTestPDFPage.TestUnitOfMeasure_MM;
var var
p: TPDFPage; p: TPDFPage;

148
packages/fcl-pdf/tests/fpttf_test.pas
View File

@ -12,25 +12,39 @@ uses
,fpcunit, testregistry ,fpcunit, testregistry
{$endif} {$endif}
,fpttf ,fpttf
,fpparsettf
; ;
type type
TMyTestFPFontCacheItem = class(TFPFontCacheItem)
protected
FFileInfo: TTFFileInfo;
end;
TFPFontCacheItemTest = class(TTestCase) TFPFontCacheItemTest = class(TTestCase)
private private
FCacheItem: TFPFontCacheItem; FCacheItem: TMyTestFPFontCacheItem;
procedure SetupRealFont;
protected protected
procedure SetUp; override; procedure SetUp; override;
procedure TearDown; override; procedure TearDown; override;
public public
property CI: TFPFontCacheItem read FCacheItem; property CI: TMyTestFPFontCacheItem read FCacheItem;
published published
procedure TestIsRegularCantFind;
procedure TestIsBoldCantFind;
procedure TestIsItalicCantFind;
procedure TestIsFixedWidthCantFind;
procedure TestFileInfoCantFind;
procedure TestIsRegular; procedure TestIsRegular;
procedure TestIsBold; procedure TestIsBold;
procedure TestIsItalic; procedure TestIsItalic;
procedure TestIsFixedWidth; procedure TestIsFixedWidth;
procedure TestRegularVsFixedWidth; procedure TestRegularVsFixedWidth;
procedure TestFileName; procedure TestFileName;
procedure TestFontInfoAfterCreate;
procedure TestTextWidth_FontUnits; procedure TestTextWidth_FontUnits;
procedure TestTextWidth_Pixels; procedure TestTextWidth_Pixels;
end; end;
@ -52,25 +66,31 @@ type
procedure TestFind_FamilyName; procedure TestFind_FamilyName;
procedure TestFind_PostscriptName; procedure TestFind_PostscriptName;
procedure TestAssignFontList; procedure TestAssignFontList;
procedure TestLoadFromFile;
procedure TestReadStandardFonts;
end; end;
implementation implementation
uses
fpparsettf;
const const
cFontCount = 5; cFontCount = 5;
resourcestring resourcestring
cErrFontCountWrong = ' - make sure you only have the 5 test fonts in the "fonts" directory.'; cErrFontCountWrong = ' - make sure you only have the 5 test fonts in the "fonts" directory.';
{ TFPFontCacheItemTest } { TFPFontCacheItemTest }
procedure TFPFontCacheItemTest.SetupRealFont;
begin
FCacheItem.Free;
FCacheItem := TMyTestFPFontCacheItem.Create('fonts' + PathDelim + 'DejaVuSans.ttf');
end;
procedure TFPFontCacheItemTest.SetUp; procedure TFPFontCacheItemTest.SetUp;
begin begin
inherited SetUp; inherited SetUp;
FCacheItem := TFPFontCacheItem.Create('mytest.ttf'); FCacheItem := TMyTestFPFontCacheItem.Create('mytest.ttf');
end; end;
procedure TFPFontCacheItemTest.TearDown; procedure TFPFontCacheItemTest.TearDown;
@ -79,29 +99,103 @@ begin
inherited TearDown; inherited TearDown;
end; end;
procedure TFPFontCacheItemTest.TestIsRegularCantFind;
begin
try
AssertFalse(CI.IsRegular); // this should raise an error
Fail('Failed on 1');
except
on E: Exception do
begin
AssertEquals('Failed on 2', 'ETTF', E.ClassName);
AssertEquals('Failed on 3', 'The font file <mytest.ttf> can''t be found.', E.Message);
end;
end;
end;
procedure TFPFontCacheItemTest.TestIsBoldCantFind;
begin
try
AssertFalse(CI.IsBold); // this should raise an error
Fail('Failed on 1');
except
on E: Exception do
begin
AssertEquals('Failed on 2', 'ETTF', E.ClassName);
AssertEquals('Failed on 3', 'The font file <mytest.ttf> can''t be found.', E.Message);
end;
end;
end;
procedure TFPFontCacheItemTest.TestIsItalicCantFind;
begin
try
AssertFalse(CI.IsItalic); // this should raise an error
Fail('Failed on 1');
except
on E: Exception do
begin
AssertEquals('Failed on 2', 'ETTF', E.ClassName);
AssertEquals('Failed on 3', 'The font file <mytest.ttf> can''t be found.', E.Message);
end;
end;
end;
procedure TFPFontCacheItemTest.TestIsFixedWidthCantFind;
begin
try
AssertFalse(CI.IsFixedWidth); // this should raise an error
Fail('Failed on 1');
except
on E: Exception do
begin
AssertEquals('Failed on 2', 'ETTF', E.ClassName);
AssertEquals('Failed on 3', 'The font file <mytest.ttf> can''t be found.', E.Message);
end;
end;end;
procedure TFPFontCacheItemTest.TestFileInfoCantFind;
begin
try
AssertFalse(CI.FontData <> nil); // this should raise an error
Fail('Failed on 1');
except
on E: Exception do
begin
AssertEquals('Failed on 2', 'ETTF', E.ClassName);
AssertEquals('Failed on 3', 'The font file <mytest.ttf> can''t be found.', E.Message);
end;
end;
end;
procedure TFPFontCacheItemTest.TestIsRegular; procedure TFPFontCacheItemTest.TestIsRegular;
begin begin
SetupRealFont;
{ regular should be the default flag set } { regular should be the default flag set }
AssertEquals('Failed on 1', True, CI.IsRegular); AssertEquals('Failed on 1', True, CI.IsRegular);
end; end;
procedure TFPFontCacheItemTest.TestIsBold; procedure TFPFontCacheItemTest.TestIsBold;
begin begin
SetupRealFont;
AssertEquals('Failed on 1', False, CI.IsBold); AssertEquals('Failed on 1', False, CI.IsBold);
end; end;
procedure TFPFontCacheItemTest.TestIsItalic; procedure TFPFontCacheItemTest.TestIsItalic;
begin begin
SetupRealFont;
AssertEquals('Failed on 1', False, CI.IsItalic); AssertEquals('Failed on 1', False, CI.IsItalic);
end; end;
procedure TFPFontCacheItemTest.TestIsFixedWidth; procedure TFPFontCacheItemTest.TestIsFixedWidth;
begin begin
SetupRealFont;
AssertEquals('Failed on 1', False, CI.IsFixedWidth); AssertEquals('Failed on 1', False, CI.IsFixedWidth);
end; end;
procedure TFPFontCacheItemTest.TestRegularVsFixedWidth; procedure TFPFontCacheItemTest.TestRegularVsFixedWidth;
begin begin
SetupRealFont;
AssertEquals('Failed on 1', True, CI.IsRegular); AssertEquals('Failed on 1', True, CI.IsRegular);
AssertEquals('Failed on 2', False, CI.IsFixedWidth); AssertEquals('Failed on 2', False, CI.IsFixedWidth);
end; end;
@ -109,8 +203,14 @@ end;
procedure TFPFontCacheItemTest.TestFileName; procedure TFPFontCacheItemTest.TestFileName;
begin begin
AssertTrue('Failed on 1', CI.FileName <> ''); AssertTrue('Failed on 1', CI.FileName <> '');
{ FileName is a non-existing file though, so FontData should be nil } { The Filename property doesn't trigger the loading of font info data }
AssertTrue('Failed on 2', CI.FontData = nil); AssertTrue('Failed on 2', CI.FFileInfo = nil);
end;
procedure TFPFontCacheItemTest.TestFontInfoAfterCreate;
begin
{ Font info isn't loaded in the constructor any more - it is now loaded on demand }
AssertTrue('Failed on 1', CI.FFileInfo = nil);
end; end;
procedure TFPFontCacheItemTest.TestTextWidth_FontUnits; procedure TFPFontCacheItemTest.TestTextWidth_FontUnits;
@ -312,6 +412,38 @@ begin
end; end;
end; end;
procedure TFPFontCacheListTest.TestLoadFromFile;
const
cFontListFile = 'fontlist.txt';
var
s: string;
lCI: TFPFontCacheItem;
begin
s := ExtractFilePath(ParamStr(0)) + cFontListFile;
AssertEquals('Failed on 1', 0, FC.Count);
FC.LoadFromFile(s);
AssertEquals('Failed on 2', 3, FC.Count);
lCI := FC.Find('DejaVuSans');
AssertTrue('Failed on 3', Assigned(lCI));
lCI := nil;
lCI := FC.Find('FreeSans');
AssertTrue('Failed on 4', Assigned(lCI));
lCI := nil;
lCI := FC.Find('LiberationSans-Italic');
AssertTrue('Failed on 5', Assigned(lCI));
lCI := nil;
end;
procedure TFPFontCacheListTest.TestReadStandardFonts;
begin
AssertEquals('Failed on 1', 0, FC.Count);
FC.ReadStandardFonts;
AssertTrue('Failed on 2', FC.Count > 1);
end;
initialization initialization
RegisterTest({$ifdef fptest}'fpTTF', {$endif}TFPFontCacheItemTest{$ifdef fptest}.Suite{$endif}); RegisterTest({$ifdef fptest}'fpTTF', {$endif}TFPFontCacheItemTest{$ifdef fptest}.Suite{$endif});

6
packages/fcl-pdf/utils/ttfdump.lpi
View File

@ -32,6 +32,7 @@
<RunParams> <RunParams>
<local> <local>
<FormatVersion Value="1"/> <FormatVersion Value="1"/>
<CommandLineParams Value="-f ../tests/fonts/FreeSans.ttf -s"/>
</local> </local>
</RunParams> </RunParams>
<Units Count="1"> <Units Count="1">
@ -56,6 +57,11 @@
<AllowLabel Value="False"/> <AllowLabel Value="False"/>
</SyntaxOptions> </SyntaxOptions>
</Parsing> </Parsing>
<Linking>
<Debugging>
<UseHeaptrc Value="True"/>
</Debugging>
</Linking>
</CompilerOptions> </CompilerOptions>
<Debugging> <Debugging>
<Exceptions Count="3"> <Exceptions Count="3">

159
packages/fcl-pdf/utils/ttfdump.lpr
View File

@ -1,46 +1,18 @@
program ttfdump; program ttfdump;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
{$codepage utf8}
uses uses
{$IFDEF UNIX}{$IFDEF UseCThreads} {$ifdef unix}cwstring,{$endif} // required for UnicodeString handling.
cwstrings, Classes,
{$ENDIF}{$ENDIF} SysUtils,
Classes, SysUtils, CustApp, CustApp,
fpparsettf, contnrs; fpparsettf,
FPFontTextMapping,
fpTTFSubsetter;
type type
// forward declarations
TTextMapping = class;
TTextMappingList = class(TObject)
private
FList: TFPObjectList;
function GetCount: Integer;
protected
function GetItem(AIndex: Integer): TTextMapping; reintroduce;
procedure SetItem(AIndex: Integer; AValue: TTextMapping); reintroduce;
public
constructor Create;
destructor Destroy; override;
function Add(AObject: TTextMapping): Integer; overload;
function Add(const ACharID, AGlyphID: uint16): Integer; overload;
property Count: Integer read GetCount;
property Items[Index: Integer]: TTextMapping read GetItem write SetItem; default;
end;
TTextMapping = class(TObject)
private
FCharID: uint16;
FGlyphID: uint16;
public
class function NewTextMap(const ACharID, AGlyphID: uint16): TTextMapping;
property CharID: uint16 read FCharID write FCharID;
property GlyphID: uint16 read FGlyphID write FGlyphID;
end;
TMyApplication = class(TCustomApplication) TMyApplication = class(TCustomApplication)
private private
@ -48,6 +20,7 @@ type
procedure DumpGlyphIndex; procedure DumpGlyphIndex;
function GetGlyphIndicesString(const AText: UnicodeString): AnsiString; overload; function GetGlyphIndicesString(const AText: UnicodeString): AnsiString; overload;
function GetGlyphIndices(const AText: UnicodeString): TTextMappingList; overload; function GetGlyphIndices(const AText: UnicodeString): TTextMappingList; overload;
procedure CreateSubsetFontFile(const AList: TTextMappingList);
protected protected
procedure DoRun; override; procedure DoRun; override;
public public
@ -56,70 +29,10 @@ type
procedure WriteHelp; virtual; procedure WriteHelp; virtual;
end; end;
TFriendClass = class(TTFFileInfo) TFriendClass = class(TTFFileInfo)
end; end;
{ TTextMappingList }
function TTextMappingList.GetCount: Integer;
begin
Result := FList.Count;
end;
function TTextMappingList.GetItem(AIndex: Integer): TTextMapping;
begin
Result := TTextMapping(FList.Items[AIndex]);
end;
procedure TTextMappingList.SetItem(AIndex: Integer; AValue: TTextMapping);
begin
FList.Items[AIndex] := AValue;
end;
constructor TTextMappingList.Create;
begin
FList := TFPObjectList.Create;
end;
destructor TTextMappingList.Destroy;
begin
FList.Free;
inherited Destroy;
end;
function TTextMappingList.Add(AObject: TTextMapping): Integer;
var
i: integer;
begin
Result := -1;
for i := 0 to FList.Count-1 do
begin
if TTextMapping(FList.Items[i]).CharID = AObject.CharID then
Exit; // mapping already exists
end;
Result := FList.Add(AObject);
end;
function TTextMappingList.Add(const ACharID, AGlyphID: uint16): Integer;
var
o: TTextMapping;
begin
o := TTextMapping.Create;
o.CharID := ACharID;
o.GlyphID := AGlyphID;
Result := Add(o);
if Result = -1 then
o.Free;
end;
{ TTextMapping }
class function TTextMapping.NewTextMap(const ACharID, AGlyphID: uint16): TTextMapping;
begin
Result := TTextMapping.Create;
Result.CharID := ACharID;
Result.GlyphID := AGlyphID;
end;
{ TMyApplication } { TMyApplication }
@ -127,16 +40,16 @@ procedure TMyApplication.DumpGlyphIndex;
begin begin
Writeln('FHHead.numberOfHMetrics = ', FFontFile.HHead.numberOfHMetrics); Writeln('FHHead.numberOfHMetrics = ', FFontFile.HHead.numberOfHMetrics);
Writeln('Length(Chars[]) = ', Length(FFontFile.Chars)); Writeln('Length(Chars[]) = ', Length(FFontFile.Chars));
writeln;
writeln('Glyph Index values:'); writeln('Glyph Index values:');
Writeln('U+0020 (space) = ', FFontFile.Chars[$0020]); Writeln(' U+0020 (space) = ', Format('%d (%0:4.4x)', [FFontFile.Chars[$0020]]));
Writeln('U+0021 (!) = ', FFontFile.Chars[$0021]); Writeln(' U+0021 (!) = ', Format('%d (%0:4.4x)', [FFontFile.Chars[$0021]]));
Writeln('U+0048 (H) = ', FFontFile.Chars[$0048]); Writeln(' U+0048 (H) = ', Format('%d (%0:4.4x)', [FFontFile.Chars[$0048]]));
writeln;
Writeln('Glyph widths:'); Writeln('Glyph widths:');
Writeln('3 = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0020]].AdvanceWidth)); Writeln(' 3 = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0020]].AdvanceWidth));
Writeln('4 = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0021]].AdvanceWidth)); Writeln(' 4 = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0021]].AdvanceWidth));
Writeln('H = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0048]].AdvanceWidth)); Writeln(' H = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0048]].AdvanceWidth));
end; end;
function TMyApplication.GetGlyphIndices(const AText: UnicodeString): TTextMappingList; function TMyApplication.GetGlyphIndices(const AText: UnicodeString): TTextMappingList;
@ -154,6 +67,20 @@ begin
end; end;
end; end;
procedure TMyApplication.CreateSubsetFontFile(const AList: TTextMappingList);
var
lSubset: TFontSubsetter;
begin
writeln;
writeln('called CreateSubsetFontFile...');
lSubset := TFontSubsetter.Create(FFontFile, AList);
try
lSubSet.SaveToFile(ExtractFileName(GetOptionValue('f'))+'.subset.ttf');
finally
FreeAndNil(lSubSet);
end;
end;
function TMyApplication.GetGlyphIndicesString(const AText: UnicodeString): AnsiString; function TMyApplication.GetGlyphIndicesString(const AText: UnicodeString): AnsiString;
var var
i: integer; i: integer;
@ -177,7 +104,7 @@ var
i: integer; i: integer;
begin begin
// quick check parameters // quick check parameters
ErrorMsg := CheckOptions('hf:', 'help'); ErrorMsg := CheckOptions('hf:s', 'help');
if ErrorMsg <> '' then if ErrorMsg <> '' then
begin begin
ShowException(Exception.Create(ErrorMsg)); ShowException(Exception.Create(ErrorMsg));
@ -196,13 +123,25 @@ begin
FFontFile.LoadFromFile(self.GetOptionValue('f')); FFontFile.LoadFromFile(self.GetOptionValue('f'));
DumpGlyphIndex; DumpGlyphIndex;
s := 'Hello, World!'; // test #1
// s := 'Hello, World!';
// test #2
s := 'Typography: “What’s wrong?”';
Writeln(''); Writeln('');
lst := GetGlyphIndices(s); lst := GetGlyphIndices(s);
Writeln(Format('%d Glyph indices for: "%s"', [lst.Count, s])); Writeln(Format('%d Glyph indices for: "%s"', [lst.Count, s]));
writeln(#9'GID'#9'CharID');
writeln(#9'---'#9'------');
for i := 0 to lst.Count-1 do for i := 0 to lst.Count-1 do
Writeln(Format(#9'%s'#9'%s', [IntToHex(lst[i].GlyphID, 4), IntToHex(lst[i].CharID, 4)])); Writeln(Format(#9'%s'#9'%s'#9'%s', [IntToHex(lst[i].GlyphID, 4), IntToHex(lst[i].CharID, 4), Char(lst[i].CharID)]));
if HasOption('s','') then
CreateSubsetFontFile(lst);
lst.Free;
writeln;
writeln;
// stop program loop // stop program loop
Terminate; Terminate;
end; end;
@ -225,11 +164,13 @@ begin
writeln('Usage: ', ExeName, ' -h'); writeln('Usage: ', ExeName, ' -h');
writeln(' -h Show this help.'); writeln(' -h Show this help.');
writeln(' -f <ttf> Load TTF font file.'); writeln(' -f <ttf> Load TTF font file.');
writeln(' -s Generate a subset TTF file.');
end; end;
var var
Application: TMyApplication; Application: TMyApplication;
begin begin
Application := TMyApplication.Create(nil); Application := TMyApplication.Create(nil);
Application.Title := 'TTF Font Dump'; Application.Title := 'TTF Font Dump';