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

* More fixes from Graeme, hopefully UTF16 works now fully

Browse Source 
git-svn-id: trunk@33453 -
This commit is contained in:
michael 2016-04-08 18:16:46 +00:00
parent f8e9b33f99
commit 897547b115
4 changed files with 122 additions and 614 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

426
packages/fcl-pdf/src/fpparsettf.pp
View File

@ -31,26 +31,6 @@ type
// Tables recognized in this unit.
TTTFTableType = (ttUnknown,ttHead,tthhea,ttmaxp,tthmtx,ttcmap,ttname,ttOS2,ttpost);
TPDFFontDefinition = Record
FontType : String;
FontName : String;
Ascender : Integer;
Descender : Integer;
CapHeight : Integer;
Flags : Integer;
BBox : Array[0..3] of Integer;
ItalicAngle : Integer;
StemV : Integer;
MissingWidth : integer;
FontUp : Integer;
FontUt : Integer;
Encoding : String;
FontFile : String;
Diffs : String;
CharWidths : String;
OriginalSize : integer;
end;
TSmallintArray = Packed Array of Int16;
TWordArray = Packed Array of UInt16;
@ -253,10 +233,11 @@ Type
FWidths: TLongHorMetrics; // hmtx data
// Needed to create PDF font def.
FOriginalSize : Cardinal;
MissingWidth: Integer;
FMissingWidth: Integer;
FNameEntries: TNameEntries;
{ This only applies to TFixedVersionRec values. }
function FixMinorVersion(const AMinor: word): word;
function GetMissingWidth: integer;
Protected
// Stream reading functions.
Function IsNativeData : Boolean; virtual;
@ -273,23 +254,10 @@ Type
procedure ParseOS2(AStream : TStream); virtual;
procedure ParsePost(AStream : TStream); virtual;
// Make differences for postscript fonts
procedure PrepareEncoding(Const AEnCoding : String);
procedure PrepareEncoding(Const AEncoding : String);
function MakeDifferences: String; virtual;
// Utility function to convert FShort to natural units
Function ToNatural(AUnit: Smallint) : Smallint;
// Some utility functions to create the PDF font definition
Procedure MakePDFFontDefinitionFile(Const FontFile,Section,AEncoding: string); virtual;
Function Flags : Integer;
Function Bold: Boolean;
Function StemV: SmallInt;
Function Embeddable : Boolean;
Function Ascender: SmallInt;
Function Descender: SmallInt;
{ Also know as the linegap. "Leading" is the gap between two lines. }
Function Leading: SmallInt;
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;
public
Chars: TWordArray;
CharWidth: array[0..255] of SmallInt;
@ -304,17 +272,32 @@ Type
// Load a TTF file from file or stream.
Procedure LoadFromFile(const AFileName : String);
Procedure LoadFromStream(AStream: TStream); virtual;
// Checks if Embedded is allowed, and also prepares CharWidths array
// Checks if Embedded is allowed, and also prepares CharWidths array. NOTE: this is possibly not needed any more.
procedure PrepareFontDefinition(const Encoding:string; Embed: Boolean);
// Fill record with PDF Font definition data.
Procedure FillPDFFontDefinition(Out ADef: TPDFFontDefinition; Const AFontFile,AEncoding : String);
// Write Font Definition data to a file named FontFile.
procedure MakePDFFontDef(const FontFile: string; const Encoding: string; Embed: Boolean);
// The following are only valid after the file was succesfully read.
// Font file header info.
Function Flags : Integer;
Function Bold: Boolean;
Function StemV: SmallInt;
Function Embeddable : Boolean;
Function Ascender: SmallInt;
Function Descender: SmallInt;
{ Also know as the linegap. "Leading" is the gap between two lines. }
Function Leading: SmallInt;
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;
{ max glyph bounding box values - as space separated values }
function BBox: string;
property MissingWidth: Integer read GetMissingWidth;
{ original font file size }
property OriginalSize: Cardinal read FOriginalSize;
property Filename: string read FFilename;
Property Directory : TTableDirectory Read FTableDir;
Property Tables : TTableDirectoryEntries Read FTables;
// The various tables as present in the font file.
Property Head : THead Read FHead;
Property HHead : THHead Read FHHead;
property CmapH : TCMapHeader Read FCmapH;
@ -338,12 +321,9 @@ type
// Convert string to known table type
Function GetTableType(Const AName : String) : TTTFTableType;
// Utility functions for text encoding conversions
function ConvertUTF8ToUTF16(Dest: PWideChar; DestWideCharCount: SizeUInt; Src: PChar; SrcCharCount: SizeUInt;
Options: TConvertOptions; out ActualWideCharCount: SizeUInt): TConvertResult;
function UTF8ToUTF16(const P: PChar; ByteCnt: SizeUInt): UnicodeString;
function UTF8ToUTF16(const S: AnsiString): UnicodeString;
function StrToUTF16Hex(const AValue: UnicodeString; AIncludeBOM: boolean = True): AnsiString;
{ To overcome the annoying compiler hint: "Local variable does not seem to be initialized" }
procedure FillMem(Dest: pointer; Size: longint; Data: Byte );
Const
@ -373,8 +353,6 @@ Const
implementation
uses
inifiles;
resourcestring
rsFontEmbeddingNotAllowed = 'Font licence does not allow embedding';
@ -386,222 +364,6 @@ begin
Result:=Pred(Result);
end;
{------------------------------------------------------------------------------
Name: ConvertUTF8ToUTF16
Params: Dest - Pointer to destination string
DestWideCharCount - Wide char count allocated in destination string
Src - Pointer to source string
SrcCharCount - Char count allocated in source string
Options - Conversion options, if none is set, both
invalid and unfinished source chars are skipped
toInvalidCharError - Stop on invalid source char and report
error
toInvalidCharToSymbol - Replace invalid source chars with '?'
toUnfinishedCharError - Stop on unfinished source char and
report error
toUnfinishedCharToSymbol - Replace unfinished source char with '?'
ActualWideCharCount - Actual wide char count converted from source
string to destination string
Returns:
trNoError - The string was successfully converted without
any error
trNullSrc - Pointer to source string is nil
trNullDest - Pointer to destination string is nil
trDestExhausted - Destination buffer size is not big enough to hold
converted string
trInvalidChar - Invalid source char has occured
trUnfinishedChar - Unfinished source char has occured
Converts the specified UTF-8 encoded string to UTF-16 encoded (system endian)
------------------------------------------------------------------------------}
function ConvertUTF8ToUTF16(Dest: PWideChar; DestWideCharCount: SizeUInt;
Src: PChar; SrcCharCount: SizeUInt; Options: TConvertOptions;
out ActualWideCharCount: SizeUInt): TConvertResult;
var
DestI, SrcI: SizeUInt;
B1, B2, B3, B4: Byte;
W: Word;
C: Cardinal;
function UnfinishedCharError: Boolean;
begin
if toUnfinishedCharToSymbol in Options then
begin
Dest[DestI] := System.WideChar('?');
Inc(DestI);
Result := False;
end
else
if toUnfinishedCharError in Options then
begin
ConvertUTF8ToUTF16 := trUnfinishedChar;
Result := True;
end
else Result := False;
end;
function InvalidCharError(Count: SizeUInt): Boolean; inline;
begin
if not (toInvalidCharError in Options) then
begin
if toInvalidCharToSymbol in Options then
begin
Dest[DestI] := System.WideChar('?');
Inc(DestI);
end;
Dec(SrcI, Count);
// skip trailing UTF-8 char bytes
while (Count > 0) do
begin
if (Byte(Src[SrcI]) and %11000000) <> %10000000 then Break;
Inc(SrcI);
Dec(Count);
end;
Result := False;
end
else
if toInvalidCharError in Options then
begin
ConvertUTF8ToUTF16 := trUnfinishedChar;
Result := True;
end;
end;
begin
ActualWideCharCount := 0;
if not Assigned(Src) then
begin
Result := trNullSrc;
Exit;
end;
if not Assigned(Dest) then
begin
Result := trNullDest;
Exit;
end;
SrcI := 0;
DestI := 0;
while (DestI < DestWideCharCount) and (SrcI < SrcCharCount) do
begin
B1 := Byte(Src[SrcI]);
Inc(SrcI);
if B1 < 128 then // single byte UTF-8 char
begin
Dest[DestI] := System.WideChar(B1);
Inc(DestI);
end
else
begin
if SrcI >= SrcCharCount then
if UnfinishedCharError then Exit(trInvalidChar)
else Break;
B2 := Byte(Src[SrcI]);
Inc(SrcI);
if (B1 and %11100000) = %11000000 then // double byte UTF-8 char
begin
if (B2 and %11000000) = %10000000 then
begin
Dest[DestI] := System.WideChar(((B1 and %00011111) shl 6) or (B2 and %00111111));
Inc(DestI);
end
else // invalid character, assume single byte UTF-8 char
if InvalidCharError(1) then Exit(trInvalidChar);
end
else
begin
if SrcI >= SrcCharCount then
if UnfinishedCharError then Exit(trInvalidChar)
else Break;
B3 := Byte(Src[SrcI]);
Inc(SrcI);
if (B1 and %11110000) = %11100000 then // triple byte UTF-8 char
begin
if ((B2 and %11000000) = %10000000) and ((B3 and %11000000) = %10000000) then
begin
W := ((B1 and %00011111) shl 12) or ((B2 and %00111111) shl 6) or (B3 and %00111111);
if (W < $D800) or (W > $DFFF) then // to single wide char UTF-16 char
begin
Dest[DestI] := System.WideChar(W);
Inc(DestI);
end
else // invalid UTF-16 character, assume double byte UTF-8 char
if InvalidCharError(2) then Exit(trInvalidChar);
end
else // invalid character, assume double byte UTF-8 char
if InvalidCharError(2) then Exit(trInvalidChar);
end
else
begin
if SrcI >= SrcCharCount then
if UnfinishedCharError then Exit(trInvalidChar)
else Break;
B4 := Byte(Src[SrcI]);
Inc(SrcI);
if ((B1 and %11111000) = %11110000) and ((B2 and %11000000) = %10000000)
and ((B3 and %11000000) = %10000000) and ((B4 and %11000000) = %10000000) then
begin // 4 byte UTF-8 char
C := ((B1 and %00011111) shl 18) or ((B2 and %00111111) shl 12)
or ((B3 and %00111111) shl 6) or (B4 and %00111111);
// to double wide char UTF-16 char
Dest[DestI] := System.WideChar($D800 or ((C - $10000) shr 10));
Inc(DestI);
if DestI >= DestWideCharCount then Break;
Dest[DestI] := System.WideChar($DC00 or ((C - $10000) and %0000001111111111));
Inc(DestI);
end
else // invalid character, assume triple byte UTF-8 char
if InvalidCharError(3) then Exit(trInvalidChar);
end;
end;
end;
end;
if DestI >= DestWideCharCount then
begin
DestI := DestWideCharCount - 1;
Result := trDestExhausted;
end
else
Result := trNoError;
Dest[DestI] := #0;
ActualWideCharCount := DestI + 1;
end;
function UTF8ToUTF16(const P: PChar; ByteCnt: SizeUInt): UnicodeString;
var
L: SizeUInt;
begin
if ByteCnt=0 then
exit('');
SetLength(Result, ByteCnt);
// wide chars of UTF-16 <= bytes of UTF-8 string
if ConvertUTF8ToUTF16(PWideChar(Result), Length(Result) + 1, P, ByteCnt,
[toInvalidCharToSymbol], L) = trNoError
then SetLength(Result, L - 1)
else Result := '';
end;
function UTF8ToUTF16(const S: AnsiString): UnicodeString;
begin
Result:=UTF8ToUTF16(PChar(S),length(S));
end;
function StrToUTF16Hex(const AValue: UnicodeString; AIncludeBOM: boolean = True): AnsiString;
var
pc: ^Word;
@ -618,6 +380,11 @@ begin
end;
end;
procedure FillMem(Dest: pointer; Size: longint; Data: Byte );
begin
FillChar(Dest^, Size, Data);
end;
function TTFFileInfo.ReadULong(AStream: TStream): Longword;inline;
begin
Result:=0;
@ -755,7 +522,7 @@ begin
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');
Raise ETTF.Create('No Format 4 map (unicode) table found <'+FFileName + ' - ' + PostScriptName+'>');
TT:=TableStartPos+FSubtables[UE].Offset;
AStream.Position:=TT;
FUnicodeMap.Format:= ReadUShort(AStream); // 2 bytes - Format of subtable
@ -839,12 +606,8 @@ begin
StringOffset:=ReadUShort(AStream); // 2 bytes
E := FNameEntries;
SetLength(E,Count);
FillMem(@N, SizeOf(TNameRecord), 0);
// Read Descriptors
{$IFDEF VER3}
N := Default(TNameRecord);
{$ELSE}
FillChar(N,SizeOf(TNameRecord),0);
{$ENDIF}
for I:=0 to Count-1 do
begin
AStream.ReadBuffer(N,SizeOf(TNameRecord));
@ -1027,7 +790,7 @@ begin
ttcmap: ParseCmap(AStream);
ttname: ParseName(AStream);
ttos2 : ParseOS2(AStream);
ttPost: ParsePost(AStream); // lecture table "Post"
ttPost: ParsePost(AStream);
end;
end;
end;
@ -1041,52 +804,17 @@ begin
raise ETTF.Create(rsFontEmbeddingNotAllowed);
PrepareEncoding(Encoding);
// MissingWidth:=ToNatural(Widths[Chars[CharCodes^[32]]].AdvanceWidth); // Char(32) - Space character
MissingWidth:=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
if (Widths[Chars[CharCodes^[i]]].AdvanceWidth> 0) and (CharNames^[i]<> '.notdef') then
CharWidth[I]:= ToNatural(Widths[Chars[CharCodes^[I]]].AdvanceWidth)
else
CharWidth[I]:= MissingWidth;
CharWidth[I]:= FMissingWidth;
end;
end;
procedure TTFFileInfo.FillPDFFontDefinition(out ADef: TPDFFontDefinition; const AFontFile, AEncoding: String);
Var
I : Integer;
S : String;
begin
ADef.FontType:='TrueType'; // DON'T LOCALIZE
ADef.FontName:=PostScriptName;
ADef.Ascender:=Ascender;
ADef.Descender:=Descender;
ADef.CapHeight:=Capheight;
ADef.Flags:=Flags;
For I:=0 to 3 do
ADef.BBox[i]:=ToNatural(FHead.BBox[I]);
ADef.ItalicAngle:=FPostScript.ItalicAngle;
ADef.StemV:=StemV;
ADef.MissingWidth:=MissingWidth;
ADef.FontUp:=ToNatural(FPostScript.UnderlinePosition);
ADef.FontUt:=ToNatural(FPostScript.UnderlineThickness);
ADef.Encoding:=AEncoding;
ADef.OriginalSize:=FOriginalSize;
ADef.FontFile:=ChangeFileExt(AFontFile,'.z');
if (Lowercase(AEncoding)<>'cp1252') then
ADef.Diffs:=MakeDifferences;
S:='';
for I:=32 to 255 do
begin
if I>32 then
S:=S+' ';
S:=S+IntToStr(CharWidth[I]);
end;
ADef.CharWidths:=S;
end;
procedure TTFFileInfo.PrepareEncoding(const AEnCoding: String);
procedure TTFFileInfo.PrepareEncoding(const AEncoding: String);
var
TE : TTTFEncoding;
V : PTTFEncodingValues;
@ -1098,49 +826,6 @@ begin
GetEncodingTables(Te,CharBase,V);
end;
procedure TTFFileInfo.MakePDFFontDefinitionFile(const FontFile, Section, AEncoding: string);
var
Ini : TMemIniFile;
S: String;
I : Integer;
Def : TPDFFontDefinition;
begin
FillPDFFontDefinition(Def,FontFile,AEncoding);
Ini:=TMemIniFile.Create(FontFile);
With Ini Do
try
WriteString(Section,'FontType',Def.FontType);
WriteString(Section,'FontName',Def.FontName);
WriteInteger(Section,'Ascent',Def.Ascender);
WriteInteger(Section,'Descent',Def.Descender);
WriteInteger(Section,'CapHeight',Def.CapHeight);
WriteInteger(Section,'Flags',Def.Flags);
S:='';
for i:=0 to 3 do
begin
if I>0 then
S:=S+' ';
S:=S+IntToStr(Def.BBox[I]);
end;
WriteString(Section,'FontBBox',S);
WriteInteger(Section,'ItalicAngle',Def.ItalicAngle);
WriteInteger(Section,'StemV',Def.StemV);
WriteInteger(Section,'MissingWidth',Def.MissingWidth);
WriteInteger(Section,'FontUp',Def.FontUp);
WriteInteger(Section,'FontUt',Def.FontUt);
WriteString(Section,'Encoding',Def.Encoding);
WriteString(Section,'FontFile',Def.FontFile);
WriteInteger(Section,'OriginalSize',Def.OriginalSize);
WriteString(Section,'Diffs',Def.Diffs);
WriteString(Section,'CharWidth',Def.CharWidths);
UpdateFile;
finally
Ini.Free;
end;
end;
function TTFFileInfo.MakeDifferences: String;
var
i,l: Integer;
@ -1212,6 +897,24 @@ begin
Result := Widths[AIndex].AdvanceWidth;
end;
function TTFFileInfo.ItalicAngle: LongWord;
begin
Result := FPostScript.ItalicAngle;
end;
function TTFFileInfo.BBox: string;
var
i: integer;
begin
Result := '';
for i := 0 to 3 do
begin
if i > 0 then
Result := Result + ' ';
Result := Result + IntToStr(ToNatural(FHead.BBox[I]));
end;
end;
destructor TTFFileInfo.Destroy;
begin
SetLength(FNameEntries, 0);
@ -1228,6 +931,15 @@ begin
Result := round(d*10000);
end;
function TTFFileInfo.GetMissingWidth: integer;
begin
if FMissingWidth = 0 then
begin
FMissingWidth := Widths[Chars[CharCodes^[32]]].AdvanceWidth; // Char(32) - Space character
end;
Result := FMissingWidth;
end;
function TTFFileInfo.IsNativeData: Boolean;
begin
Result:=False;
@ -1250,12 +962,4 @@ begin
Result := Result+64;
end;
procedure TTFFileInfo.MakePDFFontDef(const FontFile: string; const Encoding:string; Embed: Boolean);
begin
PrepareFontDefinition(Encoding, Embed);
MakePDFFontDefinitionFile(FontFile,PostScriptName,Encoding);
end;
end.

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

