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