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