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