994ccc43fb8d1b77cf56e0c942ab1546769e758f
[imager.git] / lib / Imager / Test.pm
1 package Imager::Test;
2 use strict;
3 use Test::Builder;
4 require Exporter;
5 use vars qw(@ISA @EXPORT_OK);
6 @ISA = qw(Exporter);
7 @EXPORT_OK = qw(diff_text_with_nul 
8                 test_image_raw test_image_16 test_image test_image_double 
9                 is_color3 is_color1 is_color4 
10                 is_fcolor4
11                 is_image is_image_similar 
12                 image_bounds_checks mask_tests
13                 test_colorf_gpix test_color_gpix test_colorf_glin);
14
15 sub 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
34 sub 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);
53 Color mismatch:
54   Red: $red vs $cr
55 Green: $green vs $cg
56  Blue: $blue vs $cb
57 END_DIAG
58     return;
59   }
60
61   return 1;
62 }
63
64 sub 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);
84 Color mismatch:
85   Red: $red vs $cr
86 Green: $green vs $cg
87  Blue: $blue vs $cb
88 Alpha: $alpha vs $ca
89 END_DIAG
90     return;
91   }
92
93   return 1;
94 }
95
96 sub 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);
125 Color mismatch:
126   Red: $red vs $cr
127 Green: $green vs $cg
128  Blue: $blue vs $cb
129 Alpha: $alpha vs $ca
130 END_DIAG
131     return;
132   }
133
134   return 1;
135 }
136
137 sub 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);
156 Color mismatch:
157   Grey: $grey vs $cgrey
158 END_DIAG
159     return;
160   }
161
162   return 1;
163 }
164
165 sub 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
180 sub 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);
185   $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
186   $img->box(filled => 1, color => $blue,  box => [ 20, 26, 80, 126 ]);
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
193 sub 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
206 sub 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
219 sub is_image_similar($$$$) {
220   my ($left, $right, $limit, $comment) = @_;
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});
263   if ($diff > $limit) {
264     $builder->ok(0, $comment);
265     $builder->diag("image data difference > $limit - $diff");
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
282     return;
283   }
284   
285   return $builder->ok(1, $comment);
286 }
287
288 sub 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
296 sub 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 }
321
322 sub 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
343 sub 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
364 sub 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
377 sub _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
391 sub _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.
404 sub 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
467 1;
468
469 __END__
470
471 =head1 NAME
472
473 Imager::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
482 This is a repository of functions used in testing Imager.
483
484 Some functions will only be useful in testing Imager itself, while
485 others should be useful in testing modules that use Imager.
486
487 No functions are exported by default.
488
489 =head1 FUNCTIONS
490
491 =over
492
493 =item is_color3($color, $red, $blue, $green, $comment)
494
495 Tests is $color matches the given ($red, $blue, $green)
496
497 =item is_image($im1, $im2, $comment)
498
499 Tests if the 2 images have the same content.  Both images must be
500 defined, have the same width, height, channels and the same color in
501 each pixel.  The color comparison is done at 8-bits per pixel.  The
502 color representation such as direct vs paletted, bits per sample are
503 not checked.  Equivalent to is_image_similar($im1, $im2, 0, $comment).
504
505 =item is_image_similar($im1, $im2, $maxdiff, $comment)
506
507 Tests if the 2 images have similar content.  Both images must be
508 defined, have the same width, height and channels.  The cum of the
509 squares of the differences of each sample are calculated and must be
510 less than or equal to I<$maxdiff> for the test to pass.  The color
511 comparison is done at 8-bits per pixel.  The color representation such
512 as direct vs paletted, bits per sample are not checked.
513
514 =item test_image_raw()
515
516 Returns a 150x150x3 Imager::ImgRaw test image.
517
518 =item test_image()
519
520 Returns a 150x150x3 8-bit/sample OO test image.
521
522 =item test_image_16()
523
524 Returns a 150x150x3 16-bit/sample OO test image.
525
526 =item test_image_double()
527
528 Returns a 150x150x3 double/sample OO test image.
529
530 =item diff_text_with_nul($test_name, $text1, $text2, @options)
531
532 Creates 2 test images and writes $text1 to the first image and $text2
533 to the second image with the string() method.  Each call adds 3 ok/not
534 ok to the output of the test script.
535
536 Extra options that should be supplied include the font and either a
537 color or channel parameter.
538
539 This was explicitly created for regression tests on #21770.
540
541 =item image_bounds_checks($im)
542
543 Attempts to write to various pixel positions outside the edge of the
544 image to ensure that it fails in those locations.
545
546 Any new image type should pass these tests.  Does 16 separate tests.
547
548 =item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)
549
550 Retrieves the pixel ($x,$y) from the low-level image $im and compares
551 it to the floating point color $expected, with a tolerance of epsilon.
552
553 =item test_color_gpix($im, $x, $y, $expected, $comment)
554
555 Retrieves the pixel ($x,$y) from the low-level image $im and compares
556 it to the floating point color $expected.
557
558 =item test_colorf_glin($im, $x, $y, $pels, $comment)
559
560 Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
561 low level image $im and compares them against @$pels.
562
563 =item mask_tests($im, $epsilon)
564
565 Perform a standard set of mask tests on the OO image $im.
566
567 =back
568
569 =head1 AUTHOR
570
571 Tony Cook <tony@develop-help.com>
572
573 =cut