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