paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 14:47:55 +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/fpmake.pp 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/fppdf.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,
FFontCompression: boolean;
FNoFontEmbedding: boolean;
FSubsetFontEmbedding: boolean;
FDoc: TPDFDocument;
function SetUpDocument: TPDFDocument;
procedure SaveDocument(D: TPDFDocument);
@ -77,8 +78,13 @@ begin
Result.Infos.CreationDate := Now;
lOpts := [poPageOriginAtTop];
if FSubsetFontEmbedding then
Include(lOpts, poSubsetFont);
if FNoFontEmbedding then
begin
Include(lOpts, poNoEmbeddedFonts);
Exclude(lOpts, poSubsetFont);
end;
if FFontCompression then
Include(lOpts, poCompressFonts);
if FTextCompression then
@ -132,7 +138,8 @@ end;
procedure TPDFTestApp.SimpleText(D: TPDFDocument; APage: integer);
var
P : TPDFPage;
FtTitle, FtText1, FtText2, FtText3: integer;
FtTitle, FtText1, FtText2: integer;
FtWaterMark: integer;
begin
P := D.Pages[APage];
@ -140,14 +147,16 @@ begin
FtTitle := D.AddFont('Helvetica');
FtText1 := D.AddFont('FreeSans.ttf', 'FreeSans');
FtText2 := D.AddFont('Times-BoldItalic');
// FtText3 := D.AddFont('arial.ttf', 'Arial');
FtText3 := FtText1; // to reduce font dependecies, but above works too if you have arial.ttf available
FtWaterMark := D.AddFont('Helvetica-Bold');
{ Page title }
P.SetFont(FtTitle, 23);
P.SetColor(clBlack, false);
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
@ -158,6 +167,12 @@ begin
P.WriteText(25, 57, 'Click the URL: http://www.freepascal.org');
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
P.SetColor(clBlue, false);
P.WriteText(25, 100, 'Rotated text at 30 degrees', 30);
@ -169,17 +184,16 @@ begin
// -----------------------------------
// TrueType testing purposes
P.SetFont(ftText3, 13);
P.SetFont(FtText1, 13);
P.SetColor(clBlack, false);
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, 150, 'Portuguese: Olá mundo');
P.WriteText(40, 160, 'Russian: Здравствуйте мир');
P.WriteText(40, 170, 'Vietnamese: Xin chào thế giới');
P.SetFont(ftText1, 13);
P.WriteText(15, 185, 'Box Drawing: ╠ ╣ ╦ ╩ ├ ┤ ┬ ┴');
P.WriteText(15, 200, 'Typography: “What’s wrong?”');
@ -213,30 +227,30 @@ begin
P.WriteText(25, 20, 'Sample Line Drawing (DrawLine)');
P.SetColor(clBlack, True);
P.SetPenStyle(ppsSolid);
P.SetPenStyle(ppsSolid, 1);
lPt1.X := 30; lPt1.Y := 100;
lPt2.X := 150; lPt2.Y := 150;
P.DrawLine(lPt1, lPt2, 0.2);
P.DrawLine(lPt1, lPt2, 1);
P.SetColor(clBlue, True);
P.SetPenStyle(ppsDash);
P.SetPenStyle(ppsDash, 1);
lPt1.X := 50; lPt1.Y := 70;
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 }
P.SetColor(clRed, True);
P.SetPenStyle(ppsDashDot);
P.SetPenStyle(ppsDashDot, 1);
P.DrawLine(40, 140, 160, 80, 1);
P.SetColor(clBlack, True);
P.SetPenStyle(ppsDashDotDot);
P.DrawLine(60, 50, 60, 120, 1.5);
P.SetPenStyle(ppsDashDotDot, 1);
P.DrawLine(60, 50, 60, 120, 1);
P.SetColor(clBlack, True);
P.SetPenStyle(ppsDot);
P.DrawLine(10, 80, 130, 130, 0.5);
P.SetPenStyle(ppsDot, 1);
P.DrawLine(10, 80, 130, 130, 1);
end;
procedure TPDFTestApp.SimpleLines(D: TPDFDocument; APage: integer);
@ -256,11 +270,11 @@ begin
P.WriteText(25, 20, 'Sample Line Drawing (DrawLineStyle)');
// write the text at position 100 mm from left and 120 mm from top
TsThinBlack := D.AddLineStyleDef(0.2, clBlack, ppsSolid);
TsThinBlue := D.AddLineStyleDef(0.1, clBlue, ppsDash);
TsThinBlack := D.AddLineStyleDef(1, clBlack, ppsSolid);
TsThinBlue := D.AddLineStyleDef(1, clBlue, ppsDash);
TsThinRed := D.AddLineStyleDef(1, clRed, ppsDashDot);
TsThick := D.AddLineStyleDef(1.5, clBlack, ppsDashDotDot);
TsThinBlackDot := D.AddLineStyleDef(0.5, clBlack, ppsDot);
TsThick := D.AddLineStyleDef(1, clBlack, ppsDashDotDot);
TsThinBlackDot := D.AddLineStyleDef(1, clBlack, ppsDot);
lPt1.X := 30; lPt1.Y := 100;
lPt2.X := 150; lPt2.Y := 150;
@ -697,6 +711,7 @@ var
lFontIdx: integer;
lFC: TFPFontCacheItem;
lHeight: single;
lDescenderHeight: single;
lTextHeightInMM: single;
lWidth: single;
lTextWidthInMM: single;
@ -719,21 +734,15 @@ begin
if not Assigned(lFC) then
raise Exception.Create(AFontName + ' font not found');
{ result is in pixels }
lHeight := lFC.FontData.CapHeight * APointSize * gTTFontCache.DPI / (72 * lFC.FontData.Head.UnitsPerEm);
{ convert pixels to mm as our PDFPage.UnitOfMeasure is set to mm. }
lTextHeightInMM := (lHeight * 25.4) / gTTFontCache.DPI;
lHeight := lFC.TextHeight(AText, APointSize, lDescenderHeight);
{ convert the Font Units to mm as our PDFPage.UnitOfMeasure is set to mm. }
lTextHeightInMM := (lHeight * 25.4) / gTTFontCache.DPI;
lDescenderHeightInMM := (lDescenderHeight * 25.4) / gTTFontCache.DPI;
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;
{ 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
WriteText() draws on the baseline. Also adjust the TextHeight
because CapHeight doesn't take into account the Descender. }
@ -766,7 +775,7 @@ begin
StopOnException:=True;
inherited DoRun;
// quick check parameters
ErrorMsg := CheckOptions('hp:f:t:i:j:n', '');
ErrorMsg := CheckOptions('hp:f:t:i:j:ns', '');
if ErrorMsg <> '' then
begin
WriteLn('ERROR: ' + ErrorMsg);
@ -797,6 +806,7 @@ begin
end;
FNoFontEmbedding := HasOption('n', '');
FSubsetFontEmbedding := HasOption('s', '');
FFontCompression := BoolFlag('f',true);
FTextCompression := BoolFlag('t',False);
FImageCompression := BoolFlag('i',False);
@ -852,6 +862,7 @@ begin
' If this option is not specified, then all %0:d pages are' + LineEnding +
' generated.', [cPageCount]));
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 +
' disables compression. A value of 1 enables compression.' + LineEnding +
' 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('fcl-base');
P.Dependencies.Add('fcl-image');
P.Dependencies.Add('fcl-xml');
P.Dependencies.Add('paszlib');
P.Version:='3.1.1';
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
uses
Classes, SysUtils, fpttfencodings;
Classes,
SysUtils,
fpttfencodings;
type
ETTF = Class(Exception);
// 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;
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 }
TF16Dot16 = type Int32;
@ -43,6 +49,7 @@ type
1: (Version: UInt32);
end;
{ The file header record that starts at byte 0 of a TTF file }
TTableDirectory = Packed Record
FontVersion : TFixedVersionRec; { UInt32}
Numtables : UInt16;
@ -63,7 +70,7 @@ type
AdvanceWidth : UInt16;
LSB: Int16; { leftSideBearing }
end;
TLongHorMetrics = Packed Array of TLongHorMetric;
TLongHorMetricArray = Packed Array of TLongHorMetric;
Type
TPostScript = Packed Record
@ -166,7 +173,8 @@ Type
XMaxExtent : Int16;
CaretSlopeRise : Int16;
CaretSlopeRun : Int16;
Reserved : Array[0..4] of Int16;
caretOffset: Int16; // reserved field
Reserved : Array[0..3] of Int16;
metricDataFormat : Int16;
numberOfHMetrics : UInt16;
end;
@ -219,6 +227,19 @@ Type
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)
private
FFilename: string;
@ -233,7 +254,7 @@ Type
FHHEad : THHead;
FOS2Data : TOS2Data;
FPostScript : TPostScript;
FWidths: TLongHorMetrics; // hmtx data
FWidths: TLongHorMetricArray; // hmtx data
// Needed to create PDF font def.
FOriginalSize : Cardinal;
FMissingWidth: Integer;
@ -242,7 +263,6 @@ Type
function FixMinorVersion(const AMinor: word): word;
function GetMissingWidth: integer;
Protected
Function IsNativeData : Boolean; virtual;
// Stream reading functions.
function ReadInt16(AStream: TStream): Int16; inline;
function ReadUInt32(AStream: TStream): UInt32; inline;
@ -272,6 +292,7 @@ Type
destructor Destroy; override;
{ Returns the Glyph Index value in the TTF file, where AValue is the ordinal value of a character. }
function GetGlyphIndex(AValue: word): word;
function GetTableDirEntry(const ATableName: string; var AEntry: TTableDirectoryEntry): boolean;
// Load a TTF file from file or stream.
Procedure LoadFromFile(const AFileName : String);
Procedure LoadFromStream(AStream: TStream); virtual;
@ -307,7 +328,7 @@ Type
property CmapSubtables : TCmapSubTables Read FSubtables;
property CmapUnicodeMap : TCmapFmt4 Read FUnicodeMap;
property CmapUnicodeMapSegments : TUnicodeMapSegmentArray Read FUnicodeMapSegments;
Property Widths : TLongHorMetrics Read FWidths;
Property Widths : TLongHorMetricArray Read FWidths;
Property MaxP : TMaxP Read FMaxP;
Property OS2Data : TOS2Data Read FOS2Data;
Property PostScript : TPostScript Read FPostScript;
@ -331,7 +352,8 @@ procedure FillMem(Dest: pointer; Size: longint; Data: Byte );
Const
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
@ -393,16 +415,14 @@ function TTFFileInfo.ReadUInt32(AStream: TStream): UInt32;
begin
Result:=0;
AStream.ReadBuffer(Result,SizeOf(Result));
if Not IsNativeData then
Result:=BEtoN(Result);
Result:=BEtoN(Result);
end;
function TTFFileInfo.ReadUInt16(AStream: TStream): UInt16;
begin
Result:=0;
AStream.ReadBuffer(Result,SizeOf(Result));
if Not IsNativeData then
Result:=BEtoN(Result);
Result:=BEtoN(Result);
end;
function TTFFileInfo.ReadInt16(AStream: TStream): Int16;
@ -415,8 +435,6 @@ var
i : Integer;
begin
AStream.ReadBuffer(FHead,SizeOf(FHead));
if IsNativeData then
exit;
FHead.FileVersion.Version := BEtoN(FHead.FileVersion.Version);
FHead.FileVersion.Minor := FixMinorVersion(FHead.FileVersion.Minor);
FHead.FontRevision.Version := BEtoN(FHead.FontRevision.Version);
@ -437,34 +455,29 @@ begin
end;
procedure TTFFileInfo.ParseHhea(AStream : TStream);
begin
AStream.ReadBuffer(FHHEad,SizeOf(FHHEad));
if IsNativeData then
exit;
FHHEad.TableVersion.Version := BEToN(FHHEad.TableVersion.Version);
FHHEad.TableVersion.Minor := FixMinorVersion(FHHEad.TableVersion.Minor);
FHHEad.Ascender:=BEToN(FHHEad.Ascender);
FHHEad.Descender:=BEToN(FHHEad.Descender);
FHHEad.LineGap:=BEToN(FHHEad.LineGap);
FHHead.AdvanceWidthMax := BEToN(FHHead.AdvanceWidthMax);
FHHEad.MinLeftSideBearing:=BEToN(FHHEad.MinLeftSideBearing);
FHHEad.MinRightSideBearing:=BEToN(FHHEad.MinRightSideBearing);
FHHEad.XMaxExtent:=BEToN(FHHEad.XMaxExtent);
FHHEad.CaretSlopeRise:=BEToN(FHHEad.CaretSlopeRise);
FHHEad.CaretSlopeRun:=BEToN(FHHEad.CaretSlopeRun);
FHHEad.caretOffset := BEToN(FHHEad.caretOffset);
FHHEad.metricDataFormat:=BEToN(FHHEad.metricDataFormat);
FHHEad.numberOfHMetrics:=BEToN(FHHEad.numberOfHMetrics);
FHHead.AdvanceWidthMax := BEToN(FHHead.AdvanceWidthMax);
end;
procedure TTFFileInfo.ParseMaxp(AStream : TStream);
begin
AStream.ReadBuffer(FMaxP,SizeOf(TMaxP));
if IsNativeData then
exit;
With FMaxP do
begin
begin
VersionNumber.Version := BEtoN(VersionNumber.Version);
VersionNumber.Minor := FixMinorVersion(VersionNumber.Minor);
numGlyphs:=BEtoN(numGlyphs);
@ -481,24 +494,20 @@ begin
maxSizeOfInstructions :=BEtoN(maxSizeOfInstructions);
maxComponentElements :=BEtoN(maxComponentElements);
maxComponentDepth :=BEtoN(maxComponentDepth);
end;
end;
end;
procedure TTFFileInfo.ParseHmtx(AStream : TStream);
var
i : Integer;
begin
SetLength(FWidths,FHHead.numberOfHMetrics);
AStream.ReadBuffer(FWidths[0],SizeOf(TLongHorMetric)*Length(FWidths));
if IsNativeData then
exit;
for I:=0 to FHHead.NumberOfHMetrics-1 do
begin
begin
FWidths[I].AdvanceWidth:=BEtoN(FWidths[I].AdvanceWidth);
FWidths[I].LSB:=BEtoN(FWidths[I].LSB);
end;
end;
end;
@ -510,7 +519,6 @@ var
Segm : TUnicodeMapSegment;
GlyphIDArray : Array of word;
S : TStream;
begin
TableStartPos:=AStream.Position;
FCMapH.Version:=ReadUInt16(AStream);
@ -670,80 +678,76 @@ begin
FillWord(FOS2Data,SizeOf(TOS2Data) div 2,0);
// -18, so version 1 will not overflow
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
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
if Version>=1 then
begin
begin
ulCodePageRange1:=ReadUInt32(AStream);
ulCodePageRange2:=ReadUInt32(AStream);
end;
end;
if Version>=2 then
begin
begin
sxHeight:=ReadInt16(AStream);
sCapHeight:=ReadInt16(AStream);
usDefaultChar:=ReadUInt16(AStream);
usBreakChar:=ReadUInt16(AStream);
usMaxContext:=ReadUInt16(AStream);
end;
end;
end;
end;
procedure TTFFileInfo.ParsePost(AStream : TStream);
begin
AStream.ReadBuffer(FPostScript,SizeOf(TPostScript));
if not IsNativeData then
With FPostScript do
begin
Format.Version := BEtoN(Format.Version);
Format.Minor := FixMinorVersion(Format.Minor);
ItalicAngle:=BeToN(ItalicAngle);
UnderlinePosition:=BeToN(UnderlinePosition);
underlineThickness:=BeToN(underlineThickness);
isFixedPitch:=BeToN(isFixedPitch);
minMemType42:=BeToN(minMemType42);
maxMemType42:=BeToN(maxMemType42);
minMemType1:=BeToN(minMemType1);
maxMemType1:=BeToN(maxMemType1);
end;
With FPostScript do
begin
Format.Version := BEtoN(Format.Version);
Format.Minor := FixMinorVersion(Format.Minor);
ItalicAngle:=BeToN(ItalicAngle);
UnderlinePosition:=BeToN(UnderlinePosition);
underlineThickness:=BeToN(underlineThickness);
isFixedPitch:=BeToN(isFixedPitch);
minMemType42:=BeToN(minMemType42);
maxMemType42:=BeToN(maxMemType42);
minMemType1:=BeToN(minMemType1);
maxMemType1:=BeToN(maxMemType1);
end;
end;
procedure TTFFileInfo.LoadFromFile(const AFileName: String);
Var
AStream: TFileStream;
begin
@ -763,31 +767,30 @@ var
begin
FOriginalSize:= AStream.Size;
AStream.ReadBuffer(FTableDir,Sizeof(TTableDirectory));
if not isNativeData then
With FTableDir do
begin
FontVersion.Version := BEtoN(FontVersion.Version);
FontVersion.Minor := FixMinorVersion(FontVersion.Minor);
Numtables:=BeToN(Numtables);
SearchRange:=BeToN(SearchRange);
EntrySelector:=BeToN(EntrySelector);
RangeShift:=BeToN(RangeShift);
end;
With FTableDir do
begin
FontVersion.Version := BEtoN(FontVersion.Version);
FontVersion.Minor := FixMinorVersion(FontVersion.Minor);
Numtables:=BeToN(Numtables);
SearchRange:=BeToN(SearchRange);
EntrySelector:=BeToN(EntrySelector);
RangeShift:=BeToN(RangeShift);
end;
SetLength(FTables,FTableDir.Numtables);
AStream.ReadBuffer(FTables[0],FTableDir.NumTables*Sizeof(TTableDirectoryEntry));
if Not IsNativeData then
For I:=0 to Length(FTables)-1 do
With FTables[I] do
begin
checkSum:=BeToN(checkSum);
offset:=BeToN(offset);
Length:=BeToN(Length);
end;
for I:=0 to FTableDir.NumTables-1 do
For I:=0 to Length(FTables)-1 do
With FTables[I] do
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);
if (TT<>ttUnknown) then
begin
begin
AStream.Position:=FTables[i].Offset;
Case TT of
tthead: ParseHead(AStream);
@ -799,8 +802,8 @@ begin
ttos2 : ParseOS2(AStream);
ttPost: ParsePost(AStream);
end;
end;
end;
end;
end;
procedure TTFFileInfo.PrepareFontDefinition(const Encoding: string; Embed: Boolean);
@ -813,13 +816,13 @@ begin
// MissingWidth:=ToNatural(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
begin
begin
if (CharCodes^[i]>=0) and (CharCodes^[i]<=High(Chars))
and (Widths[Chars[CharCodes^[i]]].AdvanceWidth> 0) and (CharNames^[i]<> '.notdef') then
CharWidth[I]:= ToNatural(Widths[Chars[CharCodes^[I]]].AdvanceWidth)
else
CharWidth[I]:= FMissingWidth;
end;
end;
end;
procedure TTFFileInfo.PrepareEncoding(const AEncoding: String);
@ -842,12 +845,12 @@ begin
L:= 0;
for i:=32 to 255 do
if CharNames^[i]<>CharBase^[i] then
begin
begin
if (i<>l+1) then
Result:= Result+IntToStr(i)+' ';
l:=i;
Result:= Result+'/'+CharNames^[i]+' ';
end;
end;
end;
function TTFFileInfo.Bold: Boolean;
@ -900,6 +903,23 @@ begin
result := Chars[AValue];
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;
begin
Result := Widths[AIndex].AdvanceWidth;
@ -948,11 +968,6 @@ begin
Result := FMissingWidth;
end;
function TTFFileInfo.IsNativeData: Boolean;
begin
Result:=False;
end;
function TTFFileInfo.ToNatural(AUnit: Smallint): Smallint;
begin
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;
FOwner: TFPFontCacheList; // reference to FontCacheList that owns this instance
FPostScriptName: string;
procedure DoLoadFileInfo;
procedure LoadFileInfo;
procedure BuildFontCacheItem;
procedure SetStyleIfExists(var AText: string; var AStyleFlags: TTrueTypeFontStyles; const AStyleName: String; const AStyle: TTrueTypeFontStyle);
function GetIsBold: boolean;
function GetIsFixedWidth: boolean;
function GetIsItalic: boolean;
function GetIsRegular: boolean;
function GetFamilyName: String;
function GetPostScriptName: string;
function GetFileInfo: TTFFileInfo;
public
constructor Create(const AFilename: String);
destructor Destroy; override;
@ -63,9 +68,9 @@ type
{ Result is in pixels }
function TextHeight(const AText: utf8string; const APointSize: single; out ADescender: single): single;
property FileName: String read FFileName;
property FamilyName: String read FFamilyName;
property PostScriptName: string read FPostScriptName;
property FontData: TTFFileInfo read FFileInfo;
property FamilyName: String read GetFamilyName;
property PostScriptName: string read GetPostScriptName;
property FontData: TTFFileInfo read GetFileInfo;
{ A bitmasked value describing the full font style }
property StyleFlags: TTrueTypeFontStyles read FStyleFlags;
{ IsXXX properties are convenience properties, internally querying StyleFlags. }
@ -78,7 +83,7 @@ type
TFPFontCacheList = class(TObject)
private
FBuildFontFacheIgnoresErrors: Boolean;
FBuildFontCacheIgnoresErrors: Boolean;
FList: TObjectList;
FSearchPath: TStringList;
FDPI: integer;
@ -97,6 +102,8 @@ type
function Add(const AObject: TFPFontCacheItem): integer;
procedure AssignFontList(const AStrings: TStrings);
procedure Clear;
procedure LoadFromFile(const AFilename: string);
procedure ReadStandardFonts;
property Count: integer read GetCount;
function IndexOf(const AObject: TFPFontCacheItem): integer;
function Find(const AFontCacheItem: TFPFontCacheItem): integer; overload;
@ -107,7 +114,7 @@ type
property Items[AIndex: Integer]: TFPFontCacheItem read GetItem write SetItem; default;
property SearchPath: TStringList read FSearchPath;
property DPI: integer read FDPI write SetDPI;
Property BuildFontFacheIgnoresErrors : Boolean Read FBuildFontFacheIgnoresErrors Write FBuildFontFacheIgnoresErrors;
Property BuildFontCacheIgnoresErrors : Boolean Read FBuildFontCacheIgnoresErrors Write FBuildFontCacheIgnoresErrors;
end;
@ -115,10 +122,18 @@ function gTTFontCache: TFPFontCacheList;
implementation
uses
DOM
,XMLRead
{$ifdef mswindows}
,Windows // for SHGetFolderPath API call used by gTTFontCache.ReadStandardFonts() method
{$endif}
;
resourcestring
rsNoSearchPathDefined = 'No search path was defined';
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
uFontCacheList: TFPFontCacheList;
@ -134,26 +149,66 @@ end;
{ 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;
begin
DoLoadFileInfo;
Result := fsBold in FStyleFlags;
end;
function TFPFontCacheItem.GetIsFixedWidth: boolean;
begin
DoLoadFileInfo;
Result := fsFixedWidth in FStyleFlags;
end;
function TFPFontCacheItem.GetIsItalic: boolean;
begin
DoLoadFileInfo;
Result := fsItalic in FStyleFlags;
end;
function TFPFontCacheItem.GetIsRegular: boolean;
begin
DoLoadFileInfo;
Result := fsRegular in FStyleFlags;
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;
var
s: string;
@ -205,13 +260,6 @@ begin
if AFileName = '' then
raise ETTF.Create(rsNoFontFileName);
if FileExists(AFilename) then
begin
FFileInfo := TTFFileInfo.Create;
FFileInfo.LoadFromFile(AFilename);
BuildFontCacheItem;
end;
end;
destructor TFPFontCacheItem.Destroy;
@ -253,6 +301,7 @@ var
s: string;
{$ENDIF}
begin
DoLoadFileInfo;
Result := 0;
if Length(AStr) = 0 then
Exit;
@ -294,6 +343,7 @@ end;
function TFPFontCacheItem.TextHeight(const AText: utf8string; const APointSize: single; out ADescender: single): single;
begin
DoLoadFileInfo;
{ Both lHeight and lDescenderHeight are in pixels }
Result := FFileInfo.CapHeight * 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;
s: String;
begin
if FindFirst(AFontPath + AllFilesMask, faAnyFile, sr) = 0 then
if SysUtils.FindFirst(AFontPath + AllFilesMask, faAnyFile, sr) = 0 then
begin
repeat
// check if special files to skip
@ -326,14 +376,14 @@ begin
lFont := TFPFontCacheItem.Create(AFontPath + s);
Add(lFont);
except
if not FBuildFontFacheIgnoresErrors then
if not FBuildFontCacheIgnoresErrors then
Raise;
end;
end;
end;
until FindNext(sr) <> 0;
until SysUtils.FindNext(sr) <> 0;
end;
FindClose(sr);
SysUtils.FindClose(sr);
end;
procedure TFPFontCacheList.SetDPI(AValue: integer);
@ -419,6 +469,96 @@ begin
FList.Clear;
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;
begin
Result := FList.IndexOf(AObject);

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

@ -971,7 +971,7 @@ end;
procedure TTestLiberationFont.TestOS2Data_ulUnicodeRange1;
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));
end;

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

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

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

