remove some #if 0 code
[imager.git] / lib / Imager / Test.pm
CommitLineData
9a6ab99c
TC
1package Imager::Test;
2use strict;
3use Test::Builder;
4require Exporter;
5use vars qw(@ISA @EXPORT_OK);
6@ISA = qw(Exporter);
bd8052a6
TC
7@EXPORT_OK = qw(diff_text_with_nul
8 test_image_raw test_image_16 test_image test_image_double
b3aa972f
TC
9 is_color3 is_color1 is_color4
10 is_fcolor4
11 is_image is_image_similar
bd8052a6
TC
12 image_bounds_checks mask_tests
13 test_colorf_gpix test_color_gpix test_colorf_glin);
9a6ab99c
TC
14
15sub diff_text_with_nul {
16 my ($desc, $text1, $text2, @params) = @_;
17
18 my $builder = Test::Builder->new;
19
20 print "# $desc\n";
21 my $imbase = Imager->new(xsize => 100, ysize => 100);
22 my $imcopy = Imager->new(xsize => 100, ysize => 100);
23
24 $builder->ok($imbase->string(x => 5, 'y' => 50, size => 20,
25 string => $text1,
26 @params), "$desc - draw text1");
27 $builder->ok($imcopy->string(x => 5, 'y' => 50, size => 20,
28 string => $text2,
29 @params), "$desc - draw text2");
30 $builder->isnt_num(Imager::i_img_diff($imbase->{IMG}, $imcopy->{IMG}), 0,
31 "$desc - check result different");
32}
33
9c106321
TC
34sub is_color3($$$$$) {
35 my ($color, $red, $green, $blue, $comment) = @_;
36
37 my $builder = Test::Builder->new;
38
39 unless (defined $color) {
40 $builder->ok(0, $comment);
41 $builder->diag("color is undef");
42 return;
43 }
44 unless ($color->can('rgba')) {
45 $builder->ok(0, $comment);
46 $builder->diag("color is not a color object");
47 return;
48 }
49
50 my ($cr, $cg, $cb) = $color->rgba;
51 unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue, $comment)) {
52 $builder->diag(<<END_DIAG);
53Color mismatch:
54 Red: $red vs $cr
55Green: $green vs $cg
56 Blue: $blue vs $cb
57END_DIAG
58 return;
59 }
60
61 return 1;
62}
63
b3aa972f
TC
64sub is_color4($$$$$$) {
65 my ($color, $red, $green, $blue, $alpha, $comment) = @_;
66
67 my $builder = Test::Builder->new;
68
69 unless (defined $color) {
70 $builder->ok(0, $comment);
71 $builder->diag("color is undef");
72 return;
73 }
74 unless ($color->can('rgba')) {
75 $builder->ok(0, $comment);
76 $builder->diag("color is not a color object");
77 return;
78 }
79
80 my ($cr, $cg, $cb, $ca) = $color->rgba;
81 unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue
82 && $ca == $alpha, $comment)) {
83 $builder->diag(<<END_DIAG);
84Color mismatch:
85 Red: $red vs $cr
86Green: $green vs $cg
87 Blue: $blue vs $cb
88Alpha: $alpha vs $ca
89END_DIAG
90 return;
91 }
92
93 return 1;
94}
95
96sub is_fcolor4($$$$$$;$) {
97 my ($color, $red, $green, $blue, $alpha, $comment_or_diff, $comment_or_undef) = @_;
98 my ($comment, $mindiff);
99 if (defined $comment_or_undef) {
100 ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef )
101 }
102 else {
103 ( $mindiff, $comment ) = ( 0.001, $comment_or_diff )
104 }
105
106 my $builder = Test::Builder->new;
107
108 unless (defined $color) {
109 $builder->ok(0, $comment);
110 $builder->diag("color is undef");
111 return;
112 }
113 unless ($color->can('rgba')) {
114 $builder->ok(0, $comment);
115 $builder->diag("color is not a color object");
116 return;
117 }
118
119 my ($cr, $cg, $cb, $ca) = $color->rgba;
120 unless ($builder->ok(abs($cr - $red) <= $mindiff
121 && abs($cg - $green) <= $mindiff
122 && abs($cb - $blue) <= $mindiff
123 && abs($ca - $alpha) <= $mindiff, $comment)) {
124 $builder->diag(<<END_DIAG);
125Color mismatch:
126 Red: $red vs $cr
127Green: $green vs $cg
128 Blue: $blue vs $cb
129Alpha: $alpha vs $ca
130END_DIAG
131 return;
132 }
133
134 return 1;
135}
136
9c106321
TC
137sub is_color1($$$) {
138 my ($color, $grey, $comment) = @_;
139
140 my $builder = Test::Builder->new;
141
142 unless (defined $color) {
143 $builder->ok(0, $comment);
144 $builder->diag("color is undef");
145 return;
146 }
147 unless ($color->can('rgba')) {
148 $builder->ok(0, $comment);
149 $builder->diag("color is not a color object");
150 return;
151 }
152
153 my ($cgrey) = $color->rgba;
154 unless ($builder->ok($cgrey == $grey, $comment)) {
155 $builder->diag(<<END_DIAG);
156Color mismatch:
157 Grey: $grey vs $cgrey
158END_DIAG
159 return;
160 }
161
162 return 1;
163}
164
165sub test_image_raw {
166 my $green=Imager::i_color_new(0,255,0,255);
167 my $blue=Imager::i_color_new(0,0,255,255);
168 my $red=Imager::i_color_new(255,0,0,255);
169
170 my $img=Imager::ImgRaw::new(150,150,3);
171
172 Imager::i_box_filled($img,70,25,130,125,$green);
173 Imager::i_box_filled($img,20,25,80,125,$blue);
174 Imager::i_arc($img,75,75,30,0,361,$red);
175 Imager::i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
176
177 $img;
178}
179
167660cd
TC
180sub test_image {
181 my $green = Imager::Color->new(0, 255, 0, 255);
182 my $blue = Imager::Color->new(0, 0, 255, 255);
183 my $red = Imager::Color->new(255, 0, 0, 255);
184 my $img = Imager->new(xsize => 150, ysize => 150);
d5477d3d
TC
185 $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
186 $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]);
167660cd
TC
187 $img->arc(x => 75, y => 75, r => 30, color => $red);
188 $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
189
190 $img;
191}
192
9c106321
TC
193sub test_image_16 {
194 my $green = Imager::Color->new(0, 255, 0, 255);
195 my $blue = Imager::Color->new(0, 0, 255, 255);
196 my $red = Imager::Color->new(255, 0, 0, 255);
197 my $img = Imager->new(xsize => 150, ysize => 150, bits => 16);
198 $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]);
199 $img->box(filled => 1, color => $blue, box => [ 20, 25, 80, 125 ]);
200 $img->arc(x => 75, y => 75, r => 30, color => $red);
201 $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
202
203 $img;
204}
205
bd8052a6
TC
206sub test_image_double {
207 my $green = Imager::Color->new(0, 255, 0, 255);
208 my $blue = Imager::Color->new(0, 0, 255, 255);
209 my $red = Imager::Color->new(255, 0, 0, 255);
210 my $img = Imager->new(xsize => 150, ysize => 150, bits => 'double');
211 $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]);
212 $img->box(filled => 1, color => $blue, box => [ 20, 25, 80, 125 ]);
213 $img->arc(x => 75, y => 75, r => 30, color => $red);
214 $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
215
216 $img;
217}
218
167660cd
TC
219sub is_image_similar($$$$) {
220 my ($left, $right, $limit, $comment) = @_;
9c106321
TC
221
222 my $builder = Test::Builder->new;
223
224 unless (defined $left) {
225 $builder->ok(0, $comment);
226 $builder->diag("left is undef");
227 return;
228 }
229 unless (defined $right) {
230 $builder->ok(0, $comment);
231 $builder->diag("right is undef");
232 return;
233 }
234 unless ($left->{IMG}) {
235 $builder->ok(0, $comment);
236 $builder->diag("left image has no low level object");
237 return;
238 }
239 unless ($right->{IMG}) {
240 $builder->ok(0, $comment);
241 $builder->diag("right image has no low level object");
242 return;
243 }
244 unless ($left->getwidth == $right->getwidth) {
245 $builder->ok(0, $comment);
246 $builder->diag("left width " . $left->getwidth . " vs right width "
247 . $right->getwidth);
248 return;
249 }
250 unless ($left->getheight == $right->getheight) {
251 $builder->ok(0, $comment);
252 $builder->diag("left height " . $left->getheight . " vs right height "
253 . $right->getheight);
254 return;
255 }
256 unless ($left->getchannels == $right->getchannels) {
257 $builder->ok(0, $comment);
258 $builder->diag("left channels " . $left->getchannels . " vs right channels "
259 . $right->getchannels);
260 return;
261 }
262 my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
167660cd 263 if ($diff > $limit) {
9c106321 264 $builder->ok(0, $comment);
167660cd 265 $builder->diag("image data difference > $limit - $diff");
bd8052a6
TC
266
267 if ($limit == 0) {
268 # find the first mismatch
269 CHECK:
270 for my $y (0 .. $left->getheight()-1) {
271 for my $x (0.. $left->getwidth()-1) {
272 my @lsamples = $left->getsamples(x => $x, y => $y, width => 1);
273 my @rsamples = $right->getsamples(x => $x, y => $y, width => 1);
274 if ("@lsamples" ne "@rsamples") {
275 $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
276 last CHECK;
277 }
278 }
279 }
280 }
281
9c106321
TC
282 return;
283 }
284
285 return $builder->ok(1, $comment);
286}
287
167660cd
TC
288sub is_image($$$) {
289 my ($left, $right, $comment) = @_;
290
291 local $Test::Builder::Level = $Test::Builder::Level + 1;
292
293 return is_image_similar($left, $right, 0, $comment);
294}
295
837a4b43
TC
296sub image_bounds_checks {
297 my $im = shift;
298
299 my $builder = Test::Builder->new;
300
301 $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0)');
302 $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0)');
303 $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1)');
304 $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10)');
305 $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0) float');
306 $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0) float');
307 $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1) float');
308 $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10) float');
309 my $black = Imager::Color->new(0, 0, 0);
310 require Imager::Color::Float;
311 my $blackf = Imager::Color::Float->new(0, 0, 0);
312 $builder->ok(!$im->setpixel(x => -1, y => 0, color => $black), 'bounds check set (-1, 0)');
313 $builder->ok(!$im->setpixel(x => 10, y => 0, color => $black), 'bounds check set (10, 0)');
314 $builder->ok(!$im->setpixel(x => 0, y => -1, color => $black), 'bounds check set (0, -1)');
315 $builder->ok(!$im->setpixel(x => 0, y => 10, color => $black), 'bounds check set (0, 10)');
316 $builder->ok(!$im->setpixel(x => -1, y => 0, color => $blackf), 'bounds check set (-1, 0) float');
317 $builder->ok(!$im->setpixel(x => 10, y => 0, color => $blackf), 'bounds check set (10, 0) float');
318 $builder->ok(!$im->setpixel(x => 0, y => -1, color => $blackf), 'bounds check set (0, -1) float');
319 $builder->ok(!$im->setpixel(x => 0, y => 10, color => $blackf), 'bounds check set (0, 10) float');
320}
167660cd 321
bd8052a6
TC
322sub test_colorf_gpix {
323 my ($im, $x, $y, $expected, $epsilon, $comment) = @_;
324
325 my $builder = Test::Builder->new;
326
327 defined $comment or $comment = '';
328
329 my $c = Imager::i_gpixf($im, $x, $y);
330 unless ($c) {
331 $builder->ok(0, "$comment - retrieve color at ($x,$y)");
332 return;
333 }
334 unless ($builder->ok(_colorf_cmp($c, $expected, $epsilon) == 0,
335 "$comment - got right color ($x, $y)")) {
336 print "# got: (", join(",", ($c->rgba)[0,1,2]), ")\n";
337 print "# expected: (", join(",", ($expected->rgba)[0,1,2]), ")\n";
338 return;
339 }
340 1;
341}
342
343sub test_color_gpix {
344 my ($im, $x, $y, $expected, $comment) = @_;
345
346 my $builder = Test::Builder->new;
347
348 defined $comment or $comment = '';
349 my $c = Imager::i_get_pixel($im, $x, $y);
350 unless ($c) {
351 $builder->ok(0, "$comment - retrieve color at ($x,$y)");
352 return;
353 }
354 unless ($builder->ok(_color_cmp($c, $expected) == 0,
355 "got right color ($x, $y)")) {
356 print "# got: (", join(",", ($c->rgba)[0,1,2]), ")\n";
357 print "# expected: (", join(",", ($expected->rgba)[0,1,2]), ")\n";
358 return;
359 }
360
361 return 1;
362}
363
364sub test_colorf_glin {
365 my ($im, $x, $y, $pels, $comment) = @_;
366
367 my $builder = Test::Builder->new;
368
369 my @got = Imager::i_glinf($im, $x, $x+@$pels, $y);
370 @got == @$pels
371 or return $builder->is_num(scalar(@got), scalar(@$pels), "$comment - pixels retrieved");
372
373 return $builder->ok(!grep(_colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got),
374 "$comment - check colors ($x, $y)");
375}
376
377sub _colorf_cmp {
378 my ($c1, $c2, $epsilon) = @_;
379
380 defined $epsilon or $epsilon = 0;
381
382 my @s1 = $c1->rgba;
383 my @s2 = $c2->rgba;
384
385 # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
386 return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0]
387 || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1]
388 || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
389}
390
391sub _color_cmp {
392 my ($c1, $c2) = @_;
393
394 my @s1 = $c1->rgba;
395 my @s2 = $c2->rgba;
396
397 return $s1[0] <=> $s2[0]
398 || $s1[1] <=> $s2[1]
399 || $s1[2] <=> $s2[2];
400}
401
402# these test the action of the channel mask on the image supplied
403# which should be an OO image.
404sub mask_tests {
405 my ($im, $epsilon) = @_;
406
407 my $builder = Test::Builder->new;
408
409 defined $epsilon or $epsilon = 0;
410
411 # we want to check all four of ppix() and plin(), ppix() and plinf()
412 # basic test procedure:
413 # first using default/all 1s mask, set to white
414 # make sure we got white
415 # set mask to skip a channel, set to grey
416 # make sure only the right channels set
417
418 print "# channel mask tests\n";
419 # 8-bit color tests
420 my $white = Imager::NC(255, 255, 255);
421 my $grey = Imager::NC(128, 128, 128);
422 my $white_grey = Imager::NC(128, 255, 128);
423
424 print "# with ppix\n";
425 $builder->ok($im->setmask(mask=>~0), "set to default mask");
426 $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels");
427 test_color_gpix($im->{IMG}, 0, 0, $white, "ppix");
428 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
429 $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2");
430 test_color_gpix($im->{IMG}, 0, 0, $white_grey, "ppix masked");
431
432 print "# with plin\n";
433 $builder->ok($im->setmask(mask=>~0), "set to default mask");
434 $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]),
435 "set to white all channels");
436 test_color_gpix($im->{IMG}, 0, 1, $white, "plin");
437 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
438 $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]),
439 "set to grey, no channel 2");
440 test_color_gpix($im->{IMG}, 0, 1, $white_grey, "plin masked");
441
442 # float color tests
443 my $whitef = Imager::NCF(1.0, 1.0, 1.0);
444 my $greyf = Imager::NCF(0.5, 0.5, 0.5);
445 my $white_greyf = Imager::NCF(0.5, 1.0, 0.5);
446
447 print "# with ppixf\n";
448 $builder->ok($im->setmask(mask=>~0), "set to default mask");
449 $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels");
450 test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon, "ppixf");
451 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
452 $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2");
453 test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon, "ppixf masked");
454
455 print "# with plinf\n";
456 $builder->ok($im->setmask(mask=>~0), "set to default mask");
457 $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]),
458 "set to white all channels");
459 test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon, "plinf");
460 $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
461 $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]),
462 "set to grey, no channel 2");
463 test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon, "plinf masked");
464
465}
466
9a6ab99c
TC
4671;
468
469__END__
470
471=head1 NAME
472
473Imager::Test - common functions used in testing Imager
474
475=head1 SYNOPSIS
476
477 use Imager::Test 'diff_text_with_nul';
478 diff_text_with_nul($test_name, $text1, $text2, @string_options);
479
480=head1 DESCRIPTION
481
482This is a repository of functions used in testing Imager.
483
484Some functions will only be useful in testing Imager itself, while
485others should be useful in testing modules that use Imager.
486
487No functions are exported by default.
488
489=head1 FUNCTIONS
490
491=over
492
9c106321
TC
493=item is_color3($color, $red, $blue, $green, $comment)
494
495Tests is $color matches the given ($red, $blue, $green)
496
ae12796a
TC
497=item is_image($im1, $im2, $comment)
498
499Tests if the 2 images have the same content. Both images must be
500defined, have the same width, height, channels and the same color in
501each pixel. The color comparison is done at 8-bits per pixel. The
502color representation such as direct vs paletted, bits per sample are
2fac3132
TC
503not checked. Equivalent to is_image_similar($im1, $im2, 0, $comment).
504
505=item is_image_similar($im1, $im2, $maxdiff, $comment)
506
507Tests if the 2 images have similar content. Both images must be
508defined, have the same width, height and channels. The cum of the
509squares of the differences of each sample are calculated and must be
510less than or equal to I<$maxdiff> for the test to pass. The color
511comparison is done at 8-bits per pixel. The color representation such
512as direct vs paletted, bits per sample are not checked.
ae12796a 513
9c106321
TC
514=item test_image_raw()
515
516Returns a 150x150x3 Imager::ImgRaw test image.
517
d5477d3d
TC
518=item test_image()
519
520Returns a 150x150x3 8-bit/sample OO test image.
521
9c106321
TC
522=item test_image_16()
523
524Returns a 150x150x3 16-bit/sample OO test image.
525
bd8052a6
TC
526=item test_image_double()
527
528Returns a 150x150x3 double/sample OO test image.
529
9c106321 530=item diff_text_with_nul($test_name, $text1, $text2, @options)
9a6ab99c
TC
531
532Creates 2 test images and writes $text1 to the first image and $text2
533to the second image with the string() method. Each call adds 3 ok/not
534ok to the output of the test script.
535
536Extra options that should be supplied include the font and either a
537color or channel parameter.
538
539This was explicitly created for regression tests on #21770.
540
2fac3132
TC
541=item image_bounds_checks($im)
542
543Attempts to write to various pixel positions outside the edge of the
544image to ensure that it fails in those locations.
545
546Any new image type should pass these tests. Does 16 separate tests.
547
bd8052a6
TC
548=item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)
549
550Retrieves the pixel ($x,$y) from the low-level image $im and compares
551it to the floating point color $expected, with a tolerance of epsilon.
552
553=item test_color_gpix($im, $x, $y, $expected, $comment)
554
555Retrieves the pixel ($x,$y) from the low-level image $im and compares
556it to the floating point color $expected.
557
558=item test_colorf_glin($im, $x, $y, $pels, $comment)
559
560Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
561low level image $im and compares them against @$pels.
562
563=item mask_tests($im, $epsilon)
564
565Perform a standard set of mask tests on the OO image $im.
566
9a6ab99c
TC
567=back
568
569=head1 AUTHOR
570
571Tony Cook <tony@develop-help.com>
572
573=cut