paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-11 10:29:21 +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/fpttf.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/fppdf_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;
begin
Result:=ToNatural(FOS2Data.sTypoAscender); // 2 bytes
Result:=FOS2Data.sTypoAscender;
end;
function TTFFileInfo.Descender: SmallInt;
begin
Result := ToNatural(FOS2Data.sTypoDescender); // 2 bytes
Result := FOS2Data.sTypoDescender;
end;
function TTFFileInfo.Leading: SmallInt;
begin
Result := ToNatural(FOS2Data.sTypoLineGap);
Result := FOS2Data.sTypoLineGap;
end;
function TTFFileInfo.CapHeight: SmallInt;
@ -882,7 +882,7 @@ begin
With FOS2Data do
begin
if Version>= 2 then
Result:=ToNatural(sCapHeight)
Result:=sCapHeight
else
Result:=Ascender;
end;

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

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

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

@ -20,20 +20,12 @@ uses
contnrs,
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
TTrueTypeFontStyle = (fsRegular, fsItalic, fsBold, fsCondensed, fsExtraLight, fsLight, fsSemibold, fsMedium, fsBlack, fsFixedWidth);
TTrueTypeFontStyles = set of TTrueTypeFontStyle;
{ Forward declaration }
TFPFontCacheList = class;
@ -42,34 +34,30 @@ type
private
FFamilyName: String;
FFileName: String;
FStyleFlags: LongWord;
FStyleFlags: TTrueTypeFontStyles;
FFileInfo: TTFFileInfo;
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 GetIsFixedWidth: boolean;
function GetIsItalic: 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
constructor Create(const AFilename: String);
destructor Destroy; override;
{ Returns the actual TTF font file information. }
function GetFontData: TTFFileInfo;
{ Result is in pixels }
function TextWidth(AStr: utf8string; APointSize: single): single;
property FileName: String read FFileName write SetFileName;
property FamilyName: String read FFamilyName write FFamilyName;
property FileName: String read FFileName;
property FamilyName: String read FFamilyName;
property FontData: TTFFileInfo read FFileInfo;
{ 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. }
property IsFixedWidth: boolean read GetIsFixedWidth write SetIsFixedWidth;
property IsRegular: boolean read GetIsRegular write SetIsRegular;
property IsItalic: boolean read GetIsItalic write SetIsItalic;
property IsBold: boolean read GetIsBold write SetIsBold;
property IsFixedWidth: boolean read GetIsFixedWidth;
property IsRegular: boolean read GetIsRegular;
property IsItalic: boolean read GetIsItalic;
property IsBold: boolean read GetIsBold;
end;
@ -79,8 +67,6 @@ type
FSearchPath: TStringList;
FDPI: integer;
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);
protected
function GetCount: integer; virtual;
@ -129,101 +115,89 @@ end;
function TFPFontCacheItem.GetIsBold: boolean;
begin
Result := (FStyleFlags and FP_FONT_STYLE_BOLD) <> 0;
Result := fsBold in FStyleFlags;
end;
function TFPFontCacheItem.GetIsFixedWidth: boolean;
begin
Result := (FStyleFlags and FP_FONT_STYLE_FIXEDWIDTH) <> 0;
Result := fsFixedWidth in FStyleFlags;
end;
function TFPFontCacheItem.GetIsItalic: boolean;
begin
Result := (FStyleFlags and FP_FONT_STYLE_ITALIC) <> 0;
Result := fsItalic in FStyleFlags;
end;
function TFPFontCacheItem.GetIsRegular: boolean;
begin
Result := (FStyleFlags and FP_FONT_STYLE_REGULAR) <> 0;
Result := fsRegular in FStyleFlags;
end;
procedure TFPFontCacheItem.SetFileName(const AFileName: String);
procedure TFPFontCacheItem.BuildFontCacheItem;
var
s: string;
begin
if FFileName = AFileName then Exit;
FFileName := AFileName;
if FFileInfo<>nil then
FreeAndNil(FFileInfo);
s := FFileInfo.PostScriptName;
FFamilyName := FFileInfo.FamilyName;
if Pos(s, FFamilyName) = 1 then
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;
procedure TFPFontCacheItem.SetIsBold(AValue: boolean);
procedure TFPFontCacheItem.SetStyleIfExists(var AText: string; var AStyleFlags: TTrueTypeFontStyles;
const AStyleName: String; const AStyle: TTrueTypeFontStyle);
var
i: integer;
begin
if AValue then
FStyleFlags := FStyleFlags or FP_FONT_STYLE_BOLD
else
FStyleFlags := FStyleFlags and (not FP_FONT_STYLE_BOLD);
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);
i := Pos(AStyleName, AText);
if i > 0 then
begin
AStyleFlags := AStyleFlags + [AStyle];
Delete(AText, i, Length(AStyleName));
end;
end;
constructor TFPFontCacheItem.Create(const AFilename: String);
begin
inherited Create;
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;
destructor TFPFontCacheItem.Destroy;
begin
FFileInfo.Free;
inherited Destroy;
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
the text width in Font Units. If APointSize > 0 then it returns the text width
in Pixels. }
@ -248,7 +222,6 @@ function TFPFontCacheItem.TextWidth(AStr: utf8string; APointSize: single): singl
550 * 18 * 72 / ( 72 * 2048 ) = 4.83
}
var
lFntInfo: TTFFileInfo;
i: integer;
lWidth: integer;
lGIndex: integer;
@ -262,8 +235,7 @@ begin
if Length(AStr) = 0 then
Exit;
lFntInfo := GetFontData;
if not Assigned(lFntInfo) then
if not Assigned(FFileInfo) then
Exit;
{$IFDEF ttfdebug}
@ -271,13 +243,13 @@ begin
s := '';
for i := 0 to 255 do
begin
lGIndex := lFntInfo.GetGlyphIndex(i);
lWidth := lFntInfo.GetAdvanceWidth(lGIndex);
lGIndex := FFileInfo.GetGlyphIndex(i);
lWidth := FFileInfo.GetAdvanceWidth(lGIndex);
s := s + ',' + IntToStr(lWidth);
end;
sl.Add(s);
sl.Add('UnitsPerEm = ' + IntToStr(lFntInfo.Head.UnitsPerEm));
sl.SaveToFile('/tmp/' + lFntInfo.PostScriptName + '.txt');
sl.Add('UnitsPerEm = ' + IntToStr(FFileInfo.Head.UnitsPerEm));
sl.SaveToFile(GetTempDir(True) + FFileInfo.PostScriptName + '.txt');
sl.Free;
{$ENDIF}
@ -285,8 +257,8 @@ begin
us := UTF8Decode(AStr);
for i := 1 to Length(us) do
begin
lGIndex := lFntInfo.GetGlyphIndex(Word(us[i]));
lWidth := lWidth + lFntInfo.GetAdvanceWidth(lGIndex);
lGIndex := FFileInfo.GetGlyphIndex(Word(us[i]));
lWidth := lWidth + FFileInfo.GetAdvanceWidth(lGIndex);
end;
if APointSize = 0.0 then
Result := lWidth
@ -294,7 +266,7 @@ begin
begin
{ Converting Font Units to Pixels. The formula is:
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;
@ -321,7 +293,7 @@ begin
if (lowercase(ExtractFileExt(s)) = '.ttf') or
(lowercase(ExtractFileExt(s)) = '.otf') then
begin
lFont := BuildFontCacheItem(AFontPath + s);
lFont := TFPFontCacheItem.Create(AFontPath + s);
Add(lFont);
end;
end;
@ -330,55 +302,6 @@ begin
FindClose(sr);
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);
begin
if FDPI = AValue then Exit;
@ -466,16 +389,15 @@ function TFPFontCacheList.Find(const AFamilyName: string; ABold: boolean; AItali
var
i: integer;
begin
Result := nil;
for i := 0 to Count-1 do
begin
if (Items[i].FamilyName = AFamilyName) and (items[i].IsItalic = AItalic)
and (items[i].IsBold = ABold) then
begin
Result := Items[i];
Result := Items[i];
if (Result.FamilyName = AFamilyName) and (Result.IsItalic = AItalic)
and (Result.IsBold = ABold)
then
exit;
end;
end;
Result := nil;
end;
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}
,TestFramework
{$else}
,fpcunit, testutils, testregistry
,fpcunit, testregistry
{$endif}
,fpparsettf
;
@ -356,7 +356,6 @@ implementation
uses
dateutils
,strutils
,IniFiles
;
const

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