@ -613,6 +613,7 @@ type
TPDFFont = CLass(TCollectionItem)
private
FColor: TARGBColor;
FIsStdFont: boolean;
FName: String;
FFontFilename: String;
FTrueTypeFile: TTFFileInfo;
@ -629,6 +630,7 @@ type
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;
end;
@ -721,13 +723,11 @@ type
TPDFToUnicode = class(TPDFDocumentObject)
private
FFontDef: TFontDef;
FEmbeddedFontNum: integer;
protected
procedure Write(const AStream: TStream);override;
public
constructor Create(const ADocument: TPDFDocument; const AEmbeddedFontNum: integer; AFontDef : TFontDef); overload;
property FontDef: TFontDef read FFontDef;
constructor Create(const ADocument: TPDFDocument; const AEmbeddedFontNum: integer); overload;
property EmbeddedFontNum: integer read FEmbeddedFontNum;
end;
@ -801,16 +801,15 @@ type
function CreatePageEntry(Parent, PageNum: integer): integer;virtual;
function CreateOutlines: integer;virtual;
function CreateOutlineEntry(Parent, SectNo, PageNo: integer; ATitle: string): integer;virtual;
function LoadFont(AFont: TPDFFont; Out FontDef : TFontDef): string;
function LoadFont(AFont: TPDFFont): boolean;
procedure CreateStdFont(EmbeddedFontName: string; EmbeddedFontNum: integer);virtual;
procedure CreateTTFFont(const EmbeddedFontNum: integer; FontDef : TFontDef);virtual;
procedure CreateTTFDescendantFont(const EmbeddedFontNum: integer; FontDef : TFontDef);virtual;
procedure CreateTTFCIDSystemInfo(const EmbeddedFontNum: integer; FontDef: TFontDef);virtual;
procedure CreateTTFFont(const EmbeddedFontNum: integer);virtual;
procedure CreateTTFDescendantFont(const EmbeddedFontNum: integer);virtual;
procedure CreateTTFCIDSystemInfo;virtual;
procedure CreateTp1Font(const EmbeddedFontNum: integer);virtual;
procedure CreateFontDescriptor(const EmbeddedFontNum: integer; FontDef : TFontDef);virtual;
procedure CreateToUnicode(const EmbeddedFontNum: integer; FontDef : TFontDef);virtual;
procedure CreateFontWidth(FontDef : TFontDef);virtual;
procedure CreateFontFileEntry(const EmbeddedFontNum: integer; FontDef: TFontDef);virtual;
procedure CreateFontDescriptor(const EmbeddedFontNum: integer);virtual;
procedure CreateToUnicode(const EmbeddedFontNum: integer);virtual;
procedure CreateFontFileEntry(const EmbeddedFontNum: integer);virtual;
procedure CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);virtual;
procedure CreatePageStream(APage : TPDFPage; PageNum: integer);
Function CreateGlobalXRef: TPDFXRef;
@ -1028,20 +1027,19 @@ Type
var
d: TDecompressionStream;
{$IFDEF NOHEADERWORKADOUND}
I: integer;
{$ENDIF}
Count : Integer;
Buffer : TBuffer;
begin
if AFrom.Size = 0 then
begin
ATo.Size := 0;
Exit; //==>
end;
{$IFDEF VER3}
Buffer := Default(TBuffer);
{$ELSE}
FillChar(Buffer,SizeOf(TBuffer),0);
{$ENDIF};
FillMem(@Buffer, SizeOf(TBuffer), 0);
AFrom.Position := 0;
AFrom.Seek(0,soFromEnd);
@ -1212,6 +1210,7 @@ begin
FTextMappingList := TTextMappingList.Create;
FTrueTypeFile := TTFFileInfo.Create;
FTrueTypeFile.LoadFromFile(FFontFilename);
FTrueTypeFile.PrepareFontDefinition('cp1252', True);
end;
end;
@ -1236,6 +1235,8 @@ var
c: word;
begin
Result := '';
if Length(AText) = 0 then
Exit;
for i := 1 to Length(AText) do
begin
c := Word(AText[i]);
@ -1580,7 +1581,7 @@ var
begin
if AText = '' then
Exit;
str := UTF8ToUTF16(AText);
str := UTF8Decode(AText);
Document.Fonts[FFontIndex].AddTextToMappingList(str);
end;
@ -2231,7 +2232,7 @@ function TPDFUTF8String.RemapedText: AnsiString;
var
s: UnicodeString;
begin
s := UTF8ToUTF16(FValue);
s := UTF8Decode(FValue);
Result := Document.Fonts[FontIndex].GetGlyphIndices(s);
end;
@ -2862,11 +2863,10 @@ begin
WriteString('end'+CRLF, AStream);
end;
constructor TPDFToUnicode.Create(const ADocument: TPDFDocument; const AEmbeddedFontNum: integer; AFontDef: TFontDef);
constructor TPDFToUnicode.Create(const ADocument: TPDFDocument; const AEmbeddedFontNum: integer);
begin
inherited Create(ADocument);
FEmbeddedFontNum := AEmbeddedFontNum;
FFontDef := AFontDef;
end;
{ TPDFDocument }
@ -3154,18 +3154,16 @@ begin
N := CreateName('F'+IntToStr(EmbeddedFontNum));
FDict.AddElement('Name',N);
AddFontNameToPages(N.Name,GLobalXRefCount-1);
// add font reference to all page dictionary
// add font reference to global page dictionary
FontFiles.Add('');
end;
function TPDFDocument.LoadFont(AFont: TPDFFont; out FontDef: TFontDef): string;
function TPDFDocument.LoadFont(AFont: TPDFFont): boolean;
var
lFontFile: TTFFileInfo;
lFontDef: TPDFFontDefinition;
lFName: string;
i: integer;
s: string;
begin
Result := False;
if ExtractFilePath(AFont.FontFile) <> '' then
// assume AFont.FontFile is the full path to the TTF file
lFName := AFont.FontFile
@ -3175,40 +3173,14 @@ begin
if FileExists(lFName) then
begin
lFontFile := TTFFileInfo.Create;
lFontFile.LoadFromFile(lFName);
lFontFile.PrepareFontDefinition('cp1252', True);
lFontFile.FillPDFFontDefinition(lFontDef, ExtractBaseFontName(AFont.Name), 'cp1252');
FontDef.FType := lFontDef.FontType;
FontDef.FName := lFontDef.FontName;
FontDef.FAscent := IntToStr(lFontDef.Ascender);
FontDef.FDescent := IntToStr(lFontDef.Descender);
FontDef.FCapHeight := IntToStr(lFontDef.CapHeight);
FontDef.FFlags := IntToStr(lFontDef.Flags);
s := '';
for i := 0 to 3 do
begin
if i > 0 then
s := s+' ';
s := s + IntToStr(lFontDef.BBox[i]);
end;
FontDef.FFontBBox := s;
FontDef.FItalicAngle := IntToStr(lFontDef.ItalicAngle);
FontDef.FStemV := IntToStr(lFontDef.StemV);
FontDef.FMissingWidth := IntToStr(lFontDef.MissingWidth);
FontDef.FEncoding := lFontDef.Encoding;
FontDef.FFile := lFName;
FontDef.FOriginalSize := IntToStr(lFontDef.OriginalSize);
FontDef.FDiffs := lFontDef.Diffs;
FontDef.FCharWidth := lFontDef.CharWidths;
Result := lFontDef.FontType;
lFontFile.Free;
s := LowerCase(ExtractFileExt(lFName));
Result := (s = '.ttf') or (s = '.otf');
end
else
Raise EPDF.CreateFmt(rsErrReportFontFileMissing, [lFName]);
end;
procedure TPDFDocument.CreateTTFFont(const EmbeddedFontNum: integer; FontDef : TFontDef);
procedure TPDFDocument.CreateTTFFont(const EmbeddedFontNum: integer);
var
FDict: TPDFDictionary;
N: TPDFName;
@ -3218,22 +3190,22 @@ begin
FDict := CreateGlobalXRef.Dict;
FDict.AddName('Type', 'Font');
FDict.AddName('Subtype', 'Type0');
FDict.AddName('BaseFont', FontDef.FName);
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);
Self.AddFontNameToPages(N.Name,GlobalXRefCount-1);
CreateTTFDescendantFont(EmbeddedFontNum, FontDef);
AddFontNameToPages(N.Name,GlobalXRefCount-1);
CreateTTFDescendantFont(EmbeddedFontNum);
Arr := CreateArray;
FDict.AddElement('DescendantFonts', Arr);
Arr.AddItem(TPDFReference.Create(self, GlobalXRefCount-4));
CreateToUnicode(EmbeddedFontNum, FontDef);
CreateToUnicode(EmbeddedFontNum);
FDict.AddReference('ToUnicode', GlobalXRefCount-1);
FontFiles.Add(FontDef.FFile);
FontFiles.Add(Fonts[EmbeddedFontNum].FTrueTypeFile.Filename);
end;
procedure TPDFDocument.CreateTTFDescendantFont(const EmbeddedFontNum: integer; FontDef: TFontDef);
procedure TPDFDocument.CreateTTFDescendantFont(const EmbeddedFontNum: integer);
var
FDict: TPDFDictionary;
Arr: TPDFArray;
@ -3242,13 +3214,13 @@ begin
FDict := CreateGlobalXRef.Dict;
FDict.AddName('Type', 'Font');
FDict.AddName('Subtype', 'CIDFontType2');
FDict.AddName('BaseFont', FontDef.FName);
FDict.AddName('BaseFont', Fonts[EmbeddedFontNum].Name);
CreateTTFCIDSystemInfo(EmbeddedFontNum, FontDef);
CreateTTFCIDSystemInfo;
FDict.AddReference('CIDSystemInfo', GlobalXRefCount-1);
// add fontdescriptor reference to font dictionary
CreateFontDescriptor(EmbeddedFontNum,FontDef);
CreateFontDescriptor(EmbeddedFontNum);
FDict.AddReference('FontDescriptor',GlobalXRefCount-2);
Arr := CreateArray;
@ -3256,7 +3228,7 @@ begin
Arr.AddItem(TPDFTrueTypeCharWidths.Create(self, EmbeddedFontNum));
end;
procedure TPDFDocument.CreateTTFCIDSystemInfo(const EmbeddedFontNum: integer; FontDef: TFontDef);
procedure TPDFDocument.CreateTTFCIDSystemInfo;
var
FDict: TPDFDictionary;
begin
@ -3271,59 +3243,46 @@ begin
Assert(EmbeddedFontNum<>-1);
end;
procedure TPDFDocument.CreateFontDescriptor(const EmbeddedFontNum: integer; FontDef : TFontDef);
procedure TPDFDocument.CreateFontDescriptor(const EmbeddedFontNum: integer);
var
Arr: TPDFArray;
FDict: TPDFDictionary;
begin
FDict:=CreateGlobalXRef.Dict;
FDict.AddName('Type', 'FontDescriptor');
FDict.AddName('FontName', FontDef.FName);
FDict.AddName('FontName', Fonts[EmbeddedFontNum].Name);
FDict.AddName('FontFamily', Fonts[EmbeddedFontNum].FTrueTypeFile.FamilyName);
FDict.AddInteger('Ascent', StrToInt(FontDef.FAscent));
FDict.AddInteger('Descent', StrToInt(FontDef.FDescent));
FDict.AddInteger('CapHeight', StrToInt(FontDef.FCapHeight));
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(FontDef.FFontBBox);
FDict.AddInteger('ItalicAngle',StrToInt(FontDef.FItalicAngle));
FDict.AddInteger('StemV',StrToInt(FontDef.FStemV));
FDict.AddInteger('MissingWidth', StrToInt(FontDef.FMissingWidth));
CreateFontFileEntry(EmbeddedFontNum,FontDef);
Arr.AddIntArray(Fonts[EmbeddedFontNum].FTrueTypeFile.BBox);
FDict.AddInteger('ItalicAngle',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);
end;
procedure TPDFDocument.CreateToUnicode(const EmbeddedFontNum: integer; FontDef: TFontDef);
procedure TPDFDocument.CreateToUnicode(const EmbeddedFontNum: integer);
var
lXRef: TPDFXRef;
begin
lXRef := CreateGlobalXRef;
lXRef.FStream := CreateStream(True);
lXRef.FStream.AddItem(TPDFToUnicode.Create(self, EmbeddedFontNum, FontDef));
lXRef.FStream.AddItem(TPDFToUnicode.Create(self, EmbeddedFontNum));
end;
procedure TPDFDocument.CreateFontWidth(FontDef : TFontDef);
var
Arr: TPDFArray;
FDict: TPDFDictionary;
begin
FDict:=CreateGlobalXRef.Dict;
Arr:=CreateArray;
FDict.AddElement('',Arr);
Arr.AddIntArray(FontDef.FCharWidth);
end;
procedure TPDFDocument.CreateFontFileEntry(const EmbeddedFontNum: integer; FontDef: TFontDef);
procedure TPDFDocument.CreateFontFileEntry(const EmbeddedFontNum: integer);
var
FDict: TPDFDictionary;
begin
FDict:=CreateGlobalXRef.Dict;
if poCompressFonts in Options then
FDict.AddName('Filter','FlateDecode');
FDict.AddInteger('Length1 '+IntToStr(EmbeddedFontNum),StrToInt(FontDef.FOriginalSize));
FDict.AddInteger('Length1 '+IntToStr(EmbeddedFontNum), Fonts[EmbeddedFontNum].FTrueTypeFile.OriginalSize);
end;
procedure TPDFDocument.CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);
@ -3595,7 +3554,6 @@ var
i: integer;
NumFont: integer;
FontName: string;
FontDef: TFontDef;
begin
// select the font type
NumFont:=0;
@ -3611,8 +3569,8 @@ begin
begin
CreateStdFont(FontName, NumFont);
end
else if (LoadFont(Fonts[i], FontDef)='TrueType') then
CreateTtfFont(NumFont,FontDef)
else if LoadFont(Fonts[i]) then
CreateTtfFont(NumFont)
else
CreateTp1Font(NumFont); // not implemented yet
Inc(NumFont);
@ -3767,6 +3725,7 @@ begin
F := Fonts.AddFontDef;
F.Name := AName;
F.Color := AColor;
F.IsStdFont := True;
Result := Fonts.Count-1;
end;
@ -3795,6 +3754,7 @@ begin
F.FontFile := lFName;
F.Name := AName;
F.Color := AColor;
F.IsStdFont := False;
Result := Fonts.Count-1;
end;

