From b7083402cf30bc3c67d8b489fff875acc89580c7 Mon Sep 17 00:00:00 2001 From: michael Date: Fri, 9 Dec 2016 12:51:06 +0000 Subject: [PATCH] * Fix from Graeme adding Font subset embedding and underline/strikethrough git-svn-id: trunk@35083 - --- .gitattributes | 1 + packages/fcl-pdf/examples/testfppdf.lpr | 73 +- packages/fcl-pdf/fpmake.pp | 1 + packages/fcl-pdf/src/fontmetrics_stdpdf.inc | 222 ++++ packages/fcl-pdf/src/fpparsettf.pp | 245 +++-- packages/fcl-pdf/src/fppdf.pp | 1090 +++++++++++++------ packages/fcl-pdf/src/fpttf.pp | 174 ++- packages/fcl-pdf/tests/fpparsettf_test.pas | 2 +- packages/fcl-pdf/tests/fppdf_test.pas | 218 ++-- packages/fcl-pdf/tests/fpttf_test.pas | 148 ++- packages/fcl-pdf/utils/ttfdump.lpi | 6 + packages/fcl-pdf/utils/ttfdump.lpr | 159 +-- 12 files changed, 1657 insertions(+), 682 deletions(-) create mode 100644 packages/fcl-pdf/src/fontmetrics_stdpdf.inc diff --git a/.gitattributes b/.gitattributes index ddae172ffe..7f0b6285fa 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/packages/fcl-pdf/examples/testfppdf.lpr b/packages/fcl-pdf/examples/testfppdf.lpr index aad211d54b..b3da161e00 100644 --- a/packages/fcl-pdf/examples/testfppdf.lpr +++ b/packages/fcl-pdf/examples/testfppdf.lpr @@ -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.'); diff --git a/packages/fcl-pdf/fpmake.pp b/packages/fcl-pdf/fpmake.pp index b8582b34f1..bb9c5af715 100644 --- a/packages/fcl-pdf/fpmake.pp +++ b/packages/fcl-pdf/fpmake.pp @@ -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'); diff --git a/packages/fcl-pdf/src/fontmetrics_stdpdf.inc b/packages/fcl-pdf/src/fontmetrics_stdpdf.inc new file mode 100644 index 0000000000..03739a99f7 --- /dev/null +++ b/packages/fcl-pdf/src/fontmetrics_stdpdf.inc @@ -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); + + diff --git a/packages/fcl-pdf/src/fpparsettf.pp b/packages/fcl-pdf/src/fpparsettf.pp index bcd507dd59..9680a6337a 100644 --- a/packages/fcl-pdf/src/fpparsettf.pp +++ b/packages/fcl-pdf/src/fpparsettf.pp @@ -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 diff --git a/packages/fcl-pdf/src/fppdf.pp b/packages/fcl-pdf/src/fppdf.pp index 4826a2f02a..f30187c9f6 100644 --- a/packages/fcl-pdf/src/fppdf.pp +++ b/packages/fcl-pdf/src/fppdf.pp @@ -37,7 +37,9 @@ uses fpImage, FPReadJPEG, FPReadPNG, FPReadBMP, // these are required for auto image-handler functionality zstream, - fpparsettf; + fpparsettf, + fpTTFSubsetter, + FPFontTextMapping; Const { Some popular predefined colors. Channel format is: RRGGBB } @@ -57,6 +59,7 @@ Const clNavy = $000080; clPurple = $800080; clLime = $00FF00; + clWaterMark = $F0F0F0; type TPDFPaperType = (ptCustom, ptA4, ptA5, ptLetter, ptLegal, ptExecutive, ptComm10, ptMonarch, ptDL, ptC5, ptB5); @@ -65,7 +68,7 @@ type TPDFPageLayout = (lSingle, lTwo, lContinuous); TPDFUnitOfMeasure = (uomInches, uomMillimeters, uomCentimeters, uomPixels); - TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts, poPageOriginAtTop); + TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts, poPageOriginAtTop, poSubsetFont); TPDFOptions = set of TPDFOption; EPDF = Class(Exception); @@ -74,6 +77,7 @@ type TPDFDocument = class; TPDFAnnotList = class; TPDFLineStyleDef = class; + TPDFPage = class; TARGBColor = Cardinal; TPDFFloat = Single; @@ -122,6 +126,9 @@ type procedure SetYTranslation(const AValue: TPDFFloat); end; + // CharWidth array of standard PDF fonts + TPDFFontWidthArray = array[0..255] of integer; + TPDFObject = class(TObject) Protected @@ -255,11 +262,12 @@ type TPDFString = class(TPDFAbstractString) private - FValue: string; + FValue: AnsiString; protected procedure Write(const AStream: TStream); override; public - constructor Create(Const ADocument : TPDFDocument; const AValue: string); overload; + constructor Create(Const ADocument : TPDFDocument; const AValue: AnsiString); overload; + property Value: AnsiString read FValue; end; @@ -272,6 +280,7 @@ type procedure Write(const AStream: TStream); override; public constructor Create(Const ADocument : TPDFDocument; const AValue: UTF8String; const AFontIndex: integer); overload; + property Value: UTF8String read FValue; end; { Is useful to populate an array with free-form space separated values. This @@ -284,6 +293,7 @@ type procedure Write(const AStream: TStream); override; public constructor Create(Const ADocument: TPDFDocument; const AValue: string); overload; + property Value: string read FValue; end; @@ -318,51 +328,64 @@ type private FTxtFont: integer; FTxtSize: string; + FPage: TPDFPage; + function GetPointSize: integer; protected procedure Write(const AStream: TStream); override; - Class function WriteEmbeddedFont(const ADocument: TPDFDocument; const Src: TMemoryStream; const AStream: TStream): int64; + class function WriteEmbeddedFont(const ADocument: TPDFDocument; const Src: TMemoryStream; const AStream: TStream): int64; + class function WriteEmbeddedSubsetFont(const ADocument: TPDFDocument; const AFontNum: integer; const AOutStream: TStream): int64; public - constructor Create(Const ADocument : TPDFDocument;const AFont: integer; const ASize: string); overload; + constructor Create(const ADocument: TPDFDocument;const APage: TPDFPage; const AFont: integer; const ASize: string); overload; + property FontIndex: integer read FTxtFont; + property PointSize: integer read GetPointSize; + property Page: TPDFPage read FPage; end; - TPDFText = class(TPDFDocumentObject) + TPDFBaseText = class(TPDFDocumentObject) private FX: TPDFFloat; FY: TPDFFloat; + FFont: TPDFEmbeddedFont; + FDegrees: single; + FUnderline: boolean; + FColor: TARGBColor; + FStrikeThrough: boolean; + public + constructor Create(const ADocument: TPDFDocument); override; + property X: TPDFFloat read FX write FX; + property Y: TPDFFloat read FY write FY; + property Font: TPDFEmbeddedFont read FFont write FFont; + property Degrees: single read FDegrees write FDegrees; + property Underline: boolean read FUnderline write FUnderline; + property Color: TARGBColor read FColor write FColor; + property StrikeThrough: boolean read FStrikeThrough write FStrikeThrough; + end; + + + TPDFText = class(TPDFBaseText) + private FString: TPDFString; - FFontIndex: integer; - FDegrees: single; + function GetTextWidth: single; + function GetTextHeight: single; protected - procedure Write(const AStream: TStream); override; + procedure Write(const AStream: TStream); override; public - constructor Create(Const ADocument: TPDFDocument; const AX, AY: TPDFFloat; const AText: AnsiString; const AFontIndex: integer; const ADegrees: single); overload; - destructor Destroy; override; - Property X : TPDFFloat Read FX Write FX; - Property Y : TPDFFloat Read FY Write FY; - Property Text : TPDFString Read FString; - property FontIndex: integer read FFontIndex; - property Degrees: single read FDegrees; + constructor Create(const ADocument: TPDFDocument; const AX, AY: TPDFFloat; const AText: AnsiString; const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean); overload; + destructor Destroy; override; + property Text: TPDFString read FString; end; - TPDFUTF8Text = class(TPDFDocumentObject) + TPDFUTF8Text = class(TPDFBaseText) private - FX: TPDFFloat; - FY: TPDFFloat; FString: TPDFUTF8String; - FFontIndex: integer; - FDegrees: single; protected - procedure Write(const AStream: TStream); override; + procedure Write(const AStream: TStream); override; public - constructor Create(Const ADocument: TPDFDocument; const AX, AY: TPDFFloat; const AText: UTF8String; const AFontIndex: integer; const ADegrees: single); overload; - destructor Destroy; override; - Property X : TPDFFloat Read FX Write FX; - Property Y : TPDFFloat Read FY Write FY; - Property Text : TPDFUTF8String Read FString; - property FontIndex: integer read FFontIndex; - property Degrees: single read FDegrees; + constructor Create(const ADocument: TPDFDocument; const AX, AY: TPDFFloat; const AText: UTF8String; const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean); overload; + destructor Destroy; override; + property Text: TPDFUTF8String read FString; end; @@ -416,10 +439,10 @@ type FWidth: TPDFFloat; FStroke: Boolean; protected - Class Function Command(Const xCtrl1, yCtrl1, xCtrl2, yCtrl2, xTo, yTo: TPDFFloat): String; overload; - Class Function Command(Const ACtrl1, ACtrl2, ATo3: TPDFCoord): String; overload; procedure Write(const AStream: TStream); override; public + Class Function Command(Const xCtrl1, yCtrl1, xCtrl2, yCtrl2, xTo, yTo: TPDFFloat): String; overload; + Class Function Command(Const ACtrl1, ACtrl2, ATo3: TPDFCoord): String; overload; constructor Create(Const ADocument : TPDFDocument; const xCtrl1, yCtrl1, xCtrl2, yCtrl2, xTo, yTo, AWidth: TPDFFloat; AStroke: Boolean = True);overload; constructor Create(Const ADocument : TPDFDocument; const ACtrl1, ACtrl2, ATo3: TPDFCoord; AWidth: TPDFFloat; AStroke: Boolean = True);overload; end; @@ -507,10 +530,13 @@ type FGreen: string; FBlue: string; FStroke: Boolean; + FColor: TARGBColor; protected procedure Write(const AStream: TStream);override; public + class function Command(const AStroke: boolean; const AColor: TARGBColor): string; constructor Create(Const ADocument : TPDFDocument; const AStroke: Boolean; AColor: TARGBColor); overload; + property Color: TARGBColor read FColor; end; @@ -591,19 +617,17 @@ type { When the WriteXXX() and DrawXXX() methods specify coordinates, they do it as per the PDF specification, from the bottom-left. } - - { TPDFPage } - TPDFPage = Class(TPDFDocumentObject) private FObjects : TObjectList; FOrientation: TPDFPaperOrientation; FPaper: TPDFPaper; FPaperType: TPDFPaperType; - FFontIndex: integer; FUnitOfMeasure: TPDFUnitOfMeasure; FMatrix: TPDFMatrix; FAnnots: TPDFAnnotList; + FLastFont: TPDFEmbeddedFont; + FLastFontColor: TARGBColor; procedure CalcPaperSize; function GetO(AIndex : Integer): TPDFObject; function GetObjectCount: Integer; @@ -615,8 +639,8 @@ type protected procedure AdjustMatrix; virtual; procedure DoUnitConversion(var APoint: TPDFCoord); virtual; - procedure CreateStdFontText(X, Y: TPDFFloat; AText: AnsiString; AFontIndex: integer; const ADegrees: single); virtual; - procedure CreateTTFFontText(X, Y: TPDFFloat; AText: UTF8String; AFontIndex: integer; const ADegrees: single); virtual; + procedure CreateStdFontText(X, Y: TPDFFloat; AText: AnsiString; const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean); virtual; + procedure CreateTTFFontText(X, Y: TPDFFloat; AText: UTF8String; const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean); virtual; Public Constructor Create(Const ADocument : TPDFDocument); override; Destructor Destroy; override; @@ -630,8 +654,8 @@ type Procedure SetLineStyle(AIndex : Integer; AStroke : Boolean = True); overload; Procedure SetLineStyle(S : TPDFLineStyleDef; AStroke : Boolean = True); overload; { output coordinate is the font baseline. } - Procedure WriteText(X, Y: TPDFFloat; AText : UTF8String; const ADegrees: single = 0.0); overload; - Procedure WriteText(APos: TPDFCoord; AText : UTF8String; const ADegrees: single = 0.0); overload; + Procedure WriteText(X, Y: TPDFFloat; AText : UTF8String; const ADegrees: single = 0.0; const AUnderline: boolean = false; const AStrikethrough: boolean = false); overload; + Procedure WriteText(APos: TPDFCoord; AText : UTF8String; const ADegrees: single = 0.0; const AUnderline: boolean = false; const AStrikethrough: boolean = false); overload; procedure DrawLine(X1, Y1, X2, Y2, ALineWidth : TPDFFloat; const AStroke: Boolean = True); overload; procedure DrawLine(APos1, APos2: TPDFCoord; ALineWidth: TPDFFloat; const AStroke: Boolean = True); overload; Procedure DrawLineStyle(X1, Y1, X2, Y2: TPDFFloat; AStyle: Integer); overload; @@ -700,8 +724,8 @@ type property UnitOfMeasure: TPDFUnitOfMeasure read FUnitOfMeasure write SetUnitOfMeasure default uomMillimeters; Property ObjectCount: Integer Read GetObjectCount; Property Objects[AIndex : Integer] : TPDFObject Read GetO; default; - // returns the last used FontIndex used in SetFont() - property FontIndex: integer read FFontIndex; + // returns the last font object created by SetFont() + property LastFont: TPDFEmbeddedFont read FLastFont; { A 3x3 matrix used to translate the PDF Cartesian coordinate system to an Image coordinate system. } property Matrix: TPDFMatrix read FMatrix write FMatrix; property Annots: TPDFAnnotList read FAnnots; @@ -735,39 +759,7 @@ type end; - // 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; - - - TPDFFont = CLass(TCollectionItem) + TPDFFont = class(TCollectionItem) private FIsStdFont: boolean; FName: String; @@ -775,9 +767,12 @@ type FTrueTypeFile: TTFFileInfo; { stores mapping of Char IDs to font Glyph IDs } FTextMappingList: TTextMappingList; + FSubsetFont: TStream; procedure PrepareTextMapping; procedure SetFontFilename(AValue: string); + procedure GenerateSubsetFont; public + constructor Create(ACollection: TCollection); override; destructor Destroy; override; { Returns a string where each character is replaced with a glyph index value instead. } function GetGlyphIndices(const AText: UnicodeString): AnsiString; @@ -786,6 +781,7 @@ type Property Name: String Read FName Write FName; property TextMapping: TTextMappingList read FTextMappingList; property IsStdFont: boolean read FIsStdFont write FIsStdFont; + property SubsetFont: TStream read FSubsetFont; end; @@ -884,8 +880,6 @@ type end; - { TPDFImages } - TPDFImages = Class(TCollection) Private FOwner: TPDFDocument; @@ -904,14 +898,30 @@ type end; - TPDFToUnicode = class(TPDFDocumentObject) - private - FEmbeddedFontNum: integer; + TPDFFontNumBaseObject = class(TPDFDocumentObject) protected - procedure Write(const AStream: TStream);override; + FFontNum: integer; public - constructor Create(const ADocument: TPDFDocument; const AEmbeddedFontNum: integer); overload; - property EmbeddedFontNum: integer read FEmbeddedFontNum; + constructor Create(const ADocument: TPDFDocument; const AFontNum: integer); overload; + property FontNum: integer read FFontNum; + end; + + + TPDFToUnicode = class(TPDFFontNumBaseObject) + protected + procedure Write(const AStream: TStream); override; + end; + + + TCIDToGIDMap = class(TPDFFontNumBaseObject) + protected + procedure Write(const AStream: TStream); override; + end; + + + TPDFCIDSet = class(TPDFFontNumBaseObject) + protected + procedure Write(const AStream: TStream); override; end; @@ -921,7 +931,7 @@ type FLineWidth: TPDFFloat; FPenStyle: TPDFPenStyle; Public - Procedure Assign(Source : TPersistent); override; + Procedure Assign(Source : TPersistent); override; Published Property LineWidth : TPDFFloat Read FLineWidth Write FLineWidth; Property Color : TARGBColor Read FColor Write FColor Default clBlack; @@ -938,8 +948,6 @@ type end; - { TPDFDocument } - TPDFDocument = class(TComponent) private FCatalogue: integer; @@ -963,9 +971,11 @@ type FZoomValue: string; FGlobalXRefs: TFPObjectList; // list of TPDFXRef FUnitOfMeasure: TPDFUnitOfMeasure; + function GetStdFontCharWidthsArray(const AFontName: string): TPDFFontWidthArray; function GetX(AIndex : Integer): TPDFXRef; function GetXC: Integer; function GetTotalAnnotsCount: integer; + function GetFontNamePrefix(const AFontNum: Integer): string; procedure SetFontFiles(AValue: TStrings); procedure SetFonts(AValue: TPDFFontDefs); procedure SetInfos(AValue: TPDFInfos); @@ -1005,10 +1015,12 @@ type procedure CreateTTFCIDSystemInfo;virtual; procedure CreateTp1Font(const EmbeddedFontNum: integer);virtual; procedure CreateFontDescriptor(const EmbeddedFontNum: integer);virtual; - procedure CreateToUnicode(const EmbeddedFontNum: integer);virtual; - procedure CreateFontFileEntry(const EmbeddedFontNum: integer);virtual; + procedure CreateToUnicode(const AFontNum: integer);virtual; + procedure CreateFontFileEntry(const AFontNum: integer);virtual; + procedure CreateCIDSet(const AFontNum: integer); virtual; procedure CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);virtual; function CreateAnnotEntry(const APageNum, AnnotNum: integer): integer; virtual; + function CreateCIDToGIDMap(const AFontNum: integer): integer; virtual; procedure CreatePageStream(APage : TPDFPage; PageNum: integer); Function CreateString(Const AValue : String) : TPDFString; Function CreateUTF8String(Const AValue : UTF8String; const AFontIndex: integer) : TPDFUTF8String; @@ -1027,11 +1039,12 @@ type procedure StartDocument; procedure Reset; procedure SaveToStream(const AStream: TStream); virtual; - Procedure SaveToFile(Const AFileName : String); + Procedure SaveToFile(Const AFileName : String); + function IsStandardPDFFont(AFontName: string): boolean; // Create objects, owned by this document. - Function CreateEmbeddedFont(AFontIndex, AFontSize : Integer) : TPDFEmbeddedFont; - Function CreateText(X,Y : TPDFFloat; AText : AnsiString; const AFontIndex: integer; const ADegrees: single) : TPDFText; overload; - Function CreateText(X,Y : TPDFFloat; AText : UTF8String; const AFontIndex: integer; const ADegrees: single) : TPDFUTF8Text; overload; + Function CreateEmbeddedFont(const APage: TPDFPage; AFontIndex, AFontSize : Integer) : TPDFEmbeddedFont; + Function CreateText(X,Y : TPDFFloat; AText : AnsiString; const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean) : TPDFText; overload; + Function CreateText(X,Y : TPDFFloat; AText : UTF8String; const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean) : TPDFUTF8Text; overload; Function CreateRectangle(const X,Y,W,H, ALineWidth: TPDFFloat; const AFill, AStroke: Boolean) : TPDFRectangle; function CreateRoundedRectangle(const X, Y, W, H, ARadius, ALineWidth: TPDFFloat; const AFill, AStroke: Boolean): TPDFRoundedRectangle; Function CreateColor(AColor : TARGBColor; AStroke : Boolean) : TPDFColor; @@ -1057,7 +1070,7 @@ type Property FontDirectory: string Read FFontDirectory Write FFontDirectory; Property Sections : TPDFSectionList Read FSections; Property ObjectCount : Integer Read FObjectCount; - Published + Published Property Options : TPDFOptions Read FOptions Write FOPtions; Property LineStyles : TPDFLineStyleDefs Read FLineStyleDefs Write SetLineStyles; property PageLayout: TPDFPageLayout read FPageLayout write FPageLayout default lSingle; @@ -1065,7 +1078,7 @@ type Property DefaultPaperType : TPDFPaperTYpe Read FDefaultPaperType Write FDefaultPaperType; Property DefaultOrientation : TPDFPaperOrientation Read FDefaultOrientation Write FDefaultOrientation; property DefaultUnitOfMeasure: TPDFUnitOfMeasure read FUnitOfMeasure write FUnitOfMeasure default uomMillimeters; - + end; @@ -1130,7 +1143,8 @@ function PDFCoord(x, y: TPDFFloat): TPDFCoord; implementation uses - math; + math, + fpttf; resourcestring @@ -1140,34 +1154,29 @@ resourcestring rsErrNoGlobalDict = 'Error: no global XRef named "%s".'; rsErrInvalidPageIndex = 'Invalid page index: %d'; rsErrInvalidAnnotIndex = 'Invalid annot index: %d'; - rsErrNoFontIndex = 'No FontIndex was set - please use SetFont() first.'; + rsErrNoFontDefined = 'No Font was set - please use SetFont() first.'; rsErrNoImageReader = 'Unsupported image format - no image reader available.'; + rsErrUnknownStdFont = 'Unknown standard PDF font name <%s>.'; + +{ Includes font metrics constant arrays for the standard PDF fonts. They are + not used at the moment, but in future we might want to do something with + them. } +{$I fontmetrics_stdpdf.inc } type // to get access to protected methods TTTFFriendClass = class(TTFFileInfo) end; -const - // Dot = linewidth; Dash = (5 x linewidth); Gap = (3 x linewidth); - cPenStyleBitmasks: array[TPDFPenStyle] of string = ( - '', // ppsSolid - '%0.2f %0.2f', // ppsDash (dash space ...) - '%0.2f %0.2f', // ppsDot (dot space ...) - '%0.2f %0.2f %0.2f %0.2f', // ppsDashDot (dash space dot space ...) - '%0.2f %0.2f %0.2f %0.2f %0.2f %0.2f' // ppsDashDotDot (dash space dot space dot space ...) - ); const cInchToMM = 25.4; cInchToCM = 2.54; cDefaultDPI = 72; - // mm = (pixels * 25.4) / dpi // pixels = (mm * dpi) / 25.4 // cm = ((pixels * 25.4) / dpi) / 10 -const // see http://paste.lisp.org/display/1105 BEZIER: single = 0.5522847498; // = 4/3 * (sqrt(2) - 1); @@ -1354,68 +1363,6 @@ begin _21 := AValue; 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; - { TPDFFont } procedure TPDFFont.PrepareTextMapping; @@ -1438,10 +1385,41 @@ begin PrepareTextMapping; end; +procedure TPDFFont.GenerateSubsetFont; +var + f: TFontSubsetter; + {$ifdef gdebug} + fs: TFileStream; + {$endif} +begin + if Assigned(FSubsetFont) then + FreeAndNil(FSubSetFont); + f := TFontSubsetter.Create(FTrueTypeFile, FTextMappingList); + try + FSubSetFont := TMemoryStream.Create; + f.SaveToStream(FSubsetFont); + {$ifdef gdebug} + fs := TFileStream.Create(FTrueTypeFile.PostScriptName + '-subset.ttf', fmCreate); + FSubSetFont.Position := 0; + TMemoryStream(FSubsetFont).SaveToStream(fs); + fs.Free; + {$endif} + finally + f.Free; + end; +end; + +constructor TPDFFont.Create(ACollection: TCollection); +begin + inherited Create(ACollection); + FSubsetFont := nil; +end; + destructor TPDFFont.Destroy; begin FTextMappingList.Free; FTrueTypeFile.Free; + FSubSetFont.Free; inherited Destroy; end; @@ -1449,6 +1427,7 @@ function TPDFFont.GetGlyphIndices(const AText: UnicodeString): AnsiString; var i: integer; c: word; + n: integer; begin Result := ''; if Length(AText) = 0 then @@ -1456,7 +1435,18 @@ begin for i := 1 to Length(AText) do begin c := Word(AText[i]); - Result := Result + IntToHex(FTrueTypeFile.GetGlyphIndex(c), 4); + //Result := Result + IntToHex(FTrueTypeFile.GetGlyphIndex(c), 4); + for n := 0 to FTextMappingList.Count-1 do + begin + if FTextMappingList[n].CharID = c then + begin + //if poSubsetFont in Document.Options then + // result := Result + IntToHex(FTextMappingList[n].NewGlyphID, 4); + //else + result := Result + IntToHex(FTextMappingList[n].GlyphID, 4); + break; + end; + end; end; end; @@ -1464,18 +1454,22 @@ procedure TPDFFont.AddTextToMappingList(const AText: UnicodeString); var i: integer; c: uint16; // Unicode codepoint + gid: uint16; begin if AText = '' then Exit; for i := 1 to Length(AText) do begin c := uint16(AText[i]); - FTextMappingList.Add(c, FTrueTypeFile.GetGlyphIndex(c)); + gid := FTrueTypeFile.GetGlyphIndex(c); + FTextMappingList.Add(c, gid); end; end; { TPDFTrueTypeCharWidths } +// TODO: (optional improvement) CID -> Unicode mappings, use ranges to generate a smaller CMap +// See pdfbox's writeTo() method in ToUnicodeWriter.java procedure TPDFTrueTypeCharWidths.Write(const AStream: TStream); var i: integer; @@ -1485,7 +1479,9 @@ var begin s := ''; lst := Document.Fonts[EmbeddedFontNum].TextMapping; + lst.Sort; lFont := Document.Fonts[EmbeddedFontNum].FTrueTypeFile; + // use decimal values for the output for i := 0 to lst.Count-1 do s := s + Format(' %d [%d]', [ lst[i].GlyphID, TTTFFriendClass(lFont).ToNatural(lFont.Widths[lst[i].GlyphID].AdvanceWidth)]); WriteString(s, AStream); @@ -1773,7 +1769,7 @@ begin PenStyle:=L.PenStyle; end else - Inherited; + Inherited; end; @@ -1960,7 +1956,7 @@ begin if AText = '' then Exit; str := UTF8Decode(AText); - Document.Fonts[FFontIndex].AddTextToMappingList(str); + Document.Fonts[FLastFont.FontIndex].AddTextToMappingList(str); end; procedure TPDFPage.DoUnitConversion(var APoint: TPDFCoord); @@ -1984,20 +1980,22 @@ begin end; end; -procedure TPDFPage.CreateStdFontText(X, Y: TPDFFloat; AText: AnsiString; AFontIndex: integer; const ADegrees: single); +procedure TPDFPage.CreateStdFontText(X, Y: TPDFFloat; AText: AnsiString; const AFont: TPDFEmbeddedFont; + const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean); var T: TPDFText; begin - T := Document.CreateText(X, Y, AText, AFontIndex, ADegrees); + T := Document.CreateText(X, Y, AText, AFont, ADegrees, AUnderline, AStrikeThrough); AddObject(T); end; -procedure TPDFPage.CreateTTFFontText(X, Y: TPDFFloat; AText: UTF8String; AFontIndex: integer; const ADegrees: single); +procedure TPDFPage.CreateTTFFontText(X, Y: TPDFFloat; AText: UTF8String; const AFont: TPDFEmbeddedFont; + const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean); var T: TPDFUTF8Text; begin AddTextToLookupLists(AText); - T := Document.CreateText(X, Y, AText, FFontIndex, ADegrees); + T := Document.CreateText(X, Y, AText, AFont, ADegrees, AUnderline, AStrikeThrough); AddObject(T); end; @@ -2026,7 +2024,8 @@ end; constructor TPDFPage.Create(const ADocument: TPDFDocument); begin inherited Create(ADocument); - FFontIndex := -1; + FLastFont := nil; + FLastFontColor := clBlack; FPaperType := ptA4; FUnitOfMeasure := uomMillimeters; CalcPaperSize; @@ -2059,40 +2058,35 @@ begin end; procedure TPDFPage.SetFont(AFontIndex: Integer; AFontSize: Integer); - Var F : TPDFEmbeddedFont; - begin - F:=Document.CreateEmbeddedFont(AFontIndex,AFontSize); + F:=Document.CreateEmbeddedFont(self, AFontIndex, AFontSize); AddObject(F); - FFontIndex := AFontIndex; + FLastFont := F; end; procedure TPDFPage.SetColor(AColor: TARGBColor; AStroke : Boolean = True); - Var C : TPDFColor; - begin C:=Document.CreateColor(AColor,AStroke); + if not AStroke then + FLastFontColor := AColor; AddObject(C); end; procedure TPDFPage.SetPenStyle(AStyle: TPDFPenStyle; const ALineWidth: TPDFFloat); - Var L : TPDFLineStyle; - begin L:=Document.CreateLineStyle(AStyle, ALineWidth); AddObject(L); end; procedure TPDFPage.SetLineStyle(AIndex: Integer; AStroke : Boolean = True); - begin - SetLineStyle(Document.LineStyles[Aindex]); + SetLineStyle(Document.LineStyles[Aindex],AStroke); end; procedure TPDFPage.SetLineStyle(S: TPDFLineStyleDef; AStroke: Boolean = True); @@ -2101,23 +2095,25 @@ begin SetPenStyle(S.PenStyle,S.LineWidth); end; -procedure TPDFPage.WriteText(X, Y: TPDFFloat; AText: UTF8String; const ADegrees: single); +procedure TPDFPage.WriteText(X, Y: TPDFFloat; AText: UTF8String; const ADegrees: single; + const AUnderline: boolean; const AStrikethrough: boolean); var p: TPDFCoord; begin - if FFontIndex = -1 then - raise EPDF.Create(rsErrNoFontIndex); + if not Assigned(FLastFont) then + raise EPDF.Create(rsErrNoFontDefined); p := Matrix.Transform(X, Y); DoUnitConversion(p); - if Document.Fonts[FFontIndex].IsStdFont then - CreateStdFontText(p.X, p.Y, AText, FFontIndex, ADegrees) + if Document.Fonts[FLastFont.FontIndex].IsStdFont then + CreateStdFontText(p.X, p.Y, AText, FLastFont, ADegrees, AUnderline, AStrikeThrough) else - CreateTTFFontText(p.X, p.Y, AText, FFontIndex, ADegrees); + CreateTTFFontText(p.X, p.Y, AText, FLastFont, ADegrees, AUnderline, AStrikeThrough); end; -procedure TPDFPage.WriteText(APos: TPDFCoord; AText: UTF8String; const ADegrees: single); +procedure TPDFPage.WriteText(APos: TPDFCoord; AText: UTF8String; const ADegrees: single; + const AUnderline: boolean; const AStrikethrough: boolean); begin - WriteText(APos.X, APos.Y, AText, ADegrees); + WriteText(APos.X, APos.Y, AText, ADegrees, AUnderline, AStrikeThrough); end; procedure TPDFPage.DrawLine(X1, Y1, X2, Y2, ALineWidth: TPDFFloat; const AStroke: Boolean = True); @@ -2921,6 +2917,7 @@ begin Str(F:4:0,Result) else Str(F:4:2,Result); + result := trim(Result); end; procedure TPDFObject.Write(const AStream: TStream); @@ -3165,6 +3162,11 @@ begin inherited; end; +function TPDFEmbeddedFont.GetPointSize: integer; +begin + Result := StrToInt(FTxtSize); +end; + procedure TPDFEmbeddedFont.Write(const AStream: TStream); begin WriteString('/F'+IntToStr(FTxtFont)+' '+FTxtSize+' Tf'+CRLF, AStream); @@ -3195,46 +3197,177 @@ begin WriteString('endstream', AStream); end; -constructor TPDFEmbeddedFont.Create(Const ADocument : TPDFDocument;const AFont: integer; const ASize: string); +class function TPDFEmbeddedFont.WriteEmbeddedSubsetFont(const ADocument: TPDFDocument; + const AFontNum: integer; const AOutStream: TStream): int64; +var + PS: int64; + CompressedStream: TMemoryStream; begin - inherited Create(ADocument); - FTxtFont:=AFont; - FTxtSize:=ASize; + if ADocument.Fonts[AFontNum].SubsetFont = nil then + raise Exception.Create('WriteEmbeddedSubsetFont: SubsetFont stream was not initialised.'); + WriteString(CRLF+'stream'+CRLF, AOutStream); + PS := AOutStream.Position; + if poCompressFonts in ADocument.Options then + begin + CompressedStream := TMemoryStream.Create; + CompressStream(ADocument.Fonts[AFontNum].SubsetFont, CompressedStream); + CompressedStream.Position := 0; + CompressedStream.SaveToStream(AOutStream); + CompressedStream.Free; + end + else + begin + ADocument.Fonts[AFontNum].SubsetFont.Position := 0; + TMemoryStream(ADocument.Fonts[AFontNum].SubsetFont).SaveToStream(AOutStream); + end; + Result := AOutStream.Position-PS; + + WriteString(CRLF, AOutStream); + WriteString('endstream', AOutStream); end; +constructor TPDFEmbeddedFont.Create(const ADocument: TPDFDocument; const APage: TPDFPage; const AFont: integer; + const ASize: string); +begin + inherited Create(ADocument); + FTxtFont := AFont; + FTxtSize := ASize; + FPage := APage; +end; + +{ TPDFBaseText } + +constructor TPDFBaseText.Create(const ADocument: TPDFDocument); +begin + inherited Create(ADocument); + FX := 0.0; + FY := 0.0; + FFont := nil; + FDegrees := 0.0; + FUnderline := False; + FColor := clBlack; + FStrikeThrough := False; +end; + +{ TPDFText } + +function TPDFText.GetTextWidth: single; +var + i: integer; + lWidth: double; + lFontName: string; +begin + lFontName := Document.Fonts[Font.FontIndex].Name; + if not Document.IsStandardPDFFont(lFontName) then + raise EPDF.CreateFmt(rsErrUnknownStdFont, [lFontName]); + + lWidth := 0; + for i := 1 to Length(FString.Value) do + lWidth := lWidth + Document.GetStdFontCharWidthsArray(lFontName)[Ord(FString.Value[i])]; + Result := lWidth * Font.PointSize / 1540; +end; + +function TPDFText.GetTextHeight: single; +var + lFontName: string; +begin + lFontName := Document.Fonts[Font.FontIndex].Name; + Result := 0; + case lFontName of + 'Courier': result := FONT_TIMES_COURIER_CAPHEIGHT; + 'Courier-Bold': result := FONT_TIMES_COURIER_CAPHEIGHT; + 'Courier-Oblique': result := FONT_TIMES_COURIER_CAPHEIGHT; + 'Courier-BoldOblique': result := FONT_TIMES_COURIER_CAPHEIGHT; + 'Helvetica': result := FONT_HELVETICA_ARIAL_CAPHEIGHT; + 'Helvetica-Bold': result := FONT_HELVETICA_ARIAL_BOLD_CAPHEIGHT; + 'Helvetica-Oblique': result := FONT_HELVETICA_ARIAL_ITALIC_CAPHEIGHT; + 'Helvetica-BoldOblique': result := FONT_HELVETICA_ARIAL_BOLD_ITALIC_CAPHEIGHT; + 'Times-Roman': result := FONT_TIMES_CAPHEIGHT; + 'Times-Bold': result := FONT_TIMES_BOLD_CAPHEIGHT; + 'Times-Italic': result := FONT_TIMES_ITALIC_CAPHEIGHT; + 'Times-BoldItalic': result := FONT_TIMES_BOLD_ITALIC_CAPHEIGHT; + 'Symbol': result := 300; + 'ZapfDingbats': result := 300; + else + raise EPDF.CreateFmt(rsErrUnknownStdFont, [lFontName]); + end; + Result := Result * Font.PointSize / 1540; +end; procedure TPDFText.Write(const AStream: TStream); var t1, t2, t3: string; rad: single; + lWidth: single; + lTextWidthInMM: single; + lHeight: single; + lTextHeightInMM: single; + lColor: string; + lLineWidth: string; begin + inherited Write(AStream); WriteString('BT'+CRLF, AStream); - if FDegrees <> 0.0 then + if Degrees <> 0.0 then begin - rad := DegToRad(-FDegrees); - t1 := FormatFloat('0.###;;0', Cos(rad)); - t2 := FormatFloat('0.###;;0', -Sin(rad)); - t3 := FormatFloat('0.###;;0', Sin(rad)); - WriteString(Format('%s %s %s %s %.4f %.4f Tm', [t1, t2, t3, t1, FX, FY]) + CRLF, AStream); + rad := DegToRad(-Degrees); + t1 := FloatStr(Cos(rad)); + t2 := FloatStr(-Sin(rad)); + t3 := FloatStr(Sin(rad)); + WriteString(Format('%s %s %s %s %s %s Tm', [t1, t2, t3, t1, FloatStr(X), FloatStr(Y)]) + CRLF, AStream); end else begin - WriteString(FloatStr(FX)+' '+FloatStr(FY)+' TD'+CRLF, AStream); + WriteString(FloatStr(X)+' '+FloatStr(Y)+' TD'+CRLF, AStream); end; FString.Write(AStream); WriteString(' Tj'+CRLF, AStream); WriteString('ET'+CRLF, AStream); + + if (not Underline) and (not StrikeThrough) then + Exit; + + // result is in Font Units + lWidth := GetTextWidth; + lHeight := GetTextHeight; + { convert the Font Units to Millimeters. This is also because fontcache DPI (default 96) could differ from PDF DPI (72). } + lTextWidthInMM := (lWidth * cInchToMM) / gTTFontCache.DPI; + lTextHeightInMM := (lHeight * cInchToMM) / gTTFontCache.DPI; + + if Degrees <> 0.0 then + // angled text + WriteString(Format('q %s %s %s %s %s %s cm', [t1, t2, t3, t1, FloatStr(X), FloatStr(Y)]) + CRLF, AStream) + else + // horizontal text + WriteString(Format('q 1 0 0 1 %s %s cm', [FloatStr(X), FloatStr(Y)]) + CRLF, AStream); + + { set up a pen width and stroke color } + lColor := TPDFColor.Command(True, Color); + lLineWidth := FloatStr(mmToPDF(lTextHeightInMM / 12)) + ' w '; + WriteString(lLineWidth + lColor + CRLF, AStream); + + { line segment is relative to matrix translation coordinate, set above } + if Underline then + WriteString(Format('0 -1.5 m %s -1.5 l S', [FloatStr(mmToPDF(lTextWidthInMM))]) + CRLF, AStream) + else + WriteString(Format('0 %s m %s %0:s l S', [FloatStr(mmToPDF(lTextHeightInMM) / 2), FloatStr(mmToPDF(lTextWidthInMM))]) + CRLF, AStream); + + { restore graphics state to before the translation matrix adjustment } + WriteString('Q' + CRLF, AStream); end; constructor TPDFText.Create(const ADocument: TPDFDocument; const AX, AY: TPDFFloat; const AText: AnsiString; - const AFontIndex: integer; const ADegrees: single); + const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean); begin inherited Create(ADocument); - FX := AX; - FY := AY; - FFontIndex := AFontIndex; + X := AX; + Y := AY; + Font := AFont; + Degrees := ADegrees; + Underline := AUnderline; + StrikeThrough := AStrikeThrough; + if Assigned(AFont) and Assigned(AFont.Page) then + Color := AFont.Page.FLastFontColor; FString := ADocument.CreateString(AText); - FDegrees := ADegrees; end; destructor TPDFText.Destroy; @@ -3249,34 +3382,84 @@ procedure TPDFUTF8Text.Write(const AStream: TStream); var t1, t2, t3: string; rad: single; + lFC: TFPFontCacheItem; + lWidth: single; + lTextWidthInMM: single; + lHeight: single; + lTextHeightInMM: single; + lColor: string; + lLineWidth: string; + lDescender: single; begin + inherited Write(AStream); WriteString('BT'+CRLF, AStream); - if FDegrees <> 0.0 then + if Degrees <> 0.0 then begin - rad := DegToRad(-FDegrees); - t1 := FormatFloat('0.###;;0', Cos(rad)); - t2 := FormatFloat('0.###;;0', -Sin(rad)); - t3 := FormatFloat('0.###;;0', Sin(rad)); - WriteString(Format('%s %s %s %s %.4f %.4f Tm', [t1, t2, t3, t1, FX, FY]) + CRLF, AStream); + rad := DegToRad(-Degrees); + t1 := FloatStr(Cos(rad)); + t2 := FloatStr(-Sin(rad)); + t3 := FloatStr(Sin(rad)); + WriteString(Format('%s %s %s %s %s %s Tm', [t1, t2, t3, t1, FloatStr(X), FloatStr(Y)]) + CRLF, AStream); end else begin - WriteString(FloatStr(FX)+' '+FloatStr(FY)+' TD'+CRLF, AStream); + WriteString(FloatStr(X)+' '+FloatStr(Y)+' TD'+CRLF, AStream); end; FString.Write(AStream); WriteString(' Tj'+CRLF, AStream); WriteString('ET'+CRLF, AStream); + + if (not Underline) and (not StrikeThrough) then + Exit; + + // implement Underline and Strikethrough here + lFC := gTTFontCache.Find(Document.Fonts[Font.FontIndex].Name); + if not Assigned(lFC) then + Exit; // we can't do anything further + + // result is in Font Units + lWidth := lFC.TextWidth(FString.Value, Font.PointSize); + lHeight := lFC.TextHeight(FString.Value, Font.PointSize, lDescender); + { convert the Font Units to Millimeters. This is also because fontcache DPI (default 96) could differ from PDF DPI (72). } + lTextWidthInMM := (lWidth * cInchToMM) / gTTFontCache.DPI; + lTextHeightInMM := (lHeight * cInchToMM) / gTTFontCache.DPI; + + if Degrees <> 0.0 then + // angled text + WriteString(Format('q %s %s %s %s %s %s cm', [t1, t2, t3, t1, FloatStr(X), FloatStr(Y)]) + CRLF, AStream) + else + // horizontal text + WriteString(Format('q 1 0 0 1 %s %s cm', [FloatStr(X), FloatStr(Y)]) + CRLF, AStream); + + { set up a pen width and stroke color } + lColor := TPDFColor.Command(True, Color); + lLineWidth := FloatStr(mmToPDF(lTextHeightInMM / 12)) + ' w '; + WriteString(lLineWidth + lColor + CRLF, AStream); + + { line segment is relative to matrix translation coordinate, set above } + if Underline then + WriteString(Format('0 -1.5 m %s -1.5 l S', [FloatStr(mmToPDF(lTextWidthInMM))]) + CRLF, AStream) + else + WriteString(Format('0 %s m %s %0:s l S', [FloatStr(mmToPDF(lTextHeightInMM) / 2), FloatStr(mmToPDF(lTextWidthInMM))]) + CRLF, AStream); + + { restore graphics state to before the translation matrix adjustment } + WriteString('Q' + CRLF, AStream); + end; constructor TPDFUTF8Text.Create(const ADocument: TPDFDocument; const AX, AY: TPDFFloat; const AText: UTF8String; - const AFontIndex: integer; const ADegrees: single); + const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean); begin inherited Create(ADocument); - FX := AX; - FY := AY; - FFontIndex := AFontIndex; - FString := ADocument.CreateUTF8String(AText, AFontIndex); - FDegrees := ADegrees; + X := AX; + Y := AY; + Font := AFont; + Degrees := ADegrees; + Underline := AUnderline; + if Assigned(AFont) and Assigned(AFont.Page) then + Color := AFont.Page.FLastFontColor; + StrikeThrough := AStrikeThrough; + FString := ADocument.CreateUTF8String(AText, AFont.FontIndex); end; destructor TPDFUTF8Text.Destroy; @@ -3458,6 +3641,7 @@ begin FSize.Y:=AHeight; end; +// Dot = linewidth; Dash = (5 x linewidth); Gap = (3 x linewidth); procedure TPDFLineStyle.Write(const AStream: TStream); var lMask: string; @@ -3471,19 +3655,19 @@ begin end; ppsDash: begin - lMask := Format(cPenStyleBitmasks[FStyle], [(5*w), (5*w)]); + lMask := FloatStr(5*w) + ' ' + FloatStr(5*w); end; ppsDot: begin - lMask := Format(cPenStyleBitmasks[FStyle], [(0.8*w), (4*w)]); + lMask := FloatStr(0.8*w) + ' ' + FloatStr(4*w) end; ppsDashDot: begin - lMask := Format(cPenStyleBitmasks[FStyle], [(5*w), (3*w), (0.8*w), (3*w)]); + lMask := FloatStr(5*w) + ' ' + FloatStr(3*w) + ' ' + FloatStr(0.8*w) + ' ' + FloatStr(3*w) end; ppsDashDotDot: begin - lMask := Format(cPenStyleBitmasks[FStyle], [(5*w), (3*w), (0.8*w), (3*w), (0.8*w), (3*w)]); + lMask := FloatStr(5*w) + ' ' + FloatStr(3*w) + ' ' + FloatStr(0.8*w) + ' ' + FloatStr(3*w) + ' ' + FloatStr(0.8*w) + ' ' + FloatStr(3*w) end; end; WriteString(Format('[%s] %d d'+CRLF,[lMask, FPhase]), AStream); @@ -3498,23 +3682,6 @@ begin FLineWidth := ALineWidth; end; -procedure TPDFColor.Write(const AStream: TStream); - -Var - S : String; -begin - S:=FRed+' '+FGreen+' '+FBlue; - if FStroke then - S:=S+' RG' - else - S:=S+' rg'; - if (S<>Document.CurrentColor) then - begin - WriteString(S+CRLF, AStream); - Document.CurrentColor:=S; - end; -end; - Function ARGBGetRed(AColor : TARGBColor) : Byte; begin @@ -3539,9 +3706,40 @@ begin Result:=((AColor shr 24) and $FF) end; +procedure TPDFColor.Write(const AStream: TStream); +var + S : String; +begin + S:=FRed+' '+FGreen+' '+FBlue; + if FStroke then + S:=S+' RG' + else + S:=S+' rg'; + if (S<>Document.CurrentColor) then + begin + WriteString(S+CRLF, AStream); + Document.CurrentColor:=S; + end; +end; + +class function TPDFColor.Command(const AStroke: boolean; const AColor: TARGBColor): string; +var + lR, lG, lB: string; +begin + lR := FloatStr(ARGBGetRed(AColor)/256); + lG := FloatStr(ARGBGetGreen(AColor)/256); + lB := FloatStr(ARGBGetBlue(AColor)/256); + result := lR+' '+lG+' '+lB+' '; + if AStroke then + result := result + 'RG' + else + result := result + 'rg' +end; + constructor TPDFColor.Create(Const ADocument : TPDFDocument; const AStroke: Boolean; AColor: TARGBColor); begin inherited Create(ADocument); + FColor := AColor; FRed:=FloatStr( ARGBGetRed(AColor)/256); FGreen:=FloatStr( ARGBGetGreen(AColor)/256); FBlue:=FloatStr( ARGBGetBlue(AColor)/256); @@ -3676,15 +3874,15 @@ begin end; if Pos('Length1', E.FKey.Name) > 0 then begin - M:=TMemoryStream.Create; - try - Value:=E.FKey.Name; - NumFnt:=StrToInt(Copy(Value, Succ(Pos(' ', Value)), Length(Value) - Pos(' ', Value))); - m.LoadFromFile(Document.FontFiles[NumFnt]); - Buf := TMemoryStream.Create; + Value:=E.FKey.Name; + NumFnt:=StrToInt(Copy(Value, Succ(Pos(' ', Value)), Length(Value) - Pos(' ', Value))); + if poSubsetFont in Document.Options then + begin + + buf := TMemoryStream.Create; try // write fontfile stream (could be compressed or not) to a temporary buffer so we can get the size - BufSize := TPDFEmbeddedFont.WriteEmbeddedFont(Document, M, Buf); + BufSize := TPDFEmbeddedFont.WriteEmbeddedSubsetFont(Document, NumFnt, Buf); Buf.Position := 0; // write fontfile stream length in xobject dictionary D := Document.GlobalXRefs[AObject].Dict; @@ -3696,8 +3894,31 @@ begin finally Buf.Free; end; - finally - M.Free; + + end + else + begin + M:=TMemoryStream.Create; + try + m.LoadFromFile(Document.FontFiles[NumFnt]); + Buf := TMemoryStream.Create; + try + // write fontfile stream (could be compressed or not) to a temporary buffer so we can get the size + BufSize := TPDFEmbeddedFont.WriteEmbeddedFont(Document, M, Buf); + Buf.Position := 0; + // write fontfile stream length in xobject dictionary + D := Document.GlobalXRefs[AObject].Dict; + D.AddInteger('Length', BufSize); + LastElement.Write(AStream); + WriteString('>>', AStream); + // write fontfile buffer stream in xobject dictionary + Buf.SaveToStream(AStream); + finally + Buf.Free; + end; + finally + M.Free; + end; end; end; end; @@ -3806,6 +4027,13 @@ begin FProducer := 'fpGUI Toolkit 1.4'; end; +{ TPDFFontNumBaseObject } + +constructor TPDFFontNumBaseObject.Create(const ADocument: TPDFDocument; const AFontNum: integer); +begin + inherited Create(ADocument); + FFontNum := AFontNum; +end; { TPDFToUnicode } @@ -3814,35 +4042,137 @@ var lst: TTextMappingList; i: integer; begin - lst := Document.Fonts[EmbeddedFontNum].TextMapping; + lst := Document.Fonts[FontNum].TextMapping; WriteString('/CIDInit /ProcSet findresource begin'+CRLF, AStream); WriteString('12 dict begin'+CRLF, AStream); WriteString('begincmap'+CRLF, AStream); WriteString('/CIDSystemInfo'+CRLF, AStream); WriteString('<> def'+CRLF, AStream); - WriteString(Format('/CMapName /%s def', [Document.Fonts[EmbeddedFontNum].FTrueTypeFile.PostScriptName])+CRLF, AStream); - WriteString('/CMapType 2 def'+CRLF, AStream); + + if poSubsetFont in Document.Options then + WriteString('/CMapName /Adobe-Identity-UCS def'+CRLF, AStream) + else + WriteString(Format('/CMapName /%s def', [Document.Fonts[FontNum].FTrueTypeFile.PostScriptName])+CRLF, AStream); + + WriteString('/CMapType 2 def'+CRLF, AStream); // 2 = ToUnicode + + // ToUnicode always uses 16-bit CIDs WriteString('1 begincodespacerange'+CRLF, AStream); WriteString('<0000> '+CRLF, AStream); WriteString('endcodespacerange'+CRLF, AStream); - WriteString(Format('%d beginbfchar', [lst.Count])+CRLF, AStream); - for i := 0 to lst.Count-1 do - WriteString(Format('<%s> <%s>', [IntToHex(lst[i].GlyphID, 4), IntToHex(lst[i].CharID, 4)])+CRLF, AStream); - WriteString('endbfchar'+CRLF, AStream); + + if poSubsetFont in Document.Options then + begin + // use hex values in the output + + WriteString(Format('%d beginbfrange', [lst.Count-1])+CRLF, AStream); + for i := 1 to lst.Count-1 do + WriteString(Format('<%s> <%0:s> <%s>', [IntToHex(lst[i].GlyphID, 4), IntToHex(lst[i].CharID, 4)])+CRLF, AStream); + WriteString('endbfrange'+CRLF, AStream); + +//WriteString('12 beginbfrange'+CRLF, AStream); +//WriteString('<0003> <0004> <0020>'+CRLF, AStream); +//WriteString('<0011> <0011> <002E>'+CRLF, AStream); +//WriteString('<002A> <002B> <0047>'+CRLF, AStream); +//WriteString('<0037> <0037> <0054>'+CRLF, AStream); +//WriteString('<003A> <003A> <0057>'+CRLF, AStream); +//WriteString('<0044> <0044> <0061>'+CRLF, AStream); +//WriteString('<0047> <0048> <0064>'+CRLF, AStream); +//WriteString('<004B> <004C> <0068>'+CRLF, AStream); +//WriteString('<004F> <0052> <006C>'+CRLF, AStream); +//WriteString('<0055> <0056> <0072>'+CRLF, AStream); +//WriteString('<0058> <0058> <0075>'+CRLF, AStream); +//WriteString('<005C> <005C> <0079>'+CRLF, AStream); +//WriteString('endbfrange'+CRLF, AStream); + +//WriteString('1 beginbfrange'+CRLF, AStream); +//WriteString('<0000> <0000>'+CRLF, AStream); +//WriteString('endbfrange'+CRLF, AStream); + + end + else + begin + WriteString(Format('%d beginbfchar', [lst.Count])+CRLF, AStream); + for i := 0 to lst.Count-1 do + WriteString(Format('<%s> <%s>', [IntToHex(lst[i].GlyphID, 4), IntToHex(lst[i].CharID, 4)])+CRLF, AStream); + WriteString('endbfchar'+CRLF, AStream); + end; WriteString('endcmap'+CRLF, AStream); WriteString('CMapName currentdict /CMap defineresource pop'+CRLF, AStream); WriteString('end'+CRLF, AStream); WriteString('end'+CRLF, AStream); end; -constructor TPDFToUnicode.Create(const ADocument: TPDFDocument; const AEmbeddedFontNum: integer); + +{ TCIDToGIDMap } + +procedure TCIDToGIDMap.Write(const AStream: TStream); +var + lst: TTextMappingList; + i: integer; + cid, gid: uint16; + ba: TBytes; + lMaxCharID: integer; begin - inherited Create(ADocument); - FEmbeddedFontNum := AEmbeddedFontNum; + lst := Document.Fonts[FontNum].TextMapping; + lst.Sort; + lMaxCharID := lst.GetMaxCharID; + SetLength(ba, (lMaxCharID * 2)+1); + // initialize array to 0's + for i := 0 to Length(ba)-1 do + ba[i] := 0; + for i := 0 to lst.Count-1 do + begin + cid := lst[i].GlyphID; + gid := lst[i].NewGlyphID; + + ba[2*cid] := Hi(gid); // Byte((gid shr 8) and $FF); //Hi(gid); + ba[(2*cid)+1] := Lo(gid); //Byte(gid and $FF); //Lo(gid); + end; + + AStream.WriteBuffer(ba[0], Length(ba)); + WriteString(CRLF, AStream); + SetLength(ba, 0); +end; + +{ TPDFCIDSet } + +{ CIDSet uses the bits of each byte for optimised storage. } +procedure TPDFCIDSet.Write(const AStream: TStream); +var + lst: TTextMappingList; + i: integer; + cid, gid: uint16; + ba: TBytes; + mask: uint8; + lSize: integer; +begin + lst := Document.Fonts[FontNum].TextMapping; + lst.Sort; + lSize := (lst.GetMaxCharID div 8) + 1; + SetLength(ba, lSize); + for i := 0 to lst.Count-1 do + begin + cid := lst[i].CharID; + mask := 1 shl (7 - (cid mod 8)); + if cid = 0 then + gid := 0 + else + gid := cid div 8; + ba[gid] := ba[gid] or mask; + end; + AStream.WriteBuffer(ba[0], Length(ba)); + WriteString(CRLF, AStream); + SetLength(ba, 0); end; { TPDFDocument } @@ -3871,6 +4201,28 @@ begin FFontFiles.Assign(AValue); end; +function TPDFDocument.GetStdFontCharWidthsArray(const AFontName: string): TPDFFontWidthArray; +begin + case AFontName of + 'Courier': result := FONT_COURIER_FULL; + 'Courier-Bold': result := FONT_COURIER_FULL; + 'Courier-Oblique': result := FONT_COURIER_FULL; + 'Courier-BoldOblique': result := FONT_COURIER_FULL; + 'Helvetica': result := FONT_HELVETICA_ARIAL; + 'Helvetica-Bold': result := FONT_HELVETICA_ARIAL_BOLD; + 'Helvetica-Oblique': result := FONT_HELVETICA_ARIAL_ITALIC; + 'Helvetica-BoldOblique': result := FONT_HELVETICA_ARIAL_BOLD_ITALIC; + 'Times-Roman': result := FONT_TIMES; + 'Times-Bold': result := FONT_TIMES_BOLD; + 'Times-Italic': result := FONT_TIMES_ITALIC; + 'Times-BoldItalic': result := FONT_TIMES_BOLD_ITALIC; + 'Symbol': result := FONT_SYMBOL; + 'ZapfDingbats': result := FONT_ZAPFDINGBATS; + else + raise EPDF.CreateFmt(rsErrUnknownStdFont, [AFontName]); + end; +end; + function TPDFDocument.GetX(AIndex : Integer): TPDFXRef; begin Result:=FGlobalXRefs[Aindex] as TPDFXRef; @@ -3890,6 +4242,12 @@ begin Result := Result + Pages[i].Annots.Count; end; +function TPDFDocument.GetFontNamePrefix(const AFontNum: Integer): string; +begin + // TODO: it must be 6 uppercase characters - no numbers! + Result := 'GRAEA' + Char(65+AFontNum) + '+'; +end; + function TPDFDocument.IndexOfGlobalXRef(const AValue: string): integer; var i: integer; @@ -3933,7 +4291,7 @@ var M : TMemoryStream; MCompressed: TMemoryStream; X : TPDFXRef; - PS: UInt64; + d: integer; begin TPDFObject.WriteString(IntToStr(AObject)+' 0 obj'+CRLF, AStream); X:=GlobalXRefs[AObject]; @@ -3946,19 +4304,18 @@ begin M := TMemoryStream.Create; X.FStream.Write(M); + d := M.Size; X.Dict.AddInteger('Length', M.Size); if poCompressText in Options then begin MCompressed := TMemoryStream.Create; CompressStream(M, MCompressed); - MCompressed.Position := 0; X.Dict.AddName('Filter', 'FlateDecode'); X.Dict.AddInteger('Length1', MCompressed.Size); end; X.Dict.Write(AStream); - M.Free; // write stream in contents dictionary CurrentColor:=''; @@ -3966,11 +4323,18 @@ begin TPDFObject.WriteString(CRLF+'stream'+CRLF, AStream); if poCompressText in Options then begin + MCompressed.Position := 0; MCompressed.SaveToStream(AStream); MCompressed.Free; end else - X.FStream.Write(AStream); + begin + M.Position := 0; + m.SaveToStream(AStream); +// X.FStream.Write(AStream); + end; + + M.Free; TPDFObject.WriteString('endstream', AStream); end; TPDFObject.WriteString(CRLF+'endobj'+CRLF+CRLF, AStream); @@ -4145,7 +4509,9 @@ procedure TPDFDocument.CreateStdFont(EmbeddedFontName: string; EmbeddedFontNum: var FDict: TPDFDictionary; N: TPDFName; + lFontXRef: integer; begin + lFontXRef := GlobalXRefCount; // will be used a few lines down in AddFontNameToPages() // add xref entry FDict := CreateGlobalXRef.Dict; FDict.AddName('Type', 'Font'); @@ -4156,8 +4522,9 @@ begin FDict.AddName('BaseFont', EmbeddedFontName); N := CreateName('F'+IntToStr(EmbeddedFontNum)); FDict.AddElement('Name',N); - AddFontNameToPages(N.Name,GLobalXRefCount-1); // add font reference to global page dictionary + AddFontNameToPages(N.Name, lFontXRef); + FontFiles.Add(''); end; @@ -4188,29 +4555,36 @@ var FDict: TPDFDictionary; N: TPDFName; Arr: TPDFArray; + lFontXRef: integer; begin + lFontXRef := GlobalXRefCount; // will be used a few lines down in AddFontNameToPages() + // add xref entry FDict := CreateGlobalXRef.Dict; FDict.AddName('Type', 'Font'); FDict.AddName('Subtype', 'Type0'); - FDict.AddName('BaseFont', Fonts[EmbeddedFontNum].Name); + + if poSubsetFont in Options then + FDict.AddName('BaseFont', GetFontNamePrefix(EmbeddedFontNum) + Fonts[EmbeddedFontNum].Name) + else + FDict.AddName('BaseFont', Fonts[EmbeddedFontNum].Name); + FDict.AddName('Encoding', 'Identity-H'); + // add name element to font dictionary N:=CreateName('F'+IntToStr(EmbeddedFontNum)); FDict.AddElement('Name',N); - AddFontNameToPages(N.Name,GlobalXRefCount-1); - CreateTTFDescendantFont(EmbeddedFontNum); + AddFontNameToPages(N.Name, lFontXRef); + Arr := CreateArray; + Arr.AddItem(TPDFReference.Create(self, GlobalXRefCount)); FDict.AddElement('DescendantFonts', Arr); - if (poNoEmbeddedFonts in Options) then + CreateTTFDescendantFont(EmbeddedFontNum); + + if not (poNoEmbeddedFonts in Options) then begin - Arr.AddItem(TPDFReference.Create(self, GlobalXRefCount-3)); - end - else - begin - Arr.AddItem(TPDFReference.Create(self, GlobalXRefCount-4)); + FDict.AddReference('ToUnicode', GlobalXRefCount); CreateToUnicode(EmbeddedFontNum); - FDict.AddReference('ToUnicode', GlobalXRefCount-1); end; FontFiles.Add(Fonts[EmbeddedFontNum].FTrueTypeFile.Filename); end; @@ -4224,21 +4598,31 @@ begin FDict := CreateGlobalXRef.Dict; FDict.AddName('Type', 'Font'); FDict.AddName('Subtype', 'CIDFontType2'); - FDict.AddName('BaseFont', Fonts[EmbeddedFontNum].Name); + if poSubsetFont in Options then + FDict.AddName('BaseFont', GetFontNamePrefix(EmbeddedFontNum) + Fonts[EmbeddedFontNum].Name) + else + FDict.AddName('BaseFont', Fonts[EmbeddedFontNum].Name); + FDict.AddReference('CIDSystemInfo', GlobalXRefCount); CreateTTFCIDSystemInfo; - FDict.AddReference('CIDSystemInfo', GlobalXRefCount-1); // add fontdescriptor reference to font dictionary + FDict.AddReference('FontDescriptor',GlobalXRefCount); CreateFontDescriptor(EmbeddedFontNum); - if (poNoEmbeddedFonts in Options) then - FDict.AddReference('FontDescriptor',GlobalXRefCount-1) - else - FDict.AddReference('FontDescriptor',GlobalXRefCount-2); Arr := CreateArray; FDict.AddElement('W',Arr); Arr.AddItem(TPDFTrueTypeCharWidths.Create(self, EmbeddedFontNum)); + + // TODO: Implement CIDToGIDMap here + { It's an array of 256*256*2, loop through the CID values (from Tj) and if + CID matches the loop variable, then populate the 2-byte data, otherwise write + $0 to the two bytes. Then stream the array as a PDF Reference Object and + use compression (if defined in PDFDocument.Options. } + if (poSubsetFont in Options) then + begin + FDict.AddReference('CIDToGIDMap', CreateCIDToGIDMap(EmbeddedFontNum)); + end; end; procedure TPDFDocument.CreateTTFCIDSystemInfo; @@ -4263,46 +4647,68 @@ var begin FDict:=CreateGlobalXRef.Dict; FDict.AddName('Type', 'FontDescriptor'); - FDict.AddName('FontName', Fonts[EmbeddedFontNum].Name); - FDict.AddName('FontFamily', Fonts[EmbeddedFontNum].FTrueTypeFile.FamilyName); + + if poSubsetFont in Options then + begin + FDict.AddName('FontName', GetFontNamePrefix(EmbeddedFontNum) + Fonts[EmbeddedFontNum].Name); + FDict.AddInteger('Flags', 4); + end + else + begin + FDict.AddName('FontName', Fonts[EmbeddedFontNum].Name); + FDict.AddName('FontFamily', Fonts[EmbeddedFontNum].FTrueTypeFile.FamilyName); + FDict.AddInteger('Flags', 32); + end; + FDict.AddInteger('Ascent', Fonts[EmbeddedFontNum].FTrueTypeFile.Ascender); FDict.AddInteger('Descent', Fonts[EmbeddedFontNum].FTrueTypeFile.Descender); FDict.AddInteger('CapHeight', Fonts[EmbeddedFontNum].FTrueTypeFile.CapHeight); - FDict.AddInteger('Flags', 32); Arr:=CreateArray; FDict.AddElement('FontBBox',Arr); Arr.AddIntArray(Fonts[EmbeddedFontNum].FTrueTypeFile.BBox); FDict.AddInteger('ItalicAngle', trunc(Fonts[EmbeddedFontNum].FTrueTypeFile.ItalicAngle)); FDict.AddInteger('StemV', Fonts[EmbeddedFontNum].FTrueTypeFile.StemV); FDict.AddInteger('MissingWidth', Fonts[EmbeddedFontNum].FTrueTypeFile.MissingWidth); - if (poNoEmbeddedFonts in Options) then - begin - // do nothing - end - else + if not (poNoEmbeddedFonts in Options) then begin + FDict.AddReference('FontFile2', GlobalXRefCount); CreateFontFileEntry(EmbeddedFontNum); - FDict.AddReference('FontFile2',GlobalXRefCount-1); + + if poSubsetFont in Options then + begin + // todo /CIDSet reference + FDict.AddReference('CIDSet', GlobalXRefCount); + CreateCIDSet(EmbeddedFontNum); + end; end; end; -procedure TPDFDocument.CreateToUnicode(const EmbeddedFontNum: integer); +procedure TPDFDocument.CreateToUnicode(const AFontNum: integer); var lXRef: TPDFXRef; begin lXRef := CreateGlobalXRef; lXRef.FStream := CreateStream(True); - lXRef.FStream.AddItem(TPDFToUnicode.Create(self, EmbeddedFontNum)); + lXRef.FStream.AddItem(TPDFToUnicode.Create(self, AFontNum)); end; -procedure TPDFDocument.CreateFontFileEntry(const EmbeddedFontNum: integer); +procedure TPDFDocument.CreateFontFileEntry(const AFontNum: integer); var FDict: TPDFDictionary; begin FDict:=CreateGlobalXRef.Dict; if poCompressFonts in Options then FDict.AddName('Filter','FlateDecode'); - FDict.AddInteger('Length1 '+IntToStr(EmbeddedFontNum), Fonts[EmbeddedFontNum].FTrueTypeFile.OriginalSize); + FDict.AddInteger('Length1 '+IntToStr(AFontNum), Fonts[AFontNum].FTrueTypeFile.OriginalSize); +end; + +procedure TPDFDocument.CreateCIDSet(const AFontNum: integer); +var + lXRef: TPDFXRef; +begin + lXRef := CreateGlobalXRef; + lXRef.FStream := CreateStream(True); + lXRef.FStream.AddItem(TPDFCIDSet.Create(self, AFontNum)); end; procedure TPDFDocument.CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer); @@ -4310,7 +4716,10 @@ var N: TPDFName; IDict,ADict: TPDFDictionary; i: integer; + lXRef: integer; begin + lXRef := GlobalXRefCount; // reference to be used later + IDict:=CreateGlobalXRef.Dict; IDict.AddName('Type','XObject'); IDict.AddName('Subtype','Image'); @@ -4320,22 +4729,24 @@ begin IDict.AddInteger('BitsPerComponent',8); N:=CreateName('I'+IntToStr(NumImg)); // Needed later IDict.AddElement('Name',N); - for i:=1 to GLobalXRefCount-1 do - begin + + // now find where we must add the image xref - we are looking for "Resources" + for i := 1 to GlobalXRefCount-1 do + begin ADict:=GlobalXRefs[i].Dict; if ADict.ElementCount > 0 then - begin + begin if (ADict.Values[0] is TPDFName) and ((ADict.Values[0] as TPDFName).Name='Page') then - begin + begin ADict:=ADict.ValueByName('Resources') as TPDFDictionary; ADict:=TPDFDictionary(ADict.FindValue('XObject')); if Assigned(ADict) then - begin - ADict.AddReference(N.Name,GLobalXRefCount-1); - end; + begin + ADict.AddReference(N.Name, lXRef); end; end; end; + end; end; function TPDFDocument.CreateAnnotEntry(const APageNum, AnnotNum: integer): integer; @@ -4384,6 +4795,17 @@ begin result := GlobalXRefCount-1; end; +function TPDFDocument.CreateCIDToGIDMap(const AFontNum: integer): integer; +var + lXRef: TPDFXRef; +begin + lXRef := CreateGlobalXRef; + result := GlobalXRefCount-1; + + lXRef.FStream := CreateStream(True); + lXRef.FStream.AddItem(TCIDToGIDMap.Create(self, AFontNum)); +end; + function TPDFDocument.CreateContentsEntry(const APageNum: integer): integer; var Contents: TPDFXRef; @@ -4668,23 +5090,22 @@ begin // select the font type NumFont:=0; for i:=0 to Fonts.Count-1 do - begin + begin FontName := Fonts[i].Name; - { Acrobat Reader expects us to be case sensitive. Other PDF viewers are case-insensitive. } - if (FontName='Courier') or (FontName='Courier-Bold') or (FontName='Courier-Oblique') or (FontName='Courier-BoldOblique') - or (FontName='Helvetica') or (FontName='Helvetica-Bold') or (FontName='Helvetica-Oblique') or (FontName='Helvetica-BoldOblique') - or (FontName='Times-Roman') or (FontName='Times-Bold') or (FontName='Times-Italic') or (FontName='Times-BoldItalic') - or (FontName='Symbol') - or (FontName='Zapf Dingbats') then - begin - CreateStdFont(FontName, NumFont); - end + + if IsStandardPDFFont(FontName) then + CreateStdFont(FontName, NumFont) else if LoadFont(Fonts[i]) then - CreateTtfFont(NumFont) + begin + if poSubsetFont in Options then + Fonts[i].GenerateSubsetFont; + CreateTtfFont(NumFont); + end else CreateTp1Font(NumFont); // not implemented yet + Inc(NumFont); - end; + end; end; procedure TPDFDocument.CreateImageEntries; @@ -4755,24 +5176,37 @@ begin SaveToStream(F); finally F.Free; - end; + end; end; -function TPDFDocument.CreateEmbeddedFont(AFontIndex, AFontSize : Integer): TPDFEmbeddedFont; +function TPDFDocument.IsStandardPDFFont(AFontName: string): boolean; begin - Result:=TPDFEmbeddedFont.Create(Self,AFontIndex,IntToStr(AFontSize)) + { Acrobat Reader expects us to be case sensitive. Other PDF viewers are case-insensitive. } + if (AFontName='Courier') or (AFontName='Courier-Bold') or (AFontName='Courier-Oblique') or (AFontName='Courier-BoldOblique') + or (AFontName='Helvetica') or (AFontName='Helvetica-Bold') or (AFontName='Helvetica-Oblique') or (AFontName='Helvetica-BoldOblique') + or (AFontName='Times-Roman') or (AFontName='Times-Bold') or (AFontName='Times-Italic') or (AFontName='Times-BoldItalic') + or (AFontName='Symbol') + or (AFontName='ZapfDingbats') then + Result := True + else + Result := False; end; -function TPDFDocument.CreateText(X, Y: TPDFFloat; AText: AnsiString; const AFontIndex: integer; const ADegrees: single - ): TPDFText; +function TPDFDocument.CreateEmbeddedFont(const APage: TPDFPage; AFontIndex, AFontSize: Integer): TPDFEmbeddedFont; begin - Result:=TPDFText.Create(Self, X, Y, AText, AFontIndex, ADegrees); + Result:=TPDFEmbeddedFont.Create(Self, APage, AFontIndex, IntToStr(AFontSize)) end; -function TPDFDocument.CreateText(X, Y: TPDFFloat; AText: UTF8String; const AFontIndex: integer; const ADegrees: single - ): TPDFUTF8Text; +function TPDFDocument.CreateText(X, Y: TPDFFloat; AText: AnsiString; const AFont: TPDFEmbeddedFont; + const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean): TPDFText; begin - Result := TPDFUTF8Text.Create(Self, X, Y, AText, AFontIndex, ADegrees); + Result:=TPDFText.Create(Self, X, Y, AText, AFont, ADegrees, AUnderline, AStrikeThrough); +end; + +function TPDFDocument.CreateText(X, Y: TPDFFloat; AText: UTF8String; const AFont: TPDFEmbeddedFont; + const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean): TPDFUTF8Text; +begin + Result := TPDFUTF8Text.Create(Self, X, Y, AText, AFont, ADegrees, AUnderline, AStrikeThrough); end; function TPDFDocument.CreateRectangle(const X,Y,W,H, ALineWidth: TPDFFloat; const AFill, AStroke: Boolean): TPDFRectangle; diff --git a/packages/fcl-pdf/src/fpttf.pp b/packages/fcl-pdf/src/fpttf.pp index d35431c7f5..d4ca15dcd9 100644 --- a/packages/fcl-pdf/src/fpttf.pp +++ b/packages/fcl-pdf/src/fpttf.pp @@ -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); diff --git a/packages/fcl-pdf/tests/fpparsettf_test.pas b/packages/fcl-pdf/tests/fpparsettf_test.pas index 7b31ae107f..d47e223c73 100644 --- a/packages/fcl-pdf/tests/fpparsettf_test.pas +++ b/packages/fcl-pdf/tests/fpparsettf_test.pas @@ -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; diff --git a/packages/fcl-pdf/tests/fppdf_test.pas b/packages/fcl-pdf/tests/fppdf_test.pas index 6d6bdca46d..4dcb9d65b5 100644 --- a/packages/fcl-pdf/tests/fppdf_test.pas +++ b/packages/fcl-pdf/tests/fppdf_test.pas @@ -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; diff --git a/packages/fcl-pdf/tests/fpttf_test.pas b/packages/fcl-pdf/tests/fpttf_test.pas index 9aaff3fc95..ff96fbbdbd 100644 --- a/packages/fcl-pdf/tests/fpttf_test.pas +++ b/packages/fcl-pdf/tests/fpttf_test.pas @@ -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 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 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 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 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 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}); diff --git a/packages/fcl-pdf/utils/ttfdump.lpi b/packages/fcl-pdf/utils/ttfdump.lpi index a8baa8c4e8..2adbfed8d1 100644 --- a/packages/fcl-pdf/utils/ttfdump.lpi +++ b/packages/fcl-pdf/utils/ttfdump.lpi @@ -32,6 +32,7 @@ + @@ -56,6 +57,11 @@ + + + + + diff --git a/packages/fcl-pdf/utils/ttfdump.lpr b/packages/fcl-pdf/utils/ttfdump.lpr index 2167632d65..9e564b9773 100644 --- a/packages/fcl-pdf/utils/ttfdump.lpr +++ b/packages/fcl-pdf/utils/ttfdump.lpr @@ -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 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';