]>
Commit | Line | Data |
---|---|---|
1 | package Imager::Test; | |
2 | use strict; | |
3 | use Test::More; | |
4 | use Test::Builder; | |
5 | require Exporter; | |
6 | use vars qw(@ISA @EXPORT_OK $VERSION); | |
7 | use Carp qw(croak carp); | |
8 | use Config; | |
9 | ||
10 | $VERSION = "1.001"; | |
11 | ||
12 | @ISA = qw(Exporter); | |
13 | @EXPORT_OK = | |
14 | qw( | |
15 | diff_text_with_nul | |
16 | test_image_raw | |
17 | test_image_16 | |
18 | test_image | |
19 | test_image_double | |
20 | test_image_mono | |
21 | test_image_gray | |
22 | test_image_gray_16 | |
23 | test_image_named | |
24 | is_color1 | |
25 | is_color3 | |
26 | is_color4 | |
27 | is_color_close3 | |
28 | is_fcolor1 | |
29 | is_fcolor3 | |
30 | is_fcolor4 | |
31 | color_cmp | |
32 | is_image | |
33 | is_imaged | |
34 | is_image_similar | |
35 | isnt_image | |
36 | image_bounds_checks | |
37 | mask_tests | |
38 | test_colorf_gpix | |
39 | test_color_gpix | |
40 | test_colorf_glin | |
41 | can_test_threads | |
42 | std_font_tests | |
43 | std_font_test_count | |
44 | ); | |
45 | ||
46 | sub diff_text_with_nul { | |
47 | my ($desc, $text1, $text2, @params) = @_; | |
48 | ||
49 | my $builder = Test::Builder->new; | |
50 | ||
51 | print "# $desc\n"; | |
52 | my $imbase = Imager->new(xsize => 100, ysize => 100); | |
53 | my $imcopy = Imager->new(xsize => 100, ysize => 100); | |
54 | ||
55 | $builder->ok($imbase->string(x => 5, 'y' => 50, size => 20, | |
56 | string => $text1, | |
57 | @params), "$desc - draw text1"); | |
58 | $builder->ok($imcopy->string(x => 5, 'y' => 50, size => 20, | |
59 | string => $text2, | |
60 | @params), "$desc - draw text2"); | |
61 | $builder->isnt_num(Imager::i_img_diff($imbase->{IMG}, $imcopy->{IMG}), 0, | |
62 | "$desc - check result different"); | |
63 | } | |
64 | ||
65 | sub is_color3($$$$$) { | |
66 | my ($color, $red, $green, $blue, $comment) = @_; | |
67 | ||
68 | my $builder = Test::Builder->new; | |
69 | ||
70 | unless (defined $color) { | |
71 | $builder->ok(0, $comment); | |
72 | $builder->diag("color is undef"); | |
73 | return; | |
74 | } | |
75 | unless ($color->can('rgba')) { | |
76 | $builder->ok(0, $comment); | |
77 | $builder->diag("color is not a color object"); | |
78 | return; | |
79 | } | |
80 | ||
81 | my ($cr, $cg, $cb) = $color->rgba; | |
82 | unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue, $comment)) { | |
83 | print <<END_DIAG; | |
84 | Color mismatch: | |
85 | Red: $red vs $cr | |
86 | Green: $green vs $cg | |
87 | Blue: $blue vs $cb | |
88 | END_DIAG | |
89 | return; | |
90 | } | |
91 | ||
92 | return 1; | |
93 | } | |
94 | ||
95 | sub is_color_close3($$$$$$) { | |
96 | my ($color, $red, $green, $blue, $tolerance, $comment) = @_; | |
97 | ||
98 | my $builder = Test::Builder->new; | |
99 | ||
100 | unless (defined $color) { | |
101 | $builder->ok(0, $comment); | |
102 | $builder->diag("color is undef"); | |
103 | return; | |
104 | } | |
105 | unless ($color->can('rgba')) { | |
106 | $builder->ok(0, $comment); | |
107 | $builder->diag("color is not a color object"); | |
108 | return; | |
109 | } | |
110 | ||
111 | my ($cr, $cg, $cb) = $color->rgba; | |
112 | unless ($builder->ok(abs($cr - $red) <= $tolerance | |
113 | && abs($cg - $green) <= $tolerance | |
114 | && abs($cb - $blue) <= $tolerance, $comment)) { | |
115 | $builder->diag(<<END_DIAG); | |
116 | Color out of tolerance ($tolerance): | |
117 | Red: expected $red vs received $cr | |
118 | Green: expected $green vs received $cg | |
119 | Blue: expected $blue vs received $cb | |
120 | END_DIAG | |
121 | return; | |
122 | } | |
123 | ||
124 | return 1; | |
125 | } | |
126 | ||
127 | sub is_color4($$$$$$) { | |
128 | my ($color, $red, $green, $blue, $alpha, $comment) = @_; | |
129 | ||
130 | my $builder = Test::Builder->new; | |
131 | ||
132 | unless (defined $color) { | |
133 | $builder->ok(0, $comment); | |
134 | $builder->diag("color is undef"); | |
135 | return; | |
136 | } | |
137 | unless ($color->can('rgba')) { | |
138 | $builder->ok(0, $comment); | |
139 | $builder->diag("color is not a color object"); | |
140 | return; | |
141 | } | |
142 | ||
143 | my ($cr, $cg, $cb, $ca) = $color->rgba; | |
144 | unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue | |
145 | && $ca == $alpha, $comment)) { | |
146 | $builder->diag(<<END_DIAG); | |
147 | Color mismatch: | |
148 | Red: $cr vs $red | |
149 | Green: $cg vs $green | |
150 | Blue: $cb vs $blue | |
151 | Alpha: $ca vs $alpha | |
152 | END_DIAG | |
153 | return; | |
154 | } | |
155 | ||
156 | return 1; | |
157 | } | |
158 | ||
159 | sub is_fcolor4($$$$$$;$) { | |
160 | my ($color, $red, $green, $blue, $alpha, $comment_or_diff, $comment_or_undef) = @_; | |
161 | my ($comment, $mindiff); | |
162 | if (defined $comment_or_undef) { | |
163 | ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef ) | |
164 | } | |
165 | else { | |
166 | ( $mindiff, $comment ) = ( 0.001, $comment_or_diff ) | |
167 | } | |
168 | ||
169 | my $builder = Test::Builder->new; | |
170 | ||
171 | unless (defined $color) { | |
172 | $builder->ok(0, $comment); | |
173 | $builder->diag("color is undef"); | |
174 | return; | |
175 | } | |
176 | unless ($color->can('rgba')) { | |
177 | $builder->ok(0, $comment); | |
178 | $builder->diag("color is not a color object"); | |
179 | return; | |
180 | } | |
181 | ||
182 | my ($cr, $cg, $cb, $ca) = $color->rgba; | |
183 | unless ($builder->ok(abs($cr - $red) <= $mindiff | |
184 | && abs($cg - $green) <= $mindiff | |
185 | && abs($cb - $blue) <= $mindiff | |
186 | && abs($ca - $alpha) <= $mindiff, $comment)) { | |
187 | $builder->diag(<<END_DIAG); | |
188 | Color mismatch: | |
189 | Red: $cr vs $red | |
190 | Green: $cg vs $green | |
191 | Blue: $cb vs $blue | |
192 | Alpha: $ca vs $alpha | |
193 | END_DIAG | |
194 | return; | |
195 | } | |
196 | ||
197 | return 1; | |
198 | } | |
199 | ||
200 | sub is_fcolor1($$$;$) { | |
201 | my ($color, $grey, $comment_or_diff, $comment_or_undef) = @_; | |
202 | my ($comment, $mindiff); | |
203 | if (defined $comment_or_undef) { | |
204 | ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef ) | |
205 | } | |
206 | else { | |
207 | ( $mindiff, $comment ) = ( 0.001, $comment_or_diff ) | |
208 | } | |
209 | ||
210 | my $builder = Test::Builder->new; | |
211 | ||
212 | unless (defined $color) { | |
213 | $builder->ok(0, $comment); | |
214 | $builder->diag("color is undef"); | |
215 | return; | |
216 | } | |
217 | unless ($color->can('rgba')) { | |
218 | $builder->ok(0, $comment); | |
219 | $builder->diag("color is not a color object"); | |
220 | return; | |
221 | } | |
222 | ||
223 | my ($cgrey) = $color->rgba; | |
224 | unless ($builder->ok(abs($cgrey - $grey) <= $mindiff, $comment)) { | |
225 | print <<END_DIAG; | |
226 | Color mismatch: | |
227 | Gray: $cgrey vs $grey | |
228 | END_DIAG | |
229 | return; | |
230 | } | |
231 | ||
232 | return 1; | |
233 | } | |
234 | ||
235 | sub is_fcolor3($$$$$;$) { | |
236 | my ($color, $red, $green, $blue, $comment_or_diff, $comment_or_undef) = @_; | |
237 | my ($comment, $mindiff); | |
238 | if (defined $comment_or_undef) { | |
239 | ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef ) | |
240 | } | |
241 | else { | |
242 | ( $mindiff, $comment ) = ( 0.001, $comment_or_diff ) | |
243 | } | |
244 | ||
245 | my $builder = Test::Builder->new; | |
246 | ||
247 | unless (defined $color) { | |
248 | $builder->ok(0, $comment); | |
249 | $builder->diag("color is undef"); | |
250 | return; | |
251 | } | |
252 | unless ($color->can('rgba')) { | |
253 | $builder->ok(0, $comment); | |
254 | $builder->diag("color is not a color object"); | |
255 | return; | |
256 | } | |
257 | ||
258 | my ($cr, $cg, $cb) = $color->rgba; | |
259 | unless ($builder->ok(abs($cr - $red) <= $mindiff | |
260 | && abs($cg - $green) <= $mindiff | |
261 | && abs($cb - $blue) <= $mindiff, $comment)) { | |
262 | $builder->diag(<<END_DIAG); | |
263 | Color mismatch: | |
264 | Red: $cr vs $red | |
265 | Green: $cg vs $green | |
266 | Blue: $cb vs $blue | |
267 | END_DIAG | |
268 | return; | |
269 | } | |
270 | ||
271 | return 1; | |
272 | } | |
273 | ||
274 | sub is_color1($$$) { | |
275 | my ($color, $grey, $comment) = @_; | |
276 | ||
277 | my $builder = Test::Builder->new; | |
278 | ||
279 | unless (defined $color) { | |
280 | $builder->ok(0, $comment); | |
281 | $builder->diag("color is undef"); | |
282 | return; | |
283 | } | |
284 | unless ($color->can('rgba')) { | |
285 | $builder->ok(0, $comment); | |
286 | $builder->diag("color is not a color object"); | |
287 | return; | |
288 | } | |
289 | ||
290 | my ($cgrey) = $color->rgba; | |
291 | unless ($builder->ok($cgrey == $grey, $comment)) { | |
292 | $builder->diag(<<END_DIAG); | |
293 | Color mismatch: | |
294 | Grey: $grey vs $cgrey | |
295 | END_DIAG | |
296 | return; | |
297 | } | |
298 | ||
299 | return 1; | |
300 | } | |
301 | ||
302 | sub test_image_raw { | |
303 | my $green=Imager::i_color_new(0,255,0,255); | |
304 | my $blue=Imager::i_color_new(0,0,255,255); | |
305 | my $red=Imager::i_color_new(255,0,0,255); | |
306 | ||
307 | my $img=Imager::ImgRaw::new(150,150,3); | |
308 | ||
309 | Imager::i_box_filled($img,70,25,130,125,$green); | |
310 | Imager::i_box_filled($img,20,25,80,125,$blue); | |
311 | Imager::i_arc($img,75,75,30,0,361,$red); | |
312 | Imager::i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]); | |
313 | ||
314 | $img; | |
315 | } | |
316 | ||
317 | sub test_image { | |
318 | my $green = Imager::Color->new(0, 255, 0, 255); | |
319 | my $blue = Imager::Color->new(0, 0, 255, 255); | |
320 | my $red = Imager::Color->new(255, 0, 0, 255); | |
321 | my $img = Imager->new(xsize => 150, ysize => 150); | |
322 | $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]); | |
323 | $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]); | |
324 | $img->arc(x => 75, y => 75, r => 30, color => $red); | |
325 | $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]); | |
326 | ||
327 | $img; | |
328 | } | |
329 | ||
330 | sub test_image_16 { | |
331 | my $green = Imager::Color->new(0, 255, 0, 255); | |
332 | my $blue = Imager::Color->new(0, 0, 255, 255); | |
333 | my $red = Imager::Color->new(255, 0, 0, 255); | |
334 | my $img = Imager->new(xsize => 150, ysize => 150, bits => 16); | |
335 | $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]); | |
336 | $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]); | |
337 | $img->arc(x => 75, y => 75, r => 30, color => $red); | |
338 | $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]); | |
339 | ||
340 | $img; | |
341 | } | |
342 | ||
343 | sub test_image_double { | |
344 | my $green = Imager::Color->new(0, 255, 0, 255); | |
345 | my $blue = Imager::Color->new(0, 0, 255, 255); | |
346 | my $red = Imager::Color->new(255, 0, 0, 255); | |
347 | my $img = Imager->new(xsize => 150, ysize => 150, bits => 'double'); | |
348 | $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]); | |
349 | $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]); | |
350 | $img->arc(x => 75, y => 75, r => 30, color => $red); | |
351 | $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]); | |
352 | ||
353 | $img; | |
354 | } | |
355 | ||
356 | sub test_image_gray { | |
357 | my $g50 = Imager::Color->new(128, 128, 128); | |
358 | my $g30 = Imager::Color->new(76, 76, 76); | |
359 | my $g70 = Imager::Color->new(178, 178, 178); | |
360 | my $img = Imager->new(xsize => 150, ysize => 150, channels => 1); | |
361 | $img->box(filled => 1, color => $g50, box => [ 70, 24, 130, 124 ]); | |
362 | $img->box(filled => 1, color => $g30, box => [ 20, 26, 80, 126 ]); | |
363 | $img->arc(x => 75, y => 75, r => 30, color => $g70); | |
364 | $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]); | |
365 | ||
366 | return $img; | |
367 | } | |
368 | ||
369 | sub test_image_gray_16 { | |
370 | my $g50 = Imager::Color->new(128, 128, 128); | |
371 | my $g30 = Imager::Color->new(76, 76, 76); | |
372 | my $g70 = Imager::Color->new(178, 178, 178); | |
373 | my $img = Imager->new(xsize => 150, ysize => 150, channels => 1, bits => 16); | |
374 | $img->box(filled => 1, color => $g50, box => [ 70, 24, 130, 124 ]); | |
375 | $img->box(filled => 1, color => $g30, box => [ 20, 26, 80, 126 ]); | |
376 | $img->arc(x => 75, y => 75, r => 30, color => $g70); | |
377 | $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]); | |
378 | ||
379 | return $img; | |
380 | } | |
381 | ||
382 | sub test_image_mono { | |
383 | require Imager::Fill; | |
384 | my $fh = Imager::Fill->new(hatch => 'check1x1'); | |
385 | my $img = Imager->new(xsize => 150, ysize => 150, type => "paletted"); | |
386 | my $black = Imager::Color->new(0, 0, 0); | |
387 | my $white = Imager::Color->new(255, 255, 255); | |
388 | $img->addcolors(colors => [ $black, $white ]); | |
389 | $img->box(fill => $fh, box => [ 70, 24, 130, 124 ]); | |
390 | $img->box(filled => 1, color => $white, box => [ 20, 26, 80, 126 ]); | |
391 | $img->arc(x => 75, y => 75, r => 30, color => $black, aa => 0); | |
392 | ||
393 | return $img; | |
394 | } | |
395 | ||
396 | my %name_to_sub = | |
397 | ( | |
398 | basic => \&test_image, | |
399 | basic16 => \&test_image_16, | |
400 | basic_double => \&test_image_double, | |
401 | gray => \&test_image_gray, | |
402 | gray16 => \&test_image_gray_16, | |
403 | mono => \&test_image_mono, | |
404 | ); | |
405 | ||
406 | sub test_image_named { | |
407 | my $name = shift | |
408 | or croak("No name supplied to test_image_named()"); | |
409 | my $sub = $name_to_sub{$name} | |
410 | or croak("Unknown name $name supplied to test_image_named()"); | |
411 | ||
412 | return $sub->(); | |
413 | } | |
414 | ||
415 | sub _low_image_diff_check { | |
416 | my ($left, $right, $comment) = @_; | |
417 | ||
418 | my $builder = Test::Builder->new; | |
419 | ||
420 | unless (defined $left) { | |
421 | $builder->ok(0, $comment); | |
422 | $builder->diag("left is undef"); | |
423 | return; | |
424 | } | |
425 | unless (defined $right) { | |
426 | $builder->ok(0, $comment); | |
427 | $builder->diag("right is undef"); | |
428 | return; | |
429 | } | |
430 | unless ($left->{IMG}) { | |
431 | $builder->ok(0, $comment); | |
432 | $builder->diag("left image has no low level object"); | |
433 | return; | |
434 | } | |
435 | unless ($right->{IMG}) { | |
436 | $builder->ok(0, $comment); | |
437 | $builder->diag("right image has no low level object"); | |
438 | return; | |
439 | } | |
440 | unless ($left->getwidth == $right->getwidth) { | |
441 | $builder->ok(0, $comment); | |
442 | $builder->diag("left width " . $left->getwidth . " vs right width " | |
443 | . $right->getwidth); | |
444 | return; | |
445 | } | |
446 | unless ($left->getheight == $right->getheight) { | |
447 | $builder->ok(0, $comment); | |
448 | $builder->diag("left height " . $left->getheight . " vs right height " | |
449 | . $right->getheight); | |
450 | return; | |
451 | } | |
452 | unless ($left->getchannels == $right->getchannels) { | |
453 | $builder->ok(0, $comment); | |
454 | $builder->diag("left channels " . $left->getchannels . " vs right channels " | |
455 | . $right->getchannels); | |
456 | return; | |
457 | } | |
458 | ||
459 | return 1; | |
460 | } | |
461 | ||
462 | sub is_image_similar($$$$) { | |
463 | my ($left, $right, $limit, $comment) = @_; | |
464 | ||
465 | { | |
466 | local $Test::Builder::Level = $Test::Builder::Level + 1; | |
467 | ||
468 | _low_image_diff_check($left, $right, $comment) | |
469 | or return; | |
470 | } | |
471 | ||
472 | my $builder = Test::Builder->new; | |
473 | ||
474 | my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG}); | |
475 | if ($diff > $limit) { | |
476 | $builder->ok(0, $comment); | |
477 | $builder->diag("image data difference > $limit - $diff"); | |
478 | ||
479 | if ($limit == 0) { | |
480 | # find the first mismatch | |
481 | PIXELS: | |
482 | for my $y (0 .. $left->getheight()-1) { | |
483 | for my $x (0.. $left->getwidth()-1) { | |
484 | my @lsamples = $left->getsamples(x => $x, y => $y, width => 1); | |
485 | my @rsamples = $right->getsamples(x => $x, y => $y, width => 1); | |
486 | if ("@lsamples" ne "@rsamples") { | |
487 | $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples"); | |
488 | last PIXELS; | |
489 | } | |
490 | } | |
491 | } | |
492 | } | |
493 | ||
494 | return; | |
495 | } | |
496 | ||
497 | return $builder->ok(1, $comment); | |
498 | } | |
499 | ||
500 | sub is_image($$$) { | |
501 | my ($left, $right, $comment) = @_; | |
502 | ||
503 | local $Test::Builder::Level = $Test::Builder::Level + 1; | |
504 | ||
505 | return is_image_similar($left, $right, 0, $comment); | |
506 | } | |
507 | ||
508 | sub is_imaged($$$;$) { | |
509 | my $epsilon = Imager::i_img_epsilonf(); | |
510 | if (@_ > 3) { | |
511 | ($epsilon) = splice @_, 2, 1; | |
512 | } | |
513 | ||
514 | my ($left, $right, $comment) = @_; | |
515 | ||
516 | { | |
517 | local $Test::Builder::Level = $Test::Builder::Level + 1; | |
518 | ||
519 | _low_image_diff_check($left, $right, $comment) | |
520 | or return; | |
521 | } | |
522 | ||
523 | my $builder = Test::Builder->new; | |
524 | ||
525 | my $same = Imager::i_img_samef($left->{IMG}, $right->{IMG}, $epsilon, $comment); | |
526 | if (!$same) { | |
527 | $builder->ok(0, $comment); | |
528 | $builder->diag("images different"); | |
529 | ||
530 | # find the first mismatch | |
531 | PIXELS: | |
532 | for my $y (0 .. $left->getheight()-1) { | |
533 | for my $x (0.. $left->getwidth()-1) { | |
534 | my @lsamples = $left->getsamples(x => $x, y => $y, width => 1, type => "float"); | |
535 | my @rsamples = $right->getsamples(x => $x, y => $y, width => 1, type => "float"); | |
536 | if ("@lsamples" ne "@rsamples") { | |
537 | $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples"); | |
538 | last PIXELS; | |
539 | } | |
540 | } | |
541 | } | |
542 | ||
543 | return; | |
544 | } | |
545 | ||
546 | return $builder->ok(1, $comment); | |
547 | } | |
548 | ||
549 | sub isnt_image { | |
550 | my ($left, $right, $comment) = @_; | |
551 | ||
552 | my $builder = Test::Builder->new; | |
553 | ||
554 | my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG}); | |
555 | ||
556 | return $builder->ok($diff, "$comment"); | |
557 | } | |
558 | ||
559 | sub image_bounds_checks { | |
560 | my $im = shift; | |
561 | ||
562 | my $builder = Test::Builder->new; | |
563 | ||
564 | $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0)'); | |
565 | $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0)'); | |
566 | $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1)'); | |
567 | $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10)'); | |
568 | $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0) float'); | |
569 | $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0) float'); | |
570 | $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1) float'); | |
571 | $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10) float'); | |
572 | my $black = Imager::Color->new(0, 0, 0); | |
573 | require Imager::Color::Float; | |
574 | my $blackf = Imager::Color::Float->new(0, 0, 0); | |
575 | $builder->ok(!$im->setpixel(x => -1, y => 0, color => $black), 'bounds check set (-1, 0)'); | |
576 | $builder->ok(!$im->setpixel(x => 10, y => 0, color => $black), 'bounds check set (10, 0)'); | |
577 | $builder->ok(!$im->setpixel(x => 0, y => -1, color => $black), 'bounds check set (0, -1)'); | |
578 | $builder->ok(!$im->setpixel(x => 0, y => 10, color => $black), 'bounds check set (0, 10)'); | |
579 | $builder->ok(!$im->setpixel(x => -1, y => 0, color => $blackf), 'bounds check set (-1, 0) float'); | |
580 | $builder->ok(!$im->setpixel(x => 10, y => 0, color => $blackf), 'bounds check set (10, 0) float'); | |
581 | $builder->ok(!$im->setpixel(x => 0, y => -1, color => $blackf), 'bounds check set (0, -1) float'); | |
582 | $builder->ok(!$im->setpixel(x => 0, y => 10, color => $blackf), 'bounds check set (0, 10) float'); | |
583 | } | |
584 | ||
585 | sub test_colorf_gpix { | |
586 | my ($im, $x, $y, $expected, $epsilon, $comment) = @_; | |
587 | ||
588 | my $builder = Test::Builder->new; | |
589 | ||
590 | defined $comment or $comment = ''; | |
591 | ||
592 | my $c = Imager::i_gpixf($im, $x, $y); | |
593 | unless ($c) { | |
594 | $builder->ok(0, "$comment - retrieve color at ($x,$y)"); | |
595 | return; | |
596 | } | |
597 | unless ($builder->ok(colorf_cmp($c, $expected, $epsilon) == 0, | |
598 | "$comment - got right color ($x, $y)")) { | |
599 | my @c = $c->rgba; | |
600 | my @exp = $expected->rgba; | |
601 | $builder->diag(<<EOS); | |
602 | # got: ($c[0], $c[1], $c[2]) | |
603 | # expected: ($exp[0], $exp[1], $exp[2]) | |
604 | EOS | |
605 | } | |
606 | 1; | |
607 | } | |
608 | ||
609 | sub test_color_gpix { | |
610 | my ($im, $x, $y, $expected, $comment) = @_; | |
611 | ||
612 | my $builder = Test::Builder->new; | |
613 | ||
614 | defined $comment or $comment = ''; | |
615 | my $c = Imager::i_get_pixel($im, $x, $y); | |
616 | unless ($c) { | |
617 | $builder->ok(0, "$comment - retrieve color at ($x,$y)"); | |
618 | return; | |
619 | } | |
620 | unless ($builder->ok(color_cmp($c, $expected) == 0, | |
621 | "got right color ($x, $y)")) { | |
622 | my @c = $c->rgba; | |
623 | my @exp = $expected->rgba; | |
624 | $builder->diag(<<EOS); | |
625 | # got: ($c[0], $c[1], $c[2]) | |
626 | # expected: ($exp[0], $exp[1], $exp[2]) | |
627 | EOS | |
628 | return; | |
629 | } | |
630 | ||
631 | return 1; | |
632 | } | |
633 | ||
634 | sub test_colorf_glin { | |
635 | my ($im, $x, $y, $pels, $comment) = @_; | |
636 | ||
637 | my $builder = Test::Builder->new; | |
638 | ||
639 | my @got = Imager::i_glinf($im, $x, $x+@$pels, $y); | |
640 | @got == @$pels | |
641 | or return $builder->is_num(scalar(@got), scalar(@$pels), "$comment - pixels retrieved"); | |
642 | ||
643 | return $builder->ok(!grep(colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got), | |
644 | "$comment - check colors ($x, $y)"); | |
645 | } | |
646 | ||
647 | sub colorf_cmp { | |
648 | my ($c1, $c2, $epsilon) = @_; | |
649 | ||
650 | defined $epsilon or $epsilon = 0; | |
651 | ||
652 | my @s1 = $c1->rgba; | |
653 | my @s2 = $c2->rgba; | |
654 | ||
655 | # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n"; | |
656 | return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0] | |
657 | || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1] | |
658 | || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2]; | |
659 | } | |
660 | ||
661 | sub color_cmp { | |
662 | my ($c1, $c2) = @_; | |
663 | ||
664 | my @s1 = $c1->rgba; | |
665 | my @s2 = $c2->rgba; | |
666 | ||
667 | return $s1[0] <=> $s2[0] | |
668 | || $s1[1] <=> $s2[1] | |
669 | || $s1[2] <=> $s2[2]; | |
670 | } | |
671 | ||
672 | # these test the action of the channel mask on the image supplied | |
673 | # which should be an OO image. | |
674 | sub mask_tests { | |
675 | my ($im, $epsilon) = @_; | |
676 | ||
677 | my $builder = Test::Builder->new; | |
678 | ||
679 | defined $epsilon or $epsilon = 0; | |
680 | ||
681 | # we want to check all four of ppix() and plin(), ppix() and plinf() | |
682 | # basic test procedure: | |
683 | # first using default/all 1s mask, set to white | |
684 | # make sure we got white | |
685 | # set mask to skip a channel, set to grey | |
686 | # make sure only the right channels set | |
687 | ||
688 | print "# channel mask tests\n"; | |
689 | # 8-bit color tests | |
690 | my $white = Imager::NC(255, 255, 255); | |
691 | my $grey = Imager::NC(128, 128, 128); | |
692 | my $white_grey = Imager::NC(128, 255, 128); | |
693 | ||
694 | print "# with ppix\n"; | |
695 | $builder->ok($im->setmask(mask=>~0), "set to default mask"); | |
696 | $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels"); | |
697 | test_color_gpix($im->{IMG}, 0, 0, $white, "ppix"); | |
698 | $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1"); | |
699 | $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2"); | |
700 | test_color_gpix($im->{IMG}, 0, 0, $white_grey, "ppix masked"); | |
701 | ||
702 | print "# with plin\n"; | |
703 | $builder->ok($im->setmask(mask=>~0), "set to default mask"); | |
704 | $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]), | |
705 | "set to white all channels"); | |
706 | test_color_gpix($im->{IMG}, 0, 1, $white, "plin"); | |
707 | $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1"); | |
708 | $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]), | |
709 | "set to grey, no channel 2"); | |
710 | test_color_gpix($im->{IMG}, 0, 1, $white_grey, "plin masked"); | |
711 | ||
712 | # float color tests | |
713 | my $whitef = Imager::NCF(1.0, 1.0, 1.0); | |
714 | my $greyf = Imager::NCF(0.5, 0.5, 0.5); | |
715 | my $white_greyf = Imager::NCF(0.5, 1.0, 0.5); | |
716 | ||
717 | print "# with ppixf\n"; | |
718 | $builder->ok($im->setmask(mask=>~0), "set to default mask"); | |
719 | $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels"); | |
720 | test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon, "ppixf"); | |
721 | $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1"); | |
722 | $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2"); | |
723 | test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon, "ppixf masked"); | |
724 | ||
725 | print "# with plinf\n"; | |
726 | $builder->ok($im->setmask(mask=>~0), "set to default mask"); | |
727 | $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]), | |
728 | "set to white all channels"); | |
729 | test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon, "plinf"); | |
730 | $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1"); | |
731 | $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]), | |
732 | "set to grey, no channel 2"); | |
733 | test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon, "plinf masked"); | |
734 | ||
735 | } | |
736 | ||
737 | sub std_font_test_count { | |
738 | return 21; | |
739 | } | |
740 | ||
741 | sub std_font_tests { | |
742 | my ($opts) = @_; | |
743 | ||
744 | my $font = $opts->{font} | |
745 | or carp "Missing font parameter"; | |
746 | ||
747 | my $name_font = $opts->{glyph_name_font} || $font; | |
748 | ||
749 | my $has_chars = $opts->{has_chars} || [ 1, '', 1 ]; | |
750 | ||
751 | my $glyph_names = $opts->{glyph_names} || [ "A", undef, "A" ]; | |
752 | ||
753 | SKIP: | |
754 | { # check magic is handled correctly | |
755 | # https://rt.cpan.org/Ticket/Display.html?id=83438 | |
756 | skip("no native UTF8 support in this version of perl", 10) | |
757 | unless $] >= 5.006; | |
758 | Imager->log("utf8 magic tests\n"); | |
759 | my $over = bless {}, "Imager::Test::OverUtf8"; | |
760 | my $text = "A".chr(0x2010)."A"; | |
761 | my $white = Imager::Color->new("#FFF"); | |
762 | my $base_draw = Imager->new(xsize => 80, ysize => 20); | |
763 | ok($base_draw->string(font => $font, | |
764 | text => $text, | |
765 | x => 2, | |
766 | y => 18, | |
767 | size => 15, | |
768 | color => $white, | |
769 | aa => 1), | |
770 | "magic: make a base image"); | |
771 | my $test_draw = Imager->new(xsize => 80, ysize => 20); | |
772 | ok($test_draw->string(font => $font, | |
773 | text => $over, | |
774 | x => 2, | |
775 | y => 18, | |
776 | size => 15, | |
777 | color => $white, | |
778 | aa => 1), | |
779 | "magic: draw with overload"); | |
780 | is_image($base_draw, $test_draw, "check they match"); | |
781 | if ($opts->{files}) { | |
782 | $test_draw->write(file => "testout/utf8tdr.ppm"); | |
783 | $base_draw->write(file => "testout/utf8bdr.ppm"); | |
784 | } | |
785 | ||
786 | my $base_cp = Imager->new(xsize => 80, ysize => 20); | |
787 | $base_cp->box(filled => 1, color => "#808080"); | |
788 | my $test_cp = $base_cp->copy; | |
789 | ok($base_cp->string(font => $font, | |
790 | text => $text, | |
791 | y => 2, | |
792 | y => 18, | |
793 | size => 16, | |
794 | channel => 2, | |
795 | aa => 1), | |
796 | "magic: make a base image (channel)"); | |
797 | Imager->log("magic: draw to channel with overload\n"); | |
798 | ok($test_cp->string(font => $font, | |
799 | text => $over, | |
800 | y => 2, | |
801 | y => 18, | |
802 | size => 16, | |
803 | channel => 2, | |
804 | aa => 1), | |
805 | "magic: draw with overload (channel)"); | |
806 | is_image($test_cp, $base_cp, "check they match"); | |
807 | if ($opts->{files}) { | |
808 | $test_cp->write(file => "testout/utf8tcp.ppm"); | |
809 | $base_cp->write(file => "testout/utf8bcp.ppm"); | |
810 | } | |
811 | ||
812 | Imager->log("magic: has_chars"); | |
813 | is_deeply([ $font->has_chars(string => $text) ], $has_chars, | |
814 | "magic: has_chars with normal utf8 text"); | |
815 | is_deeply([ $font->has_chars(string => $over) ], $has_chars, | |
816 | "magic: has_chars with magic utf8 text"); | |
817 | ||
818 | Imager->log("magic: bounding_box\n"); | |
819 | my @base_bb = $font->bounding_box(string => $text, size => 30); | |
820 | is_deeply([ $font->bounding_box(string => $over, size => 30) ], | |
821 | \@base_bb, | |
822 | "check bounding box magic"); | |
823 | ||
824 | SKIP: | |
825 | { | |
826 | $font->can_glyph_names | |
827 | or skip "No glyph_names", 2; | |
828 | Imager->log("magic: glyph_names\n"); | |
829 | my @text_names = $name_font->glyph_names(string => $text, reliable_only => 0); | |
830 | is_deeply(\@text_names, $glyph_names, | |
831 | "magic: glyph_names with normal utf8 text"); | |
832 | my @over_names = $name_font->glyph_names(string => $over, reliable_only => 0); | |
833 | is_deeply(\@over_names, $glyph_names, | |
834 | "magic: glyph_names with magic utf8 text"); | |
835 | } | |
836 | } | |
837 | ||
838 | { # invalid UTF8 handling at the OO level | |
839 | my $im = Imager->new(xsize => 80, ysize => 20); | |
840 | my $bad_utf8 = pack("C", 0xC0); | |
841 | Imager->_set_error(""); | |
842 | ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1, | |
843 | y => 18, x => 2), | |
844 | "drawing invalid utf8 should fail"); | |
845 | is($im->errstr, "invalid UTF8 character", "check error message"); | |
846 | Imager->_set_error(""); | |
847 | ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1, | |
848 | y => 18, x => 2, channel => 1), | |
849 | "drawing invalid utf8 should fail (channel)"); | |
850 | is($im->errstr, "invalid UTF8 character", "check error message"); | |
851 | Imager->_set_error(""); | |
852 | ok(!$font->bounding_box(string => $bad_utf8, size => 30, utf8 => 1), | |
853 | "bounding_box() bad utf8 should fail"); | |
854 | is(Imager->errstr, "invalid UTF8 character", "check error message"); | |
855 | Imager->_set_error(""); | |
856 | is_deeply([ $font->glyph_names(string => $bad_utf8, utf8 => 1) ], | |
857 | [ ], | |
858 | "glyph_names returns empty list for bad string"); | |
859 | is(Imager->errstr, "invalid UTF8 character", "check error message"); | |
860 | Imager->_set_error(""); | |
861 | is_deeply([ $font->has_chars(string => $bad_utf8, utf8 => 1) ], | |
862 | [ ], | |
863 | "has_chars returns empty list for bad string"); | |
864 | is(Imager->errstr, "invalid UTF8 character", "check error message"); | |
865 | } | |
866 | } | |
867 | ||
868 | package Imager::Test::OverUtf8; | |
869 | use overload '""' => sub { "A".chr(0x2010)."A" }; | |
870 | ||
871 | ||
872 | 1; | |
873 | ||
874 | __END__ | |
875 | ||
876 | =head1 NAME | |
877 | ||
878 | Imager::Test - common functions used in testing Imager | |
879 | ||
880 | =head1 SYNOPSIS | |
881 | ||
882 | use Imager::Test 'diff_text_with_nul'; | |
883 | diff_text_with_nul($test_name, $text1, $text2, @string_options); | |
884 | ||
885 | =head1 DESCRIPTION | |
886 | ||
887 | This is a repository of functions used in testing Imager. | |
888 | ||
889 | Some functions will only be useful in testing Imager itself, while | |
890 | others should be useful in testing modules that use Imager. | |
891 | ||
892 | No functions are exported by default. | |
893 | ||
894 | =head1 FUNCTIONS | |
895 | ||
896 | =head2 Test functions | |
897 | ||
898 | =for stopwords OO | |
899 | ||
900 | =over | |
901 | ||
902 | =item is_color1($color, $grey, $comment) | |
903 | ||
904 | Tests if the first channel of $color matches $grey. | |
905 | ||
906 | =item is_color3($color, $red, $green, $blue, $comment) | |
907 | ||
908 | Tests if $color matches the given ($red, $green, $blue) | |
909 | ||
910 | =item is_color4($color, $red, $green, $blue, $alpha, $comment) | |
911 | ||
912 | Tests if $color matches the given ($red, $green, $blue, $alpha) | |
913 | ||
914 | =item is_fcolor1($fcolor, $grey, $comment) | |
915 | ||
916 | =item is_fcolor1($fcolor, $grey, $epsilon, $comment) | |
917 | ||
918 | Tests if $fcolor's first channel is within $epsilon of ($grey). For | |
919 | the first form $epsilon is taken as 0.001. | |
920 | ||
921 | =item is_fcolor3($fcolor, $red, $green, $blue, $comment) | |
922 | ||
923 | =item is_fcolor3($fcolor, $red, $green, $blue, $epsilon, $comment) | |
924 | ||
925 | Tests if $fcolor's channels are within $epsilon of ($red, $green, | |
926 | $blue). For the first form $epsilon is taken as 0.001. | |
927 | ||
928 | =item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $comment) | |
929 | ||
930 | =item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $epsilon, $comment) | |
931 | ||
932 | Tests if $fcolor's channels are within $epsilon of ($red, $green, | |
933 | $blue, $alpha). For the first form $epsilon is taken as 0.001. | |
934 | ||
935 | =item is_image($im1, $im2, $comment) | |
936 | ||
937 | Tests if the 2 images have the same content. Both images must be | |
938 | defined, have the same width, height, channels and the same color in | |
939 | each pixel. The color comparison is done at 8-bits per pixel. The | |
940 | color representation such as direct vs paletted, bits per sample are | |
941 | not checked. Equivalent to is_image_similar($im1, $im2, 0, $comment). | |
942 | ||
943 | =item is_imaged($im, $im2, $comment) | |
944 | ||
945 | =item is_imaged($im, $im2, $epsilon, $comment) | |
946 | ||
947 | Tests if the two images have the same content at the double/sample | |
948 | level. C<$epsilon> defaults to the platform DBL_EPSILON multiplied by | |
949 | four. | |
950 | ||
951 | =item is_image_similar($im1, $im2, $maxdiff, $comment) | |
952 | ||
953 | Tests if the 2 images have similar content. Both images must be | |
954 | defined, have the same width, height and channels. The cum of the | |
955 | squares of the differences of each sample are calculated and must be | |
956 | less than or equal to I<$maxdiff> for the test to pass. The color | |
957 | comparison is done at 8-bits per pixel. The color representation such | |
958 | as direct vs paletted, bits per sample are not checked. | |
959 | ||
960 | =item isnt_image($im1, $im2, $comment) | |
961 | ||
962 | Tests that the two images are different. For regressions tests where | |
963 | something (like text output of "0") produced no change, but should | |
964 | have produced a change. | |
965 | ||
966 | =item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment) | |
967 | ||
968 | Retrieves the pixel ($x,$y) from the low-level image $im and compares | |
969 | it to the floating point color $expected, with a tolerance of epsilon. | |
970 | ||
971 | =item test_color_gpix($im, $x, $y, $expected, $comment) | |
972 | ||
973 | Retrieves the pixel ($x,$y) from the low-level image $im and compares | |
974 | it to the floating point color $expected. | |
975 | ||
976 | =item test_colorf_glin($im, $x, $y, $pels, $comment) | |
977 | ||
978 | Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the | |
979 | low level image $im and compares them against @$pels. | |
980 | ||
981 | =item is_color_close3($color, $red, $green, $blue, $tolerance, $comment) | |
982 | ||
983 | Tests if $color's first three channels are within $tolerance of ($red, | |
984 | $green, $blue). | |
985 | ||
986 | =back | |
987 | ||
988 | =head2 Test suite functions | |
989 | ||
990 | Functions that perform one or more tests, typically used to test | |
991 | various parts of Imager's implementation. | |
992 | ||
993 | =over | |
994 | ||
995 | =item image_bounds_checks($im) | |
996 | ||
997 | Attempts to write to various pixel positions outside the edge of the | |
998 | image to ensure that it fails in those locations. | |
999 | ||
1000 | Any new image type should pass these tests. Does 16 separate tests. | |
1001 | ||
1002 | =item mask_tests($im, $epsilon) | |
1003 | ||
1004 | Perform a standard set of mask tests on the OO image $im. Does 24 | |
1005 | separate tests. | |
1006 | ||
1007 | =item diff_text_with_nul($test_name, $text1, $text2, @options) | |
1008 | ||
1009 | Creates 2 test images and writes $text1 to the first image and $text2 | |
1010 | to the second image with the string() method. Each call adds 3 | |
1011 | C<ok>/C<not ok> to the output of the test script. | |
1012 | ||
1013 | Extra options that should be supplied include the font and either a | |
1014 | color or channel parameter. | |
1015 | ||
1016 | This was explicitly created for regression tests on #21770. | |
1017 | ||
1018 | =item std_font_tests({ font => $font }) | |
1019 | ||
1020 | Perform standard font interface tests. | |
1021 | ||
1022 | =item std_font_test_count() | |
1023 | ||
1024 | The number of tests performed by std_font_tests(). | |
1025 | ||
1026 | =back | |
1027 | ||
1028 | =head2 Helper functions | |
1029 | ||
1030 | =over | |
1031 | ||
1032 | =item test_image_raw() | |
1033 | ||
1034 | Returns a 150x150x3 Imager::ImgRaw test image. | |
1035 | ||
1036 | =item test_image() | |
1037 | ||
1038 | Returns a 150x150x3 8-bit/sample OO test image. Name: C<basic>. | |
1039 | ||
1040 | =item test_image_16() | |
1041 | ||
1042 | Returns a 150x150x3 16-bit/sample OO test image. Name: C<basic16> | |
1043 | ||
1044 | =item test_image_double() | |
1045 | ||
1046 | Returns a 150x150x3 double/sample OO test image. Name: C<basic_double>. | |
1047 | ||
1048 | =item test_image_gray() | |
1049 | ||
1050 | Returns a 150x150 single channel OO test image. Name: C<gray>. | |
1051 | ||
1052 | =item test_image_gray_16() | |
1053 | ||
1054 | Returns a 150x150 16-bit/sample single channel OO test image. Name: | |
1055 | C<gray16>. | |
1056 | ||
1057 | =item test_image_mono() | |
1058 | ||
1059 | Returns a 150x150 bilevel image that passes the is_bilevel() test. | |
1060 | Name: C<mono>. | |
1061 | ||
1062 | =item test_image_named($name) | |
1063 | ||
1064 | Return one of the other test images above based on name. | |
1065 | ||
1066 | =item color_cmp($c1, $c2) | |
1067 | ||
1068 | Performs an ordering of 3-channel colors (like <=>). | |
1069 | ||
1070 | =item colorf_cmp($c1, $c2) | |
1071 | ||
1072 | Performs an ordering of 3-channel floating point colors (like <=>). | |
1073 | ||
1074 | =back | |
1075 | ||
1076 | =head1 AUTHOR | |
1077 | ||
1078 | Tony Cook <tony@develop-help.com> | |
1079 | ||
1080 | =cut |