]>
Commit | Line | Data |
---|---|---|
44191929 | 1 | #!perl -w |
4f68b48f | 2 | use strict; |
ea3099db | 3 | use Test::More; |
4f68b48f | 4 | |
19dac3de TC |
5 | $|=1; |
6 | ||
44191929 | 7 | BEGIN { use_ok(Imager => ':all') } |
d8d215e3 | 8 | use Imager::Test qw(diff_text_with_nul is_color3 is_image); |
02d1d628 | 9 | |
40e78f96 TC |
10 | -d "testout" or mkdir "testout"; |
11 | ||
27e79497 | 12 | init_log("testout/t35ttfont.log",2); |
02d1d628 | 13 | |
44191929 TC |
14 | SKIP: |
15 | { | |
d8d215e3 | 16 | skip("freetype 1.x unavailable or disabled", 96) |
2368cfec | 17 | unless $Imager::formats{"tt"}; |
44191929 TC |
18 | print "# has tt\n"; |
19 | ||
20 | my $deffont = './fontfiles/dodge.ttf'; | |
21 | my $fontname=$ENV{'TTFONTTEST'} || $deffont; | |
22 | ||
23 | if (!ok(-f $fontname, "check test font file exists")) { | |
24 | print "# cannot find fontfile for truetype test $fontname\n"; | |
fa16b6c6 | 25 | skip('Cannot load test font', 89); |
44191929 TC |
26 | } |
27 | ||
d1555273 | 28 | #i_init_fonts(); |
44191929 TC |
29 | # i_tt_set_aa(1); |
30 | ||
31 | my $bgcolor = i_color_new(255,0,0,0); | |
95b2bff4 TC |
32 | my $overlay = Imager::ImgRaw::new(320,140,3); |
33 | i_box_filled($overlay, 0, 0, 319, 139, i_color_new(128, 128, 128)); | |
44191929 TC |
34 | |
35 | my $ttraw = Imager::i_tt_new($fontname); | |
36 | ok($ttraw, "create font"); | |
37 | ||
7e3298ec | 38 | my @bbox = i_tt_bbox($ttraw,50.0,'XMCLH',0); |
7fdbfba8 | 39 | is(@bbox, 8, "bounding box"); |
44191929 TC |
40 | print "#bbox: ($bbox[0], $bbox[1]) - ($bbox[2], $bbox[3])\n"; |
41 | ||
83bb9f77 | 42 | ok(i_tt_cp($ttraw,$overlay,5,50,1,50.0,'XM CLH',6,1,0), "cp output"); |
95b2bff4 | 43 | ok(i_tt_cp($ttraw,$overlay,5,120,1,50.0,'XM CLH',6,0,0), "cp output (non AA)"); |
44191929 TC |
44 | i_line($overlay,0,50,100,50,$bgcolor,1); |
45 | ||
46 | open(FH,">testout/t35ttfont.ppm") || die "cannot open testout/t35ttfont.ppm\n"; | |
47 | binmode(FH); | |
48 | my $IO = Imager::io_new_fd( fileno(FH) ); | |
49 | ok(i_writeppm_wiol($overlay, $IO), "save t35ttfont.ppm"); | |
50 | close(FH); | |
51 | ||
52 | $bgcolor=i_color_set($bgcolor,200,200,200,0); | |
53 | my $backgr=Imager::ImgRaw::new(500,300,3); | |
54 | ||
55 | # i_tt_set_aa(2); | |
56 | ||
83bb9f77 | 57 | ok(i_tt_text($ttraw,$backgr,100,120,$bgcolor,50.0,'te st',5,1,0), |
44191929 | 58 | "normal output"); |
95b2bff4 TC |
59 | ok(i_tt_text($ttraw,$backgr,100,200,$bgcolor,50.0,'te st',5,0,0), |
60 | "normal output (non AA)"); | |
44191929 TC |
61 | |
62 | my $ugly = Imager::i_tt_new("./fontfiles/ImUgly.ttf"); | |
63 | ok($ugly, "create ugly font"); | |
64 | # older versions were dropping the bottom of g and the right of a | |
65 | ok(i_tt_text($ugly, $backgr,100, 80, $bgcolor, 14, 'g%g', 3, 1, 0), | |
66 | "draw g%g"); | |
83bb9f77 | 67 | ok(i_tt_text($ugly, $backgr,150, 80, $bgcolor, 14, 'delta', 6, 1, 0), |
44191929 TC |
68 | "draw delta"); |
69 | i_line($backgr,0,20,499,20,i_color_new(0,127,0,0),1); | |
70 | ok(i_tt_text($ttraw, $backgr, 20, 20, $bgcolor, 14, 'abcdefghijklmnopqrstuvwxyz{|}', 29, 1, 0), "alphabet"); | |
71 | ok(i_tt_text($ttraw, $backgr, 20, 50, $bgcolor, 14, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 26, 1, 0), "ALPHABET"); | |
72 | ||
73 | # UTF8 tests | |
74 | # for perl < 5.6 we can hand-encode text | |
75 | # the following is "A\x{2010}A" | |
76 | # | |
77 | my $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41); | |
78 | my $alttext = "A-A"; | |
79 | ||
7e3298ec | 80 | my @utf8box = i_tt_bbox($ttraw, 50.0, $text, 1); |
7fdbfba8 | 81 | is(@utf8box, 8, "utf8 bbox element count"); |
7e3298ec | 82 | my @base = i_tt_bbox($ttraw, 50.0, $alttext, 0); |
7fdbfba8 | 83 | is(@base, 8, "alt bbox element count"); |
44191929 TC |
84 | my $maxdiff = $fontname eq $deffont ? 0 : $base[2] / 3; |
85 | print "# (@utf8box vs @base)\n"; | |
86 | ok(abs($utf8box[2] - $base[2]) <= $maxdiff, | |
87 | "compare box sizes $utf8box[2] vs $base[2] (maxerror $maxdiff)"); | |
88 | ||
89 | # hand-encoded UTF8 drawing | |
90 | ok(i_tt_text($ttraw, $backgr, 200, 80, $bgcolor, 14, $text, length($text), 1, 1), "draw hand-encoded UTF8"); | |
91 | ||
92 | ok(i_tt_cp($ttraw, $backgr, 250, 80, 1, 14, $text, length($text), 1, 1), | |
93 | "cp hand-encoded UTF8"); | |
94 | ||
95 | # ok, try native perl UTF8 if available | |
96 | SKIP: | |
97 | { | |
98 | skip("perl too old to test native UTF8 support", 5) unless $] >= 5.006; | |
99 | ||
100 | my $text; | |
101 | # we need to do this in eval to prevent compile time errors in older | |
102 | # versions | |
103 | eval q{$text = "A\x{2010}A"}; # A, HYPHEN, A in our test font | |
104 | #$text = "A".chr(0x2010)."A"; # this one works too | |
105 | ok(i_tt_text($ttraw, $backgr, 300, 80, $bgcolor, 14, $text, 0, 1, 0), | |
106 | "draw UTF8"); | |
107 | ok(i_tt_cp($ttraw, $backgr, 350, 80, 0, 14, $text, 0, 1, 0), | |
108 | "cp UTF8"); | |
7e3298ec | 109 | @utf8box = i_tt_bbox($ttraw, 50.0, $text, 0); |
7fdbfba8 | 110 | is(@utf8box, 8, "native utf8 bbox element count"); |
44191929 TC |
111 | ok(abs($utf8box[2] - $base[2]) <= $maxdiff, |
112 | "compare box sizes native $utf8box[2] vs $base[2] (maxerror $maxdiff)"); | |
113 | eval q{$text = "A\x{0905}\x{0906}\x{0103}A"}; # Devanagari | |
114 | ok(i_tt_text($ugly, $backgr, 100, 160, $bgcolor, 36, $text, 0, 1, 0), | |
115 | "more complex output"); | |
116 | } | |
117 | ||
118 | open(FH,">testout/t35ttfont2.ppm") || die "cannot open testout/t35ttfont.ppm\n"; | |
119 | binmode(FH); | |
120 | $IO = Imager::io_new_fd( fileno(FH) ); | |
121 | ok(i_writeppm_wiol($backgr, $IO), "save t35ttfont2.ppm"); | |
122 | close(FH); | |
123 | ||
124 | my $exists_font = "fontfiles/ExistenceTest.ttf"; | |
125 | my $hcfont = Imager::Font->new(file=>$exists_font, type=>'tt'); | |
126 | SKIP: | |
127 | { | |
128 | ok($hcfont, "loading existence test font") | |
7fdbfba8 | 129 | or skip("could not load test font", 20); |
44191929 TC |
130 | |
131 | # list interface | |
132 | my @exists = $hcfont->has_chars(string=>'!A'); | |
133 | ok(@exists == 2, "check return count"); | |
134 | ok($exists[0], "we have an exclamation mark"); | |
135 | ok(!$exists[1], "we have no exclamation mark"); | |
136 | ||
137 | # scalar interface | |
138 | my $exists = $hcfont->has_chars(string=>'!A'); | |
139 | ok(length($exists) == 2, "check return length"); | |
140 | ok(ord(substr($exists, 0, 1)), "we have an exclamation mark"); | |
141 | ok(!ord(substr($exists, 1, 1)), "we have no upper-case A"); | |
142 | ||
143 | my $face_name = Imager::i_tt_face_name($hcfont->{id}); | |
144 | print "# face $face_name\n"; | |
5386861e | 145 | is($face_name, 'ExistenceTest', "face name (function)"); |
44191929 | 146 | $face_name = $hcfont->face_name; |
5386861e | 147 | is($face_name, 'ExistenceTest', "face name (OO)"); |
44191929 TC |
148 | |
149 | # FT 1.x cheats and gives names even if the font doesn't have them | |
150 | my @glyph_names = $hcfont->glyph_names(string=>"!J/"); | |
5386861e | 151 | is($glyph_names[0], 'exclam', "check exclam name OO"); |
44191929 | 152 | ok(!defined($glyph_names[1]), "check for no J name OO"); |
5386861e | 153 | is($glyph_names[2], 'slash', "check slash name OO"); |
ea3099db TC |
154 | |
155 | # check invalid utf8 | |
156 | my @bad = $hcfont->glyph_names(string => "!/\xC0", utf8 => 1); | |
157 | is(@bad, 0, "should return nothing for invalid UTF-8"); | |
44191929 TC |
158 | |
159 | print "# ** name table of the test font **\n"; | |
160 | Imager::i_tt_dump_names($hcfont->{id}); | |
8a35bed5 TC |
161 | |
162 | # the test font is known to have a shorter advance width for that char | |
163 | my @bbox = $hcfont->bounding_box(string=>"/", size=>100); | |
7fdbfba8 | 164 | is(@bbox, 8, "should be 8 entries"); |
8a35bed5 TC |
165 | isnt($bbox[6], $bbox[2], "different advance width from pos width"); |
166 | print "# @bbox\n"; | |
167 | my $bbox = $hcfont->bounding_box(string=>"/", size=>100); | |
168 | isnt($bbox->pos_width, $bbox->advance_width, "OO check"); | |
7fdbfba8 TC |
169 | |
170 | cmp_ok($bbox->right_bearing, '<', 0, "check right bearing"); | |
171 | ||
172 | cmp_ok($bbox->display_width, '>', $bbox->advance_width, | |
173 | "check display width (roughly)"); | |
174 | ||
175 | # check with a char that fits inside the box | |
176 | $bbox = $hcfont->bounding_box(string=>"!", size=>100); | |
177 | print "# @$bbox\n"; | |
178 | print "# pos width ", $bbox->pos_width, "\n"; | |
179 | is($bbox->pos_width, $bbox->advance_width, | |
180 | "check backwards compatibility"); | |
181 | cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive"); | |
182 | cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive"); | |
183 | cmp_ok($bbox->display_width, '<', $bbox->advance_width, | |
184 | "display smaller than advance"); | |
44191929 TC |
185 | } |
186 | undef $hcfont; | |
187 | ||
188 | my $name_font = "fontfiles/NameTest.ttf"; | |
6a00d627 | 189 | $hcfont = Imager::Font->new(file=>$name_font, type=>'tt'); |
44191929 TC |
190 | SKIP: |
191 | { | |
192 | ok($hcfont, "loading name font") | |
193 | or skip("could not load name font $name_font", 3); | |
194 | # make sure a missing string parameter is handled correctly | |
195 | eval { | |
196 | $hcfont->glyph_names(); | |
197 | }; | |
198 | is($@, "", "correct error handling"); | |
199 | cmp_ok(Imager->errstr, '=~', qr/no string parameter/, "error message"); | |
200 | ||
201 | my $text = pack("C*", 0xE2, 0x80, 0x90); # "\x{2010}" as utf-8 | |
202 | my @names = $hcfont->glyph_names(string=>$text, utf8=>1); | |
203 | is($names[0], "hyphentwo", "check utf8 glyph name"); | |
204 | } | |
205 | ||
206 | undef $hcfont; | |
207 | ||
490aa9ae TC |
208 | SKIP: |
209 | { print "# alignment tests\n"; | |
210 | my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt'); | |
211 | ok($font, "loaded deffont OO") | |
212 | or skip("could not load font:".Imager->errstr, 4); | |
9ab6338b TC |
213 | my $im = Imager->new(xsize=>140, ysize=>150); |
214 | my %common = | |
490aa9ae TC |
215 | ( |
216 | font=>$font, | |
490aa9ae | 217 | size=>40, |
490aa9ae TC |
218 | aa=>1, |
219 | ); | |
9ab6338b TC |
220 | $im->line(x1=>0, y1=>40, x2=>139, y2=>40, color=>'blue'); |
221 | $im->line(x1=>0, y1=>90, x2=>139, y2=>90, color=>'blue'); | |
222 | $im->line(x1=>0, y1=>110, x2=>139, y2=>110, color=>'blue'); | |
223 | for my $args ([ x=>5, text=>"A", color=>"white" ], | |
224 | [ x=>40, text=>"y", color=>"white" ], | |
a6d9b737 TC |
225 | [ x=>75, text=>"A", channel=>1 ], |
226 | [ x=>110, text=>"y", channel=>1 ]) { | |
9ab6338b TC |
227 | ok($im->string(%common, @$args, 'y'=>40), "A no alignment"); |
228 | ok($im->string(%common, @$args, 'y'=>90, align=>1), "A align=1"); | |
229 | ok($im->string(%common, @$args, 'y'=>110, align=>0), "A align=0"); | |
230 | } | |
490aa9ae TC |
231 | ok($im->write(file=>'testout/t35align.ppm'), "save align image"); |
232 | } | |
233 | ||
d93d5c10 TC |
234 | { # Ticket #14804 Imager::Font->new() doesn't report error details |
235 | # when using freetype 1 | |
e32e7bb5 TC |
236 | # make sure we're using C locale for messages |
237 | use POSIX qw(setlocale LC_ALL); | |
238 | setlocale(LC_ALL, "C"); | |
239 | ||
5664d5c8 | 240 | my $font = Imager::Font->new(file=>'t/350-font/020-tt.t', type=>'tt'); |
d93d5c10 TC |
241 | ok(!$font, "font creation should have failed for invalid file"); |
242 | cmp_ok(Imager->errstr, 'eq', 'Invalid file format.', | |
243 | "test error message"); | |
e32e7bb5 TC |
244 | |
245 | setlocale(LC_ALL, ""); | |
d93d5c10 TC |
246 | } |
247 | ||
aa68d6e9 TC |
248 | { # check errstr set correctly |
249 | my $font = Imager::Font->new(file=>$fontname, type=>'tt', | |
250 | size => undef); | |
251 | ok($font, "made size error test font"); | |
252 | my $im = Imager->new(xsize=>100, ysize=>100); | |
253 | ok($im, "made size error test image"); | |
254 | ok(!$im->string(font=>$font, x=>10, 'y'=>50, string=>"Hello"), | |
255 | "drawing should fail with no size"); | |
256 | is($im->errstr, "No font size provided", "check error message"); | |
257 | ||
258 | # try no string | |
259 | ok(!$im->string(font=>$font, x=>10, 'y'=>50, size=>15), | |
260 | "drawing should fail with no string"); | |
261 | is($im->errstr, "missing required parameter 'string'", | |
262 | "check error message"); | |
263 | } | |
264 | ||
83bb9f77 TC |
265 | { # introduced in 0.46 - outputting just space crashes |
266 | my $im = Imager->new(xsize=>100, ysize=>100); | |
267 | my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', size=>14); | |
fa16b6c6 | 268 | ok($im->string(font=>$font, x=> 5, 'y' => 50, string=>' '), |
83bb9f77 TC |
269 | "outputting just a space was crashing"); |
270 | } | |
271 | ||
9a6ab99c TC |
272 | { # string output cut off at NUL ('\0') |
273 | # https://rt.cpan.org/Ticket/Display.html?id=21770 cont'd | |
274 | my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt'); | |
275 | ok($font, "loaded imugly"); | |
276 | ||
277 | diff_text_with_nul("a\\0b vs a", "a\0b", "a", | |
278 | font => $font, color => '#FFFFFF'); | |
279 | diff_text_with_nul("a\\0b vs a", "a\0b", "a", | |
280 | font => $font, channel => 1); | |
281 | ||
282 | # UTF8 encoded \x{2010} | |
283 | my $dash = pack("C*", 0xE2, 0x80, 0x90); | |
8927ff88 | 284 | diff_text_with_nul("utf8 dash\\0dash vs dash", "$dash\0$dash", $dash, |
9a6ab99c | 285 | font => $font, color => '#FFFFFF', utf8 => 1); |
8927ff88 | 286 | diff_text_with_nul("utf8 dash\\0dash vs dash", "$dash\0$dash", $dash, |
9a6ab99c TC |
287 | font => $font, channel => 1, utf8 => 1); |
288 | } | |
289 | ||
8927ff88 | 290 | SKIP: |
fa16b6c6 TC |
291 | { # RT 11972 |
292 | # when rendering to a transparent image the coverage should be | |
293 | # expressed in terms of the alpha channel rather than the color | |
294 | my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt'); | |
8927ff88 TC |
295 | ok($font, "loaded fontfiles/ImUgly.ttf") |
296 | or skip("Could not load test font: ".Imager->errstr, 4); | |
fa16b6c6 TC |
297 | my $im = Imager->new(xsize => 40, ysize => 20, channels => 4); |
298 | ok($im->string(string => "AB", size => 20, aa => 1, color => '#F00', | |
299 | x => 0, y => 15, font => $font), | |
300 | "draw to transparent image"); | |
301 | #$im->write(file => "foo.png"); | |
302 | my $im_noalpha = $im->convert(preset => 'noalpha'); | |
303 | my $im_pal = $im->to_paletted(make_colors => 'mediancut'); | |
304 | my @colors = $im_pal->getcolors; | |
305 | is(@colors, 2, "should be only 2 colors"); | |
306 | @colors = sort { ($a->rgba)[0] <=> ($b->rgba)[0] } @colors; | |
307 | is_color3($colors[0], 0, 0, 0, "check we got black"); | |
308 | is_color3($colors[1], 255, 0, 0, "and red"); | |
309 | } | |
310 | ||
d8d215e3 TC |
311 | SKIP: |
312 | { # RT 71564 | |
313 | my $noalpha = Imager::Color->new(255, 255, 255, 0); | |
314 | my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'tt', | |
315 | color => $noalpha); | |
316 | ok($font, "loaded fontfiles/ImUgly.ttf") | |
317 | or skip("Could not load test font: ".Imager->errstr, 4); | |
318 | { | |
319 | my $im = Imager->new(xsize => 40, ysize => 20); | |
320 | my $copy = $im->copy; | |
321 | ok($im->string(string => "AB", size => 20, aa => 1, | |
322 | x => 0, y => 15, font => $font), | |
323 | "draw with transparent color, aa"); | |
324 | is_image($im, $copy, "should draw nothing"); | |
325 | } | |
326 | { | |
327 | my $im = Imager->new(xsize => 40, ysize => 20); | |
328 | my $copy = $im->copy; | |
329 | ok($im->string(string => "AB", size => 20, aa => 0, | |
330 | x => 0, y => 15, font => $font), | |
331 | "draw with transparent color, non-aa"); | |
d8d215e3 TC |
332 | is_image($im, $copy, "should draw nothing"); |
333 | } | |
334 | } | |
335 | ||
44191929 | 336 | ok(1, "end of code"); |
4f68b48f | 337 | } |
ea3099db TC |
338 | |
339 | done_testing(); |