- Finished/rewrote Arnar's old SGI RGB file format support, so Imager
[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 test_image_raw test_image_16 test_image 
8                 is_color3 is_color1 is_color4 
9                 is_fcolor4
10                 is_image is_image_similar 
11                 image_bounds_checks);
12
13 sub diff_text_with_nul {
14   my ($desc, $text1, $text2, @params) = @_;
15
16   my $builder = Test::Builder->new;
17
18   print "# $desc\n";
19   my $imbase = Imager->new(xsize => 100, ysize => 100);
20   my $imcopy = Imager->new(xsize => 100, ysize => 100);
21
22   $builder->ok($imbase->string(x => 5, 'y' => 50, size => 20,
23                                string => $text1,
24                                @params), "$desc - draw text1");
25   $builder->ok($imcopy->string(x => 5, 'y' => 50, size => 20,
26                                string => $text2,
27                                @params), "$desc - draw text2");
28   $builder->isnt_num(Imager::i_img_diff($imbase->{IMG}, $imcopy->{IMG}), 0,
29                      "$desc - check result different");
30 }
31
32 sub is_color3($$$$$) {
33   my ($color, $red, $green, $blue, $comment) = @_;
34
35   my $builder = Test::Builder->new;
36
37   unless (defined $color) {
38     $builder->ok(0, $comment);
39     $builder->diag("color is undef");
40     return;
41   }
42   unless ($color->can('rgba')) {
43     $builder->ok(0, $comment);
44     $builder->diag("color is not a color object");
45     return;
46   }
47
48   my ($cr, $cg, $cb) = $color->rgba;
49   unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue, $comment)) {
50     $builder->diag(<<END_DIAG);
51 Color mismatch:
52   Red: $red vs $cr
53 Green: $green vs $cg
54  Blue: $blue vs $cb
55 END_DIAG
56     return;
57   }
58
59   return 1;
60 }
61
62 sub is_color4($$$$$$) {
63   my ($color, $red, $green, $blue, $alpha, $comment) = @_;
64
65   my $builder = Test::Builder->new;
66
67   unless (defined $color) {
68     $builder->ok(0, $comment);
69     $builder->diag("color is undef");
70     return;
71   }
72   unless ($color->can('rgba')) {
73     $builder->ok(0, $comment);
74     $builder->diag("color is not a color object");
75     return;
76   }
77
78   my ($cr, $cg, $cb, $ca) = $color->rgba;
79   unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue 
80                        && $ca == $alpha, $comment)) {
81     $builder->diag(<<END_DIAG);
82 Color mismatch:
83   Red: $red vs $cr
84 Green: $green vs $cg
85  Blue: $blue vs $cb
86 Alpha: $alpha vs $ca
87 END_DIAG
88     return;
89   }
90
91   return 1;
92 }
93
94 sub is_fcolor4($$$$$$;$) {
95   my ($color, $red, $green, $blue, $alpha, $comment_or_diff, $comment_or_undef) = @_;
96   my ($comment, $mindiff);
97   if (defined $comment_or_undef) {
98     ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef )
99   }
100   else {
101     ( $mindiff, $comment ) = ( 0.001, $comment_or_diff )
102   }
103
104   my $builder = Test::Builder->new;
105
106   unless (defined $color) {
107     $builder->ok(0, $comment);
108     $builder->diag("color is undef");
109     return;
110   }
111   unless ($color->can('rgba')) {
112     $builder->ok(0, $comment);
113     $builder->diag("color is not a color object");
114     return;
115   }
116
117   my ($cr, $cg, $cb, $ca) = $color->rgba;
118   unless ($builder->ok(abs($cr - $red) <= $mindiff
119                        && abs($cg - $green) <= $mindiff
120                        && abs($cb - $blue) <= $mindiff
121                        && abs($ca - $alpha) <= $mindiff, $comment)) {
122     $builder->diag(<<END_DIAG);
123 Color mismatch:
124   Red: $red vs $cr
125 Green: $green vs $cg
126  Blue: $blue vs $cb
127 Alpha: $alpha vs $ca
128 END_DIAG
129     return;
130   }
131
132   return 1;
133 }
134
135 sub is_color1($$$) {
136   my ($color, $grey, $comment) = @_;
137
138   my $builder = Test::Builder->new;
139
140   unless (defined $color) {
141     $builder->ok(0, $comment);
142     $builder->diag("color is undef");
143     return;
144   }
145   unless ($color->can('rgba')) {
146     $builder->ok(0, $comment);
147     $builder->diag("color is not a color object");
148     return;
149   }
150
151   my ($cgrey) = $color->rgba;
152   unless ($builder->ok($cgrey == $grey, $comment)) {
153     $builder->diag(<<END_DIAG);
154 Color mismatch:
155   Grey: $grey vs $cgrey
156 END_DIAG
157     return;
158   }
159
160   return 1;
161 }
162
163 sub test_image_raw {
164   my $green=Imager::i_color_new(0,255,0,255);
165   my $blue=Imager::i_color_new(0,0,255,255);
166   my $red=Imager::i_color_new(255,0,0,255);
167   
168   my $img=Imager::ImgRaw::new(150,150,3);
169   
170   Imager::i_box_filled($img,70,25,130,125,$green);
171   Imager::i_box_filled($img,20,25,80,125,$blue);
172   Imager::i_arc($img,75,75,30,0,361,$red);
173   Imager::i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
174
175   $img;
176 }
177
178 sub test_image {
179   my $green = Imager::Color->new(0, 255, 0, 255);
180   my $blue  = Imager::Color->new(0, 0, 255, 255);
181   my $red   = Imager::Color->new(255, 0, 0, 255);
182   my $img = Imager->new(xsize => 150, ysize => 150);
183   $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
184   $img->box(filled => 1, color => $blue,  box => [ 20, 26, 80, 126 ]);
185   $img->arc(x => 75, y => 75, r => 30, color => $red);
186   $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
187
188   $img;
189 }
190
191 sub test_image_16 {
192   my $green = Imager::Color->new(0, 255, 0, 255);
193   my $blue  = Imager::Color->new(0, 0, 255, 255);
194   my $red   = Imager::Color->new(255, 0, 0, 255);
195   my $img = Imager->new(xsize => 150, ysize => 150, bits => 16);
196   $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]);
197   $img->box(filled => 1, color => $blue,  box => [ 20, 25, 80, 125 ]);
198   $img->arc(x => 75, y => 75, r => 30, color => $red);
199   $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
200
201   $img;
202 }
203
204 sub is_image_similar($$$$) {
205   my ($left, $right, $limit, $comment) = @_;
206
207   my $builder = Test::Builder->new;
208
209   unless (defined $left) {
210     $builder->ok(0, $comment);
211     $builder->diag("left is undef");
212     return;
213   } 
214   unless (defined $right) {
215     $builder->ok(0, $comment);
216     $builder->diag("right is undef");
217     return;
218   }
219   unless ($left->{IMG}) {
220     $builder->ok(0, $comment);
221     $builder->diag("left image has no low level object");
222     return;
223   }
224   unless ($right->{IMG}) {
225     $builder->ok(0, $comment);
226     $builder->diag("right image has no low level object");
227     return;
228   }
229   unless ($left->getwidth == $right->getwidth) {
230     $builder->ok(0, $comment);
231     $builder->diag("left width " . $left->getwidth . " vs right width " 
232                    . $right->getwidth);
233     return;
234   }
235   unless ($left->getheight == $right->getheight) {
236     $builder->ok(0, $comment);
237     $builder->diag("left height " . $left->getheight . " vs right height " 
238                    . $right->getheight);
239     return;
240   }
241   unless ($left->getchannels == $right->getchannels) {
242     $builder->ok(0, $comment);
243     $builder->diag("left channels " . $left->getchannels . " vs right channels " 
244                    . $right->getchannels);
245     return;
246   }
247   my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
248   if ($diff > $limit) {
249     $builder->ok(0, $comment);
250     $builder->diag("image data difference > $limit - $diff");
251     return;
252   }
253   
254   return $builder->ok(1, $comment);
255 }
256
257 sub is_image($$$) {
258   my ($left, $right, $comment) = @_;
259
260   local $Test::Builder::Level = $Test::Builder::Level + 1;
261
262   return is_image_similar($left, $right, 0, $comment);
263 }
264
265 sub image_bounds_checks {
266   my $im = shift;
267
268   my $builder = Test::Builder->new;
269
270   $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0)');
271   $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0)');
272   $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1)');
273   $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10)');
274   $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0) float');
275   $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0) float');
276   $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1) float');
277   $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10) float');
278   my $black = Imager::Color->new(0, 0, 0);
279   require Imager::Color::Float;
280   my $blackf = Imager::Color::Float->new(0, 0, 0);
281   $builder->ok(!$im->setpixel(x => -1, y => 0, color => $black), 'bounds check set (-1, 0)');
282   $builder->ok(!$im->setpixel(x => 10, y => 0, color => $black), 'bounds check set (10, 0)');
283   $builder->ok(!$im->setpixel(x => 0, y => -1, color => $black), 'bounds check set (0, -1)');
284   $builder->ok(!$im->setpixel(x => 0, y => 10, color => $black), 'bounds check set (0, 10)');
285   $builder->ok(!$im->setpixel(x => -1, y => 0, color => $blackf), 'bounds check set (-1, 0) float');
286   $builder->ok(!$im->setpixel(x => 10, y => 0, color => $blackf), 'bounds check set (10, 0) float');
287   $builder->ok(!$im->setpixel(x => 0, y => -1, color => $blackf), 'bounds check set (0, -1) float');
288   $builder->ok(!$im->setpixel(x => 0, y => 10, color => $blackf), 'bounds check set (0, 10) float');
289 }
290
291 1;
292
293 __END__
294
295 =head1 NAME
296
297 Imager::Test - common functions used in testing Imager
298
299 =head1 SYNOPSIS
300
301   use Imager::Test 'diff_text_with_nul';
302   diff_text_with_nul($test_name, $text1, $text2, @string_options);
303
304 =head1 DESCRIPTION
305
306 This is a repository of functions used in testing Imager.
307
308 Some functions will only be useful in testing Imager itself, while
309 others should be useful in testing modules that use Imager.
310
311 No functions are exported by default.
312
313 =head1 FUNCTIONS
314
315 =over
316
317 =item is_color3($color, $red, $blue, $green, $comment)
318
319 Tests is $color matches the given ($red, $blue, $green)
320
321 =item is_image($im1, $im2, $comment)
322
323 Tests if the 2 images have the same content.  Both images must be
324 defined, have the same width, height, channels and the same color in
325 each pixel.  The color comparison is done at 8-bits per pixel.  The
326 color representation such as direct vs paletted, bits per sample are
327 not checked.  Equivalent to is_image_similar($im1, $im2, 0, $comment).
328
329 =item is_image_similar($im1, $im2, $maxdiff, $comment)
330
331 Tests if the 2 images have similar content.  Both images must be
332 defined, have the same width, height and channels.  The cum of the
333 squares of the differences of each sample are calculated and must be
334 less than or equal to I<$maxdiff> for the test to pass.  The color
335 comparison is done at 8-bits per pixel.  The color representation such
336 as direct vs paletted, bits per sample are not checked.
337
338 =item test_image_raw()
339
340 Returns a 150x150x3 Imager::ImgRaw test image.
341
342 =item test_image()
343
344 Returns a 150x150x3 8-bit/sample OO test image.
345
346 =item test_image_16()
347
348 Returns a 150x150x3 16-bit/sample OO test image.
349
350 =item diff_text_with_nul($test_name, $text1, $text2, @options)
351
352 Creates 2 test images and writes $text1 to the first image and $text2
353 to the second image with the string() method.  Each call adds 3 ok/not
354 ok to the output of the test script.
355
356 Extra options that should be supplied include the font and either a
357 color or channel parameter.
358
359 This was explicitly created for regression tests on #21770.
360
361 =item image_bounds_checks($im)
362
363 Attempts to write to various pixel positions outside the edge of the
364 image to ensure that it fails in those locations.
365
366 Any new image type should pass these tests.  Does 16 separate tests.
367
368 =back
369
370 =head1 AUTHOR
371
372 Tony Cook <tony@develop-help.com>
373
374 =cut