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

* Fixes from Graeme Geldenhuys for bug ID #30006 and bug ID #30008:

Browse Source 
--------------------------------
  * pdf unittests: fixes failing test after fpPDF changes, plus newtest added.
  * pdf: fixes failing test due to recent changes in fpPDF.
  * pdf tests: new test for new behaviour.
  * pdf: Applies patch from Mantis 30006 - and replaced bitmasks with Sets.
  * pdf tests: Updates the README file with exact font details used by the tests.
  * ttf: fixes debug output directory.
  * pdf: FPC Mantis BugID 30008: fpTTF: wrong Ascender/Descender calculation
  * pdf: fix bug where return value was never set.
  * pdf: fixes compiler hint about uninitialised variables being used.
  * pdf unittests: fixes memory leak in one test.
  * pdf unittests: fixes compiler hint about unused units in uses  clause.

git-svn-id: trunk@33535 -
This commit is contained in:
michael 2016-04-19 07:10:59 +00:00
parent 2e005ecc7d
commit ef564491b2
8 changed files with 285 additions and 250 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -2587,6 +2587,7 @@ packages/fcl-pdf/src/fpparsettf.pp svneol=native#text/plain
packages/fcl-pdf/src/fppdf.pp svneol=native#text/plain packages/fcl-pdf/src/fppdf.pp svneol=native#text/plain
packages/fcl-pdf/src/fpttf.pp svneol=native#text/plain packages/fcl-pdf/src/fpttf.pp svneol=native#text/plain
packages/fcl-pdf/src/fpttfencodings.pp svneol=native#text/plain packages/fcl-pdf/src/fpttfencodings.pp svneol=native#text/plain
packages/fcl-pdf/tests/fonts/README.txt svneol=native#text/plain
packages/fcl-pdf/tests/fpparsettf_test.pas svneol=native#text/plain packages/fcl-pdf/tests/fpparsettf_test.pas svneol=native#text/plain
packages/fcl-pdf/tests/fppdf_test.pas svneol=native#text/plain packages/fcl-pdf/tests/fppdf_test.pas svneol=native#text/plain
packages/fcl-pdf/tests/fpttf_test.pas svneol=native#text/plain packages/fcl-pdf/tests/fpttf_test.pas svneol=native#text/plain

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

@ -864,17 +864,17 @@ end;
function TTFFileInfo.Ascender: SmallInt; function TTFFileInfo.Ascender: SmallInt;
begin begin
Result:=ToNatural(FOS2Data.sTypoAscender); // 2 bytes Result:=FOS2Data.sTypoAscender;
end; end;
function TTFFileInfo.Descender: SmallInt; function TTFFileInfo.Descender: SmallInt;
begin begin
Result := ToNatural(FOS2Data.sTypoDescender); // 2 bytes Result := FOS2Data.sTypoDescender;
end; end;
function TTFFileInfo.Leading: SmallInt; function TTFFileInfo.Leading: SmallInt;
begin begin
Result := ToNatural(FOS2Data.sTypoLineGap); Result := FOS2Data.sTypoLineGap;
end; end;
function TTFFileInfo.CapHeight: SmallInt; function TTFFileInfo.CapHeight: SmallInt;
@ -882,7 +882,7 @@ begin
With FOS2Data do With FOS2Data do
begin begin
if Version>= 2 then if Version>= 2 then
Result:=ToNatural(sCapHeight) Result:=sCapHeight
else else
Result:=Ascender; Result:=Ascender;
end; end;

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

@ -2025,7 +2025,7 @@ Var
Str : TStream; Str : TStream;
CWhite : TFPColor; // white color CWhite : TFPColor; // white color
begin begin
FillChar(CWhite, SizeOf(CWhite), $FF); FillMem(@CWhite, SizeOf(CWhite), $FF);
FWidth:=Image.Width; FWidth:=Image.Width;
FHeight:=Image.Height; FHeight:=Image.Height;
Str := nil; Str := nil;
@ -3541,7 +3541,7 @@ end;
Function TPDFDocument.CreateFontDefs : TPDFFontDefs; Function TPDFDocument.CreateFontDefs : TPDFFontDefs;
begin begin
TPDFFontDefs.Create(TPDFFont); Result := TPDFFontDefs.Create(TPDFFont);
end; end;
Function TPDFDocument.CreatePDFInfos : TPDFInfos; Function TPDFDocument.CreatePDFInfos : TPDFInfos;
@ -3553,7 +3553,7 @@ end;
Function TPDFDocument.CreatePDFImages : TPDFImages; Function TPDFDocument.CreatePDFImages : TPDFImages;
begin begin
Result:=TPDFImages.Create(Self,TPDFImageItem); Result:=TPDFImages.Create(Self,TPDFImageItem);
end; end;
Function TPDFDocument.CreatePDFPages : TPDFPages; Function TPDFDocument.CreatePDFPages : TPDFPages;

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

