fcl-pdf: added function TPDFDocument.AddFont(AFontStream: TStream; AName: String): Integer and function TFPFontCacheList.AddFontFromStream(AStream: TStream): integer

packages/fcl-pdf/examples/testfppdf.lpi

@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
-    <Version Value="11"/>
+    <Version Value="12"/>
     <General>
       <Flags>
         <SaveOnlyProjectUnits Value="True"/>
@@ -9,9 +9,9 @@
         <MainUnitHasTitleStatement Value="False"/>
         <SaveJumpHistory Value="False"/>
         <SaveFoldState Value="False"/>
+        <CompatibilityMode Value="True"/>
       </Flags>
       <SessionStorage Value="InProjectDir"/>
-      <MainUnit Value="0"/>
       <Title Value="testfppdf"/>
       <UseAppBundle Value="False"/>
       <ResourceType Value="res"/>
@@ -57,6 +57,7 @@
     </SearchPaths>
     <Linking>
       <Debugging>
+        <DebugInfoType Value="dsDwarf2"/>
         <UseHeaptrc Value="True"/>
       </Debugging>
     </Linking>

packages/fcl-pdf/examples/testfppdf.lpr

@@ -53,7 +53,9 @@ type
     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);
+    procedure   TextInABox(const APage: TPDFPage; const AX, AY: TPDFFloat;
+      const APointSize: integer; const ABoxColor: TARGBColor;
+      AFontName, AFontFamilyName: string; const AText: UTF8String);
   protected
     procedure   DoRun; override;
   public
@@ -76,6 +78,11 @@ var
   lOpts: TPDFOptions;
 begin
   Result := TPDFDocument.Create(Nil);
+
+  // init search paths
+  Result.FontDirectory := ExpandFileName('fonts');
+
+  // set global props
   Result.Infos.Title := Application.Title;
   Result.Infos.Author := 'Graeme Geldenhuys';
   Result.Infos.Producer := 'fpGUI Toolkit 1.4.1';
@@ -105,6 +112,7 @@ begin
     Include(lOpts,poMetadataEntry);  
   Result.Options := lOpts;
 
+  // add content
   Result.StartDocument;
   S := Result.Sections.AddSection; // we always need at least one section
   lPageCount := cPageCount;
@@ -177,18 +185,40 @@ end;
 
 { all units of measure are in millimeters }
 procedure TPDFTestApp.SimpleText(D: TPDFDocument; APage: integer);
+const
+  FontNameTitle = 'Helvetica';
+  FontNameText1 = 'FreeSans-Regular'; // arbitrary name, could be 'Free Sans Regular' too
+  FontFamilyNameText1 = 'FreeSans'; // must correspond to the family name of the ttf
+  FontNameText2 = 'Times-BoldItalic';
+  FontNameWaterMark = 'Helvetica-Bold';
 var
   P : TPDFPage;
   FtTitle, FtText1, FtText2: integer;
   FtWaterMark: integer;
+  ms: TMemoryStream;
+  aFilename: String;
 begin
   P := D.Pages[APage];
 
-  // create the fonts to be used (use one of the 14 Adobe PDF standard fonts)
-  FtTitle := D.AddFont('Helvetica');
-  FtText1 := D.AddFont('FreeSans.ttf', 'FreeSans');
-  FtText2 := D.AddFont('Times-BoldItalic');
-  FtWaterMark := D.AddFont('Helvetica-Bold');
+  // create the fonts to be used
+  FtTitle := D.AddFont(FontNameTitle); // use one of the 14 Adobe PDF standard fonts
+
+  // demonstrating loading a font from a stream (used glyphs will be embedded in the pdf)
+  aFilename:=IncludeTrailingPathDelimiter(D.FontDirectory)+'FreeSans.ttf';
+  ms:=TMemoryStream.Create;
+  try
+    ms.LoadFromFile(aFilename);
+    FtText1 := D.AddFont(ms,FontNameText1);
+    ms.Position:=0;
+    gTTFontCache.AddFontFromStream(ms);
+  finally
+    ms.Free;
+  end;
+  // alternatively you can load from file:
+  //  FtText1 := D.AddFont(aFilename,FontNameText1);
+
+  FtText2 := D.AddFont(FontNameText2); // use a standard font
+  FtWaterMark := D.AddFont(FontNameWaterMark); // use a standard font
 
   { Page title }
   P.SetFont(FtTitle, 23);