@ -12,25 +12,39 @@ uses
,fpcunit, testregistry
{$endif}
,fpttf
,fpparsettf
;
type
TMyTestFPFontCacheItem = class(TFPFontCacheItem)
protected
FFileInfo: TTFFileInfo;
end;
TFPFontCacheItemTest = class(TTestCase)
private
FCacheItem: TFPFontCacheItem;
FCacheItem: TMyTestFPFontCacheItem;
procedure SetupRealFont;
protected
procedure SetUp; override;
procedure TearDown; override;
public
property CI: TFPFontCacheItem read FCacheItem;
property CI: TMyTestFPFontCacheItem read FCacheItem;
published
procedure TestIsRegularCantFind;
procedure TestIsBoldCantFind;
procedure TestIsItalicCantFind;
procedure TestIsFixedWidthCantFind;
procedure TestFileInfoCantFind;
procedure TestIsRegular;
procedure TestIsBold;
procedure TestIsItalic;
procedure TestIsFixedWidth;
procedure TestRegularVsFixedWidth;
procedure TestFileName;
procedure TestFontInfoAfterCreate;
procedure TestTextWidth_FontUnits;
procedure TestTextWidth_Pixels;
end;
@ -52,25 +66,31 @@ type
procedure TestFind_FamilyName;
procedure TestFind_PostscriptName;
procedure TestAssignFontList;
procedure TestLoadFromFile;
procedure TestReadStandardFonts;
end;
implementation
uses
fpparsettf;
const
cFontCount = 5;
resourcestring
cErrFontCountWrong = ' - make sure you only have the 5 test fonts in the "fonts" directory.';
{ TFPFontCacheItemTest }
procedure TFPFontCacheItemTest.SetupRealFont;
begin
FCacheItem.Free;
FCacheItem := TMyTestFPFontCacheItem.Create('fonts' + PathDelim + 'DejaVuSans.ttf');
end;
procedure TFPFontCacheItemTest.SetUp;
begin
inherited SetUp;
FCacheItem := TFPFontCacheItem.Create('mytest.ttf');
FCacheItem := TMyTestFPFontCacheItem.Create('mytest.ttf');
end;
procedure TFPFontCacheItemTest.TearDown;
@ -79,29 +99,103 @@ begin
inherited TearDown;
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;
begin
SetupRealFont;
{ regular should be the default flag set }
AssertEquals('Failed on 1', True, CI.IsRegular);
end;
procedure TFPFontCacheItemTest.TestIsBold;
begin
SetupRealFont;
AssertEquals('Failed on 1', False, CI.IsBold);
end;
procedure TFPFontCacheItemTest.TestIsItalic;
begin
SetupRealFont;
AssertEquals('Failed on 1', False, CI.IsItalic);
end;
procedure TFPFontCacheItemTest.TestIsFixedWidth;
begin
SetupRealFont;
AssertEquals('Failed on 1', False, CI.IsFixedWidth);
end;
procedure TFPFontCacheItemTest.TestRegularVsFixedWidth;
begin
SetupRealFont;
AssertEquals('Failed on 1', True, CI.IsRegular);
AssertEquals('Failed on 2', False, CI.IsFixedWidth);
end;
@ -109,8 +203,14 @@ end;
procedure TFPFontCacheItemTest.TestFileName;
begin
AssertTrue('Failed on 1', CI.FileName <> '');
{ FileName is a non-existing file though, so FontData should be nil }
AssertTrue('Failed on 2', CI.FontData = nil);
{ The Filename property doesn't trigger the loading of font info data }
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;
procedure TFPFontCacheItemTest.TestTextWidth_FontUnits;
@ -312,6 +412,38 @@ begin
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
RegisterTest({$ifdef fptest}'fpTTF', {$endif}TFPFontCacheItemTest{$ifdef fptest}.Suite{$endif});

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

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

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

@ -1,46 +1,18 @@
program ttfdump;
{$mode objfpc}{$H+}
{$codepage utf8}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cwstrings,
{$ENDIF}{$ENDIF}
Classes, SysUtils, CustApp,
fpparsettf, contnrs;
{$ifdef unix}cwstring,{$endif} // required for UnicodeString handling.
Classes,
SysUtils,
CustApp,
fpparsettf,
FPFontTextMapping,
fpTTFSubsetter;
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)
private
@ -48,6 +20,7 @@ type
procedure DumpGlyphIndex;
function GetGlyphIndicesString(const AText: UnicodeString): AnsiString; overload;
function GetGlyphIndices(const AText: UnicodeString): TTextMappingList; overload;
procedure CreateSubsetFontFile(const AList: TTextMappingList);
protected
procedure DoRun; override;
public
@ -56,70 +29,10 @@ type
procedure WriteHelp; virtual;
end;
TFriendClass = class(TTFFileInfo)
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 }
@ -127,16 +40,16 @@ procedure TMyApplication.DumpGlyphIndex;
begin
Writeln('FHHead.numberOfHMetrics = ', FFontFile.HHead.numberOfHMetrics);
Writeln('Length(Chars[]) = ', Length(FFontFile.Chars));
writeln;
writeln('Glyph Index values:');
Writeln('U+0020 (space) = ', FFontFile.Chars[$0020]);
Writeln('U+0021 (!) = ', FFontFile.Chars[$0021]);
Writeln('U+0048 (H) = ', FFontFile.Chars[$0048]);
Writeln(' U+0020 (space) = ', Format('%d (%0:4.4x)', [FFontFile.Chars[$0020]]));
Writeln(' U+0021 (!) = ', Format('%d (%0:4.4x)', [FFontFile.Chars[$0021]]));
Writeln(' U+0048 (H) = ', Format('%d (%0:4.4x)', [FFontFile.Chars[$0048]]));
writeln;
Writeln('Glyph widths:');
Writeln('3 = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0020]].AdvanceWidth));
Writeln('4 = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0021]].AdvanceWidth));
Writeln('H = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0048]].AdvanceWidth));
Writeln(' 3 = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0020]].AdvanceWidth));
Writeln(' 4 = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0021]].AdvanceWidth));
Writeln(' H = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0048]].AdvanceWidth));
end;
function TMyApplication.GetGlyphIndices(const AText: UnicodeString): TTextMappingList;
@ -154,6 +67,20 @@ begin
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;
var
i: integer;
@ -177,7 +104,7 @@ var
i: integer;
begin
// quick check parameters
ErrorMsg := CheckOptions('hf:', 'help');
ErrorMsg := CheckOptions('hf:s', 'help');
if ErrorMsg <> '' then
begin
ShowException(Exception.Create(ErrorMsg));
@ -196,13 +123,25 @@ begin
FFontFile.LoadFromFile(self.GetOptionValue('f'));
DumpGlyphIndex;
s := 'Hello, World!';
// test #1
// s := 'Hello, World!';
// test #2
s := 'Typography: “What’s wrong?”';
Writeln('');
lst := GetGlyphIndices(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
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
Terminate;
end;
@ -225,11 +164,13 @@ begin
writeln('Usage: ', ExeName, ' -h');
writeln(' -h Show this help.');
writeln(' -f <ttf> Load TTF font file.');
writeln(' -s Generate a subset TTF file.');
end;
var
Application: TMyApplication;
begin
Application := TMyApplication.Create(nil);
Application.Title := 'TTF Font Dump';