@ -20,20 +20,12 @@ uses
contnrs, contnrs,
fpparsettf; fpparsettf;
const
{ constants to query FontCacheItem.StyleFlags with. }
FP_FONT_STYLE_REGULAR = 1 shl 0; { Regular, Plain, Book }
FP_FONT_STYLE_ITALIC = 1 shl 1; { Italic }
FP_FONT_STYLE_BOLD = 1 shl 2; { Bold }
FP_FONT_STYLE_CONDENSED = 1 shl 3; { Condensed }
FP_FONT_STYLE_EXTRALIGHT = 1 shl 4; { ExtraLight }
FP_FONT_STYLE_LIGHT = 1 shl 5; { Light }
FP_FONT_STYLE_SEMIBOLD = 1 shl 6; { Semibold }
FP_FONT_STYLE_MEDIUM = 1 shl 7; { Medium }
FP_FONT_STYLE_BLACK = 1 shl 8; { Black }
FP_FONT_STYLE_FIXEDWIDTH = 1 shl 9; { Fixedwidth }
type type
TTrueTypeFontStyle = (fsRegular, fsItalic, fsBold, fsCondensed, fsExtraLight, fsLight, fsSemibold, fsMedium, fsBlack, fsFixedWidth);
TTrueTypeFontStyles = set of TTrueTypeFontStyle;
{ Forward declaration } { Forward declaration }
TFPFontCacheList = class; TFPFontCacheList = class;
@ -42,34 +34,30 @@ type
private private
FFamilyName: String; FFamilyName: String;
FFileName: String; FFileName: String;
FStyleFlags: LongWord; FStyleFlags: TTrueTypeFontStyles;
FFileInfo: TTFFileInfo; FFileInfo: TTFFileInfo;
FOwner: TFPFontCacheList; // reference to FontCacheList that owns this instance FOwner: TFPFontCacheList; // reference to FontCacheList that owns this instance
procedure BuildFontCacheItem;
procedure SetStyleIfExists(var AText: string; var AStyleFlags: TTrueTypeFontStyles; const AStyleName: String; const AStyle: TTrueTypeFontStyle);
function GetIsBold: boolean; function GetIsBold: boolean;
function GetIsFixedWidth: boolean; function GetIsFixedWidth: boolean;
function GetIsItalic: boolean; function GetIsItalic: boolean;
function GetIsRegular: boolean; function GetIsRegular: boolean;
procedure SetFileName(const AFileName: String);
procedure SetIsBold(AValue: boolean);
procedure SetIsFixedWidth(AValue: boolean);
procedure SetIsItalic(AValue: boolean);
procedure SetIsRegular(AValue: boolean);
public public
constructor Create(const AFilename: String); constructor Create(const AFilename: String);
destructor Destroy; override; destructor Destroy; override;
{ Returns the actual TTF font file information. }
function GetFontData: TTFFileInfo;
{ Result is in pixels } { Result is in pixels }
function TextWidth(AStr: utf8string; APointSize: single): single; function TextWidth(AStr: utf8string; APointSize: single): single;
property FileName: String read FFileName write SetFileName; property FileName: String read FFileName;
property FamilyName: String read FFamilyName write FFamilyName; property FamilyName: String read FFamilyName;
property FontData: TTFFileInfo read FFileInfo;
{ A bitmasked value describing the full font style } { A bitmasked value describing the full font style }
property StyleFlags: LongWord read FStyleFlags write FStyleFlags; property StyleFlags: TTrueTypeFontStyles read FStyleFlags;
{ IsXXX properties are convenience properties, internally querying StyleFlags. } { IsXXX properties are convenience properties, internally querying StyleFlags. }
property IsFixedWidth: boolean read GetIsFixedWidth write SetIsFixedWidth; property IsFixedWidth: boolean read GetIsFixedWidth;
property IsRegular: boolean read GetIsRegular write SetIsRegular; property IsRegular: boolean read GetIsRegular;
property IsItalic: boolean read GetIsItalic write SetIsItalic; property IsItalic: boolean read GetIsItalic;
property IsBold: boolean read GetIsBold write SetIsBold; property IsBold: boolean read GetIsBold;
end; end;
@ -79,8 +67,6 @@ type
FSearchPath: TStringList; FSearchPath: TStringList;
FDPI: integer; FDPI: integer;
procedure SearchForFont(const AFontPath: String); procedure SearchForFont(const AFontPath: String);
function BuildFontCacheItem(const AFontFile: String): TFPFontCacheItem;
procedure SetStyleIfExists(var AText: string; var AStyleFlags: integer; const AStyleName: String; const AStyleBit: integer);
procedure SetDPI(AValue: integer); procedure SetDPI(AValue: integer);
protected protected
function GetCount: integer; virtual; function GetCount: integer; virtual;
@ -129,101 +115,89 @@ end;
function TFPFontCacheItem.GetIsBold: boolean; function TFPFontCacheItem.GetIsBold: boolean;
begin begin
Result := (FStyleFlags and FP_FONT_STYLE_BOLD) <> 0; Result := fsBold in FStyleFlags;
end; end;
function TFPFontCacheItem.GetIsFixedWidth: boolean; function TFPFontCacheItem.GetIsFixedWidth: boolean;
begin begin
Result := (FStyleFlags and FP_FONT_STYLE_FIXEDWIDTH) <> 0; Result := fsFixedWidth in FStyleFlags;
end; end;
function TFPFontCacheItem.GetIsItalic: boolean; function TFPFontCacheItem.GetIsItalic: boolean;
begin begin
Result := (FStyleFlags and FP_FONT_STYLE_ITALIC) <> 0; Result := fsItalic in FStyleFlags;
end; end;
function TFPFontCacheItem.GetIsRegular: boolean; function TFPFontCacheItem.GetIsRegular: boolean;
begin begin
Result := (FStyleFlags and FP_FONT_STYLE_REGULAR) <> 0; Result := fsRegular in FStyleFlags;
end; end;
procedure TFPFontCacheItem.SetFileName(const AFileName: String); procedure TFPFontCacheItem.BuildFontCacheItem;
var
s: string;
begin begin
if FFileName = AFileName then Exit; s := FFileInfo.PostScriptName;
FFileName := AFileName; FFamilyName := FFileInfo.FamilyName;
if FFileInfo<>nil then if Pos(s, FFamilyName) = 1 then
FreeAndNil(FFileInfo); Delete(s, 1, Length(FFamilyName));
FStyleFlags := [fsRegular];
// extract simple styles first
if FFileInfo.PostScript.isFixedPitch > 0 then
FStyleFlags := [fsFixedWidth]; // this should overwrite Regular style
if FFileInfo.PostScript.ItalicAngle <> 0 then
FStyleFlags := FStyleFlags + [fsItalic];
// Now to more complex styles stored in StyleName field. eg: 'Condensed Medium'
SetStyleIfExists(s, FStyleFlags, 'Bold', fsBold);
SetStyleIfExists(s, FStyleFlags, 'Condensed', fsCondensed);
SetStyleIfExists(s, FStyleFlags, 'ExtraLight', fsExtraLight);
SetStyleIfExists(s, FStyleFlags, 'Light', fsLight);
SetStyleIfExists(s, FStyleFlags, 'Semibold', fsSemibold);
SetStyleIfExists(s, FStyleFlags, 'Medium', fsMedium);
SetStyleIfExists(s, FStyleFlags, 'Black', fsBlack);
SetStyleIfExists(s, FStyleFlags, 'Oblique', fsItalic);
end; end;
procedure TFPFontCacheItem.SetIsBold(AValue: boolean); procedure TFPFontCacheItem.SetStyleIfExists(var AText: string; var AStyleFlags: TTrueTypeFontStyles;
const AStyleName: String; const AStyle: TTrueTypeFontStyle);
var
i: integer;
begin begin
if AValue then i := Pos(AStyleName, AText);
FStyleFlags := FStyleFlags or FP_FONT_STYLE_BOLD if i > 0 then
else begin
FStyleFlags := FStyleFlags and (not FP_FONT_STYLE_BOLD); AStyleFlags := AStyleFlags + [AStyle];
end; Delete(AText, i, Length(AStyleName));
end;
procedure TFPFontCacheItem.SetIsFixedWidth(AValue: boolean);
begin
if AValue then
FStyleFlags := FStyleFlags or FP_FONT_STYLE_FIXEDWIDTH
else
FStyleFlags := FStyleFlags and (not FP_FONT_STYLE_FIXEDWIDTH);
// if we are FixedWidth, then Regular can't apply
FStyleFlags := FStyleFlags and (not FP_FONT_STYLE_REGULAR);
end;
procedure TFPFontCacheItem.SetIsItalic(AValue: boolean);
begin
if AValue then
FStyleFlags := FStyleFlags or FP_FONT_STYLE_ITALIC
else
FStyleFlags := FStyleFlags and (not FP_FONT_STYLE_ITALIC);
end;
procedure TFPFontCacheItem.SetIsRegular(AValue: boolean);
begin
if AValue then
FStyleFlags := FStyleFlags or FP_FONT_STYLE_REGULAR
else
FStyleFlags := FStyleFlags and (not FP_FONT_STYLE_REGULAR);
// if we are Regular, then FixedWidth can't apply
FStyleFlags := FStyleFlags and (not FP_FONT_STYLE_FIXEDWIDTH);
end; end;
constructor TFPFontCacheItem.Create(const AFilename: String); constructor TFPFontCacheItem.Create(const AFilename: String);
begin begin
inherited Create; inherited Create;
FFileName := AFilename; FFileName := AFilename;
FStyleFlags := FP_FONT_STYLE_REGULAR; FStyleFlags := [fsRegular];
if AFileName = '' then
raise ETTF.Create(rsNoFontFileName);
if FileExists(AFilename) then
begin
FFileInfo := TTFFileInfo.Create;
FFileInfo.LoadFromFile(AFilename);
BuildFontCacheItem;
end;
end; end;
destructor TFPFontCacheItem.Destroy; destructor TFPFontCacheItem.Destroy;
begin begin
FFileInfo.Free; FFileInfo.Free;
inherited Destroy; inherited Destroy;
end; end;
function TFPFontCacheItem.GetFontData: TTFFileInfo;
begin
if FFileInfo <> nil then
Exit(FFileInfo);
if FileName = '' then
raise ETTF.Create(rsNoFontFileName);
if FileExists(FileName) then
begin
FFileInfo := TTFFileInfo.Create;
FFileInfo.LoadFromFile(FileName);
Result := FFileInfo;
end
else
Result := nil;
end;
{ TextWidth returns with width of the text. If APointSize = 0.0, then it returns { 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 the text width in Font Units. If APointSize > 0 then it returns the text width
in Pixels. } in Pixels. }
@ -248,7 +222,6 @@ function TFPFontCacheItem.TextWidth(AStr: utf8string; APointSize: single): singl
550 * 18 * 72 / ( 72 * 2048 ) = 4.83 550 * 18 * 72 / ( 72 * 2048 ) = 4.83
} }
var var
lFntInfo: TTFFileInfo;
i: integer; i: integer;
lWidth: integer; lWidth: integer;
lGIndex: integer; lGIndex: integer;
@ -262,8 +235,7 @@ begin
if Length(AStr) = 0 then if Length(AStr) = 0 then
Exit; Exit;
lFntInfo := GetFontData; if not Assigned(FFileInfo) then
if not Assigned(lFntInfo) then
Exit; Exit;
{$IFDEF ttfdebug} {$IFDEF ttfdebug}
@ -271,13 +243,13 @@ begin
s := ''; s := '';
for i := 0 to 255 do for i := 0 to 255 do
begin begin
lGIndex := lFntInfo.GetGlyphIndex(i); lGIndex := FFileInfo.GetGlyphIndex(i);
lWidth := lFntInfo.GetAdvanceWidth(lGIndex); lWidth := FFileInfo.GetAdvanceWidth(lGIndex);
s := s + ',' + IntToStr(lWidth); s := s + ',' + IntToStr(lWidth);
end; end;
sl.Add(s); sl.Add(s);
sl.Add('UnitsPerEm = ' + IntToStr(lFntInfo.Head.UnitsPerEm)); sl.Add('UnitsPerEm = ' + IntToStr(FFileInfo.Head.UnitsPerEm));
sl.SaveToFile('/tmp/' + lFntInfo.PostScriptName + '.txt'); sl.SaveToFile(GetTempDir(True) + FFileInfo.PostScriptName + '.txt');
sl.Free; sl.Free;
{$ENDIF} {$ENDIF}
@ -285,8 +257,8 @@ begin
us := UTF8Decode(AStr); us := UTF8Decode(AStr);
for i := 1 to Length(us) do for i := 1 to Length(us) do
begin begin
lGIndex := lFntInfo.GetGlyphIndex(Word(us[i])); lGIndex := FFileInfo.GetGlyphIndex(Word(us[i]));
lWidth := lWidth + lFntInfo.GetAdvanceWidth(lGIndex); lWidth := lWidth + FFileInfo.GetAdvanceWidth(lGIndex);
end; end;
if APointSize = 0.0 then if APointSize = 0.0 then
Result := lWidth Result := lWidth
@ -294,7 +266,7 @@ begin
begin begin
{ Converting Font Units to Pixels. The formula is: { Converting Font Units to Pixels. The formula is:
pixels = glyph_units * pointSize * resolution / ( 72 points per inch * THead.UnitsPerEm ) } pixels = glyph_units * pointSize * resolution / ( 72 points per inch * THead.UnitsPerEm ) }
Result := lWidth * APointSize * FOwner.DPI / (72 * lFntInfo.Head.UnitsPerEm); Result := lWidth * APointSize * FOwner.DPI / (72 * FFileInfo.Head.UnitsPerEm);
end; end;
end; end;
@ -321,7 +293,7 @@ begin
if (lowercase(ExtractFileExt(s)) = '.ttf') or if (lowercase(ExtractFileExt(s)) = '.ttf') or
(lowercase(ExtractFileExt(s)) = '.otf') then (lowercase(ExtractFileExt(s)) = '.otf') then
begin begin
lFont := BuildFontCacheItem(AFontPath + s); lFont := TFPFontCacheItem.Create(AFontPath + s);
Add(lFont); Add(lFont);
end; end;
end; end;
@ -330,55 +302,6 @@ begin
FindClose(sr); FindClose(sr);
end; end;
function TFPFontCacheList.BuildFontCacheItem(const AFontFile: String): TFPFontCacheItem;
var
lFontInfo: TTFFileInfo;
s: string;
flags: integer;
begin
lFontInfo := TTFFileInfo.Create;
try
lFontInfo.LoadFromFile(AFontFile);
Result := TFPFontCacheItem.Create(AFontFile);
s := lFontInfo.PostScriptName;
Result.FamilyName := lFontInfo.FamilyName;
// extract simple styles first
if lFontInfo.PostScript.isFixedPitch > 0 then
Result.StyleFlags := FP_FONT_STYLE_FIXEDWIDTH; // this should overwrite Regular style
if lFontInfo.PostScript.ItalicAngle <> 0 then
Result.StyleFlags := Result.StyleFlags or FP_FONT_STYLE_ITALIC;
// Now to more complex styles stored in StyleName field. eg: 'Condensed Medium'
flags := Result.StyleFlags;
SetStyleIfExists(s, flags, 'Bold', FP_FONT_STYLE_BOLD);
SetStyleIfExists(s, flags, 'Condensed', FP_FONT_STYLE_CONDENSED);
SetStyleIfExists(s, flags, 'ExtraLight', FP_FONT_STYLE_EXTRALIGHT);
SetStyleIfExists(s, flags, 'Light', FP_FONT_STYLE_LIGHT);
SetStyleIfExists(s, flags, 'Semibold', FP_FONT_STYLE_SEMIBOLD);
SetStyleIfExists(s, flags, 'Medium', FP_FONT_STYLE_MEDIUM);
SetStyleIfExists(s, flags, 'Black', FP_FONT_STYLE_BLACK);
Result.StyleFlags := flags;
finally
lFontInfo.Free;
end;
end;
procedure TFPFontCacheList.SetStyleIfExists(var AText: string; var AStyleFlags: integer; const AStyleName: String;
const AStyleBit: integer);
var
i: integer;
begin
i := Pos(AStyleName, AText);
if i > 0 then
begin
AStyleFlags := AStyleFlags or AStyleBit;
Delete(AText, Length(AStyleName), i);
end;
end;
procedure TFPFontCacheList.SetDPI(AValue: integer); procedure TFPFontCacheList.SetDPI(AValue: integer);
begin begin
if FDPI = AValue then Exit; if FDPI = AValue then Exit;
@ -466,16 +389,15 @@ function TFPFontCacheList.Find(const AFamilyName: string; ABold: boolean; AItali
var var
i: integer; i: integer;
begin begin
Result := nil;
for i := 0 to Count-1 do for i := 0 to Count-1 do
begin begin
if (Items[i].FamilyName = AFamilyName) and (items[i].IsItalic = AItalic) Result := Items[i];
and (items[i].IsBold = ABold) then if (Result.FamilyName = AFamilyName) and (Result.IsItalic = AItalic)
begin and (Result.IsBold = ABold)
Result := Items[i]; then
exit; exit;
end;
end; end;
Result := nil;
end; end;
function TFPFontCacheList.PointSizeInPixels(const APointSize: single): single; function TFPFontCacheList.PointSizeInPixels(const APointSize: single): single;

95
packages/fcl-pdf/tests/fonts/README.txt Normal file
View File

@ -0,0 +1,95 @@
These sets of unit tests requires four font files of specific versions
each. Here is what the tests were designed against.
Font File | Size (bytes) | Version
----------------------------+-----------------+-----------------
DejaVuSans.ttf | 622,280 | 2.30
FreeSans.ttf | 1,563,256 | 412.2268
LiberationSans-Regular.ttf | 350,200 | 2.00.1
Ubuntu-R.ttf | 353,824 | 0.80
Details of the above font files and download locations are as follows.
DejaVu Sans
===========
Official website:
http://dejavu-fonts.org/wiki/Main_Page
Download URL:
http://sourceforge.net/projects/dejavu/files/dejavu/2.30/dejavu-fonts-ttf-2.30.tar.bz2
Description:
The DejaVu fonts are a font family based on the Vera Fonts. Its purpose is
to provide a wider range of characters while maintaining the original look
and feel through the process of collaborative development (see authors),
under a Free license.
FreeSans
========
Official website:
http://savannah.gnu.org/projects/freefont/
Download URL:
http://ftp.gnu.org/gnu/freefont/freefont-ttf-20120503.zip
Description:
We aim to provide a useful set of free outline (i.e. OpenType) fonts
covering as much as possible of the Unicode character set. The set consists
of three typefaces: one monospaced and two proportional (one with uniform
and one with modulated stroke).
License:
GNU General Public License v3 or later
Liberation
==========
Official website:
https://fedorahosted.org/liberation-fonts/
Download URL:
https://fedorahosted.org/releases/l/i/liberation-fonts/liberation-fonts-ttf-2.00.1.tar.gz
Description:
The Liberation(tm) Fonts is a font family which aims at metric compatibility
with Arial, Times New Roman, and Courier New. It is sponsored by Red Hat.
License:
* The Liberation(tm) version 2.00.0 onward are Licensed under the SIL Open
Font License, Version 1.1.
* Older versions of the Liberation(tm) Fonts is released as open source under
the GNU General Public License version 2 with exceptions. ​
https://fedoraproject.org/wiki/Licensing/LiberationFontLicense
Ubuntu
======
Official website:
http://font.ubuntu.com/
Download URL:
http://font.ubuntu.com/download/ubuntu-font-family-0.80.zip
Description:
The Ubuntu typeface has been specially created to complement the Ubuntu
tone of voice. It has a contemporary style and contains characteristics
unique to the Ubuntu brand that convey a precise, reliable and free
attitude.
License:
Ubuntu Font Licence. This licence allows the licensed fonts to be used,
studied, modified and redistributed freely.
TTF Dump output
===============
I used the Microsoft "ttfdump.exe" tool to generate the
file dump output for the Liberation Sans Regular font. I then used that to verify
the results of the TTF unit tests.
http://www.microsoft.com/typography/tools/tools.aspx

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

@ -9,7 +9,7 @@ uses
{$ifdef fptest} {$ifdef fptest}
,TestFramework ,TestFramework
{$else} {$else}
,fpcunit, testutils, testregistry ,fpcunit, testregistry
{$endif} {$endif}
,fpparsettf ,fpparsettf
; ;
@ -356,7 +356,6 @@ implementation
uses uses
dateutils dateutils
,strutils ,strutils
,IniFiles
; ;
const const

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

@ -9,7 +9,7 @@ uses
{$ifdef fptest} {$ifdef fptest}
,TestFramework ,TestFramework
{$else} {$else}
,fpcunit, testutils, testregistry ,fpcunit, testregistry
{$endif} {$endif}
,fppdf ,fppdf
; ;
@ -73,6 +73,7 @@ type
procedure TestWrite; procedure TestWrite;
procedure TestValidNames1; procedure TestValidNames1;
procedure TestValidNames2; procedure TestValidNames2;
procedure TestValidNames3;
end; end;
@ -232,7 +233,8 @@ type
TTestTPDFImageItem = class(TTestCase) TTestTPDFImageItem = class(TTestCase)
published published
procedure TestCreateStreamedData; procedure TestCreateStreamedData_Compressed;
procedure TestCreateStreamedData_Uncompressed;
end; end;
implementation implementation
@ -509,6 +511,20 @@ var
o: TPDFName; o: TPDFName;
begin begin
o := TPDFName.Create(PDF, 'Adobe Green'); o := TPDFName.Create(PDF, 'Adobe Green');
try
AssertEquals('Failed on 1', '', S.DataString);
TMockPDFName(o).Write(S);
AssertEquals('Failed on 2', '/Adobe#20Green', S.DataString);
finally
o.Free;
end;
end;
procedure TTestPDFName.TestValidNames3;
var
o: TPDFName;
begin
o := TPDFName.Create(PDF, 'Adobe Green', False);
try try
AssertEquals('Failed on 1', '', S.DataString); AssertEquals('Failed on 1', '', S.DataString);
TMockPDFName(o).Write(S); TMockPDFName(o).Write(S);
@ -1630,37 +1646,87 @@ end;
{ TTestTPDFImageItem } { TTestTPDFImageItem }
procedure TTestTPDFImageItem.TestCreateStreamedData; procedure TTestTPDFImageItem.TestCreateStreamedData_Compressed;
var var
list: TPDFImages;
itm: TPDFImageItem; itm: TPDFImageItem;
img: TFPMemoryImage; img: TFPMemoryImage;
b: TBytes; b: TBytes;
begin begin
itm := TPDFImageItem.Create(nil); list := TPDFImages.Create(nil, TPDFImageItem);
try try
itm.OwnsImage := True; itm := list.AddImageItem;
img := TFPMemoryImage.Create(5, 5);
itm.Image := img;
b := itm.StreamedData;
AssertEquals('Failed on 1', 75 {5*5*3}, Length(b));
finally
itm.Free;
end;
itm := TPDFImageItem.Create(nil);
try
itm.OwnsImage := True;
img := TFPMemoryImage.Create(10, 20);
itm.Image := img;
{ this try..except as to prove that we had a bug before we fixed it. }
try try
itm.OwnsImage := True;
img := TFPMemoryImage.Create(5, 5);
itm.Image := img;
b := itm.StreamedData; b := itm.StreamedData;
except AssertEquals('Failed on 1', 12, Length(b));
Fail('Failed on 2 - itm.StreamedData raised an exception'); finally
itm.Free;
end;
itm := list.AddImageItem;
try
itm.OwnsImage := True;
img := TFPMemoryImage.Create(10, 20);
itm.Image := img;
{ this try..except is to prove that we had a bug before, but fixed it. }
try
b := itm.StreamedData;
except
Fail('Failed on 2 - itm.StreamedData raised an exception');
end;
AssertEquals('Failed on 3', 15, Length(b));
finally
itm.Free;
end; end;
AssertEquals('Failed on 3', 600 {10*20*3}, Length(b));
finally finally
itm.Free; list.Free;
end;
end;
procedure TTestTPDFImageItem.TestCreateStreamedData_Uncompressed;
var
pdf: TPDFDocument;
list: TPDFImages;
itm: TPDFImageItem;
img: TFPMemoryImage;
b: TBytes;
begin
pdf := TPDFDocument.Create(nil);
pdf.Options := []; // disables the default image compression
list := TPDFImages.Create(pdf, TPDFImageItem);
try
itm := list.AddImageItem;
try
itm.OwnsImage := True;
img := TFPMemoryImage.Create(5, 5);
itm.Image := img;
b := itm.StreamedData;
AssertEquals('Failed on 1', 75 {5*5*3}, Length(b));
finally
itm.Free;
end;
itm := list.AddImageItem;
try
itm.OwnsImage := True;
img := TFPMemoryImage.Create(10, 20);
itm.Image := img;
{ this try..except is to prove that we had a bug before, but fixed it. }
try
b := itm.StreamedData;
except
Fail('Failed on 2 - itm.StreamedData raised an exception');
end;
AssertEquals('Failed on 3', 600 {10*20*3}, Length(b));
finally
itm.Free;
end;
finally
pdf.Free;
list.Free;
end; end;
end; end;

70
packages/fcl-pdf/tests/fpttf_test.pas
View File

@ -9,7 +9,7 @@ uses
{$ifdef fptest} {$ifdef fptest}
,TestFramework ,TestFramework
{$else} {$else}
,fpcunit, testutils, testregistry ,fpcunit, testregistry
{$endif} {$endif}
,fpttf ,fpttf
; ;
@ -56,6 +56,9 @@ implementation
uses uses
fpparsettf; fpparsettf;
resourcestring
cErrFontCountWrong = ' - make sure you only have the 4 test fonts in the "fonts" directory.';
{ TFPFontCacheItemTest } { TFPFontCacheItemTest }
procedure TFPFontCacheItemTest.SetUp; procedure TFPFontCacheItemTest.SetUp;
@ -72,87 +75,36 @@ end;
procedure TFPFontCacheItemTest.TestIsRegular; procedure TFPFontCacheItemTest.TestIsRegular;
begin begin
{ regular should be the default flag set }
CheckEquals(True, CI.IsRegular, 'Failed on 1'); CheckEquals(True, CI.IsRegular, 'Failed on 1');
CI.IsRegular := True;
CI.IsRegular := True; // to make sure bitwise masks work correctly
CheckEquals(True, CI.IsRegular, 'Failed on 2');
CI.IsItalic := True;
CheckEquals(True, CI.IsRegular, 'Failed on 3');
CI.IsRegular := False;
CheckEquals(False, CI.IsRegular, 'Failed on 4');
CI.IsRegular := False; // to make sure bitwise masks work correctly. eg: xor usage
CheckEquals(False, CI.IsRegular, 'Failed on 5');
end; end;
procedure TFPFontCacheItemTest.TestIsBold; procedure TFPFontCacheItemTest.TestIsBold;
begin begin
CheckEquals(False, CI.IsBold, 'Failed on 1'); CheckEquals(False, CI.IsBold, 'Failed on 1');
CI.IsBold := True;
CI.IsBold := True; // to make sure bitwise masks work correctly
CheckEquals(True, CI.IsBold, 'Failed on 2');
CI.IsBold := True;
CI.IsItalic := True;
CheckEquals(True, CI.IsBold, 'Failed on 3');
CI.IsBold := False;
CheckEquals(False, CI.IsBold, 'Failed on 4');
CI.IsBold := False; // to make sure bitwise masks work correctly. eg: xor usage
CheckEquals(False, CI.IsBold, 'Failed on 5');
end; end;
procedure TFPFontCacheItemTest.TestIsItalic; procedure TFPFontCacheItemTest.TestIsItalic;
begin begin
CheckEquals(False, CI.IsItalic, 'Failed on 1'); CheckEquals(False, CI.IsItalic, 'Failed on 1');
CI.IsItalic := True;
CI.IsItalic := True; // to make sure bitwise masks work correctly
CheckEquals(True, CI.IsItalic, 'Failed on 2');
CI.IsBold := True;
CI.IsItalic := True;
CheckEquals(True, CI.IsItalic, 'Failed on 3');
CI.IsItalic := False;
CheckEquals(False, CI.IsItalic, 'Failed on 4');
CI.IsItalic := False; // to make sure bitwise masks work correctly. eg: xor usage
CheckEquals(False, CI.IsItalic, 'Failed on 5');
end; end;
procedure TFPFontCacheItemTest.TestIsFixedWidth; procedure TFPFontCacheItemTest.TestIsFixedWidth;
begin begin
CheckEquals(False, CI.IsFixedWidth, 'Failed on 1'); CheckEquals(False, CI.IsFixedWidth, 'Failed on 1');
CI.IsFixedWidth := True;
CheckEquals(True, CI.IsFixedWidth, 'Failed on 2');
CI.IsFixedWidth := True; // to make sure bitwise masks work correctly
CheckEquals(True, CI.IsFixedWidth, 'Failed on 3');
CI.IsItalic := True; // changing another bitmask doesn't affect IsFixedWidth
CheckEquals(True, CI.IsFixedWidth, 'Failed on 4');
CI.IsFixedWidth := False;
CheckEquals(False, CI.IsFixedWidth, 'Failed on 5');
CI.IsFixedWidth := False; // to make sure bitwise masks work correctly. eg: xor usage
CheckEquals(False, CI.IsFixedWidth, 'Failed on 6');
end; end;
procedure TFPFontCacheItemTest.TestRegularVsFixedWidth; procedure TFPFontCacheItemTest.TestRegularVsFixedWidth;
begin begin
CheckEquals(True, CI.IsRegular, 'Failed on 1'); CheckEquals(True, CI.IsRegular, 'Failed on 1');
CheckEquals(False, CI.IsFixedWidth, 'Failed on 2'); CheckEquals(False, CI.IsFixedWidth, 'Failed on 2');
CI.IsFixedWidth := True; // this should toggle IsRegular's value
CheckEquals(False, CI.IsRegular, 'Failed on 3');
CheckEquals(True, CI.IsFixedWidth, 'Failed on 4');
CI.IsRegular := True; // this should toggle IsFixedWidth's value
CheckEquals(True, CI.IsRegular, 'Failed on 5');
CheckEquals(False, CI.IsFixedWidth, 'Failed on 6');
end; end;
procedure TFPFontCacheItemTest.TestFileName; procedure TFPFontCacheItemTest.TestFileName;
begin begin
CI.FileName := ''; CheckTrue(CI.FileName <> '', 'Failed on 1');
try { FileName is a non-existing file though, so FontData should be nil }
CI.GetFontData; CheckTrue(CI.FontData = nil, 'Failed on 2');
Fail('Failed on 1. GetFontData should work if FileName is empty.');
except
on e: Exception do
begin
CheckEquals(E.ClassName, 'ETTF', 'Failed on 2.');
end;
end;
end; end;
procedure TFPFontCacheItemTest.TestTextWidth_FontUnits; procedure TFPFontCacheItemTest.TestTextWidth_FontUnits;
@ -237,7 +189,7 @@ begin
FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts'); FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
CheckEquals(0, FC.Count, 'Failed on 2'); CheckEquals(0, FC.Count, 'Failed on 2');
FC.BuildFontCache; FC.BuildFontCache;
CheckEquals(4, FC.Count, 'Failed on 3'); CheckEquals(4, FC.Count, 'Failed on 3' + cErrFontCountWrong);
end; end;
procedure TFPFontCacheListTest.TestBuildFontCache; procedure TFPFontCacheListTest.TestBuildFontCache;
@ -256,7 +208,7 @@ begin
FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts'); FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
CheckEquals(0, FC.Count, 'Failed on 4'); CheckEquals(0, FC.Count, 'Failed on 4');
FC.BuildFontCache; FC.BuildFontCache;
CheckEquals(4, FC.Count, 'Failed on 5'); CheckEquals(4, FC.Count, 'Failed on 5' + cErrFontCountWrong);
end; end;
procedure TFPFontCacheListTest.TestClear; procedure TFPFontCacheListTest.TestClear;
@ -279,7 +231,7 @@ begin
CheckTrue(lCI = nil, 'Failed on 2'); CheckTrue(lCI = nil, 'Failed on 2');
FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts'); FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
FC.BuildFontCache; FC.BuildFontCache;
CheckEquals(4, FC.Count, 'Failed on 3'); CheckEquals(4, FC.Count, 'Failed on 3' + cErrFontCountWrong);
lCI := FC.Find('Ubuntu'); lCI := FC.Find('Ubuntu');
CheckTrue(Assigned(lCI), 'Failed on 4'); CheckTrue(Assigned(lCI), 'Failed on 4');