@ -9,7 +9,7 @@ uses
{$ifdef fptest}
,TestFramework
{$else}
,fpcunit, testutils, testregistry
,fpcunit, testregistry
{$endif}
,fppdf
;
@ -73,6 +73,7 @@ type
procedure TestWrite;
procedure TestValidNames1;
procedure TestValidNames2;
procedure TestValidNames3;
end;
@ -232,7 +233,8 @@ type
TTestTPDFImageItem = class(TTestCase)
published
procedure TestCreateStreamedData;
procedure TestCreateStreamedData_Compressed;
procedure TestCreateStreamedData_Uncompressed;
end;
implementation
@ -509,6 +511,20 @@ var
o: TPDFName;
begin
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
AssertEquals('Failed on 1', '', S.DataString);
TMockPDFName(o).Write(S);
@ -1630,37 +1646,87 @@ end;
{ TTestTPDFImageItem }
procedure TTestTPDFImageItem.TestCreateStreamedData;
procedure TTestTPDFImageItem.TestCreateStreamedData_Compressed;
var
list: TPDFImages;
itm: TPDFImageItem;
img: TFPMemoryImage;
b: TBytes;
begin
itm := TPDFImageItem.Create(nil);
list := TPDFImages.Create(nil, TPDFImageItem);
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 := 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. }
itm := list.AddImageItem;
try
itm.OwnsImage := True;
img := TFPMemoryImage.Create(5, 5);
itm.Image := img;
b := itm.StreamedData;
except
Fail('Failed on 2 - itm.StreamedData raised an exception');
AssertEquals('Failed on 1', 12, 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', 15, Length(b));
finally
itm.Free;
end;
AssertEquals('Failed on 3', 600 {10*20*3}, Length(b));
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;

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

@ -9,7 +9,7 @@ uses
{$ifdef fptest}
,TestFramework
{$else}
,fpcunit, testutils, testregistry
,fpcunit, testregistry
{$endif}
,fpttf
;
@ -56,6 +56,9 @@ implementation
uses
fpparsettf;
resourcestring
cErrFontCountWrong = ' - make sure you only have the 4 test fonts in the "fonts" directory.';
{ TFPFontCacheItemTest }
procedure TFPFontCacheItemTest.SetUp;
@ -72,87 +75,36 @@ end;
procedure TFPFontCacheItemTest.TestIsRegular;
begin
{ regular should be the default flag set }
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;
procedure TFPFontCacheItemTest.TestIsBold;
begin
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;
procedure TFPFontCacheItemTest.TestIsItalic;
begin
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;
procedure TFPFontCacheItemTest.TestIsFixedWidth;
begin
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;
procedure TFPFontCacheItemTest.TestRegularVsFixedWidth;
begin
CheckEquals(True, CI.IsRegular, 'Failed on 1');
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;
procedure TFPFontCacheItemTest.TestFileName;
begin
CI.FileName := '';
try
CI.GetFontData;
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;
CheckTrue(CI.FileName <> '', 'Failed on 1');
{ FileName is a non-existing file though, so FontData should be nil }
CheckTrue(CI.FontData = nil, 'Failed on 2');
end;
procedure TFPFontCacheItemTest.TestTextWidth_FontUnits;
@ -237,7 +189,7 @@ begin
FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
CheckEquals(0, FC.Count, 'Failed on 2');
FC.BuildFontCache;
CheckEquals(4, FC.Count, 'Failed on 3');
CheckEquals(4, FC.Count, 'Failed on 3' + cErrFontCountWrong);
end;
procedure TFPFontCacheListTest.TestBuildFontCache;
@ -256,7 +208,7 @@ begin
FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
CheckEquals(0, FC.Count, 'Failed on 4');
FC.BuildFontCache;
CheckEquals(4, FC.Count, 'Failed on 5');
CheckEquals(4, FC.Count, 'Failed on 5' + cErrFontCountWrong);
end;
procedure TFPFontCacheListTest.TestClear;
@ -279,7 +231,7 @@ begin
CheckTrue(lCI = nil, 'Failed on 2');
FC.SearchPath.Add(ExtractFilePath(ParamStr(0)) + 'fonts');
FC.BuildFontCache;
CheckEquals(4, FC.Count, 'Failed on 3');
CheckEquals(4, FC.Count, 'Failed on 3' + cErrFontCountWrong);
lCI := FC.Find('Ubuntu');
CheckTrue(Assigned(lCI), 'Failed on 4');