implement standard font tests for Imager::Font::W32
[imager.git] / lib / Imager / Test.pm
1 package Imager::Test;
2 use strict;
3 use Test::More;
4 use Test::Builder;
5 require Exporter;
6 use vars qw(@ISA @EXPORT_OK $VERSION);
7 use Carp qw(croak carp);
8 use Config;
9
10 $VERSION = "1.001";
11
12 @ISA = qw(Exporter);
13 @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), 'bounds check set (-1, 0)');
576   $builder->ok(!$im->setpixel(x => 10, y => 0, color => $black), 'bounds check set (10, 0)');
577   $builder->ok(!$im->setpixel(x => 0, y => -1, color => $black), 'bounds check set (0, -1)');
578   $builder->ok(!$im->setpixel(x => 0, y => 10, color => $black), 'bounds check set (0, 10)');
579   $builder->ok(!$im->setpixel(x => -1, y => 0, color => $blackf), 'bounds check set (-1, 0) float');
580   $builder->ok(!$im->setpixel(x => 10, y => 0, color => $blackf), 'bounds check set (10, 0) float');
581   $builder->ok(!$im->setpixel(x => 0, y => -1, color => $blackf), 'bounds check set (0, -1) float');
582   $builder->ok(!$im->setpixel(x => 0, y => 10, color => $blackf), 'bounds check set (0, 10) float');
583 }
584
585 sub test_colorf_gpix {
586   my ($im, $x, $y, $expected, $epsilon, $comment) = @_;
587
588   my $builder = Test::Builder->new;
589   
590   defined $comment or $comment = '';
591
592   my $c = Imager::i_gpixf($im, $x, $y);
593   unless ($c) {
594     $builder->ok(0, "$comment - retrieve color at ($x,$y)");
595     return;
596   }
597   unless ($builder->ok(colorf_cmp($c, $expected, $epsilon) == 0,
598              "$comment - got right color ($x, $y)")) {
599     my @c = $c->rgba;
600     my @exp = $expected->rgba;
601     $builder->diag(<<EOS);
602 # got: ($c[0], $c[1], $c[2])
603 # expected: ($exp[0], $exp[1], $exp[2])
604 EOS
605   }
606   1;
607 }
608
609 sub test_color_gpix {
610   my ($im, $x, $y, $expected, $comment) = @_;
611
612   my $builder = Test::Builder->new;
613   
614   defined $comment or $comment = '';
615   my $c = Imager::i_get_pixel($im, $x, $y);
616   unless ($c) {
617     $builder->ok(0, "$comment - retrieve color at ($x,$y)");
618     return;
619   }
620   unless ($builder->ok(color_cmp($c, $expected) == 0,
621      "got right color ($x, $y)")) {
622     my @c = $c->rgba;
623     my @exp = $expected->rgba;
624     $builder->diag(<<EOS);
625 # got: ($c[0], $c[1], $c[2])
626 # expected: ($exp[0], $exp[1], $exp[2])
627 EOS
628     return;
629   }
630
631   return 1;
632 }
633
634 sub test_colorf_glin {
635   my ($im, $x, $y, $pels, $comment) = @_;
636
637   my $builder = Test::Builder->new;
638   
639   my @got = Imager::i_glinf($im, $x, $x+@$pels, $y);
640   @got == @$pels
641     or return $builder->is_num(scalar(@got), scalar(@$pels), "$comment - pixels retrieved");
642   
643   return $builder->ok(!grep(colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got),
644      "$comment - check colors ($x, $y)");
645 }
646
647 sub colorf_cmp {
648   my ($c1, $c2, $epsilon) = @_;
649
650   defined $epsilon or $epsilon = 0;
651
652   my @s1 = $c1->rgba;
653   my @s2 = $c2->rgba;
654
655   # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
656   return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0] 
657     || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1]
658       || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
659 }
660
661 sub color_cmp {
662   my ($c1, $c2) = @_;
663
664   my @s1 = $c1->rgba;
665   my @s2 = $c2->rgba;
666
667   return $s1[0] <=> $s2[0] 
668     || $s1[1] <=> $s2[1]
669       || $s1[2] <=> $s2[2];
670 }
671
672 # these test the action of the channel mask on the image supplied
673 # which should be an OO image.
674 sub mask_tests {
675   my ($im, $epsilon) = @_;
676
677   my $builder = Test::Builder->new;
678
679   defined $epsilon or $epsilon = 0;
680
681   # we want to check all four of ppix() and plin(), ppix() and plinf()
682   # basic test procedure:
683   #   first using default/all 1s mask, set to white
684   #   make sure we got white
685   #   set mask to skip a channel, set to grey
686   #   make sure only the right channels set
687
688   print "# channel mask tests\n";
689   # 8-bit color tests
690   my $white = Imager::NC(255, 255, 255);
691   my $grey = Imager::NC(128, 128, 128);
692   my $white_grey = Imager::NC(128, 255, 128);
693
694   print "# with ppix\n";
695   $builder->ok($im->setmask(mask=>~0), "set to default mask");
696   $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels");
697   test_color_gpix($im->{IMG}, 0, 0, $white, "ppix");
698   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
699   $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2");
700   test_color_gpix($im->{IMG}, 0, 0, $white_grey, "ppix masked");
701
702   print "# with plin\n";
703   $builder->ok($im->setmask(mask=>~0), "set to default mask");
704   $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]), 
705      "set to white all channels");
706   test_color_gpix($im->{IMG}, 0, 1, $white, "plin");
707   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
708   $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]), 
709      "set to grey, no channel 2");
710   test_color_gpix($im->{IMG}, 0, 1, $white_grey, "plin masked");
711
712   # float color tests
713   my $whitef = Imager::NCF(1.0, 1.0, 1.0);
714   my $greyf = Imager::NCF(0.5, 0.5, 0.5);
715   my $white_greyf = Imager::NCF(0.5, 1.0, 0.5);
716
717   print "# with ppixf\n";
718   $builder->ok($im->setmask(mask=>~0), "set to default mask");
719   $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels");
720   test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon, "ppixf");
721   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
722   $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2");
723   test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon, "ppixf masked");
724
725   print "# with plinf\n";
726   $builder->ok($im->setmask(mask=>~0), "set to default mask");
727   $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]), 
728      "set to white all channels");
729   test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon, "plinf");
730   $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
731   $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]), 
732      "set to grey, no channel 2");
733   test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon, "plinf masked");
734
735 }
736
737 sub std_font_test_count {
738   return 21;
739 }
740
741 sub std_font_tests {
742   my ($opts) = @_;
743
744   my $font = $opts->{font}
745     or carp "Missing font parameter";
746
747   my $name_font = $opts->{glyph_name_font} || $font;
748
749   my $has_chars = $opts->{has_chars} || [ 1, '', 1 ];
750
751   my $glyph_names = $opts->{glyph_names} || [ "A", undef, "A" ];
752
753  SKIP:
754   { # check magic is handled correctly
755     # https://rt.cpan.org/Ticket/Display.html?id=83438
756     skip("no native UTF8 support in this version of perl", 10) 
757       unless $] >= 5.006;
758     Imager->log("utf8 magic tests\n");
759     my $over = bless {}, "Imager::Test::OverUtf8";
760     my $text = "A".chr(0x2010)."A";
761     my $white = Imager::Color->new("#FFF");
762     my $base_draw = Imager->new(xsize => 80, ysize => 20);
763     ok($base_draw->string(font => $font,
764                           text => $text,
765                           x => 2,
766                           y => 18,
767                           size => 15,
768                           color => $white,
769                           aa => 1),
770        "magic: make a base image");
771     my $test_draw = Imager->new(xsize => 80, ysize => 20);
772     ok($test_draw->string(font => $font,
773                           text => $over,
774                           x => 2,
775                           y => 18,
776                           size => 15,
777                           color => $white,
778                           aa => 1),
779        "magic: draw with overload");
780     is_image($base_draw, $test_draw, "check they match");
781     if ($opts->{files}) {
782       $test_draw->write(file => "testout/utf8tdr.ppm");
783       $base_draw->write(file => "testout/utf8bdr.ppm");
784     }
785
786     my $base_cp = Imager->new(xsize => 80, ysize => 20);
787     $base_cp->box(filled => 1, color => "#808080");
788     my $test_cp = $base_cp->copy;
789     ok($base_cp->string(font => $font,
790                         text => $text,
791                         y => 2,
792                         y => 18,
793                         size => 16,
794                         channel => 2,
795                         aa => 1),
796        "magic: make a base image (channel)");
797     Imager->log("magic: draw to channel with overload\n");
798     ok($test_cp->string(font => $font,
799                         text => $over,
800                         y => 2,
801                         y => 18,
802                         size => 16,
803                         channel => 2,
804                         aa => 1),
805        "magic: draw with overload (channel)");
806     is_image($test_cp, $base_cp, "check they match");
807     if ($opts->{files}) {
808       $test_cp->write(file => "testout/utf8tcp.ppm");
809       $base_cp->write(file => "testout/utf8bcp.ppm");
810     }
811
812   SKIP:
813     {
814       Imager->log("magic: has_chars\n");
815       $font->can("has_chars")
816         or skip "No has_chars aupport", 2;
817       is_deeply([ $font->has_chars(string => $text) ], $has_chars,
818                 "magic: has_chars with normal utf8 text");
819       is_deeply([ $font->has_chars(string => $over) ], $has_chars,
820                 "magic: has_chars with magic utf8 text");
821     }
822
823     Imager->log("magic: bounding_box\n");
824     my @base_bb = $font->bounding_box(string => $text, size => 30);
825     is_deeply([ $font->bounding_box(string => $over, size => 30) ],
826               \@base_bb,
827               "check bounding box magic");
828
829   SKIP:
830     {
831       $font->can_glyph_names
832         or skip "No glyph_names", 2;
833       Imager->log("magic: glyph_names\n");
834       my @text_names = $name_font->glyph_names(string => $text, reliable_only => 0);
835       is_deeply(\@text_names, $glyph_names,
836                 "magic: glyph_names with normal utf8 text");
837       my @over_names = $name_font->glyph_names(string => $over, reliable_only => 0);
838       is_deeply(\@over_names, $glyph_names,
839                 "magic: glyph_names with magic utf8 text");
840     }
841   }
842
843   { # invalid UTF8 handling at the OO level
844     my $im = Imager->new(xsize => 80, ysize => 20);
845     my $bad_utf8 = pack("C", 0xC0);
846     Imager->_set_error("");
847     ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1,
848                     y => 18, x => 2),
849        "drawing invalid utf8 should fail");
850     is($im->errstr, "invalid UTF8 character", "check error message");
851     Imager->_set_error("");
852     ok(!$im->string(font => $font, size => 1, text => $bad_utf8, utf8 => 1,
853                     y => 18, x => 2, channel => 1),
854        "drawing invalid utf8 should fail (channel)");
855     is($im->errstr, "invalid UTF8 character", "check error message");
856     Imager->_set_error("");
857     ok(!$font->bounding_box(string => $bad_utf8, size => 30, utf8 => 1),
858        "bounding_box() bad utf8 should fail");
859     is(Imager->errstr, "invalid UTF8 character", "check error message");
860   SKIP:
861     {
862       $font->can_glyph_names
863         or skip "No glyph_names support", 2;
864       Imager->_set_error("");
865       is_deeply([ $font->glyph_names(string => $bad_utf8, utf8 => 1) ],
866                 [ ],
867                 "glyph_names returns empty list for bad string");
868       is(Imager->errstr, "invalid UTF8 character", "check error message");
869     }
870   SKIP:
871     {
872       $font->can("has_chars")
873         or skip "No has_chars support", 2;
874       Imager->_set_error("");
875       is_deeply([ $font->has_chars(string => $bad_utf8, utf8 => 1) ],
876                 [ ],
877                 "has_chars returns empty list for bad string");
878       is(Imager->errstr, "invalid UTF8 character", "check error message");
879     }
880   }
881 }
882
883 package Imager::Test::OverUtf8;
884 use overload '""' => sub { "A".chr(0x2010)."A" };
885
886
887 1;
888
889 __END__
890
891 =head1 NAME
892
893 Imager::Test - common functions used in testing Imager
894
895 =head1 SYNOPSIS
896
897   use Imager::Test 'diff_text_with_nul';
898   diff_text_with_nul($test_name, $text1, $text2, @string_options);
899
900 =head1 DESCRIPTION
901
902 This is a repository of functions used in testing Imager.
903
904 Some functions will only be useful in testing Imager itself, while
905 others should be useful in testing modules that use Imager.
906
907 No functions are exported by default.
908
909 =head1 FUNCTIONS
910
911 =head2 Test functions
912
913 =for stopwords OO
914
915 =over
916
917 =item is_color1($color, $grey, $comment)
918
919 Tests if the first channel of $color matches $grey.
920
921 =item is_color3($color, $red, $green, $blue, $comment)
922
923 Tests if $color matches the given ($red, $green, $blue)
924
925 =item is_color4($color, $red, $green, $blue, $alpha, $comment)
926
927 Tests if $color matches the given ($red, $green, $blue, $alpha)
928
929 =item is_fcolor1($fcolor, $grey, $comment)
930
931 =item is_fcolor1($fcolor, $grey, $epsilon, $comment)
932
933 Tests if $fcolor's first channel is within $epsilon of ($grey).  For
934 the first form $epsilon is taken as 0.001.
935
936 =item is_fcolor3($fcolor, $red, $green, $blue, $comment)
937
938 =item is_fcolor3($fcolor, $red, $green, $blue, $epsilon, $comment)
939
940 Tests if $fcolor's channels are within $epsilon of ($red, $green,
941 $blue).  For the first form $epsilon is taken as 0.001.
942
943 =item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $comment)
944
945 =item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $epsilon, $comment)
946
947 Tests if $fcolor's channels are within $epsilon of ($red, $green,
948 $blue, $alpha).  For the first form $epsilon is taken as 0.001.
949
950 =item is_image($im1, $im2, $comment)
951
952 Tests if the 2 images have the same content.  Both images must be
953 defined, have the same width, height, channels and the same color in
954 each pixel.  The color comparison is done at 8-bits per pixel.  The
955 color representation such as direct vs paletted, bits per sample are
956 not checked.  Equivalent to is_image_similar($im1, $im2, 0, $comment).
957
958 =item is_imaged($im, $im2, $comment)
959
960 =item is_imaged($im, $im2, $epsilon, $comment)
961
962 Tests if the two images have the same content at the double/sample
963 level.  C<$epsilon> defaults to the platform DBL_EPSILON multiplied by
964 four.
965
966 =item is_image_similar($im1, $im2, $maxdiff, $comment)
967
968 Tests if the 2 images have similar content.  Both images must be
969 defined, have the same width, height and channels.  The cum of the
970 squares of the differences of each sample are calculated and must be
971 less than or equal to I<$maxdiff> for the test to pass.  The color
972 comparison is done at 8-bits per pixel.  The color representation such
973 as direct vs paletted, bits per sample are not checked.
974
975 =item isnt_image($im1, $im2, $comment)
976
977 Tests that the two images are different.  For regressions tests where
978 something (like text output of "0") produced no change, but should
979 have produced a change.
980
981 =item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)
982
983 Retrieves the pixel ($x,$y) from the low-level image $im and compares
984 it to the floating point color $expected, with a tolerance of epsilon.
985
986 =item test_color_gpix($im, $x, $y, $expected, $comment)
987
988 Retrieves the pixel ($x,$y) from the low-level image $im and compares
989 it to the floating point color $expected.
990
991 =item test_colorf_glin($im, $x, $y, $pels, $comment)
992
993 Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
994 low level image $im and compares them against @$pels.
995
996 =item is_color_close3($color, $red, $green, $blue, $tolerance, $comment)
997
998 Tests if $color's first three channels are within $tolerance of ($red,
999 $green, $blue).
1000
1001 =back
1002
1003 =head2 Test suite functions
1004
1005 Functions that perform one or more tests, typically used to test
1006 various parts of Imager's implementation.
1007
1008 =over
1009
1010 =item image_bounds_checks($im)
1011
1012 Attempts to write to various pixel positions outside the edge of the
1013 image to ensure that it fails in those locations.
1014
1015 Any new image type should pass these tests.  Does 16 separate tests.
1016
1017 =item mask_tests($im, $epsilon)
1018
1019 Perform a standard set of mask tests on the OO image $im.  Does 24
1020 separate tests.
1021
1022 =item diff_text_with_nul($test_name, $text1, $text2, @options)
1023
1024 Creates 2 test images and writes $text1 to the first image and $text2
1025 to the second image with the string() method.  Each call adds 3
1026 C<ok>/C<not ok> to the output of the test script.
1027
1028 Extra options that should be supplied include the font and either a
1029 color or channel parameter.
1030
1031 This was explicitly created for regression tests on #21770.
1032
1033 =item std_font_tests({ font => $font })
1034
1035 Perform standard font interface tests.
1036
1037 =item std_font_test_count()
1038
1039 The number of tests performed by std_font_tests().
1040
1041 =back
1042
1043 =head2 Helper functions
1044
1045 =over
1046
1047 =item test_image_raw()
1048
1049 Returns a 150x150x3 Imager::ImgRaw test image.
1050
1051 =item test_image()
1052
1053 Returns a 150x150x3 8-bit/sample OO test image. Name: C<basic>.
1054
1055 =item test_image_16()
1056
1057 Returns a 150x150x3 16-bit/sample OO test image. Name: C<basic16>
1058
1059 =item test_image_double()
1060
1061 Returns a 150x150x3 double/sample OO test image. Name: C<basic_double>.
1062
1063 =item test_image_gray()
1064
1065 Returns a 150x150 single channel OO test image. Name: C<gray>.
1066
1067 =item test_image_gray_16()
1068
1069 Returns a 150x150 16-bit/sample single channel OO test image. Name:
1070 C<gray16>.
1071
1072 =item test_image_mono()
1073
1074 Returns a 150x150 bilevel image that passes the is_bilevel() test.
1075 Name: C<mono>.
1076
1077 =item test_image_named($name)
1078
1079 Return one of the other test images above based on name.
1080
1081 =item color_cmp($c1, $c2)
1082
1083 Performs an ordering of 3-channel colors (like <=>).
1084
1085 =item colorf_cmp($c1, $c2)
1086
1087 Performs an ordering of 3-channel floating point colors (like <=>).
1088
1089 =back
1090
1091 =head1 AUTHOR
1092
1093 Tony Cook <tony@develop-help.com>
1094
1095 =cut