diff --git a/.gitattributes b/.gitattributes index 89df43d1fc..6350c3fd45 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/packages/fcl-pdf/src/fpparsettf.pp b/packages/fcl-pdf/src/fpparsettf.pp index 1bcb4b3c4a..d0aa8ac9b4 100644 --- a/packages/fcl-pdf/src/fpparsettf.pp +++ b/packages/fcl-pdf/src/fpparsettf.pp @@ -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; diff --git a/packages/fcl-pdf/src/fppdf.pp b/packages/fcl-pdf/src/fppdf.pp index ad2b1f55d8..935e88481c 100644 --- a/packages/fcl-pdf/src/fppdf.pp +++ b/packages/fcl-pdf/src/fppdf.pp @@ -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; diff --git a/packages/fcl-pdf/src/fpttf.pp b/packages/fcl-pdf/src/fpttf.pp index 79ff34c730..526f57846d 100644 --- a/packages/fcl-pdf/src/fpttf.pp +++ b/packages/fcl-pdf/src/fpttf.pp @@ -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; diff --git a/packages/fcl-pdf/tests/fonts/README.txt b/packages/fcl-pdf/tests/fonts/README.txt new file mode 100644 index 0000000000..a8592d38b0 --- /dev/null +++ b/packages/fcl-pdf/tests/fonts/README.txt @@ -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 + + diff --git a/packages/fcl-pdf/tests/fpparsettf_test.pas b/packages/fcl-pdf/tests/fpparsettf_test.pas index 9e92597413..9dddebb9f1 100644 --- a/packages/fcl-pdf/tests/fpparsettf_test.pas +++ b/packages/fcl-pdf/tests/fpparsettf_test.pas @@ -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 diff --git a/packages/fcl-pdf/tests/fppdf_test.pas b/packages/fcl-pdf/tests/fppdf_test.pas index 5dc0730149..d9291367eb 100644 --- a/packages/fcl-pdf/tests/fppdf_test.pas +++ b/packages/fcl-pdf/tests/fppdf_test.pas @@ -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; diff --git a/packages/fcl-pdf/tests/fpttf_test.pas b/packages/fcl-pdf/tests/fpttf_test.pas index a8acd46781..ada32579c0 100644 --- a/packages/fcl-pdf/tests/fpttf_test.pas +++ b/packages/fcl-pdf/tests/fpttf_test.pas @@ -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');