fix an embarassing typo
[imager.git] / lib / Imager / Test.pm
CommitLineData
9a6ab99c
TC
1package Imager::Test;
2use strict;
76ae98a6 3use Test::More;
9a6ab99c
TC
4use Test::Builder;
5require Exporter;
5715f7c3 6use vars qw(@ISA @EXPORT_OK $VERSION);
76ae98a6 7use Carp qw(croak carp);
ac594e50 8use Config;
5715f7c3 9
47e4b7d1 10$VERSION = "1.004";
5715f7c3 11
9a6ab99c 12@ISA = qw(Exporter);
8927ff88
TC
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
a7e32beb
TC
20 test_image_mono
21 test_image_gray
22 test_image_gray_16
23 test_image_named
8927ff88
TC
24 is_color1
25 is_color3
26 is_color4
27 is_color_close3
62869327 28 is_fcolor1
0aae8858 29 is_fcolor3
8927ff88
TC
30 is_fcolor4
31 color_cmp
32 is_image
e41cfe8f 33 is_imaged
5cfde30f
TC
34 is_image_similar
35 isnt_image
8927ff88
TC
36 image_bounds_checks
37 mask_tests
38 test_colorf_gpix
39 test_color_gpix
ac594e50
TC
40 test_colorf_glin
41 can_test_threads
76ae98a6
TC
42 std_font_tests
43 std_font_test_count
ac594e50 44 );
9a6ab99c
TC
45
46sub 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
9c106321
TC
65sub 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)) {
62869327 83 print <<END_DIAG;
9c106321
TC
84Color mismatch:
85 Red: $red vs $cr
86Green: $green vs $cg
87 Blue: $blue vs $cb
88END_DIAG
89 return;
90 }
91
92 return 1;
93}
94
6e4af7d4
TC
95sub 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);
116Color out of tolerance ($tolerance):
117 Red: expected $red vs received $cr
118Green: expected $green vs received $cg
119 Blue: expected $blue vs received $cb
120END_DIAG
121 return;
122 }
123
124 return 1;
125}
126
b3aa972f
TC
127sub 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);
147Color mismatch:
52f2b10a
TC
148 Red: $cr vs $red
149Green: $cg vs $green
150 Blue: $cb vs $blue
151Alpha: $ca vs $alpha
b3aa972f
TC
152END_DIAG
153 return;
154 }
155
156 return 1;
157}
158
159sub 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);
188Color mismatch:
52f2b10a
TC
189 Red: $cr vs $red
190Green: $cg vs $green
191 Blue: $cb vs $blue
192Alpha: $ca vs $alpha
b3aa972f
TC
193END_DIAG
194 return;
195 }
196
197 return 1;
198}
199
62869327
TC
200sub 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;
226Color mismatch:
227 Gray: $cgrey vs $grey
228END_DIAG
229 return;
230 }
231
232 return 1;
233}
234
0aae8858
TC
235sub 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);
263Color mismatch:
264 Red: $cr vs $red
265Green: $cg vs $green
266 Blue: $cb vs $blue
267END_DIAG
268 return;
269 }
270
271 return 1;
272}
273
9c106321
TC
274sub 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);
293Color mismatch:
294 Grey: $grey vs $cgrey
295END_DIAG
296 return;
297 }
298
299 return 1;
300}
301
302sub 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
167660cd
TC
317sub 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);
d5477d3d
TC
322 $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
323 $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]);
167660cd
TC
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
9c106321
TC
330sub 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);
a7e32beb
TC
335 $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
336 $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]);
9c106321
TC
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
bd8052a6
TC
343sub 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');
a7e32beb
TC
348 $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
349 $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]);
bd8052a6
TC
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
a7e32beb
TC
356sub 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
369sub 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
382sub 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
396my %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
406sub 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
e41cfe8f
TC
415sub _low_image_diff_check {
416 my ($left, $right, $comment) = @_;
9c106321
TC
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 }
e41cfe8f
TC
458
459 return 1;
460}
461
462sub 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
9c106321 474 my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
167660cd 475 if ($diff > $limit) {
9c106321 476 $builder->ok(0, $comment);
167660cd 477 $builder->diag("image data difference > $limit - $diff");
bd8052a6
TC
478
479 if ($limit == 0) {
480 # find the first mismatch
c5f447ac 481 PIXELS:
bd8052a6
TC
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");
c5f447ac 488 last PIXELS;
bd8052a6
TC
489 }
490 }
491 }
492 }
493
9c106321
TC
494 return;
495 }
496
497 return $builder->ok(1, $comment);
498}
499
167660cd
TC
500sub 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
360e674e 508sub is_imaged($$$;$) {
4498c8bd
TC
509 my $epsilon = Imager::i_img_epsilonf();
510 if (@_ > 3) {
511 ($epsilon) = splice @_, 2, 1;
512 }
513
e41cfe8f
TC
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
4498c8bd
TC
525 my $same = Imager::i_img_samef($left->{IMG}, $right->{IMG}, $epsilon, $comment);
526 if (!$same) {
e41cfe8f 527 $builder->ok(0, $comment);
4498c8bd
TC
528 $builder->diag("images different");
529
e41cfe8f
TC
530 # find the first mismatch
531 PIXELS:
532 for my $y (0 .. $left->getheight()-1) {
533 for my $x (0.. $left->getwidth()-1) {
4498c8bd
TC
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");
e41cfe8f
TC
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
5cfde30f
TC
549sub 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
837a4b43
TC
559sub 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);
5daeb11a
TC
575 $builder->ok($im->setpixel(x => -1, y => 0, color => $black) == 0,
576 'bounds check set (-1, 0)');
577 $builder->ok($im->setpixel(x => 10, y => 0, color => $black) == 0,
578 'bounds check set (10, 0)');
579 $builder->ok($im->setpixel(x => 0, y => -1, color => $black) == 0,
580 'bounds check set (0, -1)');
581 $builder->ok($im->setpixel(x => 0, y => 10, color => $black) == 0,
582 'bounds check set (0, 10)');
583 $builder->ok($im->setpixel(x => -1, y => 0, color => $blackf) == 0,
584 'bounds check set (-1, 0) float');
585 $builder->ok($im->setpixel(x => 10, y => 0, color => $blackf) == 0,
586 'bounds check set (10, 0) float');
587 $builder->ok($im->setpixel(x => 0, y => -1, color => $blackf) == 0,
588 'bounds check set (0, -1) float');
589 $builder->ok($im->setpixel(x => 0, y => 10, color => $blackf) == 0,
590 'bounds check set (0, 10) float');
837a4b43 591}
167660cd 592
bd8052a6
TC
593sub test_colorf_gpix {
594 my ($im, $x, $y, $expected, $epsilon, $comment) = @_;
595
596 my $builder = Test::Builder->new;
597
598 defined $comment or $comment = '';
599
600 my $c = Imager::i_gpixf($im, $x, $y);
601 unless ($c) {
602 $builder->ok(0, "$comment - retrieve color at ($x,$y)");
603 return;
604 }
8927ff88 605 unless ($builder->ok(colorf_cmp($c, $expected, $epsilon) == 0,
bd8052a6 606 "$comment - got right color ($x, $y)")) {
8927ff88
TC
607 my @c = $c->rgba;
608 my @exp = $expected->rgba;
609 $builder->diag(<<EOS);
610# got: ($c[0], $c[1], $c[2])
611# expected: ($exp[0], $exp[1], $exp[2])
612EOS
bd8052a6
TC
613 }
614 1;
615}
616
617sub test_color_gpix {
618 my ($im, $x, $y, $expected, $comment) = @_;
619
620 my $builder = Test::Builder->new;
621
622 defined $comment or $comment = '';
623 my $c = Imager::i_get_pixel($im, $x, $y);
624 unless ($c) {
625 $builder->ok(0, "$comment - retrieve color at ($x,$y)");
626 return;
627 }
8927ff88 628 unless ($builder->ok(color_cmp($c, $expected) == 0,
bd8052a6 629 "got right color ($x, $y)")) {
8927ff88
TC
630 my @c = $c->rgba;
631 my @exp = $expected->rgba;
632 $builder->diag(<<EOS);
633# got: ($c[0], $c[1], $c[2])
634# expected: ($exp[0], $exp[1], $exp[2])
635EOS
bd8052a6
TC
636 return;
637 }
638
639 return 1;
640}
641
642sub test_colorf_glin {
643 my ($im, $x, $y, $pels, $comment) = @_;
644
645 my $builder = Test::Builder->new;
646
647 my @got = Imager::i_glinf($im, $x, $x+@$pels, $y);
648 @got == @$pels
649 or return $builder->is_num(scalar(@got), scalar(@$pels), "$comment - pixels retrieved");
650
8927ff88 651 return $builder->ok(!grep(colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got),
bd8052a6
TC
652 "$comment - check colors ($x, $y)");
653}
654
8927ff88 655sub colorf_cmp {
bd8052a6
TC
656 my ($c1, $c2, $epsilon) = @_;
657
658 defined $epsilon or $epsilon = 0;
659
660 my @s1 = $c1->rgba;
661 my @s2 = $c2->rgba;
662
663 # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
664 return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0]
665 || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1]
666 || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
667}
668
8927ff88 669sub color_cmp {
bd8052a6
TC
670 my ($c1, $c2) = @_;
671
672 my @s1 = $c1->rgba;
673 my @s2 = $c2->rgba;
674
675 return $s1[0] <=> $s2[0]
676 || $s1[1] <=> $s2[1]
677 || $s1[2] <=> $s2[2];
678}
679
680# these test the action of the channel mask on the image supplied
681# which should be an OO image.
682sub mask_tests {
683 my ($im, $epsilon) = @_;
684
685 my $builder = Test::Builder->new;
686
687 defined $epsilon or $epsilon = 0;
688
689 # we want to check all four of ppix() and plin(), ppix() and plinf()
690 # basic test procedure:
691 # first using default/all 1s mask, set to white
692 # make sure we got white
693 # set mask to skip a channel, set to grey
694 # make sure only the right channels set
695
696 print "# channel mask tests\n";
697 # 8-bit color tests
698 my $white = Imager::NC(255, 255, 255);
699 my $grey = Imager::NC(128, 128, 128);
700 my $white_grey = Imager::NC(128, 255, 128);
701
702 print "# with ppix\n";
703 $builder->ok($im->setmask(mask=>~0), "set to default mask");
704 $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels");
705 test_color_gpix($im->{IMG}, 0, 0, $white, "ppix");
706 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
707 $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2");
708 test_color_gpix($im->{IMG}, 0, 0, $white_grey, "ppix masked");
709
710 print "# with plin\n";
711 $builder->ok($im->setmask(mask=>~0), "set to default mask");
712 $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]),
713 "set to white all channels");
714 test_color_gpix($im->{IMG}, 0, 1, $white, "plin");
715 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
716 $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]),
717 "set to grey, no channel 2");
718 test_color_gpix($im->{IMG}, 0, 1, $white_grey, "plin masked");
719
720 # float color tests
721 my $whitef = Imager::NCF(1.0, 1.0, 1.0);
722 my $greyf = Imager::NCF(0.5, 0.5, 0.5);
723 my $white_greyf = Imager::NCF(0.5, 1.0, 0.5);
724
725 print "# with ppixf\n";
726 $builder->ok($im->setmask(mask=>~0), "set to default mask");
727 $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels");
728 test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon, "ppixf");
729 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
730 $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2");
731 test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon, "ppixf masked");
732
733 print "# with plinf\n";
734 $builder->ok($im->setmask(mask=>~0), "set to default mask");
735 $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]),
736 "set to white all channels");
737 test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon, "plinf");
738 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
739 $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]),
740 "set to grey, no channel 2");
741 test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon, "plinf masked");
742
743}
744
76ae98a6
TC
745sub std_font_test_count {
746 return 21;
747}
748
749sub std_font_tests {
750 my ($opts) = @_;
751
752 my $font = $opts->{font}
753 or carp "Missing font parameter";
754
755 my $name_font = $opts->{glyph_name_font} || $font;
756
757 my $has_chars = $opts->{has_chars} || [ 1, '', 1 ];
758
759 my $glyph_names = $opts->{glyph_names} || [ "A", undef, "A" ];
760
761 SKIP:
762 { # check magic is handled correctly
763 # https://rt.cpan.org/Ticket/Display.html?id=83438
63cfb267 764 skip("no native UTF8 support in this version of perl", 11)
76ae98a6 765 unless $] >= 5.006;
63cfb267
TC
766 skip("overloading handling of magic is broken in this version of perl", 11)
767 unless $] >= 5.008;
76ae98a6
TC
768 Imager->log("utf8 magic tests\n");
769 my $over = bless {}, "Imager::Test::OverUtf8";
770 my $text = "A".chr(0x2010)."A";
771 my $white = Imager::Color->new("#FFF");
772 my $base_draw = Imager->new(xsize => 80, ysize => 20);
773 ok($base_draw->string(font => $font,
774 text => $text,
775 x => 2,
776 y => 18,
777 size => 15,
778 color => $white,
779 aa => 1),
780 "magic: make a base image");
781 my $test_draw = Imager->new(xsize => 80, ysize => 20);
782 ok($test_draw->string(font => $font,
783 text => $over,
784 x => 2,
785 y => 18,
786 size => 15,
787 color => $white,
788 aa => 1),
789 "magic: draw with overload");
790 is_image($base_draw, $test_draw, "check they match");
791 if ($opts->{files}) {
792 $test_draw->write(file => "testout/utf8tdr.ppm");
793 $base_draw->write(file => "testout/utf8bdr.ppm");
794 }
795
796 my $base_cp = Imager->new(xsize => 80, ysize => 20);
797 $base_cp->box(filled => 1, color => "#808080");
798 my $test_cp = $base_cp->copy;
799 ok($base_cp->string(font => $font,
800 text => $text,
801 y => 2,
802 y => 18,
803 size => 16,
804 channel => 2,
805 aa => 1),
806 "magic: make a base image (channel)");
807 Imager->log("magic: draw to channel with overload\n");
808 ok($test_cp->string(font => $font,
809 text => $over,
810 y => 2,
811 y => 18,
812 size => 16,
813 channel => 2,
814 aa => 1),
815 "magic: draw with overload (channel)");
816 is_image($test_cp, $base_cp, "check they match");
817 if ($opts->{files}) {
818 $test_cp->write(file => "testout/utf8tcp.ppm");
819 $base_cp->write(file => "testout/utf8bcp.ppm");
820 }
821
405c8105
TC
822 SKIP:
823 {
824 Imager->log("magic: has_chars\n");
825 $font->can("has_chars")
826 or skip "No has_chars aupport", 2;
827 is_deeply([ $font->has_chars(string => $text) ], $has_chars,
828 "magic: has_chars with normal utf8 text");
829 is_deeply([ $font->has_chars(string => $over) ], $has_chars,
830 "magic: has_chars with magic utf8 text");
831 }
76ae98a6
TC
832
833 Imager->log("magic: bounding_box\n");
834 my @base_bb = $font->bounding_box(string => $text, size => 30);
835 is_deeply([ $font->bounding_box(string => $over, size => 30) ],
836 \@base_bb,
837 "check bounding box magic");
838
839 SKIP:
840 {
841 $font->can_glyph_names
842 or skip "No glyph_names", 2;
843 Imager->log("magic: glyph_names\n");
844 my @text_names = $name_font->glyph_names(string => $text, reliable_only => 0);
845 is_deeply(\@text_names, $glyph_names,
846 "magic: glyph_names with normal utf8 text");
847 my @over_names = $name_font->glyph_names(string => $over, reliable_only => 0);
848 is_deeply(\@over_names, $glyph_names,
849 "magic: glyph_names with magic utf8 text");
850 }
851 }
852
853 { # invalid UTF8 handling at the OO level
854 my $im = Imager->new(xsize => 80, ysize => 20);
855 my $bad_utf8 = pack("C", 0xC0);
856 Imager->_set_error("");
857 ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1,
858 y => 18, x => 2),
859 "drawing invalid utf8 should fail");
860 is($im->errstr, "invalid UTF8 character", "check error message");
861 Imager->_set_error("");
862 ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1,
863 y => 18, x => 2, channel => 1),
864 "drawing invalid utf8 should fail (channel)");
865 is($im->errstr, "invalid UTF8 character", "check error message");
866 Imager->_set_error("");
867 ok(!$font->bounding_box(string => $bad_utf8, size => 30, utf8 => 1),
868 "bounding_box() bad utf8 should fail");
869 is(Imager->errstr, "invalid UTF8 character", "check error message");
405c8105
TC
870 SKIP:
871 {
872 $font->can_glyph_names
873 or skip "No glyph_names support", 2;
874 Imager->_set_error("");
875 is_deeply([ $font->glyph_names(string => $bad_utf8, utf8 => 1) ],
876 [ ],
877 "glyph_names returns empty list for bad string");
878 is(Imager->errstr, "invalid UTF8 character", "check error message");
879 }
880 SKIP:
881 {
882 $font->can("has_chars")
883 or skip "No has_chars support", 2;
884 Imager->_set_error("");
885 is_deeply([ $font->has_chars(string => $bad_utf8, utf8 => 1) ],
886 [ ],
887 "has_chars returns empty list for bad string");
888 is(Imager->errstr, "invalid UTF8 character", "check error message");
889 }
76ae98a6
TC
890 }
891}
892
893package Imager::Test::OverUtf8;
894use overload '""' => sub { "A".chr(0x2010)."A" };
895
896
9a6ab99c
TC
8971;
898
899__END__
900
901=head1 NAME
902
903Imager::Test - common functions used in testing Imager
904
905=head1 SYNOPSIS
906
907 use Imager::Test 'diff_text_with_nul';
908 diff_text_with_nul($test_name, $text1, $text2, @string_options);
909
910=head1 DESCRIPTION
911
912This is a repository of functions used in testing Imager.
913
914Some functions will only be useful in testing Imager itself, while
915others should be useful in testing modules that use Imager.
916
917No functions are exported by default.
918
919=head1 FUNCTIONS
920
0aae8858
TC
921=head2 Test functions
922
5715f7c3
TC
923=for stopwords OO
924
9a6ab99c
TC
925=over
926
0aae8858
TC
927=item is_color1($color, $grey, $comment)
928
929Tests if the first channel of $color matches $grey.
930
931=item is_color3($color, $red, $green, $blue, $comment)
932
933Tests if $color matches the given ($red, $green, $blue)
934
935=item is_color4($color, $red, $green, $blue, $alpha, $comment)
936
937Tests if $color matches the given ($red, $green, $blue, $alpha)
9c106321 938
62869327
TC
939=item is_fcolor1($fcolor, $grey, $comment)
940
941=item is_fcolor1($fcolor, $grey, $epsilon, $comment)
942
943Tests if $fcolor's first channel is within $epsilon of ($grey). For
944the first form $epsilon is taken as 0.001.
945
0aae8858
TC
946=item is_fcolor3($fcolor, $red, $green, $blue, $comment)
947
948=item is_fcolor3($fcolor, $red, $green, $blue, $epsilon, $comment)
949
950Tests if $fcolor's channels are within $epsilon of ($red, $green,
951$blue). For the first form $epsilon is taken as 0.001.
952
953=item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $comment)
954
955=item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $epsilon, $comment)
956
957Tests if $fcolor's channels are within $epsilon of ($red, $green,
958$blue, $alpha). For the first form $epsilon is taken as 0.001.
9c106321 959
ae12796a
TC
960=item is_image($im1, $im2, $comment)
961
962Tests if the 2 images have the same content. Both images must be
963defined, have the same width, height, channels and the same color in
964each pixel. The color comparison is done at 8-bits per pixel. The
965color representation such as direct vs paletted, bits per sample are
2fac3132
TC
966not checked. Equivalent to is_image_similar($im1, $im2, 0, $comment).
967
e41cfe8f
TC
968=item is_imaged($im, $im2, $comment)
969
4498c8bd
TC
970=item is_imaged($im, $im2, $epsilon, $comment)
971
e41cfe8f 972Tests if the two images have the same content at the double/sample
4498c8bd
TC
973level. C<$epsilon> defaults to the platform DBL_EPSILON multiplied by
974four.
e41cfe8f 975
2fac3132
TC
976=item is_image_similar($im1, $im2, $maxdiff, $comment)
977
978Tests if the 2 images have similar content. Both images must be
47e4b7d1 979defined, have the same width, height and channels. The sum of the
2fac3132
TC
980squares of the differences of each sample are calculated and must be
981less than or equal to I<$maxdiff> for the test to pass. The color
982comparison is done at 8-bits per pixel. The color representation such
983as direct vs paletted, bits per sample are not checked.
ae12796a 984
0aae8858 985=item isnt_image($im1, $im2, $comment)
9c106321 986
0aae8858
TC
987Tests that the two images are different. For regressions tests where
988something (like text output of "0") produced no change, but should
989have produced a change.
9c106321 990
0aae8858 991=item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)
d5477d3d 992
0aae8858
TC
993Retrieves the pixel ($x,$y) from the low-level image $im and compares
994it to the floating point color $expected, with a tolerance of epsilon.
d5477d3d 995
0aae8858 996=item test_color_gpix($im, $x, $y, $expected, $comment)
9c106321 997
0aae8858
TC
998Retrieves the pixel ($x,$y) from the low-level image $im and compares
999it to the floating point color $expected.
9c106321 1000
0aae8858 1001=item test_colorf_glin($im, $x, $y, $pels, $comment)
bd8052a6 1002
0aae8858
TC
1003Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
1004low level image $im and compares them against @$pels.
1005
1006=item is_color_close3($color, $red, $green, $blue, $tolerance, $comment)
1007
1008Tests if $color's first three channels are within $tolerance of ($red,
1009$green, $blue).
1010
1011=back
1012
1013=head2 Test suite functions
1014
1015Functions that perform one or more tests, typically used to test
1016various parts of Imager's implementation.
1017
1018=over
1019
1020=item image_bounds_checks($im)
1021
1022Attempts to write to various pixel positions outside the edge of the
1023image to ensure that it fails in those locations.
1024
1025Any new image type should pass these tests. Does 16 separate tests.
1026
1027=item mask_tests($im, $epsilon)
1028
1029Perform a standard set of mask tests on the OO image $im. Does 24
1030separate tests.
bd8052a6 1031
9c106321 1032=item diff_text_with_nul($test_name, $text1, $text2, @options)
9a6ab99c
TC
1033
1034Creates 2 test images and writes $text1 to the first image and $text2
5715f7c3
TC
1035to the second image with the string() method. Each call adds 3
1036C<ok>/C<not ok> to the output of the test script.
9a6ab99c
TC
1037
1038Extra options that should be supplied include the font and either a
1039color or channel parameter.
1040
1041This was explicitly created for regression tests on #21770.
1042
76ae98a6
TC
1043=item std_font_tests({ font => $font })
1044
1045Perform standard font interface tests.
1046
1047=item std_font_test_count()
1048
1049The number of tests performed by std_font_tests().
1050
0aae8858 1051=back
2fac3132 1052
0aae8858 1053=head2 Helper functions
2fac3132 1054
0aae8858 1055=over
2fac3132 1056
0aae8858 1057=item test_image_raw()
bd8052a6 1058
0aae8858 1059Returns a 150x150x3 Imager::ImgRaw test image.
bd8052a6 1060
0aae8858 1061=item test_image()
bd8052a6 1062
ca6c0621 1063Returns a 150x150x3 8-bit/sample OO test image. Name: C<basic>.
bd8052a6 1064
0aae8858 1065=item test_image_16()
bd8052a6 1066
ca6c0621 1067Returns a 150x150x3 16-bit/sample OO test image. Name: C<basic16>
bd8052a6 1068
0aae8858
TC
1069=item test_image_double()
1070
ca6c0621
TC
1071Returns a 150x150x3 double/sample OO test image. Name: C<basic_double>.
1072
1073=item test_image_gray()
1074
1075Returns a 150x150 single channel OO test image. Name: C<gray>.
1076
1077=item test_image_gray_16()
1078
1079Returns a 150x150 16-bit/sample single channel OO test image. Name:
1080C<gray16>.
1081
1082=item test_image_mono()
1083
1084Returns a 150x150 bilevel image that passes the is_bilevel() test.
1085Name: C<mono>.
1086
1087=item test_image_named($name)
1088
1089Return one of the other test images above based on name.
0aae8858
TC
1090
1091=item color_cmp($c1, $c2)
1092
1093Performs an ordering of 3-channel colors (like <=>).
1094
1095=item colorf_cmp($c1, $c2)
bd8052a6 1096
0aae8858 1097Performs an ordering of 3-channel floating point colors (like <=>).
bd8052a6 1098
9a6ab99c
TC
1099=back
1100
1101=head1 AUTHOR
1102
1103Tony Cook <tony@develop-help.com>
1104
1105=cut