154
packages/fcl-pdf/tests/fpparsettf_test.pas
View File

@ -190,10 +190,6 @@ type
procedure TestPostScript_minMemType1;
procedure TestPostScript_maxMemType1;
{ PDF Font Definition }
procedure TestPDFFontDefinition;
procedure TestMakePDFFontDefinition;
{ Utility functions }
procedure TestGetGlyphIndex;
procedure TestGetAdvanceWidth;
@ -353,10 +349,6 @@ type
procedure TestPostScript_maxMemType42;
procedure TestPostScript_minMemType1;
procedure TestPostScript_maxMemType1;
{ PDF Font Definition }
procedure TestPDFFontDefinition;
procedure TestMakePDFFontDefinition;
end;
implementation
@ -1124,78 +1116,6 @@ begin
AssertEquals('Failed on 1', 0, FI.PostScript.maxMemType1);
end;
procedure TTestLiberationFont.TestPDFFontDefinition;
var
Def: TPDFFontDefinition;
s: string;
begin
FI.FillPDFFontDefinition(Def, cFont1, 'cp1252');
AssertEquals('Failed on 1', 'TrueType', Def.FontType);
AssertEquals('Failed on 2', 'LiberationSans', Def.FontName);
AssertEquals('Failed on 3', 728, Def.Ascender);
AssertEquals('Failed on 4', -210, Def.Descender);
AssertEquals('Failed on 5', 688, Def.CapHeight);
AssertEquals('Failed on 6', 32, Def.Flags);
s := IntToStr(Def.BBox[0]) + ' ' + IntToStr(Def.BBox[1]) + ' ' +
IntToStr(Def.BBox[2]) + ' ' + IntToStr(Def.BBox[3]);
AssertEquals('Failed on 7', '-544 -303 1302 980', s);
AssertEquals('Failed on 8', 0, Def.ItalicAngle);
AssertEquals('Failed on 9', 70, Def.StemV);
AssertEquals('Failed on 10', 0, Def.MissingWidth);
AssertEquals('Failed on 11', -106, Def.FontUp);
AssertEquals('Failed on 12', 73, Def.FontUt);
AssertEquals('Failed on 13', 'cp1252', Def.Encoding);
AssertEquals('Failed on 14', ReplaceStr(cFont1, '.ttf', '.z'), Def.FontFile); // 'fonts/LiberationSans-Regular.z'
AssertEquals('Failed on 15', '', Def.Diffs);
{ CharWidths is only valid if we called MakePDFFontDef }
// AssertEquals('Failed on 16', '', Def.CharWidths);
AssertEquals('Failed on 17', 350200, Def.OriginalSize);
end;
procedure TTestLiberationFont.TestMakePDFFontDefinition;
const
cSection = 'LiberationSans';
var
lFile: string;
ini: TINIFile;
begin
lFile := ChangeFileExt(GetTempFileName, '.ini');
// writeln( lFile);
AssertTrue('Failed on 1', FileExists(lFile) = False);
try
FI.MakePDFFontDef(lFile, 'cp1252', True);
AssertTrue('Failed on 2', FileExists(lFile) = True);
ini := TINIFile.Create(lFile);
try
AssertEquals('Failed on 3', 'TrueType', ini.ReadString(cSection, 'FontType', ''));
AssertEquals('Failed on 4', 'LiberationSans', ini.ReadString(cSection, 'FontName', ''));
AssertEquals('Failed on 5', 728, ini.ReadInteger(cSection, 'Ascent', 0));
AssertEquals('Failed on 6', -210, ini.ReadInteger(cSection, 'Descent', 0));
AssertEquals('Failed on 7', 688, ini.ReadInteger(cSection, 'CapHeight', 0));
AssertEquals('Failed on 8', 32, ini.ReadInteger(cSection, 'Flags', 0));
AssertEquals('Failed on 9', '-544 -303 1302 980', ini.ReadString(cSection, 'FontBBox', ''));
AssertEquals('Failed on 10', 0, ini.ReadInteger(cSection, 'ItalicAngle', 0));
AssertEquals('Failed on 11', 70, ini.ReadInteger(cSection, 'StemV', 0));
AssertEquals('Failed on 12', 569, ini.ReadInteger(cSection, 'MissingWidth', 0));
AssertEquals('Failed on 13', -106, ini.ReadInteger(cSection, 'FontUp', 0));
AssertEquals('Failed on 14', 73, ini.ReadInteger(cSection, 'FontUt', 0));
AssertEquals('Failed on 15', 'cp1252', ini.ReadString(cSection, 'Encoding', ''));
AssertEquals('Failed on 16', ReplaceStr(lFile, '.ini', '.z'), ini.ReadString(cSection, 'FontFile', ''));
AssertEquals('Failed on 17', '', ini.ReadString(cSection, 'Diffs', ''));
AssertTrue('Failed on 18', ini.ReadString(cSection, 'CharWidth', '') <> '');
AssertEquals('Failed on 19', 350200, ini.ReadInteger(cSection, 'OriginalSize', 0));
finally
ini.Free;
end;
finally
DeleteFile(lFile);
end
end;
procedure TTestLiberationFont.TestGetGlyphIndex;
begin
AssertEquals('Failed on 1.1', 67, Ord('C'));
@ -1976,80 +1896,6 @@ begin
AssertEquals('Failed on 1', 0, FI.PostScript.maxMemType1);
end;
procedure TTestFreeSansFont.TestPDFFontDefinition;
var
Def: TPDFFontDefinition;
s: string;
begin
FI.FillPDFFontDefinition(Def, cFont1, 'cp1252');
AssertEquals('Failed on 1', 'TrueType', Def.FontType);
AssertEquals('Failed on 2', 'FreeSans', Def.FontName);
AssertEquals('Failed on 3', 800, Def.Ascender);
AssertEquals('Failed on 4', -200, Def.Descender);
AssertEquals('Failed on 5', 729, Def.CapHeight);
AssertEquals('Failed on 6', 32, Def.Flags);
s := IntToStr(Def.BBox[0]) + ' ' + IntToStr(Def.BBox[1]) + ' ' +
IntToStr(Def.BBox[2]) + ' ' + IntToStr(Def.BBox[3]);
AssertEquals('Failed on 7', '-1166 -638 2260 1050', s);
AssertEquals('Failed on 8', 0, Def.ItalicAngle);
AssertEquals('Failed on 9', 70, Def.StemV);
AssertEquals('Failed on 10', 0, Def.MissingWidth);
AssertEquals('Failed on 11', -176, Def.FontUp);
AssertEquals('Failed on 12', 50, Def.FontUt);
AssertEquals('Failed on 13', 'cp1252', Def.Encoding);
AssertEquals('Failed on 14', ReplaceStr(cFont1, '.ttf', '.z'), Def.FontFile); // 'fonts/LiberationSans-Regular.z'
AssertEquals('Failed on 15', '', Def.Diffs);
{ CharWidths is only valid if we called MakePDFFontDef }
// AssertEquals('Failed on 16', '', Def.CharWidths);
AssertEquals('Failed on 17', 1563256, Def.OriginalSize);
end;
procedure TTestFreeSansFont.TestMakePDFFontDefinition;
const
cSection = 'FreeSans';
var
lFile: string;
ini: TINIFile;
begin
lFile := ChangeFileExt(GetTempFileName, '.ini');
// writeln( lFile);
AssertTrue('Failed on 1', FileExists(lFile) = False);
try
FI.MakePDFFontDef(lFile, 'cp1252', True);
AssertTrue('Failed on 2', FileExists(lFile) = True);
ini := TINIFile.Create(lFile);
try
AssertEquals('Failed on 3', 'TrueType', ini.ReadString(cSection, 'FontType', ''));
AssertEquals('Failed on 4', 'FreeSans', ini.ReadString(cSection, 'FontName', ''));
AssertEquals('Failed on 5', 800, ini.ReadInteger(cSection, 'Ascent', 0));
AssertEquals('Failed on 6', -200, ini.ReadInteger(cSection, 'Descent', 0));
AssertEquals('Failed on 7', 729, ini.ReadInteger(cSection, 'CapHeight', 0));
AssertEquals('Failed on 8', 32, ini.ReadInteger(cSection, 'Flags', 0));
AssertEquals('Failed on 9', '-1166 -638 2260 1050', ini.ReadString(cSection, 'FontBBox', ''));
AssertEquals('Failed on 10', 0, ini.ReadInteger(cSection, 'ItalicAngle', 0));
AssertEquals('Failed on 11', 70, ini.ReadInteger(cSection, 'StemV', 0));
AssertEquals('Failed on 12', 250, ini.ReadInteger(cSection, 'MissingWidth', 0));
AssertEquals('Failed on 13', -176, ini.ReadInteger(cSection, 'FontUp', 0));
AssertEquals('Failed on 14', 50, ini.ReadInteger(cSection, 'FontUt', 0));
AssertEquals('Failed on 15', 'cp1252', ini.ReadString(cSection, 'Encoding', ''));
AssertEquals('Failed on 16', ReplaceStr(lFile, '.ini', '.z'), ini.ReadString(cSection, 'FontFile', ''));
AssertEquals('Failed on 17', '', ini.ReadString(cSection, 'Diffs', ''));
AssertTrue('Failed on 18', ini.ReadString(cSection, 'CharWidth', '') <> '');
AssertEquals('Failed on 19', 1563256, ini.ReadInteger(cSection, 'OriginalSize', 0));
finally
ini.Free;
end;
finally
DeleteFile(lFile);
end
end;
initialization
RegisterTest({$ifdef fptest}'fpParseTTF',{$endif}TTestEmptyParseTTF{$ifdef fptest}.Suite{$endif});

6
packages/fcl-pdf/tests/fppdf_test.pas
View File

@ -292,7 +292,7 @@ procedure TTestPDFObject.TestFloatStr;
Var
C : Char;
begin
AssertEquals('Failed on 1', '0.12', TMockPDFObject.FloatStr(TPDFFLoat(0.12)));
AssertEquals('Failed on 2', ' 12', TMockPDFObject.FloatStr(TPDFFLoat(12.00)));
@ -309,7 +309,7 @@ begin
AssertEquals('Failed on 9', '12.34', TMockPDFObject.FloatStr(TPDFFLoat(12.34)));
finally
FormatSettings.DecimalSeparator:=C;
end;
end;
// Set ThousandSeparator
C:=FormatSettings.ThousandSeparator;
FormatSettings.ThousandSeparator:=' ';
@ -1247,7 +1247,6 @@ end;
procedure TTestPDFImage.TestWrite;
var
o: TMockPDFImage;
ar: TPDFCoordArray;
x, y: TPDFFLoat;
begin
x := 100;
@ -1265,7 +1264,6 @@ begin
'Q'+CRLF,
S.DataString);
finally
SetLength(ar, 0);
o.Free;
end;
end;