planning too far ahead
[imager.git] / lib / Imager / Test.pm
CommitLineData
9a6ab99c
TC
1package Imager::Test;
2use strict;
3use Test::Builder;
4require Exporter;
5use vars qw(@ISA @EXPORT_OK);
6@ISA = qw(Exporter);
b3aa972f
TC
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);
9a6ab99c
TC
12
13sub 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
9c106321
TC
32sub 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);
51Color mismatch:
52 Red: $red vs $cr
53Green: $green vs $cg
54 Blue: $blue vs $cb
55END_DIAG
56 return;
57 }
58
59 return 1;
60}
61
b3aa972f
TC
62sub 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);
82Color mismatch:
83 Red: $red vs $cr
84Green: $green vs $cg
85 Blue: $blue vs $cb
86Alpha: $alpha vs $ca
87END_DIAG
88 return;
89 }
90
91 return 1;
92}
93
94sub 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);
123Color mismatch:
124 Red: $red vs $cr
125Green: $green vs $cg
126 Blue: $blue vs $cb
127Alpha: $alpha vs $ca
128END_DIAG
129 return;
130 }
131
132 return 1;
133}
134
9c106321
TC
135sub 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);
154Color mismatch:
155 Grey: $grey vs $cgrey
156END_DIAG
157 return;
158 }
159
160 return 1;
161}
162
163sub 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
167660cd
TC
178sub 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);
d5477d3d
TC
183 $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
184 $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]);
167660cd
TC
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
9c106321
TC
191sub 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
167660cd
TC
204sub is_image_similar($$$$) {
205 my ($left, $right, $limit, $comment) = @_;
9c106321
TC
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});
167660cd 248 if ($diff > $limit) {
9c106321 249 $builder->ok(0, $comment);
167660cd 250 $builder->diag("image data difference > $limit - $diff");
9c106321
TC
251 return;
252 }
253
254 return $builder->ok(1, $comment);
255}
256
167660cd
TC
257sub 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
837a4b43
TC
265sub 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}
167660cd 290
9a6ab99c
TC
2911;
292
293__END__
294
295=head1 NAME
296
297Imager::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
306This is a repository of functions used in testing Imager.
307
308Some functions will only be useful in testing Imager itself, while
309others should be useful in testing modules that use Imager.
310
311No functions are exported by default.
312
313=head1 FUNCTIONS
314
315=over
316
9c106321
TC
317=item is_color3($color, $red, $blue, $green, $comment)
318
319Tests is $color matches the given ($red, $blue, $green)
320
ae12796a
TC
321=item is_image($im1, $im2, $comment)
322
323Tests if the 2 images have the same content. Both images must be
324defined, have the same width, height, channels and the same color in
325each pixel. The color comparison is done at 8-bits per pixel. The
326color representation such as direct vs paletted, bits per sample are
2fac3132
TC
327not checked. Equivalent to is_image_similar($im1, $im2, 0, $comment).
328
329=item is_image_similar($im1, $im2, $maxdiff, $comment)
330
331Tests if the 2 images have similar content. Both images must be
332defined, have the same width, height and channels. The cum of the
333squares of the differences of each sample are calculated and must be
334less than or equal to I<$maxdiff> for the test to pass. The color
335comparison is done at 8-bits per pixel. The color representation such
336as direct vs paletted, bits per sample are not checked.
ae12796a 337
9c106321
TC
338=item test_image_raw()
339
340Returns a 150x150x3 Imager::ImgRaw test image.
341
d5477d3d
TC
342=item test_image()
343
344Returns a 150x150x3 8-bit/sample OO test image.
345
9c106321
TC
346=item test_image_16()
347
348Returns a 150x150x3 16-bit/sample OO test image.
349
350=item diff_text_with_nul($test_name, $text1, $text2, @options)
9a6ab99c
TC
351
352Creates 2 test images and writes $text1 to the first image and $text2
353to the second image with the string() method. Each call adds 3 ok/not
354ok to the output of the test script.
355
356Extra options that should be supplied include the font and either a
357color or channel parameter.
358
359This was explicitly created for regression tests on #21770.
360
2fac3132
TC
361=item image_bounds_checks($im)
362
363Attempts to write to various pixel positions outside the edge of the
364image to ensure that it fails in those locations.
365
366Any new image type should pass these tests. Does 16 separate tests.
367
9a6ab99c
TC
368=back
369
370=head1 AUTHOR
371
372Tony Cook <tony@develop-help.com>
373
374=cut