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