@@ -203,7 +233,7 @@ begin
   // 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.WriteText(25, 50, '(25mm,50mm) '+FontNameTitle+': 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);
@@ -223,7 +253,7 @@ begin
 
   P.SetFont(ftText2,16);
   P.SetColor($C00000, false);
-  P.WriteText(50, 100, '(50mm,100mm) Times-BoldItalic: Big text at absolute position');
+  P.WriteText(50, 100, '(50mm,100mm) '+FontNameText2+': Big text at absolute position');
 
 
   // -----------------------------------
@@ -248,10 +278,10 @@ begin
   P.WriteText(25, 280, 'B субботу двадцать третьего мая приезжает твоя любимая теща.');
 
   { draw a rectangle around the text }
-  TextInABox(P, 25, 255, 23, clRed, 'FreeSans', '“Text in a Box gyj?”');
+  TextInABox(P, 25, 255, 23, clRed, FontNameText1, FontFamilyNameText1, '“Text in a Box?”');
 
   { lets make a hyperlink more prominent }
-  TextInABox(P, 100, 255, 12, clMagenta, 'FreeSans', 'http://www.freepascal.org');
+  TextInABox(P, 100, 255, 12, clMagenta, FontNameText1, FontFamilyNameText1, 'http://www.freepascal.org');
   P.AddExternalLink(99, 255, 49, 5, 'http://www.freepascal.org', false);
 end;
 
@@ -753,8 +783,9 @@ 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);
+procedure TPDFTestApp.TextInABox(const APage: TPDFPage; const AX,
+  AY: TPDFFloat; const APointSize: integer; const ABoxColor: TARGBColor;
+  AFontName, AFontFamilyName: string; const AText: UTF8String);
 var
   lFontIdx: integer;
   lFC: TFPFontCacheItem;
@@ -766,6 +797,8 @@ var
   lDescenderHeightInMM: single;
   i: integer;
 begin
+  if AFontFamilyName='' then AFontFamilyName:=AFontName;
+
   for i := 0 to APage.Document.Fonts.Count-1 do
   begin
     if APage.Document.Fonts[i].Name = AFontName then
@@ -778,9 +811,9 @@ begin
   APage.SetColor(clBlack, false);
   APage.WriteText(AX, AY, AText);
 
-  lFC := gTTFontCache.Find(AFontName, False, False);
+  lFC := gTTFontCache.Find(AFontFamilyName, False, False);
   if not Assigned(lFC) then
-    raise Exception.Create(AFontName + ' font not found');
+    raise Exception.Create(AFontFamilyName + ' font family not found');
 
   lHeight := lFC.TextHeight(AText, APointSize, lDescenderHeight);
   { convert the Font Units to mm as our PDFPage.UnitOfMeasure is set to mm. }

packages/fcl-pdf/src/fppdf.pp

@@ -871,6 +871,8 @@ type
   TPDFPageClass = class of TPDFPage;
 
 
+  { TPDFSection }
+
   TPDFSection = Class(TCollectionItem)
   private
     FTitle: String;
@@ -886,6 +888,8 @@ type
   end;
 
 
+  { TPDFSectionList }
+
   TPDFSectionList = Class(TCollection)
   private
     function GetS(AIndex : Integer): TPDFSection;
@@ -895,16 +899,19 @@ type
   end;
 
 
+  { TPDFFont }
+
   TPDFFont = class(TCollectionItem)
   private
     FIsStdFont: boolean;
     FName: String;
     FFontFilename: String;
+    FFontStream: TMemoryStream;
     FTrueTypeFile: TTFFileInfo;
     { stores mapping of Char IDs to font Glyph IDs }
     FTextMappingList: TTextMappingList;
     FSubsetFont: TStream;
-    procedure   PrepareTextMapping;
+    procedure   PrepareTextMapping(aStream: TStream = nil);
     procedure   SetFontFilename(const AValue: string);
     procedure   GenerateSubsetFont;
   public
@@ -913,7 +920,9 @@ type
     { 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);
+    procedure   LoadFromStream(aStream: TStream);
     Property    FontFile: string read FFontFilename write SetFontFilename;
+    Property    FontStream: TMemoryStream read FFontStream;
     Property    Name: String Read FName Write FName;
     property    TextMapping: TTextMappingList read FTextMappingList;
     property    IsStdFont: boolean read FIsStdFont write FIsStdFont;
