* Some improvements and reworkings by Graeme Geldenhuys

   pdf: Renamed DrawImage() parameters to more clearly state the values are in pixels.
   pdf: convenience function to return a TPDFCoord data type.
   pdf: method implementation signature now matches interface section.
   pdf: Implements new overload DrawImage that takes UnitOfMeasure Width & Height parameters.
   pdf: sample: Modified the Image page to some usage of new overloaded DrawImage()
   ttf: TextWidth() parameters are now const parameters.
   ttf: Implemented a new TextHeight() method for the FontCacheItem class.

git-svn-id: trunk@33566 -

packages/fcl-pdf/examples/testfppdf.lpr

@@ -273,13 +273,17 @@ begin
   IDX := D.Images.AddFromFile('poppy.jpg',False);
   W := D.Images[IDX].Width;
   H := D.Images[IDX].Height;
-  { scalled down image (small) }
-  P.DrawImage(25, 100, W div 2, H div 2, IDX); // left-bottom coordinate of image
-  P.WriteText(90, 75, '[Scaled image]');
+  { full size image }
+  P.DrawImage(25, 130, W, H, IDX);  // left-bottom coordinate of image
+  P.WriteText(145, 90, '[Full size (defined in pixels)]');
 
-  { large image }
-  P.DrawImage(35, 190, W, H, IDX);  // left-bottom coordinate of image
-  P.WriteText(160, 150, '[Default size]');
+  { half size image }
+  P.DrawImage(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)]');
+
+  { 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]');
 end;
 
 procedure TPDFTestApp.SimpleShapes(D: TPDFDocument; APage: integer);
@@ -444,7 +448,6 @@ procedure TPDFTestApp.DoRun;
 
 var
   ErrorMsg: String;
-  v: integer;
 
 begin
   StopOnException:=True;

packages/fcl-pdf/src/fppdf.pp

@@ -530,8 +530,11 @@ type
     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;
     { X, Y coordinates are the bottom-left coordinate of the image. AWidth and AHeight are in image pixels. }
-    Procedure DrawImage(const X, Y: TPDFFloat; const AWidth, AHeight, ANumber: integer); overload;
-    Procedure DrawImage(const APos: TPDFCoord; const AWidth, AHeight, ANumber: integer); overload;
+    Procedure DrawImage(const X, Y: TPDFFloat; const APixelWidth, APixelHeight, ANumber: integer); overload;
+    Procedure DrawImage(const APos: TPDFCoord; const APixelWidth, APixelHeight, ANumber: integer); 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;
     { 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. }
@@ -922,6 +925,8 @@ function mmToPDF(mm: single): TPDFFloat;
 function cmToPDF(cm: single): TPDFFloat;
 function InchesToPDF(Inches: single): TPDFFloat;
 
+function PDFCoord(x, y: TPDFFloat): TPDFCoord;
+
 implementation
 
 
@@ -1089,6 +1094,12 @@ begin
   Result := Inches * cDefaultDPI;
 end;
 
+function PDFCoord(x, y: TPDFFloat): TPDFCoord;
+begin
+  Result.x := x;
+  Result.y := y;
+end;
+
 function PDFtoInches(APixels: TPDFFloat): single;
 begin
   Result := APixels / cDefaultDPI;
@@ -1610,7 +1621,7 @@ begin
   end;
 end;
 
-procedure TPDFPage.CreateStdFontText(X: TPDFFloat; Y: TPDFFloat; AText: AnsiString; AFontIndex: integer);
+procedure TPDFPage.CreateStdFontText(X, Y: TPDFFloat; AText: AnsiString; AFontIndex: integer);
 var
   T: TPDFText;
 begin
@@ -1618,7 +1629,7 @@ begin
   AddObject(T);
 end;
 
-procedure TPDFPage.CreateTTFFontText(X: TPDFFloat; Y: TPDFFloat; AText: UTF8String; AFontIndex: integer);
+procedure TPDFPage.CreateTTFFontText(X, Y: TPDFFloat; AText: UTF8String; AFontIndex: integer);
 var
   T: TPDFUTF8Text;
 begin
