summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormarco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2>2017-04-29 15:18:58 +0000
committermarco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2>2017-04-29 15:18:58 +0000
commitba1e9a14fde4e81d149bf52c87b63c19aa1c05e6 (patch)
tree92ad8a823e0964b619747ae053ca4f4db3a442d5
parent72021b9aaa51ebff65f085fab232797e8f0085fb (diff)
downloadfpc-ba1e9a14fde4e81d149bf52c87b63c19aa1c05e6.tar.gz
--- Merging r33998 into '.':
U packages/fcl-pdf/examples/testfppdf.lpr U packages/fcl-pdf/src/fpttf.pp U packages/fcl-pdf/src/fppdf.pp --- Recording mergeinfo for merge of r33998 into '.': U . --- Merging r34037 into '.': D packages/fcl-pdf/utils/mkpdffontdef.lpi D packages/fcl-pdf/utils/mkpdffontdef.pp --- Recording mergeinfo for merge of r34037 into '.': G . --- Merging r34060 into '.': U packages/fcl-pdf/tests/fpttf_test.pas U packages/fcl-pdf/tests/fpparsettf_test.pas U packages/fcl-pdf/src/fpparsettf.pp G packages/fcl-pdf/src/fppdf.pp --- Recording mergeinfo for merge of r34060 into '.': G . --- Merging r34543 into '.': G packages/fcl-pdf/src/fppdf.pp --- Recording mergeinfo for merge of r34543 into '.': G . --- Merging r34563 into '.': G packages/fcl-pdf/examples/testfppdf.lpr U packages/fcl-pdf/tests/fppdf_test.pas G packages/fcl-pdf/src/fpparsettf.pp G packages/fcl-pdf/src/fppdf.pp G packages/fcl-pdf/src/fpttf.pp --- Recording mergeinfo for merge of r34563 into '.': G . --- Merging r34767 into '.': G packages/fcl-pdf/examples/testfppdf.lpr G packages/fcl-pdf/tests/fpparsettf_test.pas G packages/fcl-pdf/src/fpparsettf.pp G packages/fcl-pdf/src/fppdf.pp --- Recording mergeinfo for merge of r34767 into '.': G . --- Merging r34778 into '.': G packages/fcl-pdf/src/fppdf.pp G packages/fcl-pdf/examples/testfppdf.lpr --- Recording mergeinfo for merge of r34778 into '.': G . --- Merging r34779 into '.': G packages/fcl-pdf/src/fppdf.pp --- Recording mergeinfo for merge of r34779 into '.': G . --- Merging r34780 into '.': G packages/fcl-pdf/src/fppdf.pp --- Recording mergeinfo for merge of r34780 into '.': G . --- Merging r34781 into '.': G packages/fcl-pdf/examples/testfppdf.lpr G packages/fcl-pdf/src/fppdf.pp --- Recording mergeinfo for merge of r34781 into '.': G . --- Merging r34804 into '.': G packages/fcl-pdf/src/fppdf.pp --- Recording mergeinfo for merge of r34804 into '.': G . --- Merging r35083 into '.': G packages/fcl-pdf/examples/testfppdf.lpr U packages/fcl-pdf/utils/ttfdump.lpr U packages/fcl-pdf/utils/ttfdump.lpi U packages/fcl-pdf/fpmake.pp G packages/fcl-pdf/tests/fpparsettf_test.pas G packages/fcl-pdf/tests/fppdf_test.pas G packages/fcl-pdf/tests/fpttf_test.pas A packages/fcl-pdf/src/fontmetrics_stdpdf.inc G packages/fcl-pdf/src/fpparsettf.pp G packages/fcl-pdf/src/fppdf.pp G packages/fcl-pdf/src/fpttf.pp --- Recording mergeinfo for merge of r35083 into '.': G . --- Merging r35084 into '.': A packages/fcl-pdf/src/fpttfsubsetter.pp G packages/fcl-pdf/fpmake.pp --- Recording mergeinfo for merge of r35084 into '.': G . --- Merging r35090 into '.': G packages/fcl-pdf/fpmake.pp A packages/fcl-pdf/src/fpfonttextmapping.pp --- Recording mergeinfo for merge of r35090 into '.': G . --- Merging r35094 into '.': U packages/fcl-pdf/src/fpttfsubsetter.pp --- Recording mergeinfo for merge of r35094 into '.': G . --- Merging r35126 into '.': G packages/fcl-pdf/utils/ttfdump.lpi G packages/fcl-pdf/src/fppdf.pp G packages/fcl-pdf/src/fpttfsubsetter.pp G packages/fcl-pdf/examples/testfppdf.lpr --- Recording mergeinfo for merge of r35126 into '.': G . --- Merging r35131 into '.': G packages/fcl-pdf/src/fppdf.pp G packages/fcl-pdf/src/fpttfsubsetter.pp --- Recording mergeinfo for merge of r35131 into '.': G . --- Merging r35519 into '.': G packages/fcl-pdf/src/fpttfsubsetter.pp --- Recording mergeinfo for merge of r35519 into '.': G . # revisions: 33998,34037,34060,34543,34563,34767,34778,34779,34780,34781,34804,35083,35084,35090,35094,35126,35131,35519 git-svn-id: http://svn.freepascal.org/svn/fpc/branches/fixes_3_0@36010 3ad0048d-3df7-0310-abae-a5850022a9f2
Diffstat
-rw-r--r--packages/fcl-pdf/examples/testfppdf.lpr477
-rw-r--r--packages/fcl-pdf/fpmake.pp9
-rw-r--r--packages/fcl-pdf/src/fontmetrics_stdpdf.inc222
-rw-r--r--packages/fcl-pdf/src/fpfonttextmapping.pp239
-rw-r--r--packages/fcl-pdf/src/fpparsettf.pp572
-rw-r--r--packages/fcl-pdf/src/fppdf.pp2326
-rw-r--r--packages/fcl-pdf/src/fpttf.pp192
-rw-r--r--packages/fcl-pdf/src/fpttfsubsetter.pp1259
-rw-r--r--packages/fcl-pdf/tests/fpparsettf_test.pas68
-rw-r--r--packages/fcl-pdf/tests/fppdf_test.pas222
-rw-r--r--packages/fcl-pdf/tests/fpttf_test.pas165
-rw-r--r--packages/fcl-pdf/utils/mkpdffontdef.lpi83
-rw-r--r--packages/fcl-pdf/utils/mkpdffontdef.pp36
-rw-r--r--packages/fcl-pdf/utils/ttfdump.lpi12
-rw-r--r--packages/fcl-pdf/utils/ttfdump.lpr159
15 files changed, 4820 insertions, 1221 deletions
diff --git a/packages/fcl-pdf/examples/testfppdf.lpr b/packages/fcl-pdf/examples/testfppdf.lpr
index 3e97d2221c..652ea16d13 100644
--- a/packages/fcl-pdf/examples/testfppdf.lpr
+++ b/packages/fcl-pdf/examples/testfppdf.lpr
@@ -1,5 +1,5 @@
{ This program generates a multi-page PDF document and tests various
- functionality on each of the 5 pages.
+ functionality on each of the pages.
You can also specify to generate single pages by using the -p <n>
command line parameter.
@@ -22,17 +22,20 @@ uses
fpreadjpeg,
fppdf,
fpparsettf,
+ fpttf,
typinfo;
type
TPDFTestApp = class(TCustomApplication)
private
- Fpg: integer;
+ FPage: integer;
FRawJPEG,
FImageCompression,
FTextCompression,
FFontCompression: boolean;
+ FNoFontEmbedding: boolean;
+ FSubsetFontEmbedding: boolean;
FDoc: TPDFDocument;
function SetUpDocument: TPDFDocument;
procedure SaveDocument(D: TPDFDocument);
@@ -42,8 +45,10 @@ type
procedure SimpleLines(D: TPDFDocument; APage: integer);
procedure SimpleImage(D: TPDFDocument; APage: integer);
procedure SimpleShapes(D: TPDFDocument; APage: integer);
+ procedure AdvancedShapes(D: TPDFDocument; APage: integer);
procedure SampleMatrixTransform(D: TPDFDocument; APage: integer);
procedure SampleLandscape(D: TPDFDocument; APage: integer);
+ procedure TextInABox(const APage: TPDFPage; const AX, AY: TPDFFloat; const APointSize: integer; const ABoxColor: TARGBColor; const AFontName: string; const AText: UTF8String);
protected
procedure DoRun; override;
public
@@ -54,6 +59,8 @@ type
var
Application: TPDFTestApp;
+const
+ cPageCount: integer = 8;
function TPDFTestApp.SetUpDocument: TPDFDocument;
var
@@ -66,11 +73,18 @@ begin
Result := TPDFDocument.Create(Nil);
Result.Infos.Title := Application.Title;
Result.Infos.Author := 'Graeme Geldenhuys';
- Result.Infos.Producer := 'fpGUI Toolkit 0.8';
+ Result.Infos.Producer := 'fpGUI Toolkit 1.4.1';
Result.Infos.ApplicationName := ApplicationName;
Result.Infos.CreationDate := Now;
- lOpts := [];
+ 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
@@ -83,8 +97,8 @@ begin
Result.StartDocument;
S := Result.Sections.AddSection; // we always need at least one section
- lPageCount := 7;
- if Fpg <> -1 then
+ lPageCount := cPageCount;
+ if FPage <> -1 then
lPageCount := 1;
for i := 1 to lPageCount do
begin
@@ -124,35 +138,53 @@ 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];
// create the fonts to be used (use one of the 14 Adobe PDF standard fonts)
- FtTitle := D.AddFont('Helvetica', clRed);
- FtText1 := D.AddFont('FreeSans.ttf', 'FreeSans', clGreen); // TODO: this color value means nothing - not used at all
- FtText2 := D.AddFont('Times-BoldItalic', clBlack);
- // FtText3 := D.AddFont('arial.ttf', 'Arial', clBlack);
- FtText3 := FtText1; // to reduce font dependecies, but above works too if you have arial.ttf available
+ FtTitle := D.AddFont('Helvetica');
+ FtText1 := D.AddFont('FreeSans.ttf', 'FreeSans');
+ FtText2 := D.AddFont('Times-BoldItalic');
+ 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
P.SetFont(FtTitle, 12);
P.SetColor(clBlue, false);
P.WriteText(25, 50, '(25mm,50mm) Helvetica: The quick brown fox jumps over the lazy dog.');
+ P.SetColor(clBlack, false);
+ 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);
P.SetFont(ftText2,16);
- P.SetColor($c00000, false);
- P.WriteText(60, 100, '(60mm,100mm) Times-BoldItalic: Big text at absolute position');
+ P.SetColor($C00000, false);
+ P.WriteText(50, 100, '(50mm,100mm) Times-BoldItalic: Big text at absolute position');
+
// -----------------------------------
// TrueType testing purposes
- P.SetFont(ftText3, 13);
+ P.SetFont(FtText1, 13);
P.SetColor(clBlack, false);
P.WriteText(15, 120, 'Languages: English: Hello, World!');
@@ -162,7 +194,6 @@ begin
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?”');
@@ -171,6 +202,13 @@ begin
P.WriteText(40, 230, 'OK then… (êçèûÎÐð£¢ß) \\//{}()#<>');
P.WriteText(25, 280, 'B субботу двадцать третьего мая приезжает твоя любимая теща.');
+
+ { draw a rectangle around the text }
+ TextInABox(P, 25, 255, 23, clRed, 'FreeSans', '“Text in a Box gyj?”');
+
+ { lets make a hyperlink more prominent }
+ TextInABox(P, 100, 255, 12, clMagenta, 'FreeSans', 'http://www.freepascal.org');
+ P.AddExternalLink(99, 255, 49, 5, 'http://www.freepascal.org', false);
end;
procedure TPDFTestApp.SimpleLinesRaw(D: TPDFDocument; APage: integer);
@@ -181,7 +219,7 @@ var
begin
P:=D.Pages[APage];
// create the fonts to be used (use one of the 14 Adobe PDF standard fonts)
- FtTitle := D.AddFont('Helvetica', clBlack);
+ FtTitle := D.AddFont('Helvetica');
{ Page title }
P.SetFont(FtTitle,23);
@@ -189,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);
@@ -224,7 +262,7 @@ var
begin
P:=D.Pages[APage];
// create the fonts to be used (use one of the 14 Adobe PDF standard fonts)
- FtTitle := D.AddFont('Helvetica', clRed);
+ FtTitle := D.AddFont('Helvetica');
{ Page title }
P.SetFont(FtTitle,23);
@@ -232,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;
@@ -262,7 +300,7 @@ Var
begin
P := D.Pages[APage];
// create the fonts to be used (use one of the 14 Adobe PDF standard fonts)
- FtTitle := D.AddFont('Helvetica', clBlack);
+ FtTitle := D.AddFont('Helvetica');
{ Page title }
P.SetFont(FtTitle,23);
@@ -279,13 +317,17 @@ begin
P.DrawImageRawSize(25, 130, W, H, IDX); // left-bottom coordinate of image
P.WriteText(145, 90, '[Full size (defined in pixels)]');
- { half size image }
+ { quarter size image }
P.DrawImageRawSize(25, 190, W shr 1, H shr 1, IDX); // could also have used: Integer(W div 2), Integer(H div 2)
- P.WriteText(90, 165, '[Quarter size (defined in pixels)]');
+ P.WriteText(85, 180, '[Quarter size (defined in pixels)]');
+ { rotated image }
+ P.DrawImageRawSize(150, 190, W shr 1, H shr 1, IDX, 30);
{ scalled image to 2x2 centimeters }
P.DrawImage(25, 230, 20.0, 20.0, IDX); // left-bottom coordinate of image
P.WriteText(50, 220, '[2x2 cm scaled image]');
+ { rotatedd image }
+ P.DrawImage(120, 230, 20.0, 20.0, IDX, 30);
end;
procedure TPDFTestApp.SimpleShapes(D: TPDFDocument; APage: integer);
@@ -293,10 +335,13 @@ var
P: TPDFPage;
FtTitle: integer;
lPt1: TPDFCoord;
+ lPoints: array of TPDFCoord;
+ i: integer;
+ lLineWidth: TPDFFloat;
begin
P:=D.Pages[APage];
// create the fonts to be used (use one of the 14 Adobe PDF standard fonts)
- FtTitle := D.AddFont('Helvetica', clBlack);
+ FtTitle := D.AddFont('Helvetica');
{ Page title }
P.SetFont(FtTitle,23);
@@ -305,30 +350,64 @@ begin
// ========== Rectangles ============
- { PDF origin coordinate is Bottom-Left, and we want to use Image Coordinate of Top-Left }
+ { PDF origin coordinate is Bottom-Left. }
lPt1.X := 30;
- lPt1.Y := 60+20; // origin + height
- P.SetColor(clRed, true);
- P.SetColor($37b344, false); // some green color
+ lPt1.Y := 75;
+ P.SetColor($c00000, true);
+ P.SetColor(clLtGray, false);
P.DrawRect(lPt1.X, lPt1.Y, 40, 20, 3, true, true);
lPt1.X := 20;
- lPt1.Y := 50+20; // origin + height
+ lPt1.Y := 65;
P.SetColor(clBlue, true);
- P.SetColor($b737b3, false); // some purple color
+ P.SetColor($ffff80, false); // pastel yellow
P.DrawRect(lPt1.X, lPt1.Y, 40, 20, 1, true, true);
P.SetPenStyle(ppsDashDot);
P.SetColor(clBlue, true);
- P.DrawRect(110, 70+20 {origin+height}, 40, 20, 1, false, true);
+ P.DrawRect(110, 75, 40, 20, 1, false, true);
+
+ P.SetPenStyle(ppsDash);
+ P.SetColor($37b344, true); // some green color
+ P.DrawRect(100, 70, 40, 20, 2, false, true);
+
+ P.SetPenStyle(ppsSolid);
+ P.SetColor($c00000, true);
+ P.DrawRect(90, 65, 40, 20, 4, false, true);
+
+ P.SetPenStyle(ppsSolid);
+ P.SetColor(clBlack, true);
+ P.DrawRect(170, 75, 30, 15, 1, false, true, 30);
+
+
+ // ========== Rounded Rectangle ===========
+ lPt1.X := 30;
+ lPt1.Y := 120;
+ P.SetColor($c00000, true);
+ P.SetColor(clLtGray, false);
+ P.DrawRoundedRect(lPt1.X, lPt1.Y, 40, 20, 5, 2, true, true);
+
+ lPt1.X := 20;
+ lPt1.Y := 110;
+ P.SetColor(clBlue, true);
+ P.SetColor($ffff80, false); // pastel yellow
+ P.DrawRoundedRect(lPt1.X, lPt1.Y, 40, 20, 2.4, 1, true, true);
+
+ P.SetPenStyle(ppsDashDot);
+ P.SetColor(clBlue, true);
+ P.DrawRoundedRect(110, 120, 40, 20, 1.5, 1, false, true);
P.SetPenStyle(ppsDash);
P.SetColor($37b344, true); // some green color
- P.DrawRect(100, 60+20 {origin+height}, 40, 20, 2, false, true);
+ P.DrawRoundedRect(100, 115, 40, 20, 3, 2, false, true);
P.SetPenStyle(ppsSolid);
- P.SetColor($b737b3, true); // some purple color
- P.DrawRect(90, 50+20 {origin+height}, 40, 20, 4, false, true);
+ P.SetColor($c00000, true);
+ P.DrawRoundedRect(90, 110, 40, 20, 5, 3, false, true);
+
+ P.SetPenStyle(ppsSolid);
+ P.SetColor(clBlack, true);
+ P.DrawRoundedRect(170, 120, 30, 15, 5, 1, false, true, 30);
// ========== Ellipses ============
@@ -340,35 +419,40 @@ begin
lPt1.X := 60;
lPt1.Y := 150;
P.SetColor(clBlue, true);
- P.SetColor($b737b3, false); // some purple color
+ P.SetColor($ffff80, false); // pastel yellow
P.DrawEllipse(lPt1, 10, 10, 1, True, True);
P.SetPenStyle(ppsDashDot);
P.SetColor($b737b3, True);
- P.DrawEllipse(140, 150, 35, 20, 1, False, True);
+ P.DrawEllipse(73, 150, 10, 20, 1, False, True);
+ P.SetPenStyle(ppsSolid);
+ P.SetColor(clBlack, True);
+ P.DrawEllipse(170, 150, 30, 15, 1, False, True, 30);
// ========== Lines Pen Styles ============
- P.SetPenStyle(ppsSolid);
+ lLineWidth := 1;
+
+ P.SetPenStyle(ppsSolid, lLineWidth);
P.SetColor(clBlack, True);
- P.DrawLine(30, 200, 70, 200, 1);
+ P.DrawLine(30, 170, 70, 170, lLineWidth);
- P.SetPenStyle(ppsDash);
+ P.SetPenStyle(ppsDash, lLineWidth);
P.SetColor(clBlack, True);
- P.DrawLine(30, 210, 70, 210, 1);
+ P.DrawLine(30, 175, 70, 175, lLineWidth);
- P.SetPenStyle(ppsDot);
+ P.SetPenStyle(ppsDot, lLineWidth);
P.SetColor(clBlack, True);
- P.DrawLine(30, 220, 70, 220, 1);
+ P.DrawLine(30, 180, 70, 180, lLineWidth);
- P.SetPenStyle(ppsDashDot);
+ P.SetPenStyle(ppsDashDot, lLineWidth);
P.SetColor(clBlack, True);
- P.DrawLine(30, 230, 70, 230, 1);
+ P.DrawLine(30, 185, 70, 185, lLineWidth);
- P.SetPenStyle(ppsDashDotDot);
+ P.SetPenStyle(ppsDashDotDot, lLineWidth);
P.SetColor(clBlack, True);
- P.DrawLine(30, 240, 70, 240, 1);
+ P.DrawLine(30, 190, 70, 190, lLineWidth);
// ========== Line Attribute ============
@@ -376,21 +460,178 @@ begin
P.SetPenStyle(ppsSolid);
P.SetColor(clBlack, True);
P.DrawLine(100, 170, 140, 170, 0.2);
- P.DrawLine(100, 180, 140, 180, 0.3);
- P.DrawLine(100, 190, 140, 190, 0.5);
- P.DrawLine(100, 200, 140, 200, 1);
+ P.DrawLine(100, 175, 140, 175, 0.3);
+ P.DrawLine(100, 180, 140, 180, 0.5);
+ P.DrawLine(100, 185, 140, 185, 1);
P.SetColor(clRed, True);
- P.DrawLine(100, 210, 140, 210, 2);
+ P.DrawLine(100, 190, 140, 190, 2);
P.SetColor($37b344, True);
- P.DrawLine(100, 220, 140, 220, 3);
+ P.DrawLine(100, 195, 140, 195, 3);
P.SetColor(clBlue, True);
- P.DrawLine(100, 230, 140, 230, 4);
+ P.DrawLine(100, 200, 140, 200, 4);
P.SetColor($b737b3, True);
- P.DrawLine(100, 240, 140, 240, 5);
+ P.DrawLine(100, 205, 140, 205, 5);
+
+
+ // ========== PolyLines and Polygons ============
+ P.Matrix.SetYTranslation(70);
+ P.Matrix.SetXTranslation(20);
+
+ P.SetPenStyle(ppsSolid);
+ P.SetColor(clBlack, true);
+ P.DrawRect(0, 10, 50, -50, 1, false, true);
+
+ P.SetColor($c00000, true);
+ P.ResetPath;
+ SetLength(lPoints, 10);
+ for i := 0 to 9 do
+ begin
+ lPoints[i].X := Random(50);
+ lPoints[i].Y := Random(50) + 10.5;
+ end;
+ P.DrawPolyLine(lPoints, 1);
+ P.StrokePath;
+
+
+ P.Matrix.SetXTranslation(80);
+ P.SetPenStyle(ppsSolid);
+ P.SetColor(clBlack, true);
+ P.DrawRect(0, 10, 50, -50, 1, false, true);
+
+ P.SetColor($ffff80, false); // pastel yellow
+ P.SetColor(clBlue, true);
+ P.ResetPath;
+ P.DrawPolygon(lPoints, 1);
+ P.FillStrokePath;
+
+ p.SetPenStyle(ppsSolid);
+ P.SetFont(FtTitle, 8);
+ P.SetColor(clBlack, false);
+ P.WriteText(0, 8, 'Fill using the nonzero winding number rule');
+
+
+ P.Matrix.SetXTranslation(140);
+ P.SetPenStyle(ppsSolid);
+ P.SetColor(clBlack, true);
+ P.DrawRect(0, 10, 50, -50, 1, false, true);
+
+ P.SetColor($ffff80, false); // pastel yellow
+ P.SetColor(clBlue, true);
+ P.ResetPath;
+ P.DrawPolygon(lPoints, 1);
+ P.FillEvenOddStrokePath;
+
+ p.SetPenStyle(ppsSolid);
+ P.SetFont(FtTitle, 8);
+ P.SetColor(clBlack, false);
+ P.WriteText(0, 8, 'Fill using the even-odd rule');
+end;
+
+{ Each curve uses the exact same four coordinates, just with different CubicCurveToXXX
+ method calls. I also use the page Maxtix Y-Translation to adjust the coordinate
+ system before I draw each curve. I could also refactor each curves drawing
+ code into a single parametised procedure - simply to show that each of the
+ curves really do use the same code and coordinates. }
+procedure TPDFTestApp.AdvancedShapes(D: TPDFDocument; APage: integer);
+var
+ P: TPDFPage;
+ FtTitle: integer;
+ lPt1, lPt2, lPt3, lPt4: TPDFCoord;
+begin
+ P:=D.Pages[APage];
+ // create the fonts to be used (use one of the 14 Adobe PDF standard fonts)
+ FtTitle := D.AddFont('Helvetica');
+
+ { Page title }
+ P.SetFont(FtTitle,23);
+ P.SetColor(clBlack);
+ P.WriteText(25, 20, 'Advanced Drawing');
+
+ // ========== Cubic Bezier curve ===========
+
+ // PDF c operator curve ===========
+ lPt1 := PDFCoord(75, 70);
+ lPt2 := PDFCoord(78, 40);
+ lPt3 := PDFCoord(100, 35);
+ lPt4 := PDFCoord(140, 60);
+
+ p.SetColor(clBlack, true);
+ p.SetPenStyle(ppsSolid);
+ p.MoveTo(lPt1);
+ p.CubicCurveTo(lPt2, lPt3, lPt4, 1);
+ // for fun, lets draw the control points as well
+ P.SetColor(clLtGray, True);
+ P.SetColor(clLtGray, false);
+ P.DrawEllipse(lPt2.X-0.5, lPt2.Y, 1, 1, 1, True, True);
+ P.DrawEllipse(lPt3.X-0.8, lPt3.Y, 1, 1, 1, True, True);
+ P.SetPenStyle(ppsDot);
+ P.DrawLine(lPt1, lPt2, 1);
+ P.DrawLine(lPt3, lPt4, 1);
+
+ p.SetPenStyle(ppsSolid);
+ P.SetFont(FtTitle, 8);
+ P.SetColor(clBlack, false);
+ P.WriteText(lPt1.X+1, lPt1.Y, '(current point)');
+ p.WriteText(lPt2.X+1, lPt2.Y, '(x1, y1)');
+ p.WriteText(lPt3.X+1, lPt3.Y, '(x2, y2)');
+ p.WriteText(lPt4.X+1, lPt4.Y, '(xTo, yTo)');
+
+ P.SetFont(FtTitle, 10);
+ P.WriteText(20, 50, 'CubicCurveTo(...)');
+
+
+ // PDF v operator curve ===========
+ P.Matrix.SetYTranslation(220);
+
+ p.SetColor(clBlack, true);
+ p.SetPenStyle(ppsSolid);
+ p.MoveTo(lPt1);
+ p.CubicCurveToV(lPt3, lPt4, 1);
+ // for fun, lets draw the control points as well
+ P.SetColor(clLtGray, True);
+ P.SetColor(clLtGray, false);
+ P.DrawEllipse(lPt3.X-0.8, lPt3.Y, 1, 1, 1, True, True);
+ P.SetPenStyle(ppsDot);
+ P.DrawLine(lPt3, lPt4, 1);
+
+ p.SetPenStyle(ppsSolid);
+ P.SetFont(FtTitle,8);
+ P.SetColor(clBlack, false);
+ P.WriteText(lPt1.X+1, lPt1.Y, '(current point)');
+ p.WriteText(lPt3.X+1, lPt3.Y, '(x2, y2)');
+ p.WriteText(lPt4.X+1, lPt4.Y, '(xTo, yTo)');
+
+ P.SetFont(FtTitle, 10);
+ P.WriteText(20, 50, 'CubicCurveToV(...)');
+
+
+ // PDF y operator curve ===========
+ P.Matrix.SetYTranslation(140);
+
+ p.SetColor(clBlack, true);
+ p.SetPenStyle(ppsSolid);
+ p.MoveTo(lPt1);
+ p.CubicCurveToY(lPt2, lPt4, 1);
+ // for fun, lets draw the control points as well
+ P.SetColor(clLtGray, True);
+ P.SetColor(clLtGray, false);
+ P.DrawEllipse(lPt2.X-0.5, lPt2.Y, 1, 1, 1, True, True);
+ P.SetPenStyle(ppsDot);
+ P.DrawLine(lPt1, lPt2, 1);
+
+ p.SetPenStyle(ppsSolid);
+ P.SetFont(FtTitle,8);
+ P.SetColor(clBlack, false);
+ P.WriteText(lPt1.X+1, lPt1.Y, '(current point)');
+ p.WriteText(lPt2.X+1, lPt2.Y, '(x1, y1)');
+ p.WriteText(lPt4.X+1, lPt4.Y, '(xTo, yTo)');
+
+ P.SetFont(FtTitle, 10);
+ P.WriteText(20, 50, 'CubicCurveToY(...)');
end;
procedure TPDFTestApp.SampleMatrixTransform(D: TPDFDocument; APage: integer);
@@ -412,7 +653,7 @@ var
begin
P:=D.Pages[APage];
// create the fonts to be used (use one of the 14 Adobe PDF standard fonts)
- FtTitle := D.AddFont('Helvetica', clBlack);
+ FtTitle := D.AddFont('Helvetica');
{ Page title }
P.SetFont(FtTitle,23);
@@ -448,7 +689,7 @@ begin
P.Orientation := ppoLandscape;
// create the fonts to be used (use one of the 14 Adobe PDF standard fonts)
- FtTitle := D.AddFont('Helvetica', clBlack);
+ FtTitle := D.AddFont('Helvetica');
{ Page title }
P.SetFont(FtTitle,23);
@@ -464,15 +705,59 @@ begin
P.WriteText(145, 95, Format('%d x %d (mm)', [PixelsToMM(P.Paper.W), PixelsToMM(P.Paper.H)]));
end;
+procedure TPDFTestApp.TextInABox(const APage: TPDFPage; const AX, AY: TPDFFloat; const APointSize: integer;
+ const ABoxColor: TARGBColor; const AFontName: string; const AText: UTF8String);
+var
+ lFontIdx: integer;
+ lFC: TFPFontCacheItem;
+ lHeight: single;
+ lDescenderHeight: single;
+ lTextHeightInMM: single;
+ lWidth: single;
+ lTextWidthInMM: single;
+ lDescenderHeightInMM: single;
+ i: integer;
+begin
+ for i := 0 to APage.Document.Fonts.Count-1 do
+ begin
+ if APage.Document.Fonts[i].Name = AFontName then
+ begin
+ lFontIdx := i;
+ break;
+ end;
+ end;
+ APage.SetFont(lFontIdx, APointSize);
+ APage.SetColor(clBlack, false);
+ APage.WriteText(AX, AY, AText);
+
+ lFC := gTTFontCache.Find(AFontName, False, False);
+ if not Assigned(lFC) then
+ raise Exception.Create(AFontName + ' font not found');
+
+ 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 mm as our PDFPage.UnitOfMeasure is set to mm. }
+ lTextWidthInMM := (lWidth * 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. }
+ APage.SetColor(ABoxColor, true);
+ APage.DrawRect(AX, AY+lDescenderHeightInMM, lTextWidthInMM,
+ lTextHeightInMM+lDescenderHeightInMM, 1, false, true);
+end;
+
{ TPDFTestApp }
procedure TPDFTestApp.DoRun;
Function BoolFlag(C : Char;ADefault : Boolean) : Boolean;
-
Var
V : Integer;
-
begin
Result:=ADefault;
if HasOption(C, '') then
@@ -486,12 +771,11 @@ procedure TPDFTestApp.DoRun;
var
ErrorMsg: String;
-
begin
StopOnException:=True;
inherited DoRun;
// quick check parameters
- ErrorMsg := CheckOptions('hp:f:t:i:j:', '');
+ ErrorMsg := CheckOptions('hp:f:t:i:j:ns', '');
if ErrorMsg <> '' then
begin
WriteLn('ERROR: ' + ErrorMsg);
@@ -508,48 +792,55 @@ begin
Exit;
end;
- Fpg := -1;
+ FPage := -1;
if HasOption('p', '') then
begin
- Fpg := StrToInt(GetOptionValue('p', ''));
- if (Fpg < 1) or (Fpg > 7) then
+ FPage := StrToInt(GetOptionValue('p', ''));
+ if (FPage < 1) or (FPage > cPageCount) then
begin
- Writeln('Error in -p parameter. Valid range is 1-7.');
+ Writeln(Format('Error in -p parameter. Valid range is 1-%d.', [cPageCount]));
Writeln('');
Terminate;
Exit;
end;
end;
+ FNoFontEmbedding := HasOption('n', '');
+ FSubsetFontEmbedding := HasOption('s', '');
FFontCompression := BoolFlag('f',true);
FTextCompression := BoolFlag('t',False);
FImageCompression := BoolFlag('i',False);
FRawJPEG:=BoolFlag('j',False);
+ gTTFontCache.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
+ gTTFontCache.BuildFontCache;
+
FDoc := SetupDocument;
try
FDoc.FontDirectory := 'fonts';
- if Fpg = -1 then
+ if FPage = -1 then
begin
SimpleText(FDoc, 0);
SimpleShapes(FDoc, 1);
- SimpleLines(FDoc, 2);
- SimpleLinesRaw(FDoc, 3);
- SimpleImage(FDoc, 4);
- SampleMatrixTransform(FDoc, 5);
- SampleLandscape(FDoc, 6);
+ AdvancedShapes(FDoc, 2);
+ SimpleLines(FDoc, 3);
+ SimpleLinesRaw(FDoc, 4);
+ SimpleImage(FDoc, 5);
+ SampleMatrixTransform(FDoc, 6);
+ SampleLandscape(FDoc, 7);
end
else
begin
- case Fpg of
+ case FPage of
1: SimpleText(FDoc, 0);
2: SimpleShapes(FDoc, 0);
- 3: SimpleLines(FDoc, 0);
- 4: SimpleLinesRaw(FDoc, 0);
- 5: SimpleImage(FDoc, 0);
- 6: SampleMatrixTransform(FDoc, 0);
- 7: SampleLandscape(FDoc, 0);
+ 3: AdvancedShapes(FDoc, 0);
+ 4: SimpleLines(FDoc, 0);
+ 5: SimpleLinesRaw(FDoc, 0);
+ 6: SimpleImage(FDoc, 0);
+ 7: SampleMatrixTransform(FDoc, 0);
+ 8: SampleLandscape(FDoc, 0);
end;
end;
@@ -566,11 +857,15 @@ procedure TPDFTestApp.WriteHelp;
begin
writeln('Usage:');
writeln(' -h Show this help.');
- writeln(' -p <n> Generate only one page. Valid range is 1-7.' + LineEnding +
- ' If this option is not specified, then all 7 pages are' + LineEnding +
- ' generated.');
+ writeln(Format(
+ ' -p <n> Generate only one page. Valid range is 1-%d.' + LineEnding +
+ ' 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.');
+ ' disables compression. A value of 1 enables compression.' + LineEnding +
+ ' If -n is specified, this option is ignored.');
writeln(' -t <0|1> Toggle text compression. A value of 0' + LineEnding +
' disables compression. A value of 1 enables compression.');
writeln(' -i <0|1> Toggle image compression. A value of 0' + LineEnding +
@@ -581,8 +876,8 @@ begin
end;
-
begin
+ Randomize;
Application := TPDFTestApp.Create(nil);
Application.Title := 'fpPDF Test Application';
Application.Run;
diff --git a/packages/fcl-pdf/fpmake.pp b/packages/fcl-pdf/fpmake.pp
index ecbe9ae9d5..ae41bdb2e7 100644
--- a/packages/fcl-pdf/fpmake.pp
+++ b/packages/fcl-pdf/fpmake.pp
@@ -28,17 +28,26 @@ 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.0.3';
T:=P.Targets.AddUnit('src/fpttfencodings.pp');
T:=P.Targets.AddUnit('src/fpparsettf.pp');
+ T:=P.Targets.AddUnit('src/fpfonttextmapping.pp');
With T do
Dependencies.AddUnit('fpttfencodings');
+ T:=P.Targets.AddUnit('src/fpttfsubsetter.pp');
+ With T do
+ begin
+ Dependencies.AddUnit('fpparsettf');
+ Dependencies.AddUnit('fpfonttextmapping');
+ end;
T:=P.Targets.AddUnit('src/fpttf.pp');
T:=P.Targets.AddUnit('src/fppdf.pp');
With T do
begin
Dependencies.AddUnit('fpparsettf');
+ Dependencies.AddUnit('fpttfsubsetter');
end;
// md5.ref
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/fpfonttextmapping.pp b/packages/fcl-pdf/src/fpfonttextmapping.pp
new file mode 100644
index 0000000000..facfe14c76
--- /dev/null
+++ b/packages/fcl-pdf/src/fpfonttextmapping.pp
@@ -0,0 +1,239 @@
+{
+ This file is part of the Free Component Library (FCL)
+ Copyright (c) 2016 by Graeme Geldenhuys
+
+ This unit defines classes that manage font glyph IDs and unicode
+ character codes.
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit FPFontTextMapping;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes,
+ SysUtils,
+ contnrs;
+
+type
+
+ TTextMapping = class(TObject)
+ private
+ FCharID: uint32;
+ FGlyphID: uint32;
+ FNewGlyphID: uint32;
+ FGlyphData: TStream;
+ FIsCompoundGlyph: boolean;
+ public
+ constructor Create;
+ class function NewTextMap(const ACharID, AGlyphID: uint32): TTextMapping;
+ property CharID: uint32 read FCharID write FCharID;
+ property GlyphID: uint32 read FGlyphID write FGlyphID;
+ property NewGlyphID: uint32 read FNewGlyphID write FNewGlyphID;
+ property GlyphData: TStream read FGlyphData write FGlyphData;
+ property IsCompoundGlyph: boolean read FIsCompoundGlyph write FIsCompoundGlyph;
+ end;
+
+
+ TTextMappingList = class(TObject)
+ private
+ FList: TFPObjectList;
+ function GetCount: Integer;
+ protected
+ function GetItem(AIndex: Integer): TTextMapping; virtual;
+ procedure SetItem(AIndex: Integer; AValue: TTextMapping); virtual;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ function Add(AObject: TTextMapping): Integer; overload;
+ function Add(const ACharID, AGlyphID: uint32): Integer; overload;
+ function Contains(const AGlyphID: uint32): boolean;
+ function ContainsCharID(const AID: uint32): boolean;
+ function GetNewGlyphID(const ACharID: uint32): uint32;
+ function GetMaxCharID: uint32;
+ function GetMaxGlyphID: uint32;
+ procedure Insert(const AIndex: integer; const ACharID, AGlyphID: uint32);
+ procedure Sort;
+ property Count: Integer read GetCount;
+ property Items[AIndex: Integer]: TTextMapping read GetItem write SetItem; default;
+ end;
+
+
+implementation
+
+{ TTextMapping }
+
+constructor TTextMapping.Create;
+begin
+ FGlyphData := nil;
+ FCharID := 0;
+ FGlyphID := 0;
+ FNewGlyphID := 0;
+ FIsCompoundGlyph := False;
+end;
+
+class function TTextMapping.NewTextMap(const ACharID, AGlyphID: uint32): TTextMapping;
+begin
+ Result := TTextMapping.Create;
+ Result.CharID := ACharID;
+ Result.GlyphID := AGlyphID;
+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(True);
+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: uint32): Integer;
+var
+ o: TTextMapping;
+begin
+ o := TTextMapping.Create;
+ o.CharID := ACharID;
+ o.GlyphID := AGlyphID;
+ Result := Add(o);
+ if Result = -1 then
+ o.Free;
+end;
+
+function TTextMappingList.Contains(const AGlyphID: uint32): boolean;
+var
+ i: integer;
+begin
+ Result := False;
+ for i := 0 to Count-1 do
+ begin
+ if Items[i].GlyphID = AGlyphID then
+ begin
+ Result := True;
+ Exit;
+ end;
+ end;
+end;
+
+function TTextMappingList.ContainsCharID(const AID: uint32): boolean;
+var
+ i: integer;
+begin
+ Result := False;
+ for i := 0 to Count-1 do
+ begin
+ if Items[i].CharID = AID then
+ begin
+ Result := True;
+ Exit;
+ end;
+ end;
+end;
+
+function TTextMappingList.GetNewGlyphID(const ACharID: uint32): uint32;
+var
+ i: integer;
+begin
+ for i := 0 to Count-1 do
+ begin
+ if Items[i].CharID = ACharID then
+ begin
+ Result := Items[i].NewGlyphID;
+ Exit;
+ end;
+ end;
+end;
+
+function TTextMappingList.GetMaxCharID: uint32;
+begin
+ Sort;
+ Result := Items[Count-1].CharID;
+end;
+
+function TTextMappingList.GetMaxGlyphID: uint32;
+var
+ gid: uint32;
+ i: integer;
+begin
+ gid := 0;
+ for i := 0 to Count-1 do
+ begin
+ if Items[i].GlyphID > gid then
+ gid := Items[i].GlyphID;
+ end;
+ result := gid;
+end;
+
+procedure TTextMappingList.Insert(const AIndex: integer; const ACharID, AGlyphID: uint32);
+var
+ o: TTextMapping;
+begin
+ o := TTextMapping.Create;
+ o.CharID := ACharID;
+ o.GlyphID := AGlyphID;
+ FList.Insert(AIndex, o);
+end;
+
+function CompareByCharID(A, B: TTextMapping): Integer; inline;
+begin
+ if A.CharID < B.CharID then
+ Result := -1
+ else if A.CharID > B.CharID then
+ Result := 1
+ else
+ Result := 0;
+end;
+
+function CompareByCharIDPtr(A, B: Pointer): Integer;
+begin
+ Result := CompareByCharID(TTextMapping(A), TTextMapping(B));
+end;
+
+procedure TTextMappingList.Sort;
+begin
+ FList.Sort(@CompareByCharIDPtr);
+end;
+
+end.
diff --git a/packages/fcl-pdf/src/fpparsettf.pp b/packages/fcl-pdf/src/fpparsettf.pp
index a4b7e91b42..9680a6337a 100644
--- a/packages/fcl-pdf/src/fpparsettf.pp
+++ b/packages/fcl-pdf/src/fpparsettf.pp
@@ -23,190 +23,201 @@ 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);
+ 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;
TFixedVersionRec = packed record
case Integer of
- 0: (Minor, Major: Word);
- 1: (Version: Cardinal);
+ 0: (Minor, Major: UInt16);
+ 1: (Version: UInt32);
end;
+ { The file header record that starts at byte 0 of a TTF file }
TTableDirectory = Packed Record
- FontVersion : TFixedVersionRec;
- Numtables : Word;
- SearchRange : Word;
- EntrySelector : Word;
- RangeShift : Word;
+ FontVersion : TFixedVersionRec; { UInt32}
+ Numtables : UInt16;
+ SearchRange : UInt16;
+ EntrySelector : UInt16;
+ RangeShift : UInt16;
end;
TTableDirectoryEntry = Packed Record
- Tag: Array[1..4] of char;
- checkSum : Cardinal;
- offset : Cardinal;
- Length : Cardinal;
+ Tag: Array[1..4] of AnsiChar;
+ checkSum : UInt32;
+ offset : UInt32;
+ Length : UInt32;
end;
TTableDirectoryEntries = Array of TTableDirectoryEntry;
TLongHorMetric = Packed record
- AdvanceWidth : Word;
- LSB: Smallint; { leftSideBearing }
+ AdvanceWidth : UInt16;
+ LSB: Int16; { leftSideBearing }
end;
- TLongHorMetrics = Packed Array of TLongHorMetric;
+ TLongHorMetricArray = Packed Array of TLongHorMetric;
Type
TPostScript = Packed Record
- Format : TFixedVersionRec;
- ItalicAngle : LongWord;
- UnderlinePosition : SmallInt;
- underlineThickness : SmallInt;
- isFixedPitch : Cardinal;
- minMemType42 : Cardinal;
- maxMemType42 : Cardinal;
- minMemType1 : Cardinal;
- maxMemType1 : Cardinal;
+ Format : TFixedVersionRec; { UInt32 }
+ ItalicAngle : TF16Dot16; { Int32 }
+ UnderlinePosition : Int16;
+ underlineThickness : Int16;
+ isFixedPitch : UInt32;
+ minMemType42 : UInt32;
+ maxMemType42 : UInt32;
+ minMemType1 : UInt32;
+ maxMemType1 : UInt32;
end;
TMaxP = Packed Record
- VersionNumber : TFixedVersionRec;
- numGlyphs : Word;
- maxPoints : Word;
- maxContours : Word;
- maxCompositePoints : word;
- maxCompositeContours : word;
- maxZones : Word;
- maxTwilightPoints : word;
- maxStorage : Word;
- maxFunctionDefs : Word;
- maxInstructionDefs : Word;
- maxStackElements : Word;
- maxSizeOfInstructions : word;
- maxComponentElements : Word;
- maxComponentDepth : Word;
+ VersionNumber : TFixedVersionRec; { UInt32 }
+ numGlyphs : UInt16;
+ maxPoints : UInt16;
+ maxContours : UInt16;
+ maxCompositePoints : UInt16;
+ maxCompositeContours : UInt16;
+ maxZones : UInt16;
+ maxTwilightPoints : UInt16;
+ maxStorage : UInt16;
+ maxFunctionDefs : UInt16;
+ maxInstructionDefs : UInt16;
+ maxStackElements : UInt16;
+ maxSizeOfInstructions : UInt16;
+ maxComponentElements : UInt16;
+ maxComponentDepth : UInt16;
end;
TOS2Data = Packed Record
- version : Word;
- xAvgCharWidth : SmallInt;
- usWeightClass : Word;
- usWidthClass : Word;
- fsType : SmallInt;
- ySubscriptXSize : SmallInt;
- ySubscriptYSize : SmallInt;
- ySubscriptXOffset : SmallInt;
- ySubscriptYOffset : Smallint;
- ySuperscriptXSize : Smallint;
- ySuperscriptYSize : Smallint;
- ySuperscriptXOffset : Smallint;
- ySuperscriptYOffset : Smallint;
- yStrikeoutSize : SmallInt;
- yStrikeoutPosition : Smallint;
- sFamilyClass : SmallInt; // we could split this into a record of Class & SubClass values.
+ version : UInt16;
+ xAvgCharWidth : Int16;
+ usWeightClass : UInt16;
+ usWidthClass : UInt16;
+ fsType : Int16;
+ ySubscriptXSize : Int16;
+ ySubscriptYSize : Int16;
+ ySubscriptXOffset : Int16;
+ ySubscriptYOffset : Int16;
+ ySuperscriptXSize : Int16;
+ ySuperscriptYSize : Int16;
+ ySuperscriptXOffset : Int16;
+ ySuperscriptYOffset : Int16;
+ yStrikeoutSize : Int16;
+ yStrikeoutPosition : Int16;
+ sFamilyClass : Int16; // we could split this into a record of Class & SubClass values.
panose : Array[0..9] of byte;
- ulUnicodeRange1 : Cardinal;
- ulUnicodeRange2 : Cardinal;
- ulUnicodeRange3 : Cardinal;
- ulUnicodeRange4 : Cardinal;
- achVendID : Array[0..3] of char;
- fsSelection : word;
- usFirstCharIndex : Word;
- usLastCharIndex : Word;
- sTypoAscender: Smallint;
- sTypoDescender : Smallint;
- sTypoLineGap : Smallint;
- usWinAscent : Word;
- usWinDescent : Word;
- ulCodePageRange1 : Cardinal;
- ulCodePageRange2 : Cardinal;
- sxHeight : smallint;
- sCapHeight : smallint;
- usDefaultChar : word;
- usBreakChar : word;
- usMaxContext : word;
+ ulUnicodeRange1 : UInt32;
+ ulUnicodeRange2 : UInt32;
+ ulUnicodeRange3 : UInt32;
+ ulUnicodeRange4 : UInt32;
+ achVendID : Array[0..3] of AnsiChar;
+ fsSelection : UInt16;
+ usFirstCharIndex : UInt16;
+ usLastCharIndex : UInt16;
+ sTypoAscender: Int16;
+ sTypoDescender : Int16;
+ sTypoLineGap : Int16;
+ usWinAscent : UInt16;
+ usWinDescent : UInt16;
+ ulCodePageRange1 : UInt32;
+ ulCodePageRange2 : UInt32;
+ sxHeight : Int16;
+ sCapHeight : Int16;
+ usDefaultChar : UInt16;
+ usBreakChar : UInt16;
+ usMaxContext : UInt16;
end;
{ Nicely described at [https://www.microsoft.com/typography/otspec/head.htm] }
THead = Packed record
- FileVersion : TFixedVersionRec;
- FontRevision : TFixedVersionRec;
- CheckSumAdjustment : Cardinal;
- MagicNumber : Cardinal;
- Flags : Word;
- UnitsPerEm: word;
+ FileVersion : TFixedVersionRec; { UInt32 }
+ FontRevision : TFixedVersionRec; { UInt32 }
+ CheckSumAdjustment : UInt32;
+ MagicNumber : UInt32;
+ Flags : UInt16;
+ UnitsPerEm: UInt16;
Created : Int64;
Modified : Int64;
- BBox: Packed array[0..3] of Smallint;
- MacStyle : word;
- LowestRecPPEM : word;
- FontDirectionHint : smallint;
- IndexToLocFormat : Smallint;
- glyphDataFormat : Smallint;
+ BBox: Packed array[0..3] of Int16;
+ MacStyle : UInt16;
+ LowestRecPPEM : UInt16;
+ FontDirectionHint : Int16;
+ IndexToLocFormat : Int16;
+ glyphDataFormat : Int16;
end;
{ structure described at [https://www.microsoft.com/typography/otspec/hhea.htm] }
THHead = packed record
- TableVersion : TFixedVersionRec;
- Ascender : Smallint;
- Descender : Smallint;
- LineGap : Smallint;
- AdvanceWidthMax : Word;
- MinLeftSideBearing : Smallint;
- MinRightSideBearing : Smallint;
- XMaxExtent : Smallint;
- CaretSlopeRise : Smallint;
- CaretSlopeRun : Smallint;
- Reserved : Array[0..4] of Smallint;
- metricDataFormat : Smallint;
- numberOfHMetrics : Word;
+ TableVersion : TFixedVersionRec; { UInt32 }
+ Ascender : Int16;
+ Descender : Int16;
+ LineGap : Int16;
+ AdvanceWidthMax : UInt16;
+ MinLeftSideBearing : Int16;
+ MinRightSideBearing : Int16;
+ XMaxExtent : Int16;
+ CaretSlopeRise : Int16;
+ CaretSlopeRun : Int16;
+ caretOffset: Int16; // reserved field
+ Reserved : Array[0..3] of Int16;
+ metricDataFormat : Int16;
+ numberOfHMetrics : UInt16;
end;
{ Character to glyph mapping
Structure described at [https://www.microsoft.com/typography/otspec/cmap.htm] }
TCmapHeader = packed record
- Version: word;
- SubTableCount: word;
+ Version: UInt16;
+ SubTableCount: UInt16;
end;
TCmapSubTableEntry = packed record
- PlatformID: word;
- EncodingID: word;
- Offset: Cardinal;
+ PlatformID: UInt16;
+ EncodingID: UInt16;
+ Offset: UInt32;
end;
TCmapSubTables = Array of TCmapSubTableEntry;
TCmapFmt4 = packed record
- Format: word;
- Length: word;
- LanguageID: word;
- SegmentCount2: word;
- SearchRange: word;
- EntrySelector: word;
- RangeShift: word;
+ Format: UInt16;
+ Length: UInt16;
+ LanguageID: UInt16;
+ SegmentCount2: UInt16;
+ SearchRange: UInt16;
+ EntrySelector: UInt16;
+ RangeShift: UInt16;
end;
TUnicodeMapSegment = Packed Record
- StartCode : Word;
- EndCode : Word;
- IDDelta : Smallint;
- IDRangeOffset : Word;
+ StartCode : UInt16;
+ EndCode : UInt16;
+ IDDelta : Int16;
+ IDRangeOffset : UInt16;
end;
TUnicodeMapSegmentArray = Array of TUnicodeMapSegment;
TNameRecord = Packed Record
- PlatformID : Word;
- EncodingID : Word;
- LanguageID : Word;
- NameID : Word;
- StringLength : Word;
- StringOffset : Word;
+ PlatformID : UInt16;
+ EncodingID : UInt16;
+ LanguageID : UInt16;
+ NameID : UInt16;
+ StringLength : UInt16;
+ StringOffset : UInt16;
end;
TNameEntry = Packed Record
@@ -216,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;
@@ -230,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;
@@ -240,10 +264,9 @@ Type
function GetMissingWidth: integer;
Protected
// Stream reading functions.
- Function IsNativeData : Boolean; virtual;
- function ReadShort(AStream: TStream): Smallint; inline;
- function ReadULong(AStream: TStream): Longword; inline;
- function ReadUShort(AStream: TStream): Word; inline;
+ function ReadInt16(AStream: TStream): Int16; inline;
+ function ReadUInt32(AStream: TStream): UInt32; inline;
+ function ReadUInt16(AStream: TStream): UInt16; inline;
// Parse the various well-known tables
procedure ParseHead(AStream : TStream); virtual;
procedure ParseHhea(AStream : TStream); virtual;
@@ -269,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;
@@ -288,7 +312,7 @@ Type
Function CapHeight: SmallInt;
{ Returns the glyph advance width, based on the AIndex (glyph index) value. The result is in font units. }
function GetAdvanceWidth(AIndex: word): word;
- function ItalicAngle: LongWord;
+ function ItalicAngle: single;
{ max glyph bounding box values - as space separated values }
function BBox: string;
property MissingWidth: Integer read GetMissingWidth;
@@ -304,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;
@@ -328,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
@@ -356,6 +381,7 @@ implementation
resourcestring
rsFontEmbeddingNotAllowed = 'Font licence does not allow embedding';
+ rsErrUnexpectedUnicodeSubtable = 'Unexpected unicode subtable format, expected 4, got %s';
Function GetTableType(Const AName : String) : TTTFTableType;
begin
@@ -385,25 +411,23 @@ begin
FillChar(Dest^, Size, Data);
end;
-function TTFFileInfo.ReadULong(AStream: TStream): Longword;inline;
+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.ReadUShort(AStream: TStream): Word;inline;
+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.ReadShort(AStream: TStream): Smallint;inline;
+function TTFFileInfo.ReadInt16(AStream: TStream): Int16;
begin
- Result:=SmallInt(ReadUShort(AStream));
+ Result:=Int16(ReadUInt16(AStream));
end;
procedure TTFFileInfo.ParseHead(AStream : TStream);
@@ -411,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);
@@ -433,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);
@@ -477,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;
@@ -506,55 +519,57 @@ var
Segm : TUnicodeMapSegment;
GlyphIDArray : Array of word;
S : TStream;
-
begin
TableStartPos:=AStream.Position;
- FCMapH.Version:=ReadUShort(AStream);
- FCMapH.SubtableCount:=ReadUShort(AStream);
+ FCMapH.Version:=ReadUInt16(AStream);
+ FCMapH.SubtableCount:=ReadUInt16(AStream);
SetLength(FSubtables,CMapH.SubtableCount);
for I:= 0 to FCMapH.SubtableCount-1 do
begin
- FSubtables[i].PlatformID:=ReadUShort(AStream);
- FSubtables[i].EncodingID:=ReadUShort(AStream);
- FSubtables[i].Offset:=ReadULong(AStream); // 4 bytes - Offset of subtable
+ FSubtables[i].PlatformID:=ReadUInt16(AStream);
+ FSubtables[i].EncodingID:=ReadUInt16(AStream);
+ FSubtables[i].Offset:=ReadUInt32(AStream); // 4 bytes - Offset of subtable
end;
UE:=FCMapH.SubtableCount-1;
+ if UE=0 then
+ // No CMap subtable entries, this is not an error, just exit.
+ exit;
While (UE>=0) and ((FSubtables[UE].PlatformID<>3) or (FSubtables[UE].EncodingID<> 1)) do
Dec(UE);
if (UE=-1) then
- Raise ETTF.Create('No Format 4 map (unicode) table found <'+FFileName + ' - ' + PostScriptName+'>');
+ exit;
TT:=TableStartPos+FSubtables[UE].Offset;
AStream.Position:=TT;
- FUnicodeMap.Format:= ReadUShort(AStream); // 2 bytes - Format of subtable
+ FUnicodeMap.Format:= ReadUInt16(AStream); // 2 bytes - Format of subtable
if (FUnicodeMap.Format<>4) then
- Raise ETTF.CreateFmt('Unexpected unicode subtable format, expected 4, got %s',[FUnicodeMap.Format]);
- FUnicodeMap.Length:=ReadUShort(AStream);
+ Raise ETTF.CreateFmt(rsErrUnexpectedUnicodeSubtable, [FUnicodeMap.Format]);
+ FUnicodeMap.Length:=ReadUInt16(AStream);
S:=TMemoryStream.Create;
try
// Speed up the process, read everything in a single mem block.
S.CopyFrom(AStream,Int64(FUnicodeMap.Length)-4);
S.Position:=0;
- FUnicodeMap.LanguageID:=ReadUShort(S);
- FUnicodeMap.SegmentCount2:=ReadUShort(S); // 2 bytes - Segments count
- FUnicodeMap.SearchRange:=ReadUShort(S);
- FUnicodeMap.EntrySelector:=ReadUShort(S);
- FUnicodeMap.RangeShift:=ReadUShort(S);
+ FUnicodeMap.LanguageID:=ReadUInt16(S);
+ FUnicodeMap.SegmentCount2:=ReadUInt16(S); // 2 bytes - Segments count
+ FUnicodeMap.SearchRange:=ReadUInt16(S);
+ FUnicodeMap.EntrySelector:=ReadUInt16(S);
+ FUnicodeMap.RangeShift:=ReadUInt16(S);
SegCount:=FUnicodeMap.SegmentCount2 div 2;
SetLength(FUnicodeMapSegments,SegCount);
for i:=0 to SegCount-1 do
- FUnicodeMapSegments[i].EndCode:=ReadUShort(S);
- ReadUShort(S);
+ FUnicodeMapSegments[i].EndCode:=ReadUInt16(S);
+ ReadUInt16(S);
for i:=0 to SegCount-1 do
- FUnicodeMapSegments[i].StartCode:=ReadUShort(S);
+ FUnicodeMapSegments[i].StartCode:=ReadUInt16(S);
for i:=0 to SegCount-1 do
- FUnicodeMapSegments[i].IDDelta:=ReadShort(S);
+ FUnicodeMapSegments[i].IDDelta:=ReadInt16(S);
for i:=0 to SegCount-1 do
- FUnicodeMapSegments[i].IDRangeOffset:=ReadUShort(S);
+ FUnicodeMapSegments[i].IDRangeOffset:=ReadUInt16(S);
UE:=S.Position;
UE:=(S.Size-UE) div 2;
SetLength(GlyphIDArray,UE);
For J:=0 to UE-1 do
- GlyphIDArray[J]:=ReadUShort(S);
+ GlyphIDArray[J]:=ReadUInt16(S);
J:=0;
for i:=0 to SegCount-1 do
With FUnicodeMapSegments[i] do
@@ -601,9 +616,9 @@ var
begin
TableStartPos:= AStream.Position; // memorize Table start position
- ReadUShort(AStream); // skip 2 bytes - Format
- Count:=ReadUShort(AStream); // 2 bytes
- StringOffset:=ReadUShort(AStream); // 2 bytes
+ ReadUInt16(AStream); // skip 2 bytes - Format
+ Count:=ReadUInt16(AStream); // 2 bytes
+ StringOffset:=ReadUInt16(AStream); // 2 bytes
E := FNameEntries;
SetLength(E,Count);
FillMem(@N, SizeOf(TNameRecord), 0);
@@ -663,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
- ulCodePageRange1:=ReadULong(AStream);
- ulCodePageRange2:=ReadULong(AStream);
- end;
+ begin
+ ulCodePageRange1:=ReadUInt32(AStream);
+ ulCodePageRange2:=ReadUInt32(AStream);
+ end;
if Version>=2 then
- begin
- sxHeight:=ReadShort(AStream);
- sCapHeight:=ReadShort(AStream);
- usDefaultChar:=ReadUShort(AStream);
- usBreakChar:=ReadUShort(AStream);
- usMaxContext:=ReadUShort(AStream);
- end;
+ begin
+ sxHeight:=ReadInt16(AStream);
+ sCapHeight:=ReadInt16(AStream);
+ usDefaultChar:=ReadUInt16(AStream);
+ usBreakChar:=ReadUInt16(AStream);
+ usMaxContext:=ReadUInt16(AStream);
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
@@ -756,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);
@@ -792,8 +802,8 @@ begin
ttos2 : ParseOS2(AStream);
ttPost: ParsePost(AStream);
end;
- end;
end;
+ end;
end;
procedure TTFFileInfo.PrepareFontDefinition(const Encoding: string; Embed: Boolean);
@@ -806,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);
@@ -835,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;
@@ -893,14 +903,31 @@ 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;
end;
-function TTFFileInfo.ItalicAngle: LongWord;
+function TTFFileInfo.ItalicAngle: single;
begin
- Result := FPostScript.ItalicAngle;
+ Result := FPostScript.ItalicAngle / 65536.0;
end;
function TTFFileInfo.BBox: string;
@@ -936,16 +963,11 @@ function TTFFileInfo.GetMissingWidth: integer;
begin
if FMissingWidth = 0 then
begin
- FMissingWidth := Widths[Chars[CharCodes^[32]]].AdvanceWidth; // Char(32) - Space character
+ FMissingWidth := Widths[Chars[CharCodes^[32]]].AdvanceWidth; // 32 is in reference to the Space character
end;
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 efede1ccc2..acfcd1170d 100644
--- a/packages/fcl-pdf/src/fppdf.pp
+++ b/packages/fcl-pdf/src/fppdf.pp
@@ -13,6 +13,12 @@
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ LOCALISATION NOTICE:
+ Most of the string constants in this unit should NOT be localised,
+ as they are specific constants used in the PDF Specification document.
+ If you do localise anything, make sure you know what you are doing.
+
**********************************************************************}
unit fpPDF;
@@ -28,15 +34,32 @@ uses
SysUtils,
StrUtils,
contnrs,
- fpImage, FPReadJPEG,
+ fpImage,
+ FPReadJPEG, FPReadPNG, FPReadBMP, // these are required for auto image-handler functionality
zstream,
- fpparsettf;
+ fpparsettf,
+ fpTTFSubsetter,
+ FPFontTextMapping;
Const
- clBlack = $000000;
- clBlue = $0000FF;
- clGreen = $00FF00;
- clRed = $FF0000;
+ { Some popular predefined colors. Channel format is: RRGGBB }
+ clBlack = $000000;
+ clWhite = $FFFFFF;
+ clBlue = $0000FF;
+ clGreen = $008000;
+ clRed = $FF0000;
+ clAqua = $00FFFF;
+ clMagenta = $FF00FF;
+ clYellow = $FFFF00;
+ clLtGray = $C0C0C0;
+ clMaroon = $800000;
+ clOlive = $808000;
+ clDkGray = $808080;
+ clTeal = $008080;
+ clNavy = $000080;
+ clPurple = $800080;
+ clLime = $00FF00;
+ clWaterMark = $F0F0F0;
type
TPDFPaperType = (ptCustom, ptA4, ptA5, ptLetter, ptLegal, ptExecutive, ptComm10, ptMonarch, ptDL, ptC5, ptB5);
@@ -45,11 +68,17 @@ type
TPDFPageLayout = (lSingle, lTwo, lContinuous);
TPDFUnitOfMeasure = (uomInches, uomMillimeters, uomCentimeters, uomPixels);
- TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG);
+ TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts, poPageOriginAtTop, poSubsetFont);
TPDFOptions = set of TPDFOption;
EPDF = Class(Exception);
- TPDFDocument = Class;
+
+ // forward declarations
+ TPDFDocument = class;
+ TPDFAnnotList = class;
+ TPDFLineStyleDef = class;
+ TPDFPage = class;
+
TARGBColor = Cardinal;
TPDFFloat = Single;
@@ -97,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
@@ -118,7 +150,7 @@ type
end;
- TPDFBoolean = class(TPDFObject)
+ TPDFBoolean = class(TPDFDocumentObject)
private
FValue: Boolean;
protected
@@ -128,7 +160,7 @@ type
end;
- TPDFMoveTo = class(TPDFObject)
+ TPDFMoveTo = class(TPDFDocumentObject)
private
FPos : TPDFCoord;
protected
@@ -141,7 +173,47 @@ type
end;
- TPDFInteger = class(TPDFObject)
+ TPDFResetPath = class(TPDFDocumentObject)
+ protected
+ procedure Write(const AStream: TStream); override;
+ public
+ class function Command: string;
+ end;
+
+
+ TPDFClosePath = class(TPDFDocumentObject)
+ protected
+ procedure Write(const AStream: TStream); override;
+ public
+ class function Command: string;
+ end;
+
+
+ TPDFStrokePath = class(TPDFDocumentObject)
+ protected
+ procedure Write(const AStream: TStream); override;
+ public
+ class function Command: string;
+ end;
+
+
+ TPDFPushGraphicsStack = class(TPDFDocumentObject)
+ protected
+ procedure Write(const AStream: TStream); override;
+ public
+ class function Command: string;
+ end;
+
+
+ TPDFPopGraphicsStack = class(TPDFDocumentObject)
+ protected
+ procedure Write(const AStream: TStream); override;
+ public
+ class function Command: string;
+ end;
+
+
+ TPDFInteger = class(TPDFDocumentObject)
private
FInt: integer;
protected
@@ -153,7 +225,7 @@ type
end;
- TPDFReference = class(TPDFObject)
+ TPDFReference = class(TPDFDocumentObject)
private
FValue: integer;
protected
@@ -164,7 +236,7 @@ type
end;
- TPDFName = class(TPDFObject)
+ TPDFName = class(TPDFDocumentObject)
private
FName : string;
FMustEscape: boolean;
@@ -190,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;
@@ -207,6 +280,20 @@ 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
+ class is similar to TPDFString, except it doesn't wrap the string content with
+ '(' and ')' symbols and doesn't escape the content. }
+ TPDFFreeFormString = class(TPDFAbstractString)
+ private
+ FValue: string;
+ protected
+ procedure Write(const AStream: TStream); override;
+ public
+ constructor Create(Const ADocument: TPDFDocument; const AValue: string); overload;
+ property Value: string read FValue;
end;
@@ -218,13 +305,14 @@ type
procedure AddItem(const AValue: TPDFObject);
// Add integers in S as TPDFInteger elements to the array
Procedure AddIntArray(S : String);
+ procedure AddFreeFormArrayValues(S: string);
public
constructor Create(Const ADocument : TPDFDocument); override;
destructor Destroy; override;
end;
- TPDFStream = class(TPDFObject)
+ TPDFStream = class(TPDFDocumentObject)
private
FItems: TFPObjectList;
protected
@@ -236,64 +324,83 @@ type
end;
- TPDFEmbeddedFont = class(TPDFObject)
+ TPDFEmbeddedFont = class(TPDFDocumentObject)
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(TPDFObject)
+ 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;
+ 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); 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;
+ 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(TPDFObject)
+ TPDFUTF8Text = class(TPDFBaseText)
private
- FX: TPDFFloat;
- FY: TPDFFloat;
FString: TPDFUTF8String;
- FFontIndex: integer;
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); 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;
+ 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;
TPDFLineSegment = class(TPDFDocumentObject)
private
FWidth: TPDFFloat;
+ FStroke: boolean;
P1, p2: TPDFCoord;
protected
procedure Write(const AStream: TStream); override;
public
- Class Function Command(APos : TPDFCoord) : String;
- Class Function Command(APos1,APos2 : TPDFCoord) : String;
- constructor Create(Const ADocument : TPDFDocument; const AWidth, X1,Y1, X2,Y2: TPDFFloat);overload;
+ Class Function Command(APos : TPDFCoord) : String; overload;
+ Class Function Command(x1, y1 : TPDFFloat) : String; overload;
+ Class Function Command(APos1, APos2 : TPDFCoord) : String; overload;
+ constructor Create(Const ADocument : TPDFDocument; const AWidth, X1,Y1, X2,Y2: TPDFFloat; const AStroke: Boolean = True); overload;
end;
@@ -311,18 +418,33 @@ type
end;
+ TPDFRoundedRectangle = class(TPDFDocumentObject)
+ private
+ FWidth: TPDFFloat;
+ FBottomLeft: TPDFCoord;
+ FDimensions: TPDFCoord;
+ FFill: Boolean;
+ FStroke: Boolean;
+ FRadius: TPDFFloat;
+ protected
+ procedure Write(const AStream: TStream); override;
+ public
+ constructor Create(const ADocument: TPDFDocument; const APosX, APosY, AWidth, AHeight, ARadius, ALineWidth: TPDFFloat; const AFill, AStroke: Boolean);overload;
+ end;
+
+
TPDFCurveC = class(TPDFDocumentObject)
private
- FP1,FP2,FP3: TPDFCoord;
+ FCtrl1, FCtrl2, FTo: TPDFCoord;
FWidth: TPDFFloat;
FStroke: Boolean;
protected
- Class Function Command(Const X1,Y1,X2,Y2,X3,Y3 : TPDFFloat) : String; overload;
- Class Function Command(Const AP1,AP2,AP3: TPDFCoord) : String; overload;
procedure Write(const AStream: TStream); override;
public
- constructor Create(Const ADocument : TPDFDocument; const X1,Y1,X2,Y2,X3,Y3,AWidth : TPDFFloat;AStroke: Boolean = True);overload;
- constructor Create(Const ADocument : TPDFDocument; const AP1,AP2,AP3 : TPDFCoord; AWidth: TPDFFloat; AStroke: Boolean = True);overload;
+ 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;
@@ -366,7 +488,7 @@ type
end;
- TPDFSurface = class(TPDFObject)
+ TPDFSurface = class(TPDFDocumentObject)
private
FPoints: TPDFCoordArray;
FFill : Boolean;
@@ -390,14 +512,15 @@ type
end;
- TPDFLineStyle = class(TPDFObject)
+ TPDFLineStyle = class(TPDFDocumentObject)
private
FStyle: TPDFPenStyle;
FPhase: integer;
+ FLineWidth: TPDFFloat;
protected
procedure Write(const AStream: TStream);override;
public
- constructor Create(Const ADocument : TPDFDocument; AStyle: TPDFPenStyle; APhase: integer); overload;
+ constructor Create(Const ADocument : TPDFDocument; AStyle: TPDFPenStyle; APhase: integer; ALineWidth: TPDFFloat); overload;
end;
@@ -407,14 +530,17 @@ 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;
- TPDFDictionaryItem = class(TPDFObject)
+ TPDFDictionaryItem = class(TPDFDocumentObject)
private
FKey: TPDFName;
FObj: TPDFObject;
@@ -457,7 +583,7 @@ type
end;
- TPDFXRef = class(TPDFObject)
+ TPDFXRef = class(TPDFDocumentObject)
private
FOffset: integer;
FDict: TPDFDictionary;
@@ -497,21 +623,24 @@ type
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;
+ function CreateAnnotList: TPDFAnnotList; virtual;
procedure SetOrientation(AValue: TPDFPaperOrientation);
procedure SetPaperType(AValue: TPDFPaperType);
procedure AddTextToLookupLists(AText: UTF8String);
procedure SetUnitOfMeasure(AValue: TPDFUnitOfMeasure);
- procedure AdjustMatrix;
protected
+ procedure AdjustMatrix; virtual;
procedure DoUnitConversion(var APoint: TPDFCoord); virtual;
- procedure CreateStdFontText(X, Y: TPDFFloat; AText: AnsiString; AFontIndex: integer); virtual;
- procedure CreateTTFFontText(X, Y: TPDFFloat; AText: UTF8String; AFontIndex: integer); 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;
@@ -520,47 +649,92 @@ type
Procedure SetFont(AFontIndex : Integer; AFontSize : Integer); virtual;
// used for stroking and nonstroking colors - purpose determined by the AStroke parameter
Procedure SetColor(AColor : TARGBColor; AStroke : Boolean = True); virtual;
- Procedure SetPenStyle(AStyle : TPDFPenStyle); virtual;
+ Procedure SetPenStyle(AStyle : TPDFPenStyle; const ALineWidth: TPDFFloat = 1.0); virtual;
+ // Set color and pen style from line style
+ 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); overload;
- Procedure WriteText(APos: TPDFCoord; AText : UTF8String); overload;
- procedure DrawLine(X1, Y1, X2, Y2, ALineWidth : TPDFFloat); overload;
- procedure DrawLine(APos1: TPDFCoord; APos2: TPDFCoord; ALineWidth: TPDFFloat); 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;
- Procedure DrawLineStyle(APos1: TPDFCoord; APos2: TPDFCoord; AStyle: Integer); overload;
+ Procedure DrawLineStyle(APos1, APos2: TPDFCoord; AStyle: Integer); overload;
+ { X, Y coordinates are the bottom-left coordinate of the rectangle. The W and H parameters are in the UnitOfMeasure units. }
+ Procedure DrawRect(const X, Y, W, H, ALineWidth: TPDFFloat; const AFill, AStroke : Boolean; const ADegrees: single = 0.0); overload;
+ Procedure DrawRect(const APos: TPDFCoord; const W, H, ALineWidth: TPDFFloat; const AFill, AStroke : Boolean; const ADegrees: single = 0.0); overload;
{ X, Y coordinates are the bottom-left coordinate of the rectangle. The W and H parameters are in the UnitOfMeasure units. }
- Procedure DrawRect(const X, Y, W, H, ALineWidth: TPDFFloat; const AFill, AStroke : Boolean); overload;
- Procedure DrawRect(const APos: TPDFCoord; const W, H, ALineWidth: TPDFFloat; const AFill, AStroke : Boolean); overload;
+ procedure DrawRoundedRect(const X, Y, W, H, ARadius, ALineWidth: TPDFFloat; const AFill, AStroke : Boolean; const ADegrees: single = 0.0);
{ X, Y coordinates are the bottom-left coordinate of the image. AWidth and AHeight are in image pixels. }
- Procedure DrawImageRawSize(const X, Y: TPDFFloat; const APixelWidth, APixelHeight, ANumber: integer); overload;
- Procedure DrawImageRawSize(const APos: TPDFCoord; const APixelWidth, APixelHeight, ANumber: integer); overload;
+ Procedure DrawImageRawSize(const X, Y: TPDFFloat; const APixelWidth, APixelHeight, ANumber: integer; const ADegrees: single = 0.0); overload;
+ Procedure DrawImageRawSize(const APos: TPDFCoord; const APixelWidth, APixelHeight, ANumber: integer; const ADegrees: single = 0.0); overload;
{ X, Y coordinates are the bottom-left coordinate of the image. AWidth and AHeight are in UnitOfMeasure units. }
- Procedure DrawImage(const X, Y: TPDFFloat; const AWidth, AHeight: TPDFFloat; const ANumber: integer); overload;
- Procedure DrawImage(const APos: TPDFCoord; const AWidth, AHeight: TPDFFloat; const ANumber: integer); overload;
+ Procedure DrawImage(const X, Y: TPDFFloat; const AWidth, AHeight: TPDFFloat; const ANumber: integer; const ADegrees: single = 0.0); overload;
+ Procedure DrawImage(const APos: TPDFCoord; const AWidth, AHeight: TPDFFloat; const ANumber: integer; const ADegrees: single = 0.0); overload;
{ X, Y coordinates are the bottom-left coordinate of the boundry rectangle.
The W and H parameters are in the UnitOfMeasure units. A negative AWidth will
cause the ellpise to draw to the left of the origin point. }
- Procedure DrawEllipse(const APosX, APosY, AWidth, AHeight, ALineWidth: TPDFFloat; const AFill: Boolean = True; AStroke: Boolean = True); overload;
- Procedure DrawEllipse(const APos: TPDFCoord; const AWidth, AHeight, ALineWidth: TPDFFloat; const AFill: Boolean = True; AStroke: Boolean = True); overload;
+ Procedure DrawEllipse(const APosX, APosY, AWidth, AHeight, ALineWidth: TPDFFloat; const AFill: Boolean = True; AStroke: Boolean = True; const ADegrees: single = 0.0); overload;
+ Procedure DrawEllipse(const APos: TPDFCoord; const AWidth, AHeight, ALineWidth: TPDFFloat; const AFill: Boolean = True; AStroke: Boolean = True; const ADegrees: single = 0.0); overload;
+ procedure DrawPolygon(const APoints: array of TPDFCoord; const ALineWidth: TPDFFloat);
+ procedure DrawPolyLine(const APoints: array of TPDFCoord; const ALineWidth: TPDFFloat);
+ { start a new subpath }
+ procedure ResetPath;
+ { Close the current subpath by appending a straight line segment from the current point to the starting point of the subpath. }
+ procedure ClosePath;
+ procedure ClosePathStroke;
+ { render the actual path }
+ procedure StrokePath;
+ { Fill using the nonzero winding number rule. }
+ procedure FillStrokePath;
+ { Fill using the Even-Odd rule. }
+ procedure FillEvenOddStrokePath;
+ { Move the current drawing position to (x, y) }
+ procedure MoveTo(x, y: TPDFFloat); overload;
+ procedure MoveTo(APos: TPDFCoord); overload;
+ { Append a cubic Bezier curve to the current path
+ - The curve extends from the current point to the point (xTo, yTo),
+ using (xCtrl1, yCtrl1) and (xCtrl2, yCtrl2) as the Bezier control points
+ - The new current point is (xTo, yTo) }
+ procedure CubicCurveTo(const xCtrl1, yCtrl1, xCtrl2, yCtrl2, xTo, yTo, ALineWidth: TPDFFloat; AStroke: Boolean = True); overload;
+ procedure CubicCurveTo(ACtrl1, ACtrl2, ATo: TPDFCoord; const ALineWidth: TPDFFloat; AStroke: Boolean = True); overload;
+ { Append a cubic Bezier curve to the current path
+ - The curve extends from the current point to the point (xTo, yTo),
+ using the current point and (xCtrl2, yCtrl2) as the Bezier control points
+ - The new current point is (xTo, yTo) }
+ procedure CubicCurveToV(xCtrl2, yCtrl2, xTo, yTo: TPDFFloat; const ALineWidth: TPDFFloat; AStroke: Boolean = True); overload;
+ procedure CubicCurveToV(ACtrl2, ATo: TPDFCoord; const ALineWidth: TPDFFloat; AStroke: Boolean = True); overload;
+ { Append a cubic Bezier curve to the current path
+ - The curve extends from the current point to the point (xTo, yTo),
+ using (xCtrl1, yCtrl1) and (xTo, yTo) as the Bezier control points
+ - The new current point is (xTo, yTo) }
+ procedure CubicCurveToY(xCtrl1, yCtrl1, xTo, yTo: TPDFFloat; const ALineWidth: TPDFFloat; AStroke: Boolean = True); overload;
+ procedure CubicCurveToY(ACtrl1, ATo: TPDFCoord; const ALineWidth: TPDFFloat; AStroke: Boolean = True); overload;
+ { Define a rectangle that becomes a clickable hotspot, referencing the URI argument. }
+ Procedure AddExternalLink(const APosX, APosY, AWidth, AHeight: TPDFFloat; const AURI: string; ABorder: boolean = false);
{ This returns the paper height, converted to whatever UnitOfMeasure is set too }
function GetPaperHeight: TPDFFloat;
Function HasImages : Boolean;
// Quick settings for Paper.
Property PaperType : TPDFPaperType Read FPaperType Write SetPaperType default ptA4;
Property Orientation : TPDFPaperOrientation Read FOrientation Write SetOrientation;
- // Set this if you want custom paper size.
+ // Set this if you want custom paper size. You must set this before setting PaperType = ptCustom.
Property Paper : TPDFPaper Read FPaper Write FPaper;
// Unit of Measure - how the PDF Page should convert the coordinates and dimensions
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;
end;
+ TPDFPageClass = class of TPDFPage;
+
+
TPDFSection = Class(TCollectionItem)
private
FTitle: String;
@@ -585,59 +759,29 @@ type
end;
- // forward declarations
- TTextMapping = class;
-
-
- TTextMappingList = class(TObject)
+ TPDFFont = class(TCollectionItem)
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)
- private
- FColor: TARGBColor;
FIsStdFont: boolean;
FName: String;
FFontFilename: String;
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;
procedure AddTextToMappingList(const AText: UnicodeString);
Property FontFile: string read FFontFilename write SetFontFilename;
Property Name: String Read FName Write FName;
- Property Color: TARGBColor Read FColor Write FColor;
property TextMapping: TTextMappingList read FTextMappingList;
property IsStdFont: boolean read FIsStdFont write FIsStdFont;
+ property SubsetFont: TStream read FSubsetFont;
end;
@@ -665,17 +809,52 @@ type
TPDFPages = Class(TPDFDocumentObject)
private
- FList : TFPObjectList;
- function GetP(AIndex : Integer): TPDFPage;
+ FList: TFPObjectList;
+ FPageClass: TPDFPageClass;
+ function GetP(AIndex: Integer): TPDFPage;
+ function GetPageCount: integer;
public
- Destructor Destroy; override;
- Function AddPage : TPDFPage;
- procedure Add(APage: TPDFPage);
- Property Pages[AIndex : Integer] : TPDFPage Read GetP; Default;
+ constructor Create(const ADocument: TPDFDocument); override; overload;
+ destructor Destroy; override;
+ function AddPage: TPDFPage;
+ procedure Add(APage: TPDFPage);
+ property Count: integer read GetPageCount;
+ property Pages[AIndex: Integer]: TPDFPage read GetP; default;
+ property PageClass: TPDFPageClass read FPageClass write FPageClass;
+ end;
+
+
+ TPDFAnnot = class(TPDFObject)
+ private
+ FLeft: TPDFFloat;
+ FBottom: TPDFFloat;
+ FWidth: TPDFFloat;
+ FHeight: TPDFFloat;
+ FURI: string;
+ FBorder: boolean;
+ public
+ constructor Create(const ADocument: TPDFDocument); override; overload;
+ constructor Create(const ADocument: TPDFDocument; const ALeft, ABottom, AWidth, AHeight: TPDFFloat; const AURI: String; const ABorder: Boolean = false); overload;
+ end;
+
+
+ TPDFAnnotList = class(TPDFDocumentObject)
+ private
+ FList: TFPObjectList;
+ procedure CheckList;
+ function GetAnnot(AIndex: integer): TPDFAnnot;
+ public
+ destructor Destroy; override;
+ function AddAnnot: TPDFAnnot;
+ function Count: integer;
+ procedure Add(AAnnot: TPDFAnnot);
+ property Annots[AIndex: integer]: TPDFAnnot read GetAnnot; default;
end;
+
TPDFImageCompression = (icNone, icDeflate, icJPEG);
+
TPDFImageItem = Class(TCollectionItem)
private
FImage: TFPCustomImage;
@@ -701,8 +880,6 @@ type
end;
- { TPDFImages }
-
TPDFImages = Class(TCollection)
Private
FOwner: TPDFDocument;
@@ -721,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;
@@ -737,6 +930,8 @@ type
FColor: TARGBColor;
FLineWidth: TPDFFloat;
FPenStyle: TPDFPenStyle;
+ Public
+ Procedure Assign(Source : TPersistent); override;
Published
Property LineWidth : TPDFFloat Read FLineWidth Write FLineWidth;
Property Color : TARGBColor Read FColor Write FColor Default clBlack;
@@ -753,15 +948,13 @@ type
end;
- { TPDFDocument }
-
TPDFDocument = class(TComponent)
private
FCatalogue: integer;
FCurrentColor: string;
FCurrentWidth: string;
FDefaultOrientation: TPDFPaperOrientation;
- FDefaultPaperType: TPDFPaperTYpe;
+ FDefaultPaperType: TPDFPaperType;
FFontDirectory: string;
FFontFiles: TStrings;
FFonts: TPDFFontDefs;
@@ -777,8 +970,12 @@ type
FTrailer: TPDFDictionary;
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);
@@ -802,7 +999,8 @@ type
procedure CreateTrailer;virtual;
procedure CreateFontEntries; virtual;
procedure CreateImageEntries; virtual;
- function CreateContentsEntry: integer;virtual;
+ procedure CreateAnnotEntries(const APageNum: integer; const APageDict: TPDFDictionary); virtual;
+ function CreateContentsEntry(const APageNum: integer): integer;virtual;
function CreateCatalogEntry: integer;virtual;
procedure CreateInfoEntry;virtual;
procedure CreatePreferencesEntry;virtual;
@@ -817,9 +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;
@@ -834,33 +1035,33 @@ type
Property CurrentWidth: string Read FCurrentWidth Write FCurrentWidth;
public
constructor Create(AOwner : TComponent); override;
- procedure StartDocument;
destructor Destroy; override;
- procedure SaveToStream(const AStream: TStream);
+ procedure StartDocument;
+ procedure Reset;
+ procedure SaveToStream(const AStream: TStream); virtual;
+ 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) : TPDFText; overload;
- Function CreateText(X,Y : TPDFFloat; AText : UTF8String; const AFontIndex: integer) : 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;
Function CreateBoolean(AValue : Boolean) : TPDFBoolean;
Function CreateInteger(AValue : Integer) : TPDFInteger;
Function CreateReference(AValue : Integer) : TPDFReference;
- Function CreateLineStyle(APenStyle: TPDFPenStyle) : TPDFLineStyle;
+ Function CreateLineStyle(APenStyle: TPDFPenStyle; const ALineWidth: TPDFFloat) : TPDFLineStyle;
Function CreateName(AValue : String; const AMustEscape: boolean = True) : TPDFName;
Function CreateStream(OwnsObjects : Boolean = True) : TPDFStream;
Function CreateDictionary : TPDFDictionary;
Function CreateXRef : TPDFXRef;
Function CreateArray : TPDFArray;
Function CreateImage(const ALeft, ABottom, AWidth, AHeight: TPDFFloat; ANumber: integer) : TPDFImage;
- Function AddFont(AName : String; AColor : TARGBColor = clBlack) : Integer; overload;
- Function AddFont(AFontFile: String; AName : String; AColor : TARGBColor = clBlack) : Integer; overload;
+ Function AddFont(AName : String) : Integer; overload;
+ Function AddFont(AFontFile: String; AName : String) : Integer; overload;
Function AddLineStyleDef(ALineWidth : TPDFFloat; AColor : TARGBColor = clBlack; APenStyle : TPDFPenStyle = ppsSolid) : Integer;
- Property Options : TPDFOptions Read FOptions Write FOPtions;
- property PageLayout: TPDFPageLayout read FPageLayout write FPageLayout default lSingle;
- Property Infos : TPDFInfos Read FInfos Write SetInfos;
Property Fonts : TPDFFontDefs Read FFonts Write SetFonts;
- Property LineStyles : TPDFLineStyleDefs Read FLineStyleDefs Write SetLineStyles;
Property Pages : TPDFPages Read FPages;
Property Images : TPDFImages Read FImages;
Property Catalogue: integer Read FCatalogue;
@@ -868,9 +1069,16 @@ type
Property FontFiles : TStrings Read FFontFiles Write SetFontFiles;
Property FontDirectory: string Read FFontDirectory Write FFontDirectory;
Property Sections : TPDFSectionList Read FSections;
+ Property ObjectCount : Integer Read FObjectCount;
+ Published
+ Property Options : TPDFOptions Read FOptions Write FOPtions;
+ Property LineStyles : TPDFLineStyleDefs Read FLineStyleDefs Write SetLineStyles;
+ property PageLayout: TPDFPageLayout read FPageLayout write FPageLayout default lSingle;
+ Property Infos : TPDFInfos Read FInfos Write SetInfos;
Property DefaultPaperType : TPDFPaperTYpe Read FDefaultPaperType Write FDefaultPaperType;
Property DefaultOrientation : TPDFPaperOrientation Read FDefaultOrientation Write FDefaultOrientation;
- Property ObjectCount : Integer Read FObjectCount;
+ property DefaultUnitOfMeasure: TPDFUnitOfMeasure read FUnitOfMeasure write FUnitOfMeasure default uomMillimeters;
+
end;
@@ -924,46 +1132,54 @@ procedure CompressString(const AFrom: string; var ATo: string);
procedure DecompressStream(AFrom: TStream; ATo: TStream);
function mmToPDF(mm: single): TPDFFloat;
+function PDFTomm(APixels : TPDFFloat) : Single;
function cmToPDF(cm: single): TPDFFloat;
+function PDFtoCM(APixels: TPDFFloat): single;
function InchesToPDF(Inches: single): TPDFFloat;
+function PDFtoInches(APixels: TPDFFloat): single;
function PDFCoord(x, y: TPDFFloat): TPDFCoord;
implementation
+uses
+ math,
+ fpttf;
+
-Resourcestring
+resourcestring
rsErrReportFontFileMissing = 'Font File "%s" does not exist.';
- SErrDictElementNotFound = 'Error: Dictionary element "%s" not found.';
- SerrInvalidSectionPage = 'Error: Invalid section page index.';
- SErrNoGlobalDict = 'Error: no global XRef named "%s".';
- SErrInvalidPageIndex = 'Invalid page index: %d';
- SErrNoFontIndex = 'No FontIndex was set - please use SetFont() first.';
+ rsErrDictElementNotFound = 'Error: Dictionary element "%s" not found.';
+ rsErrInvalidSectionPage = 'Error: Invalid section page index.';
+ rsErrNoGlobalDict = 'Error: no global XRef named "%s".';
+ rsErrInvalidPageIndex = 'Invalid page index: %d';
+ rsErrInvalidAnnotIndex = 'Invalid annot index: %d';
+ 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
- // TODO: we should improve this to take into account the line width
- cPenStyleBitmasks: array[TPDFPenStyle] of string = (
- '', // ppsSolid
- '5 3', // ppsDash (dash space ...)
- '1 3', // ppsDot (dot space ...)
- '5 3 1 3', // ppsDashDot (dash space dot space ...)
- '5 3 1 3 1 3' // 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
+ // see http://paste.lisp.org/display/1105
+ BEZIER: single = 0.5522847498; // = 4/3 * (sqrt(2) - 1);
+
function DateToPdfDate(const ADate: TDateTime): string;
begin
@@ -1076,7 +1292,7 @@ begin
Result := mm * (cDefaultDPI / cInchToMM);
end;
-function PDFtoMM(APixels: TPDFFloat): single;
+function PDFTomm(APixels: TPDFFloat): Single;
begin
Result := (APixels * cInchToMM) / cDefaultDPI;
end;
@@ -1107,14 +1323,6 @@ begin
Result := APixels / cDefaultDPI;
end;
-{ TPDFInfos }
-
-constructor TPDFInfos.Create;
-begin
- inherited Create;
- FProducer := 'fpGUI Toolkit 0.8';
-end;
-
{ TPDFMatrix }
function TPDFMatrix.Transform(APoint: TPDFCoord): TPDFCoord;
@@ -1155,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;
@@ -1239,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;
@@ -1250,6 +1427,7 @@ function TPDFFont.GetGlyphIndices(const AText: UnicodeString): AnsiString;
var
i: integer;
c: word;
+ n: integer;
begin
Result := '';
if Length(AText) = 0 then
@@ -1257,7 +1435,14 @@ begin
for i := 1 to Length(AText) do
begin
c := Word(AText[i]);
- Result := Result + IntToHex(FTrueTypeFile.GetGlyphIndex(c), 4);
+ for n := 0 to FTextMappingList.Count-1 do
+ begin
+ if FTextMappingList[n].CharID = c then
+ begin
+ result := Result + IntToHex(FTextMappingList[n].GlyphID, 4);
+ break;
+ end;
+ end;
end;
end;
@@ -1265,18 +1450,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;
@@ -1286,7 +1475,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);
@@ -1331,6 +1522,66 @@ begin
FPos:=APos;
end;
+{ TPDFResetPath }
+
+procedure TPDFResetPath.Write(const AStream: TStream);
+begin
+ WriteString(Command, AStream);
+end;
+
+class function TPDFResetPath.Command: string;
+begin
+ Result := 'n' + CRLF;
+end;
+
+{ TPDFClosePath }
+
+procedure TPDFClosePath.Write(const AStream: TStream);
+begin
+ WriteString(Command, AStream);
+end;
+
+class function TPDFClosePath.Command: string;
+begin
+ Result := 'h' + CRLF;
+end;
+
+{ TPDFStrokePath }
+
+procedure TPDFStrokePath.Write(const AStream: TStream);
+begin
+ WriteString(Command, AStream);
+end;
+
+class function TPDFStrokePath.Command: string;
+begin
+ Result := 'S' + CRLF;
+end;
+
+{ TPDFPushGraphicsStack }
+
+procedure TPDFPushGraphicsStack.Write(const AStream: TStream);
+begin
+ WriteString(Command, AStream);
+end;
+
+class function TPDFPushGraphicsStack.Command: string;
+begin
+ Result := 'q'+CRLF;
+end;
+
+{ TPDFPopGraphicsStack }
+
+procedure TPDFPopGraphicsStack.Write(const AStream: TStream);
+begin
+ WriteString(Command, AStream);
+end;
+
+class function TPDFPopGraphicsStack.Command: string;
+begin
+ Result := 'Q' + CRLF;
+end;
+
{ TPDFEllipse }
procedure TPDFEllipse.Write(const AStream: TStream);
@@ -1344,8 +1595,8 @@ begin
Y:=FCenter.Y;
W2:=FDimensions.X/2;
H2:=FDimensions.Y/2;
- WS:=W2*11/20;
- HS:=H2*11/20;
+ WS:=W2*BEZIER;
+ HS:=H2*BEZIER;
// Starting point
WriteString(TPDFMoveTo.Command(X,Y+H2),AStream);
WriteString(TPDFCurveC.Command(X, Y+H2-HS, X+W2-WS, Y, X+W2, Y),AStream);
@@ -1452,51 +1703,72 @@ end;
{ TPDFCurveC }
-class function TPDFCurveC.Command(const X1, Y1, X2, Y2, X3, Y3: TPDFFloat
- ): String;
+class function TPDFCurveC.Command(const xCtrl1, yCtrl1, xCtrl2, yCtrl2, xTo, yTo: TPDFFloat): String;
begin
- Result:=FloatStr(X1)+' '+FloatStr(Y1)+' '+
- FloatStr(X2)+' '+FloatStr(Y2)+' '+
- FloatStr(X3)+' '+FloatStr(Y3)+' c'+CRLF
+ Result:=FloatStr(xCtrl1)+' '+FloatStr(yCtrl1)+' '+
+ FloatStr(xCtrl2)+' '+FloatStr(yCtrl2)+' '+
+ FloatStr(xTo)+' '+FloatStr(yTo)+' c'+CRLF
end;
-class function TPDFCurveC.Command(const AP1, AP2, AP3: TPDFCoord): String;
+class function TPDFCurveC.Command(const ACtrl1, ACtrl2, ATo3: TPDFCoord): String;
begin
- Result:=Command(AP1.X,AP1.Y,AP2.X,AP2.Y,AP3.X,AP3.Y);
+ Result := Command(ACtrl1.X, ACtrl1.Y, ACtrl2.X, ACtrl2.Y, ATo3.X, ATo3.Y);
end;
procedure TPDFCurveC.Write(const AStream: TStream);
begin
if FStroke then
- SetWidth(FWidth,AStream);
- WriteString(Command(FP1,FP2,FP3),AStream);
+ SetWidth(FWidth, AStream);
+ WriteString(Command(FCtrl1, FCtrl2, FTo), AStream);
if FStroke then
WriteString('S'+CRLF, AStream);
end;
-constructor TPDFCurveC.Create(const ADocument: TPDFDocument; const X1, Y1, X2, Y2, X3, Y3,AWidth: TPDFFloat;AStroke: Boolean = True);
+constructor TPDFCurveC.Create(const ADocument: TPDFDocument; const xCtrl1, yCtrl1, xCtrl2, yCtrl2, xTo, yTo,
+ AWidth: TPDFFloat; AStroke: Boolean);
begin
Inherited Create(ADocument);
- FP1.X:=X1;
- FP1.Y:=Y1;
- FP2.X:=X2;
- FP2.Y:=Y2;
- FP3.X:=X3;
- FP3.Y:=Y3;
- FWidth:=AWidth;
- FStroke:=AStroke;
+ FCtrl1.X := xCtrl1;
+ FCtrl1.Y := yCtrl1;
+ FCtrl2.X := xCtrl2;
+ FCtrl2.Y := yCtrl2;
+ FTo.X := xTo;
+ FTo.Y := yTo;
+ FWidth := AWidth;
+ FStroke := AStroke;
end;
-constructor TPDFCurveC.Create(const ADocument: TPDFDocument; const AP1, AP2, AP3: TPDFCoord; AWidth: TPDFFloat;AStroke: Boolean = True);
+constructor TPDFCurveC.Create(const ADocument: TPDFDocument; const ACtrl1, ACtrl2, ATo3: TPDFCoord;
+ AWidth: TPDFFloat; AStroke: Boolean);
begin
Inherited Create(ADocument);
- FP1:=AP1;
- FP2:=AP2;
- FP3:=AP3;
- FWidth:=AWidth;
- FStroke:=AStroke;
+ FCtrl1 := ACtrl1;
+ FCtrl2 := ACtrl2;
+ FTo := ATo3;
+ FWidth := AWidth;
+ FStroke := AStroke;
end;
+{ TPDFLineStyleDef }
+
+Procedure TPDFLineStyleDef.Assign(Source : TPersistent);
+
+Var
+ L : TPDFLineStyleDef;
+
+begin
+ if Source is TPDFLineStyleDef then
+ begin
+ L:=Source as TPDFLineStyleDef;
+ LineWidth:=L.LineWidth;
+ Color:=L.Color;
+ PenStyle:=L.PenStyle;
+ end
+ else
+ Inherited;
+end;
+
+
{ TPDFLineStyleDefs }
function TPDFLineStyleDefs.GetI(AIndex : Integer): TPDFLineStyleDef;
@@ -1516,7 +1788,18 @@ begin
if Assigned(Flist) then
Result:=TPDFPage(FList[Aindex])
else
- Raise EListError.CreateFmt(SErrInvalidPageIndex,[AIndex]);
+ Raise EListError.CreateFmt(rsErrInvalidPageIndex,[AIndex]);
+end;
+
+function TPDFPages.GetPageCount: integer;
+begin
+ result := FList.Count;
+end;
+
+constructor TPDFPages.Create(const ADocument: TPDFDocument);
+begin
+ inherited Create(ADocument);
+ FPageClass := TPDFPage;
end;
destructor TPDFPages.Destroy;
@@ -1529,7 +1812,7 @@ function TPDFPages.AddPage: TPDFPage;
begin
if (FList=Nil) then
FList:=TFPObjectList.Create;
- Result:=TPDFPage.Create(Document);
+ Result := PageClass.Create(Document);
FList.Add(Result);
end;
@@ -1540,6 +1823,69 @@ begin
FList.Add(APage);
end;
+{ TPDFAnnot }
+
+constructor TPDFAnnot.Create(const ADocument: TPDFDocument);
+begin
+ inherited Create(ADocument);
+end;
+
+constructor TPDFAnnot.Create(const ADocument: TPDFDocument; const ALeft, ABottom, AWidth, AHeight: TPDFFloat;
+ const AURI: String; const ABorder: Boolean);
+begin
+ Create(ADocument);
+ FLeft := ALeft;
+ FBottom := ABottom;
+ FWidth := AWidth;
+ FHeight := AHeight;
+ FURI := AURI;
+ FBorder := ABorder;
+end;
+
+{ TPDFAnnotList }
+
+procedure TPDFAnnotList.CheckList;
+begin
+ if (FList = nil) then
+ FList := TFPObjectList.Create;
+end;
+
+function TPDFAnnotList.GetAnnot(AIndex: integer): TPDFAnnot;
+begin
+ if Assigned(FList) then
+ Result := TPDFAnnot(FList[AIndex])
+ else
+ raise EListError.CreateFmt(rsErrInvalidAnnotIndex, [AIndex]);
+end;
+
+destructor TPDFAnnotList.Destroy;
+begin
+ FreeAndNil(FList);
+ inherited Destroy;
+end;
+
+function TPDFAnnotList.AddAnnot: TPDFAnnot;
+begin
+ CheckList;
+ Result := TPDFAnnot.Create(Document);
+ FList.Add(Result);
+end;
+
+function TPDFAnnotList.Count: integer;
+begin
+ if Assigned(FList) then
+ result := FList.Count
+ else
+ result := 0;
+end;
+
+procedure TPDFAnnotList.Add(AAnnot: TPDFAnnot);
+begin
+ CheckList;
+ FList.Add(AAnnot);
+end;
+
+
{ TPDFPage }
function TPDFPage.GetO(AIndex : Integer): TPDFObject;
@@ -1555,6 +1901,11 @@ begin
Result:=FObjects.Count;
end;
+function TPDFPage.CreateAnnotList: TPDFAnnotList;
+begin
+ result := TPDFAnnotList.Create(Document);
+end;
+
procedure TPDFPage.SetOrientation(AValue: TPDFPaperOrientation);
begin
if FOrientation=AValue then Exit;
@@ -1601,7 +1952,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);
@@ -1625,20 +1976,22 @@ begin
end;
end;
-procedure TPDFPage.CreateStdFontText(X, Y: TPDFFloat; AText: AnsiString; AFontIndex: integer);
+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);
+ T := Document.CreateText(X, Y, AText, AFont, ADegrees, AUnderline, AStrikeThrough);
AddObject(T);
end;
-procedure TPDFPage.CreateTTFFontText(X, Y: TPDFFloat; AText: UTF8String; AFontIndex: integer);
+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);
+ T := Document.CreateText(X, Y, AText, AFont, ADegrees, AUnderline, AStrikeThrough);
AddObject(T);
end;
@@ -1652,13 +2005,23 @@ end;
procedure TPDFPage.AdjustMatrix;
begin
- FMatrix._21 := GetPaperHeight;
+ if poPageOriginAtTop in Document.Options then
+ begin
+ FMatrix._11 := -1;
+ FMatrix._21 := GetPaperHeight;
+ end
+ else
+ begin
+ FMatrix._11 := 1;
+ FMatrix._21 := 0;
+ end;
end;
constructor TPDFPage.Create(const ADocument: TPDFDocument);
begin
inherited Create(ADocument);
- FFontIndex := -1;
+ FLastFont := nil;
+ FLastFontColor := clBlack;
FPaperType := ptA4;
FUnitOfMeasure := uomMillimeters;
CalcPaperSize;
@@ -1666,17 +2029,20 @@ begin
begin
PaperType := ADocument.DefaultPaperType;
Orientation := ADocument.DefaultOrientation;
+ FUnitOfMeasure:=ADocument.DefaultUnitOfMeasure;
end;
FMatrix._00 := 1;
FMatrix._20 := 0;
- FMatrix._11 := -1; // flip coordinates
- AdjustMatrix; // sets FMatrix._21 value
+ AdjustMatrix;
+
+ FAnnots := CreateAnnotList;
end;
destructor TPDFPage.Destroy;
begin
FreeAndNil(FObjects);
+ FreeAndNil(FAnnots);
inherited Destroy;
end;
@@ -1688,56 +2054,65 @@ 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);
-
+procedure TPDFPage.SetPenStyle(AStyle: TPDFPenStyle; const ALineWidth: TPDFFloat);
Var
L : TPDFLineStyle;
-
begin
- L:=Document.CreateLineStyle(AStyle);
+ L:=Document.CreateLineStyle(AStyle, ALineWidth);
AddObject(L);
end;
-procedure TPDFPage.WriteText(X, Y: TPDFFloat; AText: UTF8String);
+procedure TPDFPage.SetLineStyle(AIndex: Integer; AStroke : Boolean = True);
+begin
+ SetLineStyle(Document.LineStyles[Aindex],AStroke);
+end;
+
+procedure TPDFPage.SetLineStyle(S: TPDFLineStyleDef; AStroke: Boolean = True);
+begin
+ SetColor(S.Color,AStroke);
+ SetPenStyle(S.PenStyle,S.LineWidth);
+end;
+
+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(SErrNoFontIndex);
+ 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)
+ 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);
+ CreateTTFFontText(p.X, p.Y, AText, FLastFont, ADegrees, AUnderline, AStrikeThrough);
end;
-procedure TPDFPage.WriteText(APos: TPDFCoord; AText: UTF8String);
+procedure TPDFPage.WriteText(APos: TPDFCoord; AText: UTF8String; const ADegrees: single;
+ const AUnderline: boolean; const AStrikethrough: boolean);
begin
- WriteText(APos.X, APos.Y, AText);
+ WriteText(APos.X, APos.Y, AText, ADegrees, AUnderline, AStrikeThrough);
end;
-procedure TPDFPage.DrawLine(X1, Y1, X2, Y2, ALineWidth: TPDFFloat);
+procedure TPDFPage.DrawLine(X1, Y1, X2, Y2, ALineWidth: TPDFFloat; const AStroke: Boolean = True);
var
L : TPDFLineSegment;
p1, p2: TPDFCoord;
@@ -1746,13 +2121,14 @@ begin
p2 := Matrix.Transform(X2, Y2);
DoUnitConversion(p1);
DoUnitConversion(p2);
- L := TPDFLineSegment.Create(Document, ALineWidth, p1.X, p1.Y, p2.X, p2.Y);
+ L := TPDFLineSegment.Create(Document, ALineWidth, p1.X, p1.Y, p2.X, p2.Y, AStroke);
AddObject(L);
end;
-procedure TPDFPage.DrawLine(APos1: TPDFCoord; APos2: TPDFCoord; ALineWidth: TPDFFloat);
+procedure TPDFPage.DrawLine(APos1, APos2: TPDFCoord; ALineWidth: TPDFFloat;
+ const AStroke: Boolean);
begin
- DrawLine(APos1.X, APos1.Y, APos2.X, APos2.Y, ALineWidth);
+ DrawLine(APos1.X, APos1.Y, APos2.X, APos2.Y, ALineWidth, AStroke);
end;
procedure TPDFPage.DrawLineStyle(X1, Y1, X2, Y2: TPDFFloat; AStyle: Integer);
@@ -1760,83 +2136,327 @@ var
S: TPDFLineStyleDef;
begin
S := Document.LineStyles[AStyle];
- SetColor(S.Color, True);
- SetPenStyle(S.PenStyle);
+ SetLineStyle(S);
DrawLine(X1, Y1, X2, Y2, S.LineWidth);
end;
-procedure TPDFPage.DrawLineStyle(APos1: TPDFCoord; APos2: TPDFCoord; AStyle: Integer);
+procedure TPDFPage.DrawLineStyle(APos1, APos2: TPDFCoord; AStyle: Integer);
begin
DrawLineStyle(APos1.X, APos1.Y, APos2.X, APos2.Y, AStyle);
end;
-procedure TPDFPage.DrawRect(const X, Y, W, H, ALineWidth: TPDFFloat; const AFill, AStroke: Boolean);
+procedure TPDFPage.DrawRect(const X, Y, W, H, ALineWidth: TPDFFloat; const AFill, AStroke: Boolean;
+ const ADegrees: single);
var
R: TPDFRectangle;
p1, p2: TPDFCoord;
+ t1, t2, t3: string;
+ rad: single;
begin
p1 := Matrix.Transform(X, Y);
DoUnitConversion(p1);
p2.X := W;
p2.Y := H;
DoUnitConversion(p2);
- R := Document.CreateRectangle(p1.X, p1.Y, p2.X, p2.Y, ALineWidth, AFill, AStroke);
+
+ if ADegrees <> 0.0 then
+ begin
+ rad := DegToRad(-ADegrees);
+ t1 := FormatFloat('0.###;;0', Cos(rad));
+ t2 := FormatFloat('0.###;;0', -Sin(rad));
+ t3 := FormatFloat('0.###;;0', Sin(rad));
+ AddObject(TPDFPushGraphicsStack.Create(Document));
+ // PDF v1.3 page 132 & 143
+ AddObject(TPDFFreeFormString.Create(Document, Format('%s %s %s %s %.4f %.4f cm', [t1, t2, t3, t1, p1.X, p1.Y]) + CRLF));
+ // co-ordinates are now based on the newly transformed matrix co-ordinates.
+ R := Document.CreateRectangle(0, 0, p2.X, p2.Y, ALineWidth, AFill, AStroke);
+ end
+ else
+ R := Document.CreateRectangle(p1.X, p1.Y, p2.X, p2.Y, ALineWidth, AFill, AStroke);
+
AddObject(R);
+
+ if ADegrees <> 0.0 then
+ AddObject(TPDFPopGraphicsStack.Create(Document));
end;
-procedure TPDFPage.DrawRect(const APos: TPDFCoord; const W, H, ALineWidth: TPDFFloat; const AFill, AStroke: Boolean);
+procedure TPDFPage.DrawRect(const APos: TPDFCoord; const W, H, ALineWidth: TPDFFloat; const AFill, AStroke: Boolean;
+ const ADegrees: single);
begin
- DrawRect(APos.X, APos.Y, W, H, ALineWidth, AFill, AStroke);
+ DrawRect(APos.X, APos.Y, W, H, ALineWidth, AFill, AStroke, ADegrees);
end;
-procedure TPDFPage.DrawImageRawSize(const X, Y: TPDFFloat; const APixelWidth, APixelHeight, ANumber: integer);
+procedure TPDFPage.DrawRoundedRect(const X, Y, W, H, ARadius, ALineWidth: TPDFFloat; const AFill, AStroke: Boolean;
+ const ADegrees: single);
+var
+ R: TPDFRoundedRectangle;
+ p1, p2, p3: TPDFCoord;
+ t1, t2, t3: string;
+ rad: single;
+begin
+ p1 := Matrix.Transform(X, Y);
+ DoUnitConversion(p1);
+ p2.X := W;
+ p2.Y := H;
+ DoUnitConversion(p2);
+ p3.X := ARadius;
+ p3.Y := 0;
+ DoUnitConversion(p3);
+ if ADegrees <> 0.0 then
+ begin
+ rad := DegToRad(-ADegrees);
+ t1 := FormatFloat('0.###;;0', Cos(rad));
+ t2 := FormatFloat('0.###;;0', -Sin(rad));
+ t3 := FormatFloat('0.###;;0', Sin(rad));
+ AddObject(TPDFPushGraphicsStack.Create(Document));
+ // PDF v1.3 page 132 & 143
+ AddObject(TPDFFreeFormString.Create(Document, Format('%s %s %s %s %.4f %.4f cm', [t1, t2, t3, t1, p1.X, p1.Y]) + CRLF));
+ // co-ordinates are now based on the newly transformed matrix co-ordinates.
+ R := Document.CreateRoundedRectangle(0, 0, p2.X, p2.Y, p3.X, ALineWidth, AFill, AStroke);
+ end
+ else
+ R := Document.CreateRoundedRectangle(p1.X, p1.Y, p2.X, p2.Y, p3.X, ALineWidth, AFill, AStroke);
+
+ AddObject(R);
+
+ if ADegrees <> 0.0 then
+ AddObject(TPDFPopGraphicsStack.Create(Document));
+end;
+
+procedure TPDFPage.DrawImageRawSize(const X, Y: TPDFFloat; const APixelWidth, APixelHeight, ANumber: integer;
+ const ADegrees: single);
var
p1: TPDFCoord;
+ t1, t2, t3: string;
+ rad: single;
begin
p1 := Matrix.Transform(X, Y);
DoUnitConversion(p1);
- AddObject(Document.CreateImage(p1.X, p1.Y, APixelWidth, APixelHeight, ANumber));
+ if ADegrees <> 0.0 then
+ begin
+ rad := DegToRad(-ADegrees);
+ t1 := FormatFloat('0.###;;0', Cos(rad));
+ t2 := FormatFloat('0.###;;0', -Sin(rad));
+ t3 := FormatFloat('0.###;;0', Sin(rad));
+ AddObject(TPDFPushGraphicsStack.Create(Document));
+ // PDF v1.3 page 132 & 143
+ AddObject(TPDFFreeFormString.Create(Document, Format('%s %s %s %s %.4f %.4f cm', [t1, t2, t3, t1, p1.X, p1.Y]) + CRLF));
+ // co-ordinates are now based on the newly transformed matrix co-ordinates.
+ AddObject(Document.CreateImage(0, 0, APixelWidth, APixelHeight, ANumber));
+ end
+ else
+ AddObject(Document.CreateImage(p1.X, p1.Y, APixelWidth, APixelHeight, ANumber));
+
+ if ADegrees <> 0.0 then
+ AddObject(TPDFPopGraphicsStack.Create(Document));
end;
-procedure TPDFPage.DrawImageRawSize(const APos: TPDFCoord; const APixelWidth, APixelHeight, ANumber: integer);
+procedure TPDFPage.DrawImageRawSize(const APos: TPDFCoord; const APixelWidth, APixelHeight, ANumber: integer;
+ const ADegrees: single);
begin
- DrawImage(APos.X, APos.Y, APixelWidth, APixelHeight, ANumber);
+ DrawImage(APos.X, APos.Y, APixelWidth, APixelHeight, ANumber, ADegrees);
end;
-procedure TPDFPage.DrawImage(const X, Y: TPDFFloat; const AWidth, AHeight: TPDFFloat; const ANumber: integer);
+procedure TPDFPage.DrawImage(const X, Y: TPDFFloat; const AWidth, AHeight: TPDFFloat; const ANumber: integer;
+ const ADegrees: single);
var
p1, p2: TPDFCoord;
+ t1, t2, t3: string;
+ rad: single;
begin
p1 := Matrix.Transform(X, Y);
DoUnitConversion(p1);
p2.X := AWidth;
p2.Y := AHeight;
DoUnitConversion(p2);
- AddObject(Document.CreateImage(p1.X, p1.Y, p2.X, p2.Y, ANumber));
+
+ if ADegrees <> 0.0 then
+ begin
+ rad := DegToRad(-ADegrees);
+ t1 := FormatFloat('0.###;;0', Cos(rad));
+ t2 := FormatFloat('0.###;;0', -Sin(rad));
+ t3 := FormatFloat('0.###;;0', Sin(rad));
+ AddObject(TPDFPushGraphicsStack.Create(Document));
+ // PDF v1.3 page 132 & 143
+ AddObject(TPDFFreeFormString.Create(Document, Format('%s %s %s %s %.4f %.4f cm', [t1, t2, t3, t1, p1.X, p1.Y]) + CRLF));
+ // co-ordinates are now based on the newly transformed matrix co-ordinates.
+ AddObject(Document.CreateImage(0, 0, p2.X, p2.Y, ANumber));
+ end
+ else
+ AddObject(Document.CreateImage(p1.X, p1.Y, p2.X, p2.Y, ANumber));
+
+ if ADegrees <> 0.0 then
+ AddObject(TPDFPopGraphicsStack.Create(Document));
end;
-procedure TPDFPage.DrawImage(const APos: TPDFCoord; const AWidth, AHeight: TPDFFloat; const ANumber: integer);
+procedure TPDFPage.DrawImage(const APos: TPDFCoord; const AWidth, AHeight: TPDFFloat; const ANumber: integer;
+ const ADegrees: single);
begin
- DrawImage(APos.X, APos.Y, AWidth, AHeight, ANumber);
+ DrawImage(APos.X, APos.Y, AWidth, AHeight, ANumber, ADegrees);
end;
-procedure TPDFPage.DrawEllipse(const APosX, APosY, AWidth, AHeight,
- ALineWidth: TPDFFloat; const AFill: Boolean; AStroke: Boolean);
+procedure TPDFPage.DrawEllipse(const APosX, APosY, AWidth, AHeight, ALineWidth: TPDFFloat; const AFill: Boolean;
+ AStroke: Boolean; const ADegrees: single);
var
p1, p2: TPDFCoord;
+ t1, t2, t3: string;
+ rad: single;
begin
p1 := Matrix.Transform(APosX, APosY);
DoUnitConversion(p1);
p2.X := AWidth;
p2.Y := AHeight;
DoUnitConversion(p2);
- AddObject(TPDFEllipse.Create(Document, p1.X, p1.Y, p2.X, p2.Y, ALineWidth, AFill, AStroke));
+
+ if ADegrees <> 0.0 then
+ begin
+ rad := DegToRad(-ADegrees);
+ t1 := FormatFloat('0.###;;0', Cos(rad));
+ t2 := FormatFloat('0.###;;0', -Sin(rad));
+ t3 := FormatFloat('0.###;;0', Sin(rad));
+ AddObject(TPDFPushGraphicsStack.Create(Document));
+ // PDF v1.3 page 132 & 143
+ AddObject(TPDFFreeFormString.Create(Document, Format('%s %s %s %s %.4f %.4f cm', [t1, t2, t3, t1, p1.X, p1.Y]) + CRLF));
+ // co-ordinates are now based on the newly transformed matrix co-ordinates.
+ AddObject(TPDFEllipse.Create(Document, 0, 0, p2.X, p2.Y, ALineWidth, AFill, AStroke));
+ end
+ else
+ AddObject(TPDFEllipse.Create(Document, p1.X, p1.Y, p2.X, p2.Y, ALineWidth, AFill, AStroke));
+
+ if ADegrees <> 0.0 then
+ AddObject(TPDFPopGraphicsStack.Create(Document));
end;
procedure TPDFPage.DrawEllipse(const APos: TPDFCoord; const AWidth, AHeight, ALineWidth: TPDFFloat;
- const AFill: Boolean; AStroke: Boolean);
+ const AFill: Boolean; AStroke: Boolean; const ADegrees: single);
+begin
+ DrawEllipse(APos.X, APos.Y, AWidth, AHeight, ALineWidth, AFill, AStroke, ADegrees);
+end;
+
+procedure TPDFPage.DrawPolygon(const APoints: array of TPDFCoord; const ALineWidth: TPDFFloat);
+begin
+ DrawPolyLine(APoints, ALineWidth);
+ ClosePath;
+end;
+
+procedure TPDFPage.DrawPolyLine(const APoints: array of TPDFCoord; const ALineWidth: TPDFFloat);
+var
+ i: integer;
begin
- DrawEllipse(APos.X, APos.Y, AWidth, AHeight, ALineWidth, AFill, AStroke);
+ if Length(APoints) < 2 then
+ Exit; { not enough points to draw a line. Should this raise an exception? }
+ MoveTo(APoints[0].X, APoints[0].Y);
+ for i := Low(APoints)+1 to High(APoints) do
+ DrawLine(APoints[i-1].X, APoints[i-1].Y, APoints[i].X, APoints[i].Y, ALineWidth, False);
+end;
+
+procedure TPDFPage.ResetPath;
+begin
+ AddObject(TPDFResetPath.Create(Document));
+end;
+
+procedure TPDFPage.ClosePath;
+begin
+ AddObject(TPDFClosePath.Create(Document));
+end;
+
+procedure TPDFPage.ClosePathStroke;
+begin
+ AddObject(TPDFFreeFormString.Create(Document, 's'+CRLF));
+end;
+
+procedure TPDFPage.StrokePath;
+begin
+ AddObject(TPDFStrokePath.Create(Document));
+end;
+
+procedure TPDFPage.FillStrokePath;
+begin
+ AddObject(TPDFFreeFormString.Create(Document, 'B'+CRLF));
+end;
+
+procedure TPDFPage.FillEvenOddStrokePath;
+begin
+ AddObject(TPDFFreeFormString.Create(Document, 'B*'+CRLF));
+end;
+
+procedure TPDFPage.MoveTo(x, y: TPDFFloat);
+var
+ p1: TPDFCoord;
+begin
+ p1 := Matrix.Transform(x, y);
+ DoUnitConversion(p1);
+ AddObject(TPDFMoveTo.Create(Document, p1.x, p1.y));
+end;
+
+procedure TPDFPage.MoveTo(APos: TPDFCoord);
+begin
+ MoveTo(APos.X, APos.Y);
+end;
+
+procedure TPDFPage.CubicCurveTo(const xCtrl1, yCtrl1, xCtrl2, yCtrl2, xTo, yTo, ALineWidth: TPDFFloat; AStroke: Boolean);
+var
+ p1, p2, p3: TPDFCoord;
+begin
+ p1 := Matrix.Transform(xCtrl1, yCtrl1);
+ DoUnitConversion(p1);
+ p2 := Matrix.Transform(xCtrl2, yCtrl2);
+ DoUnitConversion(p2);
+ p3 := Matrix.Transform(xTo, yTo);
+ DoUnitConversion(p3);
+ AddObject(TPDFCurveC.Create(Document, p1.x, p1.y, p2.x, p2.y, p3.x, p3.y, ALineWidth, AStroke));
+end;
+
+procedure TPDFPage.CubicCurveTo(ACtrl1, ACtrl2, ATo: TPDFCoord; const ALineWidth: TPDFFloat; AStroke: Boolean);
+begin
+ CubicCurveTo(ACtrl1.X, ACtrl1.Y, ACtrl2.X, ACtrl2.Y, ATo.X, ATo.Y, ALineWidth, AStroke);
+end;
+
+procedure TPDFPage.CubicCurveToV(xCtrl2, yCtrl2, xTo, yTo: TPDFFloat; const ALineWidth: TPDFFloat; AStroke: Boolean);
+var
+ p2, p3: TPDFCoord;
+begin
+ p2 := Matrix.Transform(xCtrl2, yCtrl2);
+ DoUnitConversion(p2);
+ p3 := Matrix.Transform(xTo, yTo);
+ DoUnitConversion(p3);
+ AddObject(TPDFCurveV.Create(Document, p2.x, p2.y, p3.x, p3.y, ALineWidth, AStroke));
+end;
+
+procedure TPDFPage.CubicCurveToV(ACtrl2, ATo: TPDFCoord; const ALineWidth: TPDFFloat; AStroke: Boolean);
+begin
+ CubicCurveToV(ACtrl2.X, ACtrl2.Y, ATo.X, ATo.Y, ALineWidth, AStroke);
+end;
+
+procedure TPDFPage.CubicCurveToY(xCtrl1, yCtrl1, xTo, yTo: TPDFFloat; const ALineWidth: TPDFFloat; AStroke: Boolean);
+var
+ p1, p3: TPDFCoord;
+begin
+ p1 := Matrix.Transform(xCtrl1, yCtrl1);
+ DoUnitConversion(p1);
+ p3 := Matrix.Transform(xTo, yTo);
+ DoUnitConversion(p3);
+ AddObject(TPDFCurveY.Create(Document, p1.x, p1.y, p3.x, p3.y, ALineWidth, AStroke));
+end;
+
+procedure TPDFPage.CubicCurveToY(ACtrl1, ATo: TPDFCoord; const ALineWidth: TPDFFloat; AStroke: Boolean);
+begin
+ CubicCurveToY(ACtrl1.X, ACtrl1.Y, ATo.X, ATo.Y, ALineWidth, AStroke);
+end;
+
+procedure TPDFPage.AddExternalLink(const APosX, APosY, AWidth, AHeight: TPDFFloat;
+ const AURI: string; ABorder: boolean);
+var
+ an: TPDFAnnot;
+ p1, p2: TPDFCoord;
+begin
+ p1 := Matrix.Transform(APosX, APosY);
+ DoUnitConversion(p1);
+ p2.X := AWidth;
+ p2.Y := AHeight;
+ DoUnitConversion(p2);
+ an := TPDFAnnot.Create(Document, p1.X, p1.Y, p2.X, p2.Y, AURI, ABorder);
+ Annots.Add(an);
end;
function TPDFPage.GetPaperHeight: TPDFFloat;
@@ -1895,7 +2515,7 @@ begin
If Assigned(FPages) then
Result:=TPDFPage(FPages[Aindex])
else
- Raise EPDF.CreateFmt(SerrInvalidSectionPage,[AIndex]);
+ Raise EPDF.CreateFmt(rsErrInvalidSectionPage,[AIndex]);
end;
function TPDFSection.GetP: INteger;
@@ -2049,7 +2669,6 @@ begin
end;
procedure TPDFImageItem.CreateStreamedData(AUseCompression: Boolean);
-
Var
X,Y : Integer;
C : TFPColor;
@@ -2082,7 +2701,7 @@ begin
Str.WriteByte(C.Red shr 8);
Str.WriteByte(C.Green shr 8);
- Str.WriteByte(C.blue shr 8);
+ Str.WriteByte(C.Blue shr 8);
end;
if Str<>MS then
Str.Free;
@@ -2098,10 +2717,8 @@ begin
end;
function TPDFImageItem.WriteImageStream(AStream: TStream): int64;
-
var
Img : TBytes;
-
begin
TPDFObject.WriteString(CRLF+'stream'+CRLF,AStream);
Img:=StreamedData;
@@ -2120,18 +2737,21 @@ begin
Result := False;
exit;
end;
- Result := True;
+
+ { if dimensions don't match, we know we can exit early }
+ Result := (Image.Width = AImage.Width) and (Image.Height = AImage.Height);
+ if not Result then
+ Exit;
+
for x := 0 to Image.Width-1 do
for y := 0 to Image.Height-1 do
- if Image.Pixels[x, y] <> AImage.Pixels[x, y] then
+ if Image.Colors[x, y] <> AImage.Colors[x, y] then
begin
Result := False;
Exit;
end;
end;
-
-
{ TPDFImages }
function TPDFImages.GetI(AIndex : Integer): TPDFImageItem;
@@ -2176,8 +2796,9 @@ function TPDFImages.AddFromFile(const AFileName: String; KeepImage: Boolean): In
{$IF NOT (FPC_FULLVERSION >= 30101)}
function FindReaderFromExtension(extension: String): TFPCustomImageReaderClass;
- var s : string;
- r : integer;
+ var
+ s: string;
+ r: integer;
begin
extension := lowercase (extension);
if (extension <> '') and (extension[1] = '.') then
@@ -2196,8 +2817,8 @@ function TPDFImages.AddFromFile(const AFileName: String; KeepImage: Boolean): In
end;
Result := nil;
end;
- function FindReaderFromFileName(const filename: String
- ): TFPCustomImageReaderClass;
+
+ function FindReaderFromFileName(const filename: String): TFPCustomImageReaderClass;
begin
Result := FindReaderFromExtension(ExtractFileExt(filename));
end;
@@ -2256,6 +2877,8 @@ begin
begin
IP:=AddImageItem;
I:=TFPMemoryImage.Create(0,0);
+ if not Assigned(Handler) then
+ raise EPDF.Create(rsErrNoImageReader);
Reader := Handler.Create;
try
I.LoadFromStream(AStream, Reader);
@@ -2290,6 +2913,7 @@ begin
Str(F:4:0,Result)
else
Str(F:4:2,Result);
+ result := trim(Result);
end;
procedure TPDFObject.Write(const AStream: TStream);
@@ -2402,13 +3026,7 @@ var
s: AnsiString;
begin
s := Utf8ToAnsi(FValue);
- if poCompressText in Document.Options then
- begin
- // TODO: Implement text compression
- WriteString('('+s+')', AStream);
- end
- else
- WriteString('('+s+')', AStream);
+ WriteString('('+s+')', AStream);
end;
constructor TPDFString.Create(Const ADocument : TPDFDocument; const AValue: string);
@@ -2431,13 +3049,7 @@ end;
procedure TPDFUTF8String.Write(const AStream: TStream);
begin
- if poCompressText in Document.Options then
- begin
- // TODO: Implement text compression
- WriteString('<'+RemapedText+'>', AStream)
- end
- else
- WriteString('<'+RemapedText+'>', AStream);
+ WriteString('<'+RemapedText+'>', AStream);
end;
constructor TPDFUTF8String.Create(const ADocument: TPDFDocument; const AValue: UTF8String; const AFontIndex: integer);
@@ -2447,6 +3059,23 @@ begin
FFontIndex := AFontIndex;
end;
+{ TPDFFreeFormString }
+
+procedure TPDFFreeFormString.Write(const AStream: TStream);
+var
+ s: AnsiString;
+begin
+ s := Utf8ToAnsi(FValue);
+ WriteString(s, AStream);
+end;
+
+constructor TPDFFreeFormString.Create(const ADocument: TPDFDocument; const AValue: string);
+begin
+ inherited Create(ADocument);
+ FValue := AValue;
+end;
+
+
{ TPDFArray }
procedure TPDFArray.Write(const AStream: TStream);
@@ -2485,6 +3114,11 @@ begin
AddItem(Document.CreateInteger(StrToInt(S)));
end;
+procedure TPDFArray.AddFreeFormArrayValues(S: string);
+begin
+ AddItem(TPDFFreeFormString.Create(nil, S));
+end;
+
constructor TPDFArray.Create(const ADocument: TPDFDocument);
begin
inherited Create(ADocument);
@@ -2524,6 +3158,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);
@@ -2554,31 +3193,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
+ 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;
+ FTxtFont := AFont;
+ FTxtSize := ASize;
+ FPage := APage;
end;
+{ TPDFBaseText }
-procedure TPDFText.Write(const AStream: TStream);
+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);
- WriteString(FloatStr(FX)+' '+FloatStr(FY)+' TD'+CRLF, AStream);
+ if Degrees <> 0.0 then
+ begin
+ 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(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);
+constructor TPDFText.Create(const ADocument: TPDFDocument; const AX, AY: TPDFFloat; const AText: AnsiString;
+ const AFont: TPDFEmbeddedFont; const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean);
begin
inherited Create(ADocument);
- FX:=AX;
- FY:=AY;
- FFontIndex := AFontIndex;
- FString:=ADocument.CreateString(AText);
+ 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);
end;
destructor TPDFText.Destroy;
@@ -2590,22 +3375,87 @@ end;
{ TPDFUTF8Text }
procedure TPDFUTF8Text.Write(const AStream: TStream);
-begin
+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);
- WriteString(FloatStr(FX)+' '+FloatStr(FY)+' TD'+CRLF, AStream);
+ if Degrees <> 0.0 then
+ begin
+ 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(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 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);
+ 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;
@@ -2620,9 +3470,11 @@ procedure TPDFLineSegment.Write(const AStream: TStream);
begin
SetWidth(FWidth,AStream);
- WriteString(TPDFMoveTo.Command(P1), AStream);
+ if FStroke then
+ WriteString(TPDFMoveTo.Command(P1), AStream);
WriteString(Command(P2),AStream);
- WriteString('S'+CRLF, AStream);
+ if FStroke then
+ WriteString('S'+CRLF, AStream);
end;
class function TPDFLineSegment.Command(APos: TPDFCoord): String;
@@ -2630,13 +3482,18 @@ begin
Result:=FloatStr(APos.X)+' '+FloatStr(APos.Y)+' l'+CRLF
end;
+class function TPDFLineSegment.Command(x1, y1: TPDFFloat): String;
+begin
+ Result := FloatStr(x1)+' '+FloatStr(y1)+' l'+CRLF
+end;
+
class function TPDFLineSegment.Command(APos1, APos2: TPDFCoord): String;
begin
Result:=TPDFMoveTo.Command(APos1)+Command(APos2);
end;
-constructor TPDFLineSegment.Create(const ADocument: TPDFDocument; const AWidth,
- X1, Y1, X2, Y2: TPDFFloat);
+constructor TPDFLineSegment.Create(const ADocument: TPDFDocument; const AWidth, X1, Y1, X2, Y2: TPDFFloat;
+ const AStroke: Boolean);
begin
inherited Create(ADocument);
FWidth:=AWidth;
@@ -2644,8 +3501,11 @@ begin
P1.Y:=Y1;
P2.X:=X2;
P2.Y:=Y2;
+ FStroke := AStroke;
end;
+{ TPDFRectangle }
+
procedure TPDFRectangle.Write(const AStream: TStream);
begin
if FStroke then
@@ -2677,6 +3537,67 @@ begin
FStroke := AStroke;
end;
+{ TPDFRoundedRectangle }
+
+procedure TPDFRoundedRectangle.Write(const AStream: TStream);
+var
+ c: TPDFFloat;
+ x1, y1, x2, y2: TPDFFloat;
+begin
+ if FStroke then
+ SetWidth(FWidth, AStream);
+
+ // bottom left
+ x1 := FBottomLeft.X;
+ y1 := FBottomLeft.Y;
+
+ // top right
+ x2 := FBottomLeft.X + FDimensions.X;
+ y2 := FBottomLeft.Y + FDimensions.Y;
+
+ // radius
+ c := FRadius;
+
+ // Starting point is bottom left, then drawing anti-clockwise
+ WriteString(TPDFMoveTo.Command(x1+c, y1), AStream);
+ WriteString(TPDFLineSegment.Command(x2-c, y1), AStream);
+
+ WriteString(TPDFCurveC.Command(x2-c+BEZIER*c, y1, x2, y1+c-BEZIER*c, x2, y1+c), AStream);
+ WriteString(TPDFLineSegment.Command(x2, y2-c), AStream);
+
+ WriteString(TPDFCurveC.Command(x2, y2-c+BEZIER*c, x2-c+BEZIER*c, y2, x2-c, y2), AStream);
+ WriteString(TPDFLineSegment.Command(x1+c, y2), AStream);
+
+ WriteString(TPDFCurveC.Command(x1+c-BEZIER*c, y2, x1, y2-c+BEZIER*c, x1, y2-c), AStream);
+ WriteString(TPDFLineSegment.Command(x1, y1+c), AStream);
+
+ WriteString(TPDFCurveC.Command(x1, y1+c-BEZIER*c, x1+c-BEZIER*c, y1, x1+c, y1), AStream);
+ WriteString('h'+CRLF, AStream);
+
+ if FStroke and FFill then
+ WriteString('b'+CRLF, AStream)
+ else if FFill then
+ WriteString('f'+CRLF, AStream)
+ else if FStroke then
+ WriteString('S'+CRLF, AStream);
+end;
+
+constructor TPDFRoundedRectangle.Create(const ADocument: TPDFDocument; const APosX, APosY, AWidth, AHeight, ARadius,
+ ALineWidth: TPDFFloat; const AFill, AStroke: Boolean);
+begin
+ inherited Create(ADocument);
+ FBottomLeft.X := APosX;
+ FBottomLeft.Y := APosY;
+ FDimensions.X := AWidth;
+ FDimensions.Y := AHeight;
+ FWidth := ALineWidth;
+ FFill := AFill;
+ FStroke := AStroke;
+ FRadius := ARadius;
+end;
+
+{ TPDFSurface }
+
procedure TPDFSurface.Write(const AStream: TStream);
var
i: integer;
@@ -2700,10 +3621,10 @@ end;
procedure TPDFImage.Write(const AStream: TStream);
begin
- WriteString('q'+CRLF, AStream); // save graphics state
+ WriteString(TPDFPushGraphicsStack.Command, AStream); // save graphics state
WriteString(FloatStr(FSize.X)+' 0 0 '+FloatStr(FSize.Y)+' '+FloatStr( FPos.X)+' '+FloatStr( FPos.Y)+' cm'+CRLF, AStream);
WriteString('/I'+IntToStr(FNumber)+' Do'+CRLF, AStream);
- WriteString('Q'+CRLF, AStream); // restore graphics state
+ WriteString(TPDFPopGraphicsStack.Command, AStream); // restore graphics state
end;
constructor TPDFImage.Create(const ADocument: TPDFDocument; const ALeft, ABottom, AWidth, AHeight: TPDFFloat; ANumber: integer);
@@ -2716,33 +3637,45 @@ begin
FSize.Y:=AHeight;
end;
+// Dot = linewidth; Dash = (5 x linewidth); Gap = (3 x linewidth);
procedure TPDFLineStyle.Write(const AStream: TStream);
+var
+ lMask: string;
+ w: TPDFFloat;
begin
- WriteString(Format('[%s] %d d'+CRLF,[cPenStyleBitmasks[FStyle],FPhase]), AStream);
+ w := FLineWidth;
+ case FStyle of
+ ppsSolid:
+ begin
+ lMask := '';
+ end;
+ ppsDash:
+ begin
+ lMask := FloatStr(5*w) + ' ' + FloatStr(5*w);
+ end;
+ ppsDot:
+ begin
+ lMask := FloatStr(0.8*w) + ' ' + FloatStr(4*w)
+ end;
+ ppsDashDot:
+ begin
+ lMask := FloatStr(5*w) + ' ' + FloatStr(3*w) + ' ' + FloatStr(0.8*w) + ' ' + FloatStr(3*w)
+ end;
+ ppsDashDotDot:
+ begin
+ 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);
end;
-constructor TPDFLineStyle.Create(Const ADocument : TPDFDocument; AStyle: TPDFPenStyle; APhase: integer);
+constructor TPDFLineStyle.Create(const ADocument: TPDFDocument; AStyle: TPDFPenStyle; APhase: integer;
+ ALineWidth: TPDFFloat);
begin
inherited Create(ADocument);
- FStyle:=AStyle;
- FPhase:=APhase;
-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;
+ FStyle := AStyle;
+ FPhase := APhase;
+ FLineWidth := ALineWidth;
end;
Function ARGBGetRed(AColor : TARGBColor) : Byte;
@@ -2769,9 +3702,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);
@@ -2906,15 +3870,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;
@@ -2926,8 +3890,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;
@@ -2987,7 +3974,7 @@ function TPDFDictionary.ElementByName(const AKey: String): TPDFDictionaryItem;
begin
Result:=FindElement(AKey);
If (Result=Nil) then
- Raise EPDF.CreateFmt(SErrDictElementNotFound,[AKey]);
+ Raise EPDF.CreateFmt(rsErrDictElementNotFound,[AKey]);
end;
function TPDFDictionary.ValueByName(const AKey: String): TPDFObject;
@@ -3028,6 +4015,22 @@ begin
inherited;
end;
+{ TPDFInfos }
+
+constructor TPDFInfos.Create;
+begin
+ inherited Create;
+ FProducer := 'fpGUI Toolkit 1.4';
+end;
+
+{ TPDFFontNumBaseObject }
+
+constructor TPDFFontNumBaseObject.Create(const ADocument: TPDFDocument; const AFontNum: integer);
+begin
+ inherited Create(ADocument);
+ FFontNum := AFontNum;
+end;
+
{ TPDFToUnicode }
procedure TPDFToUnicode.Write(const AStream: TStream);
@@ -3035,35 +4038,125 @@ 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('<</Registry (Adobe)'+CRLF, AStream);
- WriteString('/Ordering (Identity)'+CRLF, AStream);
+
+ if poSubsetFont in Document.Options then
+ WriteString('/Ordering (UCS)'+CRLF, AStream)
+ else
+ WriteString('/Ordering (Identity)'+CRLF, AStream);
+
WriteString('/Supplement 0'+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> <FFFF>'+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
+ { TODO: Future Improvement - We can reduce the entries in the beginbfrange
+ by actually using ranges for consecutive numbers.
+ eg:
+ <0051> <0053> <006E>
+ vs
+ <0051> <0051> <006E>
+ <0052> <0052> <006F>
+ <0053> <0053> <0070>
+ }
+ // 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);
+ 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);
-begin
- inherited Create(ADocument);
- FEmbeddedFontNum := AEmbeddedFontNum;
+
+{ TCIDToGIDMap }
+
+procedure TCIDToGIDMap.Write(const AStream: TStream);
+var
+ lst: TTextMappingList;
+ i: integer;
+ cid, gid: uint16;
+ ba: TBytes;
+ lMaxCharID: integer;
+begin
+ 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 }
@@ -3092,6 +4185,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;
@@ -3102,6 +4217,21 @@ begin
Result:=FGlobalXRefs.Count;
end;
+function TPDFDocument.GetTotalAnnotsCount: integer;
+var
+ i: integer;
+begin
+ Result := 0;
+ for i := 0 to Pages.Count-1 do
+ 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;
@@ -3143,31 +4273,54 @@ end;
procedure TPDFDocument.WriteObject(const AObject: integer; const AStream: TStream);
var
M : TMemoryStream;
+ MCompressed: TMemoryStream;
X : TPDFXRef;
+ d: integer;
begin
TPDFObject.WriteString(IntToStr(AObject)+' 0 obj'+CRLF, AStream);
X:=GlobalXRefs[AObject];
if X.FStream = nil then
X.Dict.WriteDictionary(AObject, AStream)
else
+ begin
+ CurrentColor := '';
+ CurrentWidth := '';
+
+ M := TMemoryStream.Create;
+ X.FStream.Write(M);
+ d := M.Size;
+ X.Dict.AddInteger('Length', M.Size);
+
+ if poCompressText in Options then
begin
- M:=TMemoryStream.Create;
- try
- CurrentColor:='';
- CurrentWidth:='';
- X.FStream.Write(M);
- X.Dict.AddInteger('Length',M.Size);
- finally
- M.Free;
+ MCompressed := TMemoryStream.Create;
+ CompressStream(M, MCompressed);
+ X.Dict.AddName('Filter', 'FlateDecode');
+ X.Dict.AddInteger('Length1', MCompressed.Size);
end;
+
X.Dict.Write(AStream);
+
// write stream in contents dictionary
CurrentColor:='';
CurrentWidth:='';
TPDFObject.WriteString(CRLF+'stream'+CRLF, AStream);
- X.FStream.Write(AStream);
- TPDFObject.WriteString('endstream', AStream);
+ if poCompressText in Options then
+ begin
+ MCompressed.Position := 0;
+ MCompressed.SaveToStream(AStream);
+ MCompressed.Free;
+ end
+ else
+ 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);
end;
@@ -3207,9 +4360,12 @@ begin
IDict:=CreateGlobalXRef.Dict;
Trailer.AddReference('Info', GLobalXRefCount-1);
(Trailer.ValueByName('Size') as TPDFInteger).Value:=GLobalXRefCount;
- IDict.AddString('Title',Infos.Title);
- IDict.AddString('Author',Infos.Author);
- IDict.AddString('Creator',Infos.ApplicationName);
+ if Infos.Title <> '' then
+ IDict.AddString('Title',Infos.Title);
+ if Infos.Author <> '' then
+ IDict.AddString('Author',Infos.Author);
+ if Infos.ApplicationName <> '' then
+ IDict.AddString('Creator',Infos.ApplicationName);
IDict.AddString('Producer',Infos.Producer);
IDict.AddString('CreationDate',DateToPdfDate(Infos.CreationDate));
end;
@@ -3251,26 +4407,26 @@ end;
function TPDFDocument.CreatePageEntry(Parent, PageNum: integer): integer;
var
-
PDict,ADict: TPDFDictionary;
Arr : TPDFArray;
PP : TPDFPage;
-
begin
// add xref entry
PP:=Pages[PageNum];
PDict:=CreateGlobalXRef.Dict;
+
PDict.AddName('Type','Page');
PDict.AddReference('Parent',Parent);
ADict:=GlobalXRefs[Parent].Dict;
(ADict.ValueByName('Count') as TPDFInteger).Inc;
- (ADict.ValueByName('Kids') as TPDFArray).AddItem(CreateReference(GLobalXRefCount-1));
+ (ADict.ValueByName('Kids') as TPDFArray).AddItem(CreateReference(GlobalXRefCount-1));
Arr:=CreateArray;
Arr.AddItem(CreateInteger(0));
Arr.AddItem(CreateInteger(0));
Arr.AddItem(CreateInteger(PP.Paper.W));
Arr.AddItem(CreateInteger(PP.Paper.H));
PDict.AddElement('MediaBox',Arr);
+ CreateAnnotEntries(PageNum, PDict);
ADict:=CreateDictionary;
PDict.AddElement('Resources',ADict);
Arr:=CreateArray; // procset
@@ -3282,7 +4438,8 @@ begin
ADict.AddElement('Font',CreateDictionary);
if PP.HasImages then
ADict.AddElement('XObject', CreateDictionary);
- Result:=GLobalXRefCount-1;
+
+ Result:=GlobalXRefCount-1;
end;
function TPDFDocument.CreateOutlines: integer;
@@ -3339,7 +4496,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');
@@ -3350,8 +4509,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;
@@ -3382,23 +4542,37 @@ 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);
- Arr.AddItem(TPDFReference.Create(self, GlobalXRefCount-4));
- CreateToUnicode(EmbeddedFontNum);
- FDict.AddReference('ToUnicode', GlobalXRefCount-1);
+ CreateTTFDescendantFont(EmbeddedFontNum);
+
+ if not (poNoEmbeddedFonts in Options) then
+ begin
+ FDict.AddReference('ToUnicode', GlobalXRefCount);
+ CreateToUnicode(EmbeddedFontNum);
+ end;
FontFiles.Add(Fonts[EmbeddedFontNum].FTrueTypeFile.Filename);
end;
@@ -3411,18 +4585,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);
- 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 <xxx> 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;
@@ -3447,49 +4634,79 @@ 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',Fonts[EmbeddedFontNum].FTrueTypeFile.ItalicAngle);
+ FDict.AddInteger('ItalicAngle', trunc(Fonts[EmbeddedFontNum].FTrueTypeFile.ItalicAngle));
FDict.AddInteger('StemV', Fonts[EmbeddedFontNum].FTrueTypeFile.StemV);
FDict.AddInteger('MissingWidth', Fonts[EmbeddedFontNum].FTrueTypeFile.MissingWidth);
- CreateFontFileEntry(EmbeddedFontNum);
- FDict.AddReference('FontFile2',GlobalXRefCount-1);
+ if not (poNoEmbeddedFonts in Options) then
+ begin
+ FDict.AddReference('FontFile2', GlobalXRefCount);
+ CreateFontFileEntry(EmbeddedFontNum);
+
+ 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.CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);
+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);
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');
@@ -3499,33 +4716,95 @@ 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.CreateContentsEntry: integer;
+function TPDFDocument.CreateAnnotEntry(const APageNum, AnnotNum: integer): integer;
var
- Contents: TPDFXRef;
+ lDict, ADict: TPDFDictionary;
+ an: TPDFAnnot;
+ ar: TPDFArray;
+ lXRef: TPDFXRef;
+ s: string;
+begin
+ an := Pages[APageNum].Annots[AnnotNum];
+ lXRef := CreateGlobalXRef;
+ lDict := lXRef.Dict;
+ lDict.AddName('Type', 'Annot');
+ lDict.AddName('Subtype', 'Link');
+ { Invert link on click - PDF 1.3 spec pg.410. It is the default value, but
+ some PDF viewers don't apply that if not explicity specified. }
+ lDict.AddName('H', 'I');
+
+ { Border array consists of 3 or 4 values. The first three elements describe
+ the horizontal corner radius, the vertical corner radius and the border
+ width. A 0 border width means no border is drawn. The optional 4th element
+ is an array defining a dash pattern. For example: /Border [16 16 2 [2 1]] }
+ ar := CreateArray;
+ lDict.AddElement('Border', ar);
+ if an.FBorder then
+ s := '1'
+ else
+ s := '0';
+ ar.AddFreeFormArrayValues('0 0 ' + s);
+
+ ar := CreateArray;
+ lDict.AddElement('Rect', ar);
+ s := ar.FloatStr(an.FLeft);
+ s := s + ' ' + ar.FloatStr(an.FBottom);
+ s := s + ' ' + ar.FloatStr(an.FLeft + an.FWidth);
+ s := s + ' ' + ar.FloatStr(an.FBottom + an.FHeight);
+ ar.AddFreeFormArrayValues(s);
+
+ ADict := CreateDictionary;
+ lDict.AddElement('A', ADict);
+ ADict.AddName('Type', 'Action');
+ ADict.AddName('S', 'URI');
+ ADict.AddString('URI', an.FURI);
+
+ 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;
+ i: integer;
begin
Contents:=CreateGlobalXRef;
Contents.FStream:=CreateStream(False);
Result:=GlobalXRefCount-1;
- GlobalXrefs[GlobalXRefCount-2].Dict.AddReference('Contents',Result);
+ { TODO: This is terrible code. See if we can make a better plan getting hold
+ of the reference to the Page dictionary. }
+ i := 2 + Pages[APageNum].Annots.Count; // + GetTotalAnnotsCount;
+ GlobalXrefs[GlobalXRefCount-i].Dict.AddReference('Contents',Result);
end;
procedure TPDFDocument.CreatePageStream(APage : TPDFPage; PageNum: integer);
@@ -3553,46 +4832,39 @@ begin
Result:=FGlobalXRefs.Add(AXRef);
end;
-
function TPDFDocument.GlobalXRefByName(const AName: String): TPDFXRef;
begin
Result:=FindGlobalXRef(AName);
if Result=Nil then
- Raise EPDF.CreateFmt(SErrNoGlobalDict,[AName]);
+ Raise EPDF.CreateFmt(rsErrNoGlobalDict,[AName]);
end;
-Function TPDFDocument.CreateLineStyles : TPDFLineStyleDefs;
-
+function TPDFDocument.CreateLineStyles: TPDFLineStyleDefs;
begin
Result:=TPDFLineStyleDefs.Create(TPDFLineStyleDef);
end;
-Function TPDFDocument.CreateSectionList : TPDFSectionList;
-
+function TPDFDocument.CreateSectionList: TPDFSectionList;
begin
Result:=TPDFSectionList.Create(TPDFSection)
end;
-Function TPDFDocument.CreateFontDefs : TPDFFontDefs;
-
+function TPDFDocument.CreateFontDefs: TPDFFontDefs;
begin
Result := TPDFFontDefs.Create(TPDFFont);
end;
-Function TPDFDocument.CreatePDFInfos : TPDFInfos;
-
+function TPDFDocument.CreatePDFInfos: TPDFInfos;
begin
Result:=TPDFInfos.Create;
end;
-Function TPDFDocument.CreatePDFImages : TPDFImages;
-
+function TPDFDocument.CreatePDFImages: TPDFImages;
begin
Result:=TPDFImages.Create(Self,TPDFImageItem);
end;
-Function TPDFDocument.CreatePDFPages : TPDFPages;
-
+function TPDFDocument.CreatePDFPages: TPDFPages;
begin
Result:=TPDFPages.Create(Self);
end;
@@ -3613,11 +4885,13 @@ begin
FDefaultOrientation:=ppoPortrait;
FZoomValue:='100';
FOptions := [poCompressFonts, poCompressImages];
+ FUnitOfMeasure:=uomMillimeters;
end;
procedure TPDFDocument.StartDocument;
begin
+ Reset;
CreateRefTable;
CreateTrailer;
FCatalogue:=CreateCatalogEntry;
@@ -3627,6 +4901,18 @@ begin
FontDirectory:=ExtractFilePath(ParamStr(0));
end;
+procedure TPDFDocument.Reset;
+begin
+ FLineStyleDefs.Clear;
+ FFonts.Clear;
+ FImages.Clear;
+ FFontFiles.Clear;
+ FreeAndNil(FPages);
+ FPages:=CreatePDFPages;
+ FreeAndNil(FSections);
+ FSections:=CreateSectionList;
+end;
+
destructor TPDFDocument.Destroy;
begin
@@ -3764,7 +5050,7 @@ begin
Arr.AddItem(CreateReference(GLobalXRefCount-1));
Arr.AddItem(CreateName('XYZ null null '+TPDFObject.FloatStr(StrToInt(FZoomValue) / 100), False));
end;
- PageNum:=CreateContentsEntry; // pagenum = object number in the pdf file
+ PageNum:=CreateContentsEntry(k); // pagenum = object number in the pdf file
CreatePageStream(S.Pages[k],PageNum);
if (Sections.Count>1) and (poOutline in Options) then
begin
@@ -3791,40 +5077,52 @@ 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
+
+ if IsStandardPDFFont(FontName) then
+ CreateStdFont(FontName, NumFont)
+ else if LoadFont(Fonts[i]) then
begin
- CreateStdFont(FontName, NumFont);
+ if poSubsetFont in Options then
+ Fonts[i].GenerateSubsetFont;
+ CreateTtfFont(NumFont);
end
- else if LoadFont(Fonts[i]) then
- CreateTtfFont(NumFont)
else
CreateTp1Font(NumFont); // not implemented yet
+
Inc(NumFont);
- end;
+ end;
end;
procedure TPDFDocument.CreateImageEntries;
-
Var
I : Integer;
-
begin
for i:=0 to Images.Count-1 do
CreateImageEntry(Images[i].Width,Images[i].Height,i);
end;
-procedure TPDFDocument.SaveToStream(const AStream: TStream);
+procedure TPDFDocument.CreateAnnotEntries(const APageNum: integer; const APageDict: TPDFDictionary);
+var
+ i: integer;
+ refnum: integer;
+ ar: TPDFArray;
+begin
+ if GetTotalAnnotsCount = 0 then
+ Exit;
+ ar := CreateArray;
+ APageDict.AddElement('Annots', ar);
+ for i := 0 to Pages[APageNum].Annots.Count-1 do
+ begin
+ refnum := CreateAnnotEntry(APageNum, i);
+ ar.AddItem(CreateReference(refnum));
+ end;
+end;
+procedure TPDFDocument.SaveToStream(const AStream: TStream);
var
i, XRefPos: integer;
-
begin
CreateSectionsOutLine;
CreateFontEntries;
@@ -3854,25 +5152,48 @@ begin
TPDFObject.WriteString(PDF_FILE_END, AStream);
end;
-function TPDFDocument.CreateEmbeddedFont(AFontIndex, AFontSize : Integer): TPDFEmbeddedFont;
+procedure TPDFDocument.SaveToFile(const AFileName: String);
+
+Var
+ F : TFileStream;
+
begin
- Result:=TPDFEmbeddedFont.Create(Self,AFontIndex,IntToStr(AFontSize))
+ F:=TFileStream.Create(AFileName,fmCreate);
+ try
+ SaveToStream(F);
+ finally
+ F.Free;
+ end;
end;
-function TPDFDocument.CreateText(X, Y: TPDFFloat; AText: AnsiString; const AFontIndex: integer): TPDFText;
+function TPDFDocument.IsStandardPDFFont(AFontName: string): boolean;
begin
- {$ifdef gdebug}
- writeln('TPDFDocument.CreateText( AnsiString ) ', AFontIndex);
- {$endif}
- Result:=TPDFText.Create(Self,X,Y,AText,AFontIndex);
+ { 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: UTF8String; const AFontIndex: integer): TPDFUTF8Text;
+function TPDFDocument.CreateEmbeddedFont(const APage: TPDFPage; AFontIndex, AFontSize: Integer): TPDFEmbeddedFont;
begin
- {$ifdef gdebug}
- writeln('TPDFDocument.CreateText( UTF8String ) ', AFontIndex);
- {$endif}
- Result := TPDFUTF8Text.Create(Self,X,Y,AText,AFontIndex);
+ Result:=TPDFEmbeddedFont.Create(Self, APage, AFontIndex, IntToStr(AFontSize))
+end;
+
+function TPDFDocument.CreateText(X, Y: TPDFFloat; AText: AnsiString; const AFont: TPDFEmbeddedFont;
+ const ADegrees: single; const AUnderline: boolean; const AStrikethrough: boolean): TPDFText;
+begin
+ 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;
@@ -3880,6 +5201,12 @@ begin
Result:=TPDFRectangle.Create(Self,X,Y,W,H,ALineWidth,AFill, AStroke);
end;
+function TPDFDocument.CreateRoundedRectangle(const X, Y, W, H, ARadius, ALineWidth: TPDFFloat;
+ const AFill, AStroke: Boolean): TPDFRoundedRectangle;
+begin
+ Result := TPDFRoundedRectangle.Create(Self, X, Y, W, H, ARadius, ALineWidth, AFill, AStroke);
+end;
+
function TPDFDocument.CreateColor(AColor: TARGBColor; AStroke: Boolean): TPDFColor;
begin
Result:=TPDFColor.Create(Self,AStroke,AColor);
@@ -3910,9 +5237,9 @@ begin
Result := TPDFUTF8String.Create(self, AValue, AFontIndex);
end;
-function TPDFDocument.CreateLineStyle(APenStyle: TPDFPenStyle): TPDFLineStyle;
+function TPDFDocument.CreateLineStyle(APenStyle: TPDFPenStyle; const ALineWidth: TPDFFloat): TPDFLineStyle;
begin
- Result:=TPDFLineStyle.Create(Self,APenStyle,0)
+ Result := TPDFLineStyle.Create(Self, APenStyle, 0, ALineWidth);
end;
function TPDFDocument.CreateName(AValue: String; const AMustEscape: boolean = True): TPDFName;
@@ -3946,7 +5273,7 @@ begin
Result:=TPDFImage.Create(Self,ALeft,ABottom,AWidth,AHeight,ANumber);
end;
-function TPDFDocument.AddFont(AName: String; AColor : TARGBColor = clBlack): Integer;
+function TPDFDocument.AddFont(AName: String): Integer;
var
F: TPDFFont;
i: integer;
@@ -3962,12 +5289,11 @@ begin
end;
F := Fonts.AddFontDef;
F.Name := AName;
- F.Color := AColor;
F.IsStdFont := True;
Result := Fonts.Count-1;
end;
-function TPDFDocument.AddFont(AFontFile: String; AName: String; AColor: TARGBColor): Integer;
+function TPDFDocument.AddFont(AFontFile: String; AName: String): Integer;
var
F: TPDFFont;
i: integer;
@@ -3991,7 +5317,6 @@ begin
lFName := IncludeTrailingPathDelimiter(FontDirectory)+AFontFile;
F.FontFile := lFName;
F.Name := AName;
- F.Color := AColor;
F.IsStdFont := False;
Result := Fonts.Count-1;
end;
@@ -4011,5 +5336,6 @@ begin
end;
+
end.
diff --git a/packages/fcl-pdf/src/fpttf.pp b/packages/fcl-pdf/src/fpttf.pp
index ba2bee7677..d4ca15dcd9 100644
--- a/packages/fcl-pdf/src/fpttf.pp
+++ b/packages/fcl-pdf/src/fpttf.pp
@@ -1,11 +1,22 @@
{
+ This file is part of the Free Component Library (FCL)
+ Copyright (c) 2015 by Graeme Geldenhuys
+
Description:
This is a homegrown font cache. The fpReport reports can reference
a font by its name. The job of the font cache is to look through
its cached fonts to match the font name, and which *.ttf file it
relates too. The reporting code can then extract font details
correctly (eg: font width, height etc).
-}
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
unit fpTTF;
{$mode objfpc}{$H+}
@@ -38,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;
@@ -52,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. }
@@ -67,6 +83,7 @@ type
TFPFontCacheList = class(TObject)
private
+ FBuildFontCacheIgnoresErrors: Boolean;
FList: TObjectList;
FSearchPath: TStringList;
FDPI: integer;
@@ -85,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;
@@ -95,6 +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 BuildFontCacheIgnoresErrors : Boolean Read FBuildFontCacheIgnoresErrors Write FBuildFontCacheIgnoresErrors;
end;
@@ -102,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;
@@ -121,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;
@@ -192,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;
@@ -240,6 +301,7 @@ var
s: string;
{$ENDIF}
begin
+ DoLoadFileInfo;
Result := 0;
if Length(AStr) = 0 then
Exit;
@@ -281,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);
@@ -294,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
@@ -309,13 +372,18 @@ begin
if (lowercase(ExtractFileExt(s)) = '.ttf') or
(lowercase(ExtractFileExt(s)) = '.otf') then
begin
- lFont := TFPFontCacheItem.Create(AFontPath + s);
- Add(lFont);
+ try
+ lFont := TFPFontCacheItem.Create(AFontPath + s);
+ Add(lFont);
+ except
+ 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);
@@ -401,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/src/fpttfsubsetter.pp b/packages/fcl-pdf/src/fpttfsubsetter.pp
new file mode 100644
index 0000000000..1bf107b6f2
--- /dev/null
+++ b/packages/fcl-pdf/src/fpttfsubsetter.pp
@@ -0,0 +1,1259 @@
+{
+ This file is part of the Free Component Library (FCL)
+ Copyright (c) 2016 by Graeme Geldenhuys
+
+ This unit creates a new TTF subset font file, reducing the file
+ size in the process. This is primarily so the new font file can
+ be embedded in PDF documents.
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit fpTTFSubsetter;
+
+{$mode objfpc}{$H+}
+
+{ $R+}
+
+// enable this define for more verbose output
+{.$define gdebug}
+
+interface
+
+uses
+ Classes,
+ SysUtils,
+ contnrs,
+ fpparsettf,
+ FPFontTextMapping;
+
+type
+ ETTFSubsetter = class(Exception);
+
+ TArrayUInt32 = array of UInt32;
+
+ // forward declaration
+ TGIDList = class;
+ TGIDListEnumerator = class;
+
+
+ TFontSubsetter = class(TObject)
+ private
+ FPrefix: string;
+ FHasAddedCompoundReferences: boolean; // one glyph made up of multiple glyphs
+ FKeepTables: TStrings;
+ FFontInfo: TTFFileInfo;
+ FGlyphIDList: TTextMappingList;
+ FStream: TFileStream; // original TTF file
+ FGlyphLocations: array of UInt32;
+ FGlyphIDs: TGIDList;
+ function Int32HighestOneBit(const AValue: integer): integer;
+ function Int32Log2(const AValue: integer): integer;
+ function ToUInt32(const AHigh, ALow: UInt32): UInt32;
+ function ToUInt32(const ABytes: AnsiString): UInt32;
+ function GetRawTable(const ATableName: AnsiString): TMemoryStream;
+ function WriteFileHeader(AOutStream: TStream; const nTables: integer): uint32;
+ function WriteTableHeader(AOutStream: TStream; const ATag: AnsiString; const AOffset: UInt32; const AData: TStream): int64;
+ function GetNewGlyphId(const OldGid: integer): Integer;
+ procedure WriteTableBodies(AOutStream: TStream; const ATables: TStringList);
+ procedure UpdateOrigGlyphIDList;
+ // AGlyphID is the original GlyphID in the original TTF file
+ function GetCharIDfromGlyphID(const AGlyphID: uint32): uint32;
+ { Copy glyph data as-is for a specific glyphID. }
+ function GetRawGlyphData(const AGlyphID: UInt16): TMemoryStream;
+ procedure LoadLocations;
+ // Stream writing functions.
+ procedure WriteInt16(AStream: TStream; const AValue: Int16); inline;
+ procedure WriteUInt16(AStream: TStream; const AValue: UInt16); inline;
+ procedure WriteInt32(AStream: TStream; const AValue: Int32); inline;
+ procedure WriteUInt32(AStream: TStream; const AValue: UInt32); inline;
+ function ReadInt16(AStream: TStream): Int16; inline;
+ function ReadUInt32(AStream: TStream): UInt32; inline;
+ function ReadUInt16(AStream: TStream): UInt16; inline;
+
+ procedure AddCompoundReferences;
+ function buildHeadTable: TStream;
+ function buildHheaTable: TStream;
+ function buildMaxpTable: TStream;
+ function buildFpgmTable: TStream;
+ function buildPrepTable: TStream;
+ function buildCvtTable: TStream;
+ function buildGlyfTable(var newOffsets: TArrayUInt32): TStream;
+ function buildLocaTable(var newOffsets: TArrayUInt32): TStream;
+ function buildCmapTable: TStream;
+ function buildHmtxTable: TStream;
+ public
+ constructor Create(const AFont: TTFFileInfo; const AGlyphIDList: TTextMappingList);
+ constructor Create(const AFont: TTFFileInfo);
+ destructor Destroy; override;
+ procedure SaveToFile(const AFileName: String);
+ procedure SaveToStream(const AStream: TStream);
+ // Add the given Unicode codepoint to the subset.
+ procedure Add(const ACodePoint: uint32);
+ // The prefix to add to the font's PostScript name.
+ property Prefix: string read FPrefix write FPrefix;
+ end;
+
+
+ TGIDItem = class(TObject)
+ private
+ FGID: integer;
+ FGlyphData: TMemoryStream;
+ FIsCompoundGlyph: boolean;
+ FNewGID: integer;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ property IsCompoundGlyph: boolean read FIsCompoundGlyph write FIsCompoundGlyph;
+ property GID: integer read FGID write FGID;
+ property GlyphData: TMemoryStream read FGlyphData write FGlyphData;
+ property NewGID: integer read FNewGID write FNewGID;
+ end;
+
+
+ TGIDList = class(TObject)
+ private
+ FList: TFPObjectList;
+ function GetCount: integer;
+ function GetItems(i: integer): TGIDItem;
+ procedure SetItems(i: integer; const AValue: TGIDItem);
+ public
+ constructor Create;
+ destructor Destroy; override;
+ function Add(const GID: Integer): integer; overload;
+ function Add(const AObject: TGIDItem): integer; overload;
+ procedure Clear;
+ function Contains(const GID: integer): boolean;
+ function GetEnumerator: TGIDListEnumerator;
+ function GetNewGlyphID(const OriginalGID: integer): integer;
+ procedure Sort;
+ property Count: integer read GetCount;
+ property Items[i: integer]: TGIDItem read GetItems write SetItems; default;
+ end;
+
+
+ TGIDListEnumerator = class(TObject)
+ private
+ FIndex: Integer;
+ FList: TGIDList;
+ public
+ constructor Create(AList: TGIDList);
+ function GetCurrent: TGIDItem;
+ function MoveNext: Boolean;
+ property Current: TGIDItem read GetCurrent;
+ end;
+
+
+
+
+implementation
+
+uses
+ math;
+
+resourcestring
+ rsErrFontInfoNotAssigned = 'FontInfo was not assigned';
+ rsErrFailedToReadFromStream = 'Failed to read from file stream';
+ rsErrCantFindFontFile = 'Can''t find the actual TTF font file.';
+ rsErrGlyphLocationsNotLoaded = 'Glyph Location data has not been loaded yet.';
+
+const
+ PAD_BUF: array[ 1..3 ] of Byte = ( $0, $0, $0 );
+
+
+{ TFontSubsetter }
+
+{ The method simply returns the int value with a single one-bit, in the position
+ of the highest-order one-bit in the specified value, or zero if the specified
+ value is itself equal to zero. }
+function TFontSubsetter.Int32HighestOneBit(const AValue: integer): integer;
+var
+ i: integer;
+begin
+ i := AValue;
+ i := i or (i shr 1);
+ i := i or (i shr 2);
+ i := i or (i shr 4);
+ i := i or (i shr 8);
+ i := i or (i shr 16);
+// i := i or (i shr 32);
+ Result := i - (i shr 1);
+end;
+
+function TFontSubsetter.Int32Log2(const AValue: integer): integer;
+begin
+ if AValue <= 0 then
+ raise Exception.Create('Illegal argument');
+// Result := 31 - Integer.numberOfLeadingZeros(n);
+
+ Result := Floor(Log10(AValue) / Log10(2));
+end;
+
+function TFontSubsetter.ToUInt32(const AHigh, ALow: UInt32): UInt32;
+begin
+ result := ((AHigh and $FFFF) shl 16) or (ALow and $FFFF);
+end;
+
+function TFontSubsetter.ToUInt32(const ABytes: AnsiString): UInt32;
+var
+ b: array of Byte absolute ABytes;
+begin
+ Result := (b[0] and $FF) shl 24
+ or (b[1] and $FF) shl 16
+ or (b[2] and $FF) shl 8
+ or (b[3] and $FF);
+end;
+
+function TFontSubsetter.GetRawTable(const ATableName: AnsiString): TMemoryStream;
+var
+ lEntry: TTableDirectoryEntry;
+begin
+ Result := nil;
+ FillMem(@lEntry, SizeOf(TTableDirectoryEntry), 0);
+ if not FFontInfo.GetTableDirEntry(ATableName, lEntry) then
+ Exit;
+
+ Result := TMemoryStream.Create;
+ FStream.Seek(lEntry.offset, soFromBeginning);
+ if Result.CopyFrom(FStream, lEntry.Length) <> lEntry.Length then
+ raise ETTF.Create('GetRawTable: ' + rsErrFailedToReadFromStream);
+end;
+
+{ AOutStream: the data output stream.
+ nTables: the number of font tables.
+ result: the file offset of the first TTF table to write. }
+function TFontSubsetter.WriteFileHeader(AOutStream: TStream; const nTables: integer): uint32;
+var
+ mask: integer;
+ searchRange: integer;
+ entrySelector: integer;
+ rangeShift: integer;
+begin
+ WriteUInt32(AOutStream, $00010000);
+ WriteUInt16(AOutStream, nTables);
+
+ mask := Int32HighestOneBit(nTables);
+ searchRange := mask * 16;
+ WriteUInt16(AOutStream, searchRange);
+
+ entrySelector := Int32Log2(mask);
+ WriteUInt16(AOutStream, entrySelector);
+
+ rangeShift := 16 * nTables - searchRange;
+ WriteUInt16(AOutStream, rangeShift);
+
+ result := $00010000 + ToUInt32(nTables, searchRange) + ToUInt32(entrySelector, rangeShift);
+end;
+
+function TFontSubsetter.WriteTableHeader(AOutStream: TStream; const ATag: AnsiString; const AOffset: UInt32;
+ const AData: TStream): int64;
+var
+ checksum: Int64;
+ n: integer;
+ lByte: Byte;
+begin
+ AData.Position := 0;
+ checksum := 0;
+
+ for n := 0 to AData.Size-1 do
+ begin
+ lByte := AData.ReadByte;
+ checksum := checksum + (((lByte and $FF) shl 24) - n mod 4 * 8);
+ end;
+ checksum := checksum and $FFFFFFFF;
+
+ AOutStream.WriteBuffer(Pointer(ATag)^, 4); // Tag is always 4 bytes - written as-is, no NtoBE() required
+ WriteUInt32(AOutStream, checksum);
+ WriteUInt32(AOutStream, AOffset);
+ WriteUInt32(AOutStream, AData.Size);
+
+ {$ifdef gdebug}
+ writeln(Format('tag: "%s" CRC: %8.8x offset: %8.8x (%2:7d bytes) size: %8.8x (%3:7d bytes)', [ATag, checksum, AOffset, AData.Size]));
+ {$endif}
+
+ // account for the checksum twice, once for the header field, once for the content itself
+ Result := ToUInt32(ATag) + checksum + checksum + AOffset + AData.Size;
+end;
+
+function TFontSubsetter.GetNewGlyphId(const OldGid: integer): Integer;
+var
+ itm: TGIDItem;
+begin
+ result := -1;
+ for itm in FGlyphIDs do
+ begin
+ if itm.GID = OldGID then
+ begin
+ Result := itm.NewGID;
+ exit;
+ end;
+ end;
+end;
+
+procedure TFontSubsetter.WriteTableBodies(AOutStream: TStream; const ATables: TStringList);
+var
+ i: integer;
+ n: uint64;
+ lData: TStream;
+begin
+ for i := 0 to ATables.Count-1 do
+ begin
+ lData := TStream(ATables.Objects[i]);
+ if lData <> nil then
+ begin
+ lData.Position := 0;
+ n := lData.Size;
+ AOutStream.CopyFrom(lData, lData.Size);
+ end;
+ if (n mod 4) <> 0 then
+ begin
+ {$ifdef gdebug}
+ writeln('Padding applied at the end of ', ATables[i], ': ', 4 - (n mod 4), ' byte(s)');
+ {$endif}
+ AOutStream.WriteBuffer(PAD_BUF, 4 - (n mod 4));
+ end;
+ end;
+end;
+
+{ This updates the original GlyphIDList passed in to the constructor - normally
+ done by fcl-pdf. This allows fcl-pdf to use the NewGlyphID values in its
+ generated PDF output. }
+procedure TFontSubsetter.UpdateOrigGlyphIDList;
+var
+ i: integer;
+ itm: TGIDItem;
+begin
+ for itm in FGlyphIDs do
+ begin
+ for i := 0 to FGlyphIDList.Count-1 do
+ begin
+ if FGlyphIDList[i].GlyphID = itm.GID then
+ begin
+ FGlyphIDList[i].NewGlyphID := itm.NewGID;
+ break;
+ end;
+ end;
+ end;
+end;
+
+function TFontSubsetter.GetCharIDfromGlyphID(const AGlyphID: uint32): uint32;
+var
+ i: integer;
+begin
+ Result := 0;
+ for i := 0 to Length(FFontInfo.Chars)-1 do
+ if FFontInfo.Chars[i] = AGlyphID then
+ begin
+ Result := i;
+ Exit;
+ end;
+end;
+
+function TFontSubsetter.GetRawGlyphData(const AGlyphID: UInt16): TMemoryStream;
+var
+ lGlyf: TTableDirectoryEntry;
+ lSize: UInt16;
+begin
+ Result := nil;
+ if Length(FGlyphLocations) < 2 then
+ raise ETTF.Create(rsErrGlyphLocationsNotLoaded);
+ FillMem(@lGlyf, SizeOf(TTableDirectoryEntry), 0);
+ FFontInfo.GetTableDirEntry(TTFTableNames[ttglyf], lGlyf);
+
+ lSize := FGlyphLocations[AGlyphID+1] - FGlyphLocations[AGlyphID];
+ Result := TMemoryStream.Create;
+ if lSize > 0 then
+ begin
+ FStream.Seek(lGlyf.offset + FGlyphLocations[AGlyphID], soFromBeginning);
+ if Result.CopyFrom(FStream, lSize) <> lSize then
+ raise ETTF.Create('GetRawGlyphData: ' + rsErrFailedToReadFromStream)
+ else
+ Result.Position := 0;
+ end;
+end;
+
+procedure TFontSubsetter.LoadLocations;
+var
+ lLocaEntry: TTableDirectoryEntry;
+ lGlyf: TTableDirectoryEntry;
+ ms: TMemoryStream;
+ numLocations: integer;
+ n: integer;
+begin
+ FillMem(@lGlyf, SizeOf(TTableDirectoryEntry), 0);
+ FillMem(@lLocaEntry, SizeOf(TTableDirectoryEntry), 0);
+
+ FFontInfo.GetTableDirEntry(TTFTableNames[ttglyf], lGlyf);
+ if FFontInfo.GetTableDirEntry(TTFTableNames[ttloca], lLocaEntry) then
+ begin
+ ms := TMemoryStream.Create;
+ try
+ FStream.Seek(lLocaEntry.offset, soFromBeginning);
+ if ms.CopyFrom(FStream, lLocaEntry.Length) <> lLocaEntry.Length then
+ raise ETTF.Create('LoadLocations: ' + rsErrFailedToReadFromStream)
+ else
+ ms.Position := 0;
+
+ if FFontInfo.Head.IndexToLocFormat = 0 then
+ begin
+ // Short offsets
+ numLocations := lLocaEntry.Length shr 1;
+ {$IFDEF gDEBUG}
+ Writeln('Number of Glyph locations ( 16 bits offsets ): ', numLocations );
+ {$ENDIF}
+ SetLength(FGlyphLocations, numLocations);
+ for n := 0 to numLocations-1 do
+ FGlyphLocations[n] := BEtoN(ms.ReadWord) * 2;
+ end
+ else
+ begin
+ // Long offsets
+ numLocations := lLocaEntry.Length shr 2;
+ {$IFDEF gDEBUG}
+ Writeln('Number of Glyph locations ( 32 bits offsets ): ', numLocations );
+ {$ENDIF}
+ SetLength(FGlyphLocations, numLocations);
+ for n := 0 to numLocations-1 do
+ FGlyphLocations[n] := BEtoN(ms.ReadDWord);
+ end;
+ finally
+ ms.Free;
+ end;
+ end
+ else
+ begin
+ {$ifdef gDEBUG}
+ Writeln('WARNING: ''loca'' table is not found.');
+ {$endif}
+ end;
+end;
+
+procedure TFontSubsetter.WriteInt16(AStream: TStream; const AValue: Int16);
+begin
+ AStream.WriteBuffer(NtoBE(AValue), 2);
+end;
+
+procedure TFontSubsetter.WriteUInt16(AStream: TStream; const AValue: UInt16);
+begin
+ AStream.WriteWord(NtoBE(AValue));
+end;
+
+procedure TFontSubsetter.WriteInt32(AStream: TStream; const AValue: Int32);
+begin
+ AStream.WriteBuffer(NtoBE(AValue), 4);
+end;
+
+procedure TFontSubsetter.WriteUInt32(AStream: TStream; const AValue: UInt32);
+begin
+ AStream.WriteDWord(NtoBE(AValue));
+end;
+
+function TFontSubsetter.ReadInt16(AStream: TStream): Int16;
+begin
+ Result:=Int16(ReadUInt16(AStream));
+end;
+
+function TFontSubsetter.ReadUInt32(AStream: TStream): UInt32;
+begin
+ Result:=0;
+ AStream.ReadBuffer(Result,SizeOf(Result));
+ Result:=BEtoN(Result);
+end;
+
+function TFontSubsetter.ReadUInt16(AStream: TStream): UInt16;
+begin
+ Result:=0;
+ AStream.ReadBuffer(Result,SizeOf(Result));
+ Result:=BEtoN(Result);
+end;
+
+procedure TFontSubsetter.AddCompoundReferences;
+var
+ GlyphIDsToAdd: TStringList;
+ n: integer;
+ gs: TMemoryStream;
+ buf: TGlyphHeader;
+ i: integer;
+ flags: uint16;
+ glyphIndex: uint16;
+ hasNested: boolean;
+begin
+ if FHasAddedCompoundReferences then
+ Exit;
+ FHasAddedCompoundReferences := True;
+
+ LoadLocations;
+
+ repeat
+ GlyphIDsToAdd := TStringList.Create;
+ GlyphIDsToAdd.Duplicates := dupIgnore;
+ GlyphIDsToAdd.Sorted := True;
+
+ for n := 0 to FGlyphIDs.Count-1 do
+ begin
+ if not Assigned(FGlyphIDs[n].GlyphData) then
+ FGlyphIDs[n].GlyphData := GetRawGlyphData(FGlyphIDs[n].GID);
+ gs := FGlyphIDs[n].GlyphData;
+ gs.Position := 0;
+
+ if gs.Size > 0 then
+ begin
+ FillMem(@buf, SizeOf(TGlyphHeader), 0);
+ gs.ReadBuffer(buf, SizeOf(Buf));
+ {$IFDEF gDEBUG}
+ writeln(' glyph data size: ', gs.Size);
+ {$ENDIF}
+
+ if buf.numberOfContours = -1 then
+ begin
+ FGlyphIDs[n].IsCompoundGlyph := True;
+ {$IFDEF gDEBUG}
+ writeln(' numberOfContours: ', buf.numberOfContours);
+ {$ENDIF}
+ repeat
+ flags := ReadUInt16(gs);
+ glyphIndex := ReadUInt16(gs);
+ // find compound glyph IDs and add them to the GlyphIDsToAdd list
+ if not FGlyphIDs.Contains(glyphIndex) then
+ begin
+ {$IFDEF gDEBUG}
+ writeln(Format(' glyphIndex: %.4x (%0:d) ', [glyphIndex]));
+ {$ENDIF}
+ GlyphIDsToAdd.Add(IntToStr(glyphIndex));
+ end;
+ // ARG_1_AND_2_ARE_WORDS
+ if (flags and (1 shl 0)) <> 0 then
+ ReadUInt32(gs)
+ else
+ ReadUInt16(gs);
+ // WE_HAVE_A_TWO_BY_TWO
+ if (flags and (1 shl 7)) <> 0 then
+ begin
+ ReadUInt32(gs);
+ ReadUInt32(gs);
+ end
+ // WE_HAVE_AN_X_AND_Y_SCALE
+ else if (flags and (1 shl 6)) <> 0 then
+ begin
+ ReadUInt32(gs);
+ end
+ // WE_HAVE_A_SCALE
+ else if (flags and (1 shl 3)) <> 0 then
+ begin
+ ReadUInt16(gs);
+ end;
+
+ until (flags and (1 shl 5)) = 0; // MORE_COMPONENTS
+ end; { if buf.numberOfContours = -1 }
+ end; { if gs.Size > 0 }
+ end; { for n ... FGlyphIDs.Count-1 }
+
+ if GlyphIDsToAdd.Count > 0 then
+ begin
+ for i := 0 to GlyphIDsToAdd.Count-1 do
+ begin
+ glyphIndex := StrToInt(GlyphIDsToAdd[i]);
+ FGlyphIDs.Add(glyphIndex);
+ end;
+ end;
+ hasNested := GlyphIDsToAdd.Count > 0;
+ {$IFDEF gDEBUG}
+ if hasNested then
+ writeln('------------------');
+ {$ENDIF}
+ FreeAndNil(GlyphIDsToAdd);
+ until (hasNested = false);
+end;
+
+function TFontSubsetter.buildHeadTable: TStream;
+var
+ t: THead;
+ rec: THead;
+ i: Integer;
+begin
+ Result := TMemoryStream.Create;
+
+ t := FFontInfo.Head;
+ FillMem(@rec, SizeOf(THead), 0);
+ rec.FileVersion.Version := NtoBE(t.FileVersion.Version);
+ rec.FontRevision.Version := NtoBE(t.FontRevision.Version);
+ rec.CheckSumAdjustment := 0;
+ rec.MagicNumber := NtoBE(t.MagicNumber);
+ rec.Flags := NtoBE(t.Flags);
+ rec.UnitsPerEm := NtoBE(t.UnitsPerEm);
+ rec.Created := NtoBE(t.Created);
+ rec.Modified := NtoBE(t.Modified);
+ For i := 0 to 3 do
+ rec.BBox[i] := NtoBE(t.BBox[i]);
+ rec.MacStyle := NtoBE(t.MacStyle);
+ rec.LowestRecPPEM := NtoBE(t.LowestRecPPEM);
+ rec.FontDirectionHint := NtoBE(t.FontDirectionHint);
+ // force long format of 'loca' table. ie: 'loca' table offsets are in 4-Bytes each, not Words.
+ rec.IndexToLocFormat := NtoBE(Int16(1)); //NtoBE(t.IndexToLocFormat);
+ rec.glyphDataFormat := NtoBE(t.glyphDataFormat);
+
+ Result.WriteBuffer(rec, SizeOf(THead));
+end;
+
+function TFontSubsetter.buildHheaTable: TStream;
+var
+ t: THHead;
+ rec: THHead;
+ hmetrics: UInt16;
+begin
+ Result := TMemoryStream.Create;
+
+ t := FFontInfo.HHead;
+ FillMem(@rec, SizeOf(THHead), 0);
+ rec.TableVersion.Version := NtoBE(t.TableVersion.Version);
+ rec.Ascender := NtoBE(t.Ascender);
+ rec.Descender := NtoBE(t.Descender);
+ rec.LineGap := NtoBE(t.LineGap);
+ rec.AdvanceWidthMax := NtoBE(t.AdvanceWidthMax);
+ rec.MinLeftSideBearing := NtoBE(t.MinLeftSideBearing);
+ rec.MinRightSideBearing := NtoBE(t.MinRightSideBearing);
+ rec.XMaxExtent := NtoBE(t.XMaxExtent);
+ rec.CaretSlopeRise := NtoBE(t.CaretSlopeRise);
+ rec.CaretSlopeRun := NtoBE(t.CaretSlopeRun);
+ rec.caretOffset := NtoBE(t.caretOffset);
+ rec.metricDataFormat := NtoBE(t.metricDataFormat);
+// rec.numberOfHMetrics := NtoBE(t.numberOfHMetrics);
+
+ hmetrics := FGlyphIDs.Count;
+ if (FGlyphIDs.Items[FGlyphIDs.Count-1].GID >= t.numberOfHMetrics) and (not FGlyphIDs.Contains(t.numberOfHMetrics-1)) then
+ inc(hmetrics);
+ rec.numberOfHMetrics := NtoBE(hmetrics);
+
+ Result.WriteBuffer(rec, SizeOf(THHead));
+end;
+
+function TFontSubsetter.buildMaxpTable: TStream;
+var
+ t: TMaxP;
+ rec: TMaxP;
+ lCount: word;
+begin
+ Result := TMemoryStream.Create;
+
+ t := FFontInfo.MaxP;
+ FillMem(@rec, SizeOf(TMaxP), 0);
+ rec.VersionNumber.Version := NtoBE(t.VersionNumber.Version);
+
+ lCount := FGlyphIDs.Count;
+ rec.numGlyphs := NtoBE(lCount);
+
+ rec.maxPoints := NtoBE(t.maxPoints);
+ rec.maxContours := NtoBE(t.maxContours);
+ rec.maxCompositePoints := NtoBE(t.maxCompositePoints);
+ rec.maxCompositeContours := NtoBE(t.maxCompositeContours);
+ rec.maxZones := NtoBE(t.maxZones);
+ rec.maxTwilightPoints := NtoBE(t.maxTwilightPoints);
+ rec.maxStorage := NtoBE(t.maxStorage);
+ rec.maxFunctionDefs := NtoBE(t.maxFunctionDefs);
+ rec.maxInstructionDefs := NtoBE(t.maxInstructionDefs);
+ rec.maxStackElements := NtoBE(t.maxStackElements);
+ rec.maxSizeOfInstructions := NtoBE(t.maxSizeOfInstructions);
+ rec.maxComponentElements := NtoBE(t.maxComponentElements);
+ rec.maxComponentDepth := NtoBE(t.maxComponentDepth);
+
+ Result.WriteBuffer(rec, SizeOf(TMaxP));
+end;
+
+function TFontSubsetter.buildFpgmTable: TStream;
+begin
+ Result := GetRawTable('fpgm');
+ Result.Position := 0;
+end;
+
+function TFontSubsetter.buildPrepTable: TStream;
+begin
+ Result := GetRawTable('prep');
+ Result.Position := 0;
+end;
+
+function TFontSubsetter.buildCvtTable: TStream;
+begin
+ Result := GetRawTable('cvt ');
+ Result.Position := 0;
+end;
+
+function TFontSubsetter.buildGlyfTable(var newOffsets: TArrayUInt32): TStream;
+var
+ n: integer;
+ lOffset: uint32;
+ lLen: uint32;
+ gs: TMemoryStream;
+ buf: TGlyphHeader;
+ flags: uint16;
+ glyphIndex: uint16;
+begin
+ lOffset := 0;
+ Result := TMemoryStream.Create;
+ LoadLocations;
+
+ { - Assign new glyph indexes
+ - Retrieve glyph data if it doesn't yet exist (retrieved from original TTF file) }
+ for n := 0 to FGlyphIDs.Count-1 do
+ begin
+ FGlyphIDs[n].NewGID := n;
+ if not Assigned(FGlyphIDs[n].GlyphData) then
+ FGlyphIDs[n].GlyphData := GetRawGlyphData(FGlyphIDs[n].GID);
+ end;
+
+ { - Now fix GlyphID references in Compound Glyphs to point to new GlyphIDs }
+ for n := 0 to FGlyphIDs.Count-1 do
+ begin
+ if not FGlyphIDs[n].IsCompoundGlyph then
+ Continue;
+ {$IFDEF gDEBUG}
+ writeln(Format('found compound glyph: %.4x glyphID: %d', [0, FGlyphIDs[n].GID]));
+ {$ENDIF}
+ gs := TMemoryStream(FGlyphIDs[n].GlyphData);
+ gs.Position := 0;
+
+ if gs.Size > 0 then
+ begin
+ FillMem(@buf, SizeOf(TGlyphHeader), 0);
+ gs.ReadBuffer(buf, SizeOf(Buf));
+
+ if buf.numberOfContours = -1 then
+ begin
+ repeat
+ flags := ReadUInt16(gs);
+ lOffset := gs.Position;
+ glyphIndex := ReadUInt16(gs);
+ // now write new GlyphID in it's place.
+ gs.Position := lOffset;
+ glyphIndex := FGlyphIDs.GetNewGlyphID(glyphIndex);
+ WriteUInt16(gs, glyphIndex);
+
+ // ARG_1_AND_2_ARE_WORDS
+ if (flags and (1 shl 0)) <> 0 then
+ ReadUInt32(gs)
+ else
+ ReadUInt16(gs);
+ // WE_HAVE_A_TWO_BY_TWO
+ if (flags and (1 shl 7)) <> 0 then
+ begin
+ ReadUInt32(gs);
+ ReadUInt32(gs);
+ end
+ // WE_HAVE_AN_X_AND_Y_SCALE
+ else if (flags and (1 shl 6)) <> 0 then
+ begin
+ ReadUInt32(gs);
+ end
+ // WE_HAVE_A_SCALE
+ else if (flags and (1 shl 3)) <> 0 then
+ begin
+ ReadUInt16(gs);
+ end;
+
+ until (flags and (1 shl 5)) = 0; // MORE_COMPONENTS
+ end; { if buf.numberOfContours = -1 }
+ end; { if gs.Size > 0 }
+ end; { for n ... FGlyphIDList.Count-1 }
+
+ // write all glyph data to resulting data stream
+ lOffset := 0;
+ for n := 0 to FGlyphIDs.Count-1 do
+ begin
+ newOffsets[n] := lOffset;
+ lOffset := lOffset + FGlyphIDs[n].GlyphData.Size;
+ FGlyphIDs[n].GlyphData.Position := 0;
+ Result.CopyFrom(FGlyphIDs[n].GlyphData, FGlyphIDs[n].GlyphData.Size);
+ // 4-byte alignment
+ if (lOffset mod 4) <> 0 then
+ begin
+ lLen := 4 - (lOffset mod 4);
+ Result.WriteBuffer(PAD_BUF, lLen);
+ lOffset := lOffset + lLen;
+ end;
+ end;
+ newOffsets[n+1] := lOffset;
+end;
+
+// write as UInt32 as defined in head.indexToLocFormat field (long format).
+function TFontSubsetter.buildLocaTable(var newOffsets: TArrayUInt32): TStream;
+var
+ i: integer;
+begin
+ Result := TMemoryStream.Create;
+ for i := 0 to Length(newOffsets)-1 do
+ WriteUInt32(Result, newOffsets[i]);
+end;
+
+function TFontSubsetter.buildCmapTable: TStream;
+const
+ // platform
+ PLATFORM_UNICODE = 0;
+ PLATFORM_MACINTOSH = 1;
+ // value 2 is reserved; do not use
+ PLATFORM_WINDOWS = 3;
+
+ // Mac encodings
+ ENCODING_MAC_ROMAN = 0;
+
+ // Windows encodings
+ ENCODING_WIN_SYMBOL = 0; // Unicode, non-standard character set
+ ENCODING_WIN_UNICODE_BMP = 1; // Unicode BMP (UCS-2)
+ ENCODING_WIN_SHIFT_JIS = 2;
+ ENCODING_WIN_BIG5 = 3;
+ ENCODING_WIN_PRC = 4;
+ ENCODING_WIN_WANSUNG = 5;
+ ENCODING_WIN_JOHAB = 6;
+ ENCODING_WIN_UNICODE_FULL = 10; // Unicode Full (UCS-4)
+
+ // Unicode encodings
+ ENCODING_UNICODE_1_0 = 0;
+ ENCODING_UNICODE_1_1 = 1;
+ ENCODING_UNICODE_2_0_BMP = 3;
+ ENCODING_UNICODE_2_0_FULL = 4;
+var
+ segCount: UInt16;
+ searchRange: UInt16;
+ i: integer;
+ startCode: Array of Integer;
+ endCode: Array of Integer;
+ idDelta: Array of Integer;
+ lastChar: integer;
+ prevChar: integer;
+ lastGid: integer;
+ curGid: integer;
+ itm: TTextMapping;
+begin
+ Result := TMemoryStream.Create;
+ SetLength(startCode, FGlyphIDList.Count);
+ SetLength(endCode, FGlyphIDList.Count);
+ SetLength(idDelta, FGlyphIDList.Count);
+
+ // cmap header
+ WriteUInt16(Result, 0); // version
+ WriteUInt16(Result, 1); // numberSubTables
+
+ // encoding record
+ WriteUInt16(Result, PLATFORM_WINDOWS); // platformID
+ WriteUInt16(Result, ENCODING_WIN_UNICODE_BMP); // platformSpecificID
+ WriteUInt32(Result, 4 * 2 + 4); // offset
+
+ // build Format 4 subtable (Unicode BMP)
+ lastChar := 0;
+ prevChar := lastChar;
+ lastGid := GetNewGlyphId(FGlyphIDList[0].GlyphID);
+ segCount := 0;
+
+ for i := 0 to FGlyphIDList.Count-1 do
+ begin
+ itm := FGlyphIDList[i];
+ if itm.CharID > $FFFF then
+ raise Exception.Create('non-BMP Unicode character');
+ curGid := GetNewGlyphId(itm.GlyphID);
+
+ if (itm.CharID <> FGlyphIDList[prevChar].CharID+1) or ((curGid - lastGid) <> (itm.CharID - FGlyphIDList[lastChar].CharID)) then
+ begin
+ if (lastGid <> 0) then
+ begin
+ { don't emit ranges, which map to GID 0, the undef glyph is emitted at the very last segment }
+ startCode[segCount] := FGlyphIDList[lastChar].CharID;
+ endCode[segCount] := FGlyphIDList[prevChar].CharID;
+ idDelta[segCount] := lastGid - FGlyphIDList[lastChar].CharID;
+ inc(segCount);
+ end
+ else if not (FGlyphIDList[lastChar].CharID = FGlyphIDList[prevChar].CharID) then
+ begin
+ { shorten ranges which start with GID 0 by one }
+ startCode[segCount] := FGlyphIDList[lastChar].CharID + 1;
+ endCode[segCount] := FGlyphIDList[prevChar].CharID;
+ idDelta[segCount] := lastGid - FGlyphIDList[lastChar].CharID;
+ inc(segCount);
+ end;
+ lastGid := curGid;
+ lastChar := i;
+ end;
+ prevChar := i;
+ end;
+
+ // trailing segment
+ startCode[segCount] := FGlyphIDList[lastChar].CharID;
+ endCode[segCount] := FGlyphIDList[prevChar].CharID;
+ idDelta[segCount] := lastGid - FGlyphIDList[lastChar].CharID;
+ inc(segCount);
+
+ // GID 0
+ startCode[segCount] := $FFFF;
+ endCode[segCount] := $FFFF;
+ idDelta[segCount] := 1;
+ inc(segCount);
+
+ // write format 4 subtable
+ searchRange := trunc(2 * Power(2, Floor(Log2(segCount))));
+ WriteUInt16(Result, 4); // format
+ WriteUInt16(Result, 8 * 2 + segCount * 4*2); // length
+ WriteUInt16(Result, 0); // language
+ WriteUInt16(Result, segCount * 2); // segCountX2
+ WriteUInt16(Result, searchRange); // searchRange
+ WriteUInt16(Result, trunc(log2(searchRange / 2))); // entrySelector
+ WriteUInt16(Result, 2 * segCount - searchRange); // rangeShift
+
+ // write endCode
+ for i := 0 to segCount-1 do
+ WriteUInt16(Result, endCode[i]);
+
+ // reservedPad
+ WriteUInt16(Result, 0);
+
+ // startCode
+ for i := 0 to segCount-1 do
+ WriteUInt16(Result, startCode[i]);
+
+ // idDelta
+ for i := 0 to segCount-1 do
+ begin
+ {$IFDEF gDEBUG}
+ writeln(Format(' idDelta[%d] = %d', [i, idDelta[i]]));
+ {$ENDIF}
+ WriteInt16(Result, idDelta[i]);
+ end;
+
+ // idRangeOffset
+ for i := 0 to segCount-1 do
+ WriteUInt16(Result, 0);
+end;
+
+function TFontSubsetter.buildHmtxTable: TStream;
+var
+ n: integer;
+begin
+ Result := TMemoryStream.Create;
+ for n := 0 to FGlyphIDs.Count-1 do
+ begin
+ WriteUInt16(Result, FFontInfo.Widths[FGlyphIDs[n].GID].AdvanceWidth);
+ WriteInt16(Result, FFontInfo.Widths[FGlyphIDs[n].GID].LSB);
+ end;
+end;
+
+constructor TFontSubsetter.Create(const AFont: TTFFileInfo; const AGlyphIDList: TTextMappingList);
+var
+ i: integer;
+begin
+ FFontInfo := AFont;
+ if not Assigned(FFontInfo) then
+ raise ETTFSubsetter.Create(rsErrFontInfoNotAssigned);
+ FGlyphIDList := AGlyphIDList;
+
+ FGlyphIDs := TGIDList.Create;
+ // always copy GID 0
+ FGlyphIDs.Add(0);
+
+ FKeepTables := TStringList.Create;
+ FHasAddedCompoundReferences := False;
+ FPrefix := '';
+
+ // create a default list
+ FKeepTables.Add('head');
+ FKeepTables.Add('hhea');
+ FKeepTables.Add('maxp');
+ FKeepTables.Add('hmtx');
+ FKeepTables.Add('cmap');
+ FKeepTables.Add('fpgm');
+ FKeepTables.Add('prep');
+ FKeepTables.Add('cvt ');
+ FKeepTables.Add('loca');
+ FKeepTables.Add('glyf');
+
+ if Assigned(FGlyphIDList) then
+ begin
+ FGlyphIDList.Sort;
+ for i := 0 to FGlyphIDList.Count-1 do
+ FGlyphIDs.Add(FGlyphIDList[i].GlyphID);
+ end;
+
+ if FFontInfo.Filename <> '' then
+ FStream := TFileStream.Create(FFontInfo.FileName, fmOpenRead or fmShareDenyNone)
+ else
+ raise ETTF.Create(rsErrCantFindFontFile);
+end;
+
+constructor TFontSubsetter.Create(const AFont: TTFFileInfo);
+begin
+ Create(AFont, nil);
+end;
+
+destructor TFontSubsetter.Destroy;
+var
+ i: integer;
+begin
+ // the owner of FGlyphIDList doesn't need the GlyphData information
+ for i := 0 to FGlyphIDList.Count-1 do
+ FGlyphIDList[i].GlyphData.Free;
+ FStream.Free;
+ FKeepTables.Free;
+ FreeAndNil(FGlyphIDs);
+ inherited Destroy;
+end;
+
+procedure TFontSubsetter.SaveToFile(const AFileName: String);
+var
+ fs: TFileStream;
+begin
+ fs := TFileStream.Create(AFileName, fmCreate);
+ try
+ SaveToStream(fs);
+ finally
+ FreeAndNil(fs);
+ end;
+end;
+
+procedure TFontSubsetter.SaveToStream(const AStream: TStream);
+var
+ checksum: int64;
+ offset: int64;
+ head: TStream;
+ hhea: TStream;
+ maxp: TStream;
+ hmtx: TStream;
+ cmap: TStream;
+ fpgm: TStream;
+ prep: TStream;
+ cvt: TStream;
+ loca: TStream;
+ glyf: TStream;
+ newLoca: TArrayUInt32;
+ tables: TStringList;
+ i: integer;
+ o: uint64;
+ p: uint64;
+ lPadding: byte;
+begin
+ FGlyphIDs.Sort;
+
+ // resolve compound glyph references
+ AddCompoundReferences;
+
+ // always copy GID 0
+ FGlyphIDList.Add(0, 0);
+ FGlyphIDList.Sort;
+
+ SetLength(newLoca, FGlyphIDs.Count+1);
+
+ head := buildHeadTable();
+ hhea := buildHheaTable();
+ maxp := buildMaxpTable();
+ fpgm := buildFpgmTable();
+ prep := buildPrepTable();
+ cvt := buildCvtTable();
+ glyf := buildGlyfTable(newLoca);
+ loca := buildLocaTable(newLoca);
+ cmap := buildCmapTable();
+ hmtx := buildHmtxTable();
+
+ tables := TStringList.Create;
+ tables.CaseSensitive := True;
+ if Assigned(cmap) then
+ tables.AddObject('cmap', cmap);
+ if Assigned(glyf) then
+ tables.AddObject('glyf', glyf);
+ tables.AddObject('head', head);
+ tables.AddObject('hhea', hhea);
+ tables.AddObject('hmtx', hmtx);
+ if Assigned(loca) then
+ tables.AddObject('loca', loca);
+ tables.AddObject('maxp', maxp);
+ tables.AddObject('fpgm', fpgm);
+ tables.AddObject('prep', prep);
+ tables.AddObject('cvt ', cvt);
+ tables.Sort;
+
+ // calculate checksum
+ checksum := writeFileHeader(AStream, tables.Count);
+ offset := 12 + (16 * tables.Count);
+ lPadding := 0;
+ for i := 0 to tables.Count-1 do
+ begin
+ if tables.Objects[i] <> nil then
+ begin
+ checksum := checksum + WriteTableHeader(AStream, tables.Strings[i], offset, TStream(tables.Objects[i]));
+ p := TStream(tables.Objects[i]).Size;
+ // table bodies must be 4-byte aligned - calculate the padding so the tableHeader.Offset field can reflect that.
+ if (p mod 4) = 0 then
+ lPadding := 0
+ else
+ lPadding := 4 - (p mod 4);
+ o := p + lPadding;
+ offset := offset + o;
+ end;
+ end;
+ checksum := $B1B0AFBA - (checksum and $ffffffff);
+
+ // update head.ChecksumAdjustment field
+ head.Seek(8, soBeginning);
+ WriteInt32(head, Int32(checksum));
+
+ // write table bodies
+ WriteTableBodies(AStream, tables);
+
+ for i := 0 to tables.Count-1 do
+ TStream(tables.Objects[i]).Free;
+ tables.Free;
+
+ UpdateOrigGlyphIDList;
+end;
+
+procedure TFontSubsetter.Add(const ACodePoint: uint32);
+var
+ gid: uint32;
+begin
+ gid := FFontInfo.Chars[ACodePoint];
+ if gid <> 0 then
+ begin
+ FGlyphIDList.Add(ACodePoint, FFontInfo.Chars[ACodePoint]);
+ FGlyphIDs.Add(gid);
+ end;
+end;
+
+{ TGIDList }
+
+function TGIDList.GetCount: integer;
+begin
+ Result := FList.Count;
+end;
+
+function TGIDList.GetItems(i: integer): TGIDItem;
+begin
+ Result := FList[i] as TGIDItem;
+end;
+
+procedure TGIDList.SetItems(i: integer; const AValue: TGIDItem);
+begin
+ FList[i] := AValue;
+end;
+
+constructor TGIDList.Create;
+begin
+ FList := TFPObjectList.Create;
+end;
+
+destructor TGIDList.Destroy;
+begin
+ FList.Free;
+ inherited Destroy;
+end;
+
+function TGIDList.Add(const GID: Integer): integer;
+var
+ itm: TGIDItem;
+begin
+ itm := TGIDItem.Create;
+ itm.GID := GID;
+ result := Add(itm);
+end;
+
+function TGIDList.Add(const AObject: TGIDItem): integer;
+begin
+ Result := FList.Add(AObject);
+end;
+
+procedure TGIDList.Clear;
+begin
+ FList.Clear;
+end;
+
+function TGIDList.Contains(const GID: integer): boolean;
+var
+ itm: TGIDItem;
+begin
+ Result := False;
+ for itm in self do
+ begin
+ if itm.GID = GID then
+ begin
+ Result := True;
+ Exit;
+ end;
+ end;
+end;
+
+function TGIDList.GetEnumerator: TGIDListEnumerator;
+begin
+ Result := TGIDListEnumerator.Create(self);
+end;
+
+function TGIDList.GetNewGlyphID(const OriginalGID: integer): integer;
+var
+ itm: TGIDItem;
+begin
+ Result := -1;
+ for itm in self do
+ begin
+ if itm.GID = OriginalGID then
+ begin
+ Result := itm.NewGID;
+ Exit;
+ end;
+ end;
+end;
+
+function CompareByGID(A, B: TGIDItem): Integer; inline;
+begin
+ if A.GID < B.GID then
+ Result := -1
+ else if A.GID > B.GID then
+ Result := 1
+ else
+ Result := 0;
+end;
+
+function CompareByGIDPtr(A, B: Pointer): Integer;
+begin
+ Result := CompareByGID(TGIDItem(A), TGIDItem(B));
+end;
+
+procedure TGIDList.Sort;
+begin
+ FList.Sort(@CompareByGIDPtr);
+end;
+
+{ TGIDListEnumerator }
+
+constructor TGIDListEnumerator.Create(AList: TGIDList);
+begin
+ FIndex := -1;
+ FList := AList;
+end;
+
+function TGIDListEnumerator.GetCurrent: TGIDItem;
+begin
+ Result := FList[FIndex];
+end;
+
+function TGIDListEnumerator.MoveNext: Boolean;
+begin
+ Result := FIndex < (FList.Count-1);
+ if Result then
+ Inc(FIndex);
+end;
+
+{ TGIDItem }
+
+constructor TGIDItem.Create;
+begin
+ FGID := -1;
+ FNewGID := -1;
+ FGlyphData := nil;
+ FIsCompoundGlyph := False;
+end;
+
+destructor TGIDItem.Destroy;
+begin
+ FreeAndNil(FGlyphData);
+ inherited Destroy;
+end;
+
+
+end.
+
diff --git a/packages/fcl-pdf/tests/fpparsettf_test.pas b/packages/fcl-pdf/tests/fpparsettf_test.pas
index 9dddebb9f1..d47e223c73 100644
--- a/packages/fcl-pdf/tests/fpparsettf_test.pas
+++ b/packages/fcl-pdf/tests/fpparsettf_test.pas
@@ -196,6 +196,15 @@ type
end;
+ TTestLiberationItalicFont = class(TBaseTestParseTTF)
+ protected
+ procedure SetUp; override;
+ published
+ { PostScript data structure }
+ procedure TestPostScript_ItalicAngle;
+ end;
+
+
TTestFreeSansFont = class(TBaseTestParseTTF)
protected
procedure SetUp; override;
@@ -361,6 +370,7 @@ uses
const
cFont1 = 'fonts' + PathDelim + 'LiberationSans-Regular.ttf';
cFont2 = 'fonts' + PathDelim + 'FreeSans.ttf';
+ cFont3 = 'fonts' + PathDelim + 'LiberationSans-Italic.ttf';
{ TTestEmptyParseTTF }
@@ -468,22 +478,17 @@ var
begin
// LONGDATETIME: Date represented in number of seconds since 12:00 midnight,
// January 1, 1904. The value is represented as a signed 64-bit integer.
- //dt := EncodeDateTime(1904, 1, 1, 0, 0, 0, 0);
- //s := FormatDateTime('yyyy-mm-dd hh:nn:ss', dt);
- //AssertEquals('Failed on 1', '1904-01-01 00:00:00', s);
- //dt := IncSecond(dt, FI.Head.Created);
-
- // The above code equates to using MacToDateTime()
dt := MacToDateTime(FI.Head.Created);
- // We don't use this AssertEquals() because it shows a huge Double data-type
- // value as the result.
- //AssertEquals('Failed on 1', EncodeDateTime(2012, 10, 4, 20, 2, 31, 0), dt);
+ // value verified with Microsoft's ttfdump tool and GMT timezone (no daylight saving applied).
+ // created: Thu Oct 04 11:02:31 2012
+ // modified: Thu Oct 04 11:02:31 2012
+ AssertEquals('Failed on 1', EncodeDateTime(2012, 10, 4, 11, 2, 31, 0), dt);
// Instead we use this - which shows human readable dates.
s := FormatDateTime('yyyy-mm-dd hh:nn:ss', dt);
- AssertEquals('Failed on 2', '2012-10-04 20:02:31', s);
+ AssertEquals('Failed on 2', '2012-10-04 11:02:31', s);
end;
procedure TTestLiberationFont.TestHead_Modified;
@@ -491,9 +496,13 @@ var
dt: TDateTime;
s: string;
begin
+ // value verified with Microsoft's ttfdump tool and GMT timezone (no daylight saving applied).
+ // created: Thu Oct 04 11:02:31 2012
+ // modified: Thu Oct 04 11:02:31 2012
+
dt := MacToDateTime(FI.Head.Modified);
s := FormatDateTime('yyyy-mm-dd hh:nn:ss', dt);
- AssertEquals('Failed on 2', '2012-10-04 20:02:31', s);
+ AssertEquals('Failed on 2', '2012-10-04 11:02:31', s);
end;
procedure TTestLiberationFont.TestHead_BBox_xMin;
@@ -962,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;
@@ -1150,6 +1159,23 @@ begin
AssertEquals('Failed on 12', 1139, FI.GetAdvanceWidth(20)); // '1'
end;
+{ TTestLiberationItalicFont }
+
+procedure TTestLiberationItalicFont.SetUp;
+begin
+ inherited SetUp;
+ AssertTrue('Failed to find TTF font file <' + cFont3 + '>' + LineEnding +
+ 'You can download it from [https://fedorahosted.org/releases/l/i/liberation-fonts/liberation-fonts-ttf-2.00.1.tar.gz]',
+ FileExists(cFont3) = True);
+ LoadFont(cFont3);
+end;
+
+procedure TTestLiberationItalicFont.TestPostScript_ItalicAngle;
+begin
+ AssertEquals('Failed on 1', -12.0, FI.PostScript.ItalicAngle / 65536.0);
+ AssertEquals('Failed on 2', -12.0, FI.ItalicAngle);
+end;
+
{ TTestFreeSansFont }
procedure TTestFreeSansFont.SetUp;
@@ -1232,22 +1258,20 @@ var
begin
// LONGDATETIME: Date represented in number of seconds since 12:00 midnight,
// January 1, 1904. The value is represented as a signed 64-bit integer.
- //dt := EncodeDateTime(1904, 1, 1, 0, 0, 0, 0);
- //s := FormatDateTime('yyyy-mm-dd hh:nn:ss', dt);
- //AssertEquals('Failed on 1', '1904-01-01 00:00:00', s);
- //dt := IncSecond(dt, FI.Head.Created);
+ // value verified with Microsoft's ttfdump tool and GMT timezone (no daylight saving applied).
+ // created: Thu May 03 13:34:25 2012
+ // modified: Thu May 03 13:34:25 2012
- // The above code equates to using MacToDateTime()
dt := MacToDateTime(FI.Head.Created);
// We don't use this AssertEquals() because it shows a huge Double data-type
// value as the result.
- //AssertEquals('Failed on 1', EncodeDateTime(2012, 10, 4, 20, 2, 31, 0), dt);
+ AssertEquals('Failed on 1', EncodeDateTime(2012, 5, 3, 13, 34, 25, 0), dt);
// Instead we use this - which shows human readable dates.
s := FormatDateTime('yyyy-mm-dd hh:nn:ss', dt);
- AssertEquals('Failed on 2', '2012-05-02 22:34:25', s);
+ AssertEquals('Failed on 2', '2012-05-03 13:34:25', s);
end;
procedure TTestFreeSansFont.TestHead_Modified;
@@ -1255,9 +1279,12 @@ var
dt: TDateTime;
s: string;
begin
+ // value verified with Microsoft's ttfdump tool and GMT timezone (no daylight saving applied).
+ // created: Thu May 03 13:34:25 2012
+ // modified: Thu May 03 13:34:25 2012
dt := MacToDateTime(FI.Head.Modified);
s := FormatDateTime('yyyy-mm-dd hh:nn:ss', dt);
- AssertEquals('Failed on 2', '2012-05-02 22:34:25', s);
+ AssertEquals('Failed on 2', '2012-05-03 13:34:25', s);
end;
procedure TTestFreeSansFont.TestHead_BBox_xMin;
@@ -1900,6 +1927,7 @@ initialization
RegisterTest({$ifdef fptest}'fpParseTTF',{$endif}TTestEmptyParseTTF{$ifdef fptest}.Suite{$endif});
RegisterTest({$ifdef fptest}'fpParseTTF',{$endif}TTestLiberationFont{$ifdef fptest}.Suite{$endif});
RegisterTest({$ifdef fptest}'fpParseTTF',{$endif}TTestFreeSansFont{$ifdef fptest}.Suite{$endif});
+ RegisterTest({$ifdef fptest}'fpParseTTF',{$endif}TTestLiberationItalicFont{$ifdef fptest}.Suite{$endif});
end.
diff --git a/packages/fcl-pdf/tests/fppdf_test.pas b/packages/fcl-pdf/tests/fppdf_test.pas
index d512e94458..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;
@@ -655,7 +675,7 @@ var
s8: UTF8String;
begin
PDF.Options := []; // disable all compression
- fnt := PDF.AddFont(cFont1, 'Liberation Sans', clBlack);
+ fnt := PDF.AddFont(cFont1, 'Liberation Sans');
o := TPDFUTF8String.Create(PDF, 'TestT', fnt);
try
AssertEquals('Failed on 1', '', S.DataString);
@@ -685,7 +705,7 @@ var
o: TPDFUTF8String;
fnt: integer;
begin
- fnt := PDF.AddFont(cFont1, 'Liberation Sans', clBlack);
+ fnt := PDF.AddFont(cFont1, 'Liberation Sans');
o := TPDFUTF8String.Create(PDF, 'a(b)c\def/g', fnt);
try
AssertEquals('Failed on 1', '', S.DataString);
@@ -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,16 +1560,36 @@ 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 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 1 3 1 3] 1 d'+CRLF,
+ '[5 3 0.80 3 0.80 3] 1 d'+CRLF,
S.DataString);
finally
o.Free;
end;
+ DefaultFormatSettings.DecimalSeparator := d;
end;
{ TTestPDFColor }
@@ -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 d29dbb5a54..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,22 +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 4 test fonts in the "fonts" directory.';
+ 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;
@@ -76,29 +99,103 @@ begin
inherited TearDown;
end;
+procedure TFPFontCacheItemTest.TestIsRegularCantFind;
+begin
+ try
+ AssertFalse(CI.IsRegular); // this should raise an error
+ Fail('Failed on 1');
+ except
+ on E: Exception do
+ begin
+ AssertEquals('Failed on 2', 'ETTF', E.ClassName);
+ AssertEquals('Failed on 3', 'The font file <mytest.ttf> can''t be found.', E.Message);
+ end;
+ end;
+end;
+
+procedure TFPFontCacheItemTest.TestIsBoldCantFind;
+begin
+ try
+ AssertFalse(CI.IsBold); // this should raise an error
+ Fail('Failed on 1');
+ except
+ on E: Exception do
+ begin
+ AssertEquals('Failed on 2', 'ETTF', E.ClassName);
+ AssertEquals('Failed on 3', 'The font file <mytest.ttf> can''t be found.', E.Message);
+ end;
+ end;
+end;
+
+procedure TFPFontCacheItemTest.TestIsItalicCantFind;
+begin
+ try
+ AssertFalse(CI.IsItalic); // this should raise an error
+ Fail('Failed on 1');
+ except
+ on E: Exception do
+ begin
+ AssertEquals('Failed on 2', 'ETTF', E.ClassName);
+ AssertEquals('Failed on 3', 'The font file <mytest.ttf> can''t be found.', E.Message);
+ end;
+ end;
+end;
+
+procedure TFPFontCacheItemTest.TestIsFixedWidthCantFind;
+begin
+ try
+ AssertFalse(CI.IsFixedWidth); // this should raise an error
+ Fail('Failed on 1');
+ except
+ on E: Exception do
+ begin
+ AssertEquals('Failed on 2', 'ETTF', E.ClassName);
+ AssertEquals('Failed on 3', 'The font file <mytest.ttf> can''t be found.', E.Message);
+ end;
+ end;end;
+
+procedure TFPFontCacheItemTest.TestFileInfoCantFind;
+begin
+ try
+ AssertFalse(CI.FontData <> nil); // this should raise an error
+ Fail('Failed on 1');
+ except
+ on E: Exception do
+ begin
+ AssertEquals('Failed on 2', 'ETTF', E.ClassName);
+ AssertEquals('Failed on 3', 'The font file <mytest.ttf> can''t be found.', E.Message);
+ end;
+ end;
+end;
+
procedure TFPFontCacheItemTest.TestIsRegular;
begin
+ SetupRealFont;
{ regular should be the default flag set }
AssertEquals('Failed on 1', True, CI.IsRegular);
end;
procedure TFPFontCacheItemTest.TestIsBold;
begin
+ SetupRealFont;
AssertEquals('Failed on 1', False, CI.IsBold);
end;
procedure TFPFontCacheItemTest.TestIsItalic;
begin
+ SetupRealFont;
AssertEquals('Failed on 1', False, CI.IsItalic);
end;
procedure TFPFontCacheItemTest.TestIsFixedWidth;
begin
+ SetupRealFont;
AssertEquals('Failed on 1', False, CI.IsFixedWidth);
end;
procedure TFPFontCacheItemTest.TestRegularVsFixedWidth;
begin
+ SetupRealFont;
AssertEquals('Failed on 1', True, CI.IsRegular);
AssertEquals('Failed on 2', False, CI.IsFixedWidth);
end;
@@ -106,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;
@@ -192,7 +295,7 @@ begin
FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
AssertEquals('Failed on 2', 0, FC.Count);
FC.BuildFontCache;
- AssertEquals('Failed on 3' + cErrFontCountWrong, 4, FC.Count);
+ AssertEquals('Failed on 3' + cErrFontCountWrong, cFontCount, FC.Count);
end;
procedure TFPFontCacheListTest.TestBuildFontCache;
@@ -211,7 +314,7 @@ begin
FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
AssertEquals('Failed on 4', 0, FC.Count);
FC.BuildFontCache;
- AssertEquals('Failed on 5' + cErrFontCountWrong, 4, FC.Count);
+ AssertEquals('Failed on 5' + cErrFontCountWrong, cFontCount, FC.Count);
end;
procedure TFPFontCacheListTest.TestBuildFontCache_tests_for_bug;
@@ -227,7 +330,7 @@ begin
AssertEquals('Failed on 1', 0, FC.Count);
FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
FC.BuildFontCache;
- AssertEquals('Failed on 2', 4, FC.Count);
+ AssertEquals('Failed on 2' + cErrFontCountWrong, cFontCount, FC.Count);
FC.Clear;
AssertEquals('Failed on 3', 0, FC.Count);
end;
@@ -242,7 +345,7 @@ begin
AssertTrue('Failed on 2', lCI = nil);
FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
FC.BuildFontCache;
- AssertEquals('Failed on 3' + cErrFontCountWrong, 4, FC.Count);
+ AssertEquals('Failed on 3' + cErrFontCountWrong, cFontCount, FC.Count);
lCI := FC.Find('Ubuntu');
AssertTrue('Failed on 4', Assigned(lCI));
@@ -272,7 +375,7 @@ begin
AssertTrue('Failed on 2', lCI = nil);
FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
FC.BuildFontCache;
- AssertEquals('Failed on 3' + cErrFontCountWrong, 4, FC.Count);
+ AssertEquals('Failed on 3' + cErrFontCountWrong, cFontCount, FC.Count);
lCI := FC.Find('Ubuntu');
AssertTrue('Failed on 4', Assigned(lCI));
@@ -301,14 +404,46 @@ begin
AssertEquals('Failed on 1', 0, FC.Count);
FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
FC.BuildFontCache;
- AssertEquals('Failed on 2', 4, FC.Count);
+ AssertEquals('Failed on 2' + cErrFontCountWrong, cFontCount, FC.Count);
FC.AssignFontList(sl);
- AssertEquals('Failed on 3', 4, sl.Count);
+ AssertEquals('Failed on 3', cFontCount, sl.Count);
finally
sl.Free;
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/mkpdffontdef.lpi b/packages/fcl-pdf/utils/mkpdffontdef.lpi
deleted file mode 100644
index 3b479598f6..0000000000
--- a/packages/fcl-pdf/utils/mkpdffontdef.lpi
+++ /dev/null
@@ -1,83 +0,0 @@
-<?xml version="1.0" encoding="UTF-8"?>
-<CONFIG>
- <ProjectOptions>
- <Version Value="9"/>
- <General>
- <Flags>
- <MainUnitHasCreateFormStatements Value="False"/>
- <MainUnitHasTitleStatement Value="False"/>
- </Flags>
- <SessionStorage Value="InProjectDir"/>
- <MainUnit Value="0"/>
- <Title Value="mkpdffontdef"/>
- <UseAppBundle Value="False"/>
- <ResourceType Value="res"/>
- </General>
- <i18n>
- <EnableI18N LFM="False"/>
- </i18n>
- <VersionInfo>
- <StringTable ProductVersion=""/>
- </VersionInfo>
- <BuildModes Count="1">
- <Item1 Name="Default" Default="True"/>
- </BuildModes>
- <PublishOptions>
- <Version Value="2"/>
- </PublishOptions>
- <RunParams>
- <local>
- <FormatVersion Value="1"/>
- <CommandLineParams Value="/usr/share/fonts/truetype/msttcorefonts/arial.ttf cp1252 arial.fnt"/>
- </local>
- </RunParams>
- <Units Count="3">
- <Unit0>
- <Filename Value="mkpdffontdef.pp"/>
- <IsPartOfProject Value="True"/>
- </Unit0>
- <Unit1>
- <Filename Value="fpttfencodings.pp"/>
- <IsPartOfProject Value="True"/>
- </Unit1>
- <Unit2>
- <Filename Value="fpparsettf.pp"/>
- <IsPartOfProject Value="True"/>
- </Unit2>
- </Units>
- </ProjectOptions>
- <CompilerOptions>
- <Version Value="11"/>
- <Target>
- <Filename Value="mkpdffontdef"/>
- </Target>
- <SearchPaths>
- <IncludeFiles Value="$(ProjOutDir)"/>
- <OtherUnitFiles Value="../src"/>
- <UnitOutputDirectory Value="units/"/>
- </SearchPaths>
- <Parsing>
- <SyntaxOptions>
- <UseAnsiStrings Value="False"/>
- </SyntaxOptions>
- </Parsing>
- <Linking>
- <Debugging>
- <UseHeaptrc Value="True"/>
- </Debugging>
- </Linking>
- </CompilerOptions>
- <Debugging>
- <Exceptions Count="3">
- <Item1>
- <Name Value="EAbort"/>
- </Item1>
- <Item2>
- <Name Value="ECodetoolError"/>
- </Item2>
- <Item3>
- <Name Value="EFOpenError"/>
- </Item3>
- </Exceptions>
- </Debugging>
-</CONFIG>
diff --git a/packages/fcl-pdf/utils/mkpdffontdef.pp b/packages/fcl-pdf/utils/mkpdffontdef.pp
deleted file mode 100644
index ff2a60d7bd..0000000000
--- a/packages/fcl-pdf/utils/mkpdffontdef.pp
+++ /dev/null
@@ -1,36 +0,0 @@
-{
- This file is part of the Free Component Library (FCL)
- Copyright (c) 2014 by Michael Van Canneyt
-
- This small program reads a TTF font file and creates a definition in a .ini file for later use
-
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-
- **********************************************************************}
-{$mode objfpc}
-{$h+}
-
-program mkpdffontdef;
-
-uses sysutils, fpttfencodings, fpparsettf;
-
-begin
- if (ParamCount<3) then
- begin
- writeln('Usage : ',ExtractFileName(paramstr(0)),' ttffilename encoding fntfilename');
- Halt(1);
- end;
- With TTFFileInfo.Create do
- try
- LoadFromFile(ParamStr(1));
- MakePDFFontDef(Paramstr(3),Paramstr(2),False)
- finally
- Free;
- end;
-end.
-
diff --git a/packages/fcl-pdf/utils/ttfdump.lpi b/packages/fcl-pdf/utils/ttfdump.lpi
index a8baa8c4e8..9969635656 100644
--- a/packages/fcl-pdf/utils/ttfdump.lpi
+++ b/packages/fcl-pdf/utils/ttfdump.lpi
@@ -32,6 +32,7 @@
<RunParams>
<local>
<FormatVersion Value="1"/>
+ <CommandLineParams Value="-f ../tests/fonts/FreeSans.ttf -s"/>
</local>
</RunParams>
<Units Count="1">
@@ -56,6 +57,17 @@
<AllowLabel Value="False"/>
</SyntaxOptions>
</Parsing>
+ <CodeGeneration>
+ <Checks>
+ <RangeChecks Value="True"/>
+ <OverflowChecks Value="True"/>
+ </Checks>
+ </CodeGeneration>
+ <Linking>
+ <Debugging>
+ <UseHeaptrc Value="True"/>
+ </Debugging>
+ </Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
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
+ TFriendClass = class(TTFFileInfo)
end;
- Result := FList.Add(AObject);
-end;
-
-function TTextMappingList.Add(const ACharID, AGlyphID: uint16): Integer;
-var
- o: TTextMapping;
-begin
- o := TTextMapping.Create;
- o.CharID := ACharID;
- o.GlyphID := AGlyphID;
- Result := Add(o);
- if Result = -1 then
- o.Free;
-end;
-{ TTextMapping }
-
-class function TTextMapping.NewTextMap(const ACharID, AGlyphID: uint16): TTextMapping;
-begin
- Result := TTextMapping.Create;
- Result.CharID := ACharID;
- Result.GlyphID := AGlyphID;
-end;
{ TMyApplication }
@@ -127,16 +40,16 @@ procedure TMyApplication.DumpGlyphIndex;
begin
Writeln('FHHead.numberOfHMetrics = ', FFontFile.HHead.numberOfHMetrics);
Writeln('Length(Chars[]) = ', Length(FFontFile.Chars));
-
+ writeln;
writeln('Glyph Index values:');
- Writeln('U+0020 (space) = ', FFontFile.Chars[$0020]);
- Writeln('U+0021 (!) = ', FFontFile.Chars[$0021]);
- Writeln('U+0048 (H) = ', FFontFile.Chars[$0048]);
-
+ Writeln(' U+0020 (space) = ', Format('%d (%0:4.4x)', [FFontFile.Chars[$0020]]));
+ Writeln(' U+0021 (!) = ', Format('%d (%0:4.4x)', [FFontFile.Chars[$0021]]));
+ Writeln(' U+0048 (H) = ', Format('%d (%0:4.4x)', [FFontFile.Chars[$0048]]));
+ writeln;
Writeln('Glyph widths:');
- Writeln('3 = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0020]].AdvanceWidth));
- Writeln('4 = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0021]].AdvanceWidth));
- Writeln('H = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0048]].AdvanceWidth));
+ Writeln(' 3 = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0020]].AdvanceWidth));
+ Writeln(' 4 = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0021]].AdvanceWidth));
+ Writeln(' H = ', TFriendClass(FFontFile).ToNatural(FFontFile.Widths[FFontFile.Chars[$0048]].AdvanceWidth));
end;
function TMyApplication.GetGlyphIndices(const AText: UnicodeString): TTextMappingList;
@@ -154,6 +67,20 @@ begin
end;
end;
+procedure TMyApplication.CreateSubsetFontFile(const AList: TTextMappingList);
+var
+ lSubset: TFontSubsetter;
+begin
+ writeln;
+ writeln('called CreateSubsetFontFile...');
+ lSubset := TFontSubsetter.Create(FFontFile, AList);
+ try
+ lSubSet.SaveToFile(ExtractFileName(GetOptionValue('f'))+'.subset.ttf');
+ finally
+ FreeAndNil(lSubSet);
+ end;
+end;
+
function TMyApplication.GetGlyphIndicesString(const AText: UnicodeString): AnsiString;
var
i: integer;
@@ -177,7 +104,7 @@ var
i: integer;
begin
// quick check parameters
- ErrorMsg := CheckOptions('hf:', 'help');
+ ErrorMsg := CheckOptions('hf:s', 'help');
if ErrorMsg <> '' then
begin
ShowException(Exception.Create(ErrorMsg));
@@ -196,13 +123,25 @@ begin
FFontFile.LoadFromFile(self.GetOptionValue('f'));
DumpGlyphIndex;
- s := 'Hello, World!';
+ // test #1
+// s := 'Hello, World!';
+ // test #2
+ s := 'Typography: “What’s wrong?”';
+
Writeln('');
lst := GetGlyphIndices(s);
Writeln(Format('%d Glyph indices for: "%s"', [lst.Count, s]));
+ writeln(#9'GID'#9'CharID');
+ writeln(#9'---'#9'------');
for i := 0 to lst.Count-1 do
- Writeln(Format(#9'%s'#9'%s', [IntToHex(lst[i].GlyphID, 4), IntToHex(lst[i].CharID, 4)]));
+ Writeln(Format(#9'%s'#9'%s'#9'%s', [IntToHex(lst[i].GlyphID, 4), IntToHex(lst[i].CharID, 4), Char(lst[i].CharID)]));
+
+ if HasOption('s','') then
+ CreateSubsetFontFile(lst);
+ lst.Free;
+ writeln;
+ writeln;
// stop program loop
Terminate;
end;
@@ -225,11 +164,13 @@ begin
writeln('Usage: ', ExeName, ' -h');
writeln(' -h Show this help.');
writeln(' -f <ttf> Load TTF font file.');
+ writeln(' -s Generate a subset TTF file.');
end;
+
+
var
Application: TMyApplication;
-
begin
Application := TMyApplication.Create(nil);
Application.Title := 'TTF Font Dump';
View Lorry Controller Status