@@ -921,6 +930,8 @@ type
   end;
 
 
+  { TPDFTrueTypeCharWidths }
+
   TPDFTrueTypeCharWidths = class(TPDFDocumentObject)
   private
     FEmbeddedFontNum: integer;
@@ -1234,6 +1245,7 @@ type
     Function CreateImage(const ALeft, ABottom, AWidth, AHeight: TPDFFloat; ANumber: integer) : TPDFImage;
     Function AddFont(AName : String) : Integer; overload;
     Function AddFont(AFontFile: String; AName : String) : Integer; overload;
+    Function AddFont(AFontStream: TStream; AName : String) : Integer; overload;
     Function AddLineStyleDef(ALineWidth : TPDFFloat; AColor : TARGBColor = clBlack; APenStyle : TPDFPenStyle = ppsSolid) : Integer;
     function AddLineStyleDef(ALineWidth : TPDFFloat; AColor : TARGBColor = clBlack; ADashArray : TDashArray = []) : Integer;
     procedure AddOutputIntent(const Subtype, OutputConditionIdentifier, Info: string; ICCProfile: TStream);
@@ -1735,16 +1747,22 @@ end;
 
 { TPDFFont }
 
-procedure TPDFFont.PrepareTextMapping;
+procedure TPDFFont.PrepareTextMapping(aStream: TStream);
 begin
-  if FFontFilename <> '' then
+  if (FFontFilename = '') and (FFontStream=nil) then
+    exit;
+  // only create objects when needed
+  if FTextMappingList<>nil then
+    Exception.Create('TPDFFont.PrepareTextMapping already created');
+  FTextMappingList := TTextMappingList.Create;
+  FTrueTypeFile := TTFFileInfo.Create;
+  if FFontStream<>nil then
   begin
-    // only create objects when needed
-    FTextMappingList := TTextMappingList.Create;
-    FTrueTypeFile := TTFFileInfo.Create;
+    FFontStream.Position:=0;
+    FTrueTypeFile.LoadFromStream(FFontStream);
+  end else
     FTrueTypeFile.LoadFromFile(FFontFilename);
-    FTrueTypeFile.PrepareFontDefinition('cp1252', True);
-  end;
+  FTrueTypeFile.PrepareFontDefinition('cp1252', True);
 end;
 
 procedure TPDFFont.SetFontFilename(const AValue: string);
@@ -1787,9 +1805,10 @@ end;
 
 destructor TPDFFont.Destroy;
 begin
-  FTextMappingList.Free;
-  FTrueTypeFile.Free;
-  FSubSetFont.Free;
+  FreeAndNil(FFontStream);
+  FreeAndNil(FTextMappingList);
+  FreeAndNil(FTrueTypeFile);
+  FreeAndNil(FSubSetFont);
   inherited Destroy;
 end;
 
@@ -1835,6 +1854,18 @@ begin
   end;
 end;
 
+procedure TPDFFont.LoadFromStream(aStream: TStream);
+begin
+  if FFontStream=aStream then Exit;
+  if FFontStream<>nil then
+    raise Exception.Create('TPDFFont.SetFontStream has already a stream');
+  if FFontFilename<>'' then
+    raise Exception.Create('TPDFFont.SetFontStream has already a file');
+  FFontStream:=TMemoryStream.Create;
+  FFontStream.CopyFrom(aStream,aStream.Size-aStream.Position);
+  PrepareTextMapping;
+end;
+
 { TPDFTrueTypeCharWidths }
 
 // TODO: (optional improvement) CID -> Unicode mappings, use ranges to generate a smaller CMap
@@ -3030,7 +3061,7 @@ begin
     Raise EPDF.CreateFmt(rsErrInvalidSectionPage,[AIndex]);
 end;
 
-function TPDFSection.GetP: INteger;
+function TPDFSection.GetP: Integer;
 begin
   if Assigned(FPages) then
     Result:=FPages.Count
@@ -4795,6 +4826,7 @@ var
   M, Buf : TMemoryStream;
   E : TPDFDictionaryItem;
   D : TPDFDictionary;
+  aFont: TPDFFont;
 begin
   if GetE(0).FKey.Name='' then
     GetE(0).Write(AStream)  // write a charwidth array of a font
@@ -4849,6 +4881,7 @@ begin
           begin
             Value:=E.FKey.Name;
             NumFnt:=StrToInt(Copy(Value, Succ(Pos(' ', Value)), Length(Value) - Pos(' ', Value)));