@@ -1774,16 +1785,33 @@ begin
   DrawRect(APos.X, APos.Y, W, H, ALineWidth, AFill, AStroke);
 end;
 
-procedure TPDFPage.DrawImage(const X, Y: TPDFFloat; const AWidth, AHeight, ANumber: integer);
+procedure TPDFPage.DrawImage(const X, Y: TPDFFloat; const APixelWidth, APixelHeight, ANumber: integer);
 var
   p1: TPDFCoord;
 begin
   p1 := Matrix.Transform(X, Y);
   DoUnitConversion(p1);
-  AddObject(Document.CreateImage(p1.X, p1.Y, AWidth, AHeight, ANumber));
+  AddObject(Document.CreateImage(p1.X, p1.Y, APixelWidth, APixelHeight, ANumber));
+end;
+
+procedure TPDFPage.DrawImage(const APos: TPDFCoord; const APixelWidth, APixelHeight, ANumber: integer);
+begin
+  DrawImage(APos.X, APos.Y, APixelWidth, APixelHeight, ANumber);
+end;
+
+procedure TPDFPage.DrawImage(const X, Y: TPDFFloat; const AWidth, AHeight: TPDFFloat; const ANumber: integer);
+var
+  p1, p2: TPDFCoord;
+begin
+  p1 := Matrix.Transform(X, Y);
+  DoUnitConversion(p1);
+  p2.X := AWidth;
+  p2.Y := AHeight;
+  DoUnitConversion(p2);
+  AddObject(Document.CreateImage(p1.X, p1.Y, round(p2.Y), round(p2.Y), ANumber));
 end;
 
-procedure TPDFPage.DrawImage(const APos: TPDFCoord; const AWidth, AHeight, ANumber: integer);
+procedure TPDFPage.DrawImage(const APos: TPDFCoord; const AWidth, AHeight: TPDFFloat; const ANumber: integer);
 begin
   DrawImage(APos.X, APos.Y, AWidth, AHeight, ANumber);
 end;

packages/fcl-pdf/src/fpttf.pp

@@ -48,7 +48,9 @@ type
     constructor Create(const AFilename: String);
     destructor  Destroy; override;
     { Result is in pixels }
