paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 15:49:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
mattias 2023-11-02 16:32:24 +01:00
parent 605a495db1
commit be68d66137
4 changed files with 183 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
packages/fcl-pdf/examples/testfppdf.lpi
View File

@ -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>

61
packages/fcl-pdf/examples/testfppdf.lpr
View File

@ -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. }

110
packages/fcl-pdf/src/fppdf.pp
View File

@ -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;

50
packages/fcl-pdf/src/fpttf.pp
View File

@ -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;