+            aFont:=Document.Fonts[NumFnt];
             if poSubsetFont in Document.Options then
             begin
 
@@ -4871,9 +4904,15 @@ begin
             end
             else
             begin
-              M:=TMemoryStream.Create;
+              if aFont.FontStream<>nil then
+              begin
+                M:=aFont.FontStream;
+                M.Position:=0;
+              end else
+                M:=TMemoryStream.Create;
               try
-                m.LoadFromFile(Document.FontFiles[NumFnt]);
+                if aFont.FontStream=nil then
+                  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
@@ -4890,7 +4929,8 @@ begin
                   Buf.Free;
                 end;
               finally
-                M.Free;
+                if aFont.FontStream=nil then
+                  M.Free;
               end;
             end;
           end;
@@ -5691,6 +5731,9 @@ var
   s: string;
 begin
   Result := False;
+  if AFont.TextMapping<>nil then
+    exit(true);
+
   if ExtractFilePath(AFont.FontFile) <> '' then
     // assume AFont.FontFile is the full path to the TTF file
     lFName := AFont.FontFile
@@ -5713,6 +5756,8 @@ var
   N: TPDFName;
   Arr: TPDFArray;
   lFontXRef: integer;
+  aFilename: String;
+  TTF: TTFFileInfo;
 begin
   lFontXRef := GlobalXRefCount; // will be used a few lines down in AddFontNameToPages()
 
@@ -5743,7 +5788,20 @@ begin
     FDict.AddReference('ToUnicode', GlobalXRefCount);
     CreateToUnicode(EmbeddedFontNum);
   end;
-  FontFiles.Add(Fonts[EmbeddedFontNum].FTrueTypeFile.Filename);
+  TTF:=Fonts[EmbeddedFontNum].FTrueTypeFile;
+  aFilename:=TTF.Filename;
+  if ExtractFilename(aFilename)='' then
+  begin
+    aFilename:='';
+    if TTF.Bold then
+      aFilename:=aFilename+'Bold';
+    if TTF.ItalicAngle<>0 then
+      aFilename:=aFilename+'Italic';
+    if aFilename='' then
+      aFilename:='Regular';
+    aFilename:=TTF.FamilyName+'-'+aFilename;
+  end;
+  FontFiles.Add(aFilename);
 end;
 
 procedure TPDFDocument.CreateTTFDescendantFont(const EmbeddedFontNum: integer);
@@ -6534,9 +6592,8 @@ end;
 function TPDFDocument.AddFont(AName: String): Integer;
 var
   F: TPDFFont;
-  i: integer;
 begin
-  { reuse existing font definition if it exists }
+  // reuse existing font definition if it exists
   Result:=Fonts.FindFont(AName);
   if Result>=0 then exit;
   F := Fonts.AddFontDef;
@@ -6548,10 +6605,9 @@ end;
 function TPDFDocument.AddFont(AFontFile: String; AName: String): Integer;
 var
   F: TPDFFont;
-  i: integer;
   lFName: string;
 begin
-  { reuse existing font definition if it exists }
+  // reuse existing font definition if it exists
   Result:=Fonts.FindFont(AName);
   if Result>=0 then exit;
   F := Fonts.AddFontDef;
@@ -6567,6 +6623,20 @@ begin
   Result := Fonts.Count-1;
 end;
 
+function TPDFDocument.AddFont(AFontStream: TStream; AName: String): Integer;
+var
+  F: TPDFFont;
+begin
+  // reuse existing font definition if it exists
+  Result:=Fonts.FindFont(AName);
+  if Result>=0 then exit;
+  F := Fonts.AddFontDef;
+  F.Name := AName;
+  F.IsStdFont := False;
+  F.LoadFromStream(AFontStream);
+  Result := Fonts.Count-1;
+end;
+
 function TPDFDocument.AddLineStyleDef(ALineWidth: TPDFFloat; AColor: TARGBColor;
   APenStyle: TPDFPenStyle): Integer;
 

packages/fcl-pdf/src/fpttf.pp

@@ -54,10 +54,13 @@ type
   TFPFontCacheList = class;
 
 
+  { TFPFontCacheItem }
+
   TFPFontCacheItem = class(TObject)
   private
     FFamilyName: String;
     FFileName: String;