-    function    TextWidth(AStr: utf8string; APointSize: single): single;
+    function    TextWidth(const AStr: utf8string; const APointSize: single): single;
+    { 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;
@@ -206,7 +208,7 @@ end;
 { TextWidth returns with width of the text. If APointSize = 0.0, then it returns
   the text width in Font Units. If APointSize > 0 then it returns the text width
   in Pixels. }
-function TFPFontCacheItem.TextWidth(AStr: utf8string; APointSize: single): single;
+function TFPFontCacheItem.TextWidth(const AStr: utf8string; const APointSize: single): single;
 {
     From Microsoft's Typography website:
     Converting FUnits (font units) to pixels
@@ -275,6 +277,13 @@ begin
   end;
 end;
 
+function TFPFontCacheItem.TextHeight(const AText: utf8string; const APointSize: single; out ADescender: single): single;
+begin
+  { 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);
+end;
+
 { TFPFontCacheList }
 
 procedure TFPFontCacheList.SearchForFonts(const AFontPath: String);

packages/fcl-pdf/tests/fppdf_test.pas

@@ -29,6 +29,12 @@ type
   end;
 
 
+  TGeneralPDFTests = class(TTestCase)
+  published
+    procedure   TestPDFCoord;
+  end;
+
+
   TTestPDFObject = class(TBasePDFTest)
   published
     procedure   TestFloatStr;
@@ -181,6 +187,7 @@ type
   TTestPDFImage = class(TBasePDFTest)
   published
     procedure   TestWrite;
+    procedure   TestPageDrawImage_Pixels;
   end;
 
 
@@ -300,6 +307,22 @@ begin
   inherited TearDown;
 end;
 
+{ TGeneralPDFTests }
+
+procedure TGeneralPDFTests.TestPDFCoord;
+var
+  c: TPDFCoord;
+begin
+  c.x := 0;
+  c.y := 0;
+  AssertEquals('Failed on 1', 0, c.x);
+  AssertEquals('Failed on 2', 0, c.y);
+  c := PDFCoord(10, 20);
+  AssertEquals('Failed on 3', 10, c.x);
+  AssertEquals('Failed on 4', 20, c.y);
+end;
+
+
 { TTestPDFObject }
 
 procedure TTestPDFObject.TestFloatStr;
@@ -1347,6 +1370,29 @@ begin
   end;
 end;
 
+procedure TTestPDFImage.TestPageDrawImage_Pixels;
+var
+  p: TPDFPage;
+  img: TMockPDFImage;
+begin
+  p := PDF.Pages.AddPage;
+  AssertEquals('Failed on 1', 0, p.ObjectCount);
+  p.DrawImage(10, 20, 200, 100, 1);
+  AssertEquals('Failed on 2', 1, p.ObjectCount);
+  img := TMockPDFImage(p.Objects[0]);
+  AssertTrue('Failed on 3', img <> nil);
+  AssertEquals('Failed on 4', '', S.DataString);
+  img.Write(S);
+  AssertEquals('Failed on 5',
+    // save graphics state
+    'q'+CRLF+
+    '200 0 0 100 28.35 785.31 cm'+CRLF+
+    '/I1 Do'+CRLF+
+    // restore graphics state
+    'Q'+CRLF,
+    S.DataString);
+end;
+
 { TTestPDFLineStyle }
 
 procedure TTestPDFLineStyle.TestWrite_ppsSolid;
@@ -1795,6 +1841,7 @@ end;
 
 
 initialization
+  RegisterTest({$ifdef fptest}'fpPDF',{$endif}TGeneralPDFTests{$ifdef fptest}.Suite{$endif});
   RegisterTest({$ifdef fptest}'fpPDF',{$endif}TTestPDFObject{$ifdef fptest}.Suite{$endif});
   RegisterTest({$ifdef fptest}'fpPDF',{$endif}TTestTPDFDocumentObject{$ifdef fptest}.Suite{$endif});
   RegisterTest({$ifdef fptest}'fpPDF',{$endif}TTestPDFBoolean{$ifdef fptest}.Suite{$endif});

packages/fcl-pdf/tests/fpttf_test.pas

@@ -47,8 +47,11 @@ type
   published
     procedure TestCount;
     procedure TestBuildFontCache;
+    procedure TestBuildFontCache_tests_for_bug;
     procedure TestClear;
     procedure TestFind_FamilyName;
+    procedure TestFind_PostscriptName;
+    procedure TestAssignFontList;
   end;
 
 implementation
@@ -117,10 +120,10 @@ begin
     lFC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
     lFC.BuildFontCache;
 
-    lCI := lFC.Find('Liberation Sans');
+    lCI := lFC.Find('LiberationSans');
     AssertEquals('Failed on 1', 14684, round(lCI.TextWidth('Country Ppml01', 0.0)));
 
-    lCI := lFC.Find('DejaVu Sans');
+    lCI := lFC.Find('DejaVuSans');
     AssertEquals('Failed on 2', 16492, round(lCI.TextWidth('Country Ppml01', 0.0)));
 
     lCI := lFC.Find('Ubuntu'); // 7333 is the raw glyph width, but with kerning it is 7339
@@ -141,7 +144,7 @@ begin
     lFC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
     lFC.BuildFontCache;
 
-    lCI := lFC.Find('Liberation Sans');
+    lCI := lFC.Find('LiberationSans');
     px := 14684 * 10 * 96 / (72 * 2048);  // 95.599px
     AssertEquals('Failed on 1', px, lCI.TextWidth('Country Ppml01', 10.0));
     px := 14684 * 12 * 96 / (72 * 2048);  // 114.7188px
@@ -149,7 +152,7 @@ begin
     px := 14684 * 24 * 96 / (72 * 2048);  // 229.4375px
     AssertEquals('Failed on 3', px, lCI.TextWidth('Country Ppml01', 24.0));
 
-    lCI := lFC.Find('DejaVu Sans');
+    lCI := lFC.Find('DejaVuSans');
     px := 16492 * 10 * 96 / (72 * 2048);  // 107.369px
     AssertEquals('Failed on 4', px, lCI.TextWidth('Country Ppml01', 10.0));
     px := 16492 * 12 * 96 / (72 * 2048);  // 128.8438px
@@ -211,6 +214,14 @@ begin
   AssertEquals('Failed on 5' + cErrFontCountWrong, 4, FC.Count);
 end;
 
+procedure TFPFontCacheListTest.TestBuildFontCache_tests_for_bug;
+begin
+  AssertEquals('Failed on 1', 0, FC.Count);
+  FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'path_doesnt_exist');
+  FC.BuildFontCache;
+  AssertEquals('Failed on 2', 0, FC.Count);
+end;
+
 procedure TFPFontCacheListTest.TestClear;
 begin
   AssertEquals('Failed on 1', 0, FC.Count);
@@ -238,19 +249,66 @@ begin
   { TODO: We should try and extend this to make font paths user configure
            thus the tests could be more flexible. }
 
-  lCI := FC.Find('Ubuntu', True); // bold font
+  lCI := FC.Find('Ubuntu', True, False); // bold font
   AssertTrue('Failed on 5', lCI = nil);
   lCI := FC.Find('Ubuntu', False, True); // italic font
   AssertTrue('Failed on 6', lCI = nil);
   lCI := FC.Find('Ubuntu', True, True); // bold+italic font
   AssertTrue('Failed on 7', lCI = nil);
 
-  lCI := FC.Find('DejaVu Sans');
+  lCI := FC.Find('DejaVu Sans', False, False);
+  AssertTrue('Failed on 8', Assigned(lCI));
+  lCI := FC.Find('DejaVu Sans', True, False);
+  AssertTrue('Failed on 9', lCI = nil);
+end;
+
+procedure TFPFontCacheListTest.TestFind_PostscriptName;
+var
+  lCI: TFPFontCacheItem;
+begin
+  lCI := nil;
+  AssertEquals('Failed on 1', 0, FC.Count);
+  lCI := FC.Find('Ubuntu');
+  AssertTrue('Failed on 2', lCI = nil);
+  FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
+  FC.BuildFontCache;
+  AssertEquals('Failed on 3' + cErrFontCountWrong, 4, FC.Count);
+  lCI := FC.Find('Ubuntu');
+  AssertTrue('Failed on 4', Assigned(lCI));
+
+  { TODO: We should try and extend this to make font paths user configure
+           thus the tests could be more flexible. }
+
+  lCI := FC.Find('Ubuntu-Bold');
+  AssertTrue('Failed on 5', lCI = nil);
+  lCI := FC.Find('Ubuntu-Italic');
+  AssertTrue('Failed on 6', lCI = nil);
+  lCI := FC.Find('Ubuntu-BoldItalic');
+  AssertTrue('Failed on 7', lCI = nil);
+
+  lCI := FC.Find('DejaVuSans');
   AssertTrue('Failed on 8', Assigned(lCI));
-  lCI := FC.Find('DejaVu Sans Bold');
+  lCI := FC.Find('DejaVuSans-Bold');
   AssertTrue('Failed on 9', lCI = nil);
 end;
 
+procedure TFPFontCacheListTest.TestAssignFontList;
+var
+  sl: TStringList;
+begin
+  sl := TStringList.Create;
+  try
+    AssertEquals('Failed on 1', 0, FC.Count);
+    FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
+    FC.BuildFontCache;
+    AssertEquals('Failed on 2', 4, FC.Count);
+    FC.AssignFontList(sl);
+    AssertEquals('Failed on 3', 4, sl.Count);
+  finally
+    sl.Free;
+  end;
+end;
+
 
 initialization
   RegisterTest({$ifdef fptest}'fpTTF', {$endif}TFPFontCacheItemTest{$ifdef fptest}.Suite{$endif});