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