+    FStream: TStream;
     FStyleFlags: TTrueTypeFontStyles;
     FFileInfo: TTFFileInfo;
     FOwner: TFPFontCacheList; // reference to FontCacheList that owns this instance
@@ -76,13 +79,15 @@ type
     function    GetHumanFriendlyName: string;
     function    GetFileInfo: TTFFileInfo;
   public
-    constructor Create(const AFilename: String);
+    constructor Create(const AFilename: String); overload;
+    constructor Create(const AStream: TStream); overload; // AStream is freed on destroy
     destructor  Destroy; override;
     { Result is in pixels }
     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    Stream: TStream read FStream;
     property    FamilyName: String read GetFamilyName;
     property    PostScriptName: string read GetPostScriptName;
     property    HumanFriendlyName: string read GetHumanFriendlyName;
@@ -103,7 +108,7 @@ type
   TFPFontCacheList = class(TObject)
   private
     FBuildFontCacheIgnoresErrors: Boolean;
-    FList: TObjectList;
+    FList: TObjectList; // list of TFPFontCacheItem
     FSearchPath: TStringList;
     FDPI: integer;
     procedure   SearchForFonts(const AFontPath: String);
@@ -120,9 +125,10 @@ type
     destructor  Destroy; override;
     procedure   BuildFontCache;
     function    Add(const AObject: TFPFontCacheItem): integer;
+    function    AddFontFromStream(AStream: TStream): integer; // add a single font from stream, returns index
     procedure   AssignFontList(const AStrings: TStrings);
     procedure   Clear;
-    procedure   LoadFromFile(const AFilename: string);
+    procedure   LoadFromFile(const AFilename: string); // load list of filenames
     procedure   ReadStandardFonts;
     property    Count: integer read GetCount;
     function    IndexOf(const AObject: TFPFontCacheItem): integer;
@@ -221,14 +227,18 @@ end;
 
 procedure TFPFontCacheItem.LoadFileInfo;
 begin
-  if FileExists(FFilename) then
+  if FStream<>nil then
+  begin
+    FFileInfo := TTFFileInfo.Create;
+    FFileInfo.LoadFromStream(FStream);
+  end else if (FFilename<>'') and FileExists(FFilename) then
   begin
     FFileInfo := TTFFileInfo.Create;
     FFileInfo.LoadFromFile(FFilename);
-    BuildFontCacheItem;
   end
   else
     raise ETTF.CreateFmt(rsMissingFontFile, [FFilename]);
+  BuildFontCacheItem;
 end;
 
 function TFPFontCacheItem.GetIsBold: boolean;
@@ -333,9 +343,20 @@ begin
     raise ETTF.Create(rsNoFontFileName);
 end;
 
+constructor TFPFontCacheItem.Create(const AStream: TStream);
+begin
+  inherited Create;
+  if AStream = nil then
+    raise ETTF.Create(rsNoFontFileName);
+
+  FStream := AStream;
+  FStyleFlags := [fsRegular];
+end;
+
 destructor TFPFontCacheItem.Destroy;
 begin
-  FFileInfo.Free;
+  FreeAndNil(FStream);
+  FreeAndNil(FFileInfo);
   inherited Destroy;
 end;
 
@@ -555,6 +576,20 @@ begin
   end;
 end;
 
+function TFPFontCacheList.AddFontFromStream(AStream: TStream): integer;
+var
+  ms: TMemoryStream;
+  Item: TFPFontCacheItem;
+begin
+  ms:=TMemoryStream.Create;
+  ms.CopyFrom(AStream,AStream.Size-AStream.Position);
+  ms.Position:=0;
+  Item:=TFPFontCacheItem.Create(ms);
+  Result:=Add(Item);
+  if Item.FamilyName='' then
+    raise EFontNotFound.Create('TFPFontCacheList.AddFontFromStream font has no family name');
+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.
@@ -699,7 +734,8 @@ begin
   Result:=DoFindPostScriptFontName(aFontName,aBold,aItalic,lfc);
 end;
 
-function  TFPFontCacheList.DoFindPostScriptFontName(const AFontName: string; ABold: boolean; AItalic: boolean; Out aBaseFont : TFPFontCacheItem): String;
+function TFPFontCacheList.DoFindPostScriptFontName(const AFontName: string;
+  ABold: boolean; AItalic: boolean; out aBaseFont: TFPFontCacheItem): String;
 
 Var
    lNewFC : TFPFontCacheItem;