]>
Commit | Line | Data |
---|---|---|
10461f9a | 1 | #!perl -w |
02d1d628 AMH |
2 | ######################### We start with some black magic to print on failure. |
3 | ||
10461f9a TC |
4 | # this used to do the check for the load of Imager, but I want to be able |
5 | # to count tests, which means I need to load Imager first | |
6 | # since many of the early tests already do this, we don't really need to | |
02d1d628 | 7 | |
10461f9a | 8 | use strict; |
02d1d628 | 9 | use Imager; |
10461f9a | 10 | use IO::Seekable; |
e2cb7e23 | 11 | |
feba68a3 TC |
12 | my $buggy_giflib_file = "buggy_giflib.txt"; |
13 | ||
40e78f96 TC |
14 | -d "testout" or mkdir "testout"; |
15 | ||
10461f9a | 16 | Imager::init("log"=>"testout/t50basicoo.log"); |
02d1d628 | 17 | |
10461f9a | 18 | # single image/file types |
b6071a43 | 19 | my @types = qw( jpeg png raw pnm gif tiff bmp tga ); |
02d1d628 | 20 | |
10461f9a TC |
21 | # multiple image/file formats |
22 | my @mtypes = qw(tiff gif); | |
23 | ||
24 | my %hsh=%Imager::formats; | |
25 | ||
26 | my $test_num = 0; | |
27 | my $count; | |
28 | for my $type (@types) { | |
29 | $count += 31 if $hsh{$type}; | |
30 | } | |
31 | for my $type (@mtypes) { | |
32 | $count += 7 if $hsh{$type}; | |
33 | } | |
02d1d628 | 34 | |
10461f9a | 35 | print "1..$count\n"; |
02d1d628 AMH |
36 | |
37 | print "# avaliable formats:\n"; | |
38 | for(keys %hsh) { print "# $_\n"; } | |
39 | ||
40 | #print Dumper(\%hsh); | |
41 | ||
10461f9a | 42 | my $img = Imager->new(); |
e2cb7e23 | 43 | |
10461f9a | 44 | my %files; |
797a9f9c | 45 | @files{@types} = ({ file => "JPEG/testimg/209_yonge.jpg" }, |
b6071a43 TC |
46 | { file => "testimg/test.png" }, |
47 | { file => "testimg/test.raw", xsize=>150, ysize=>150, type=>'raw', interleave => 0}, | |
48 | { file => "testimg/penguin-base.ppm" }, | |
ec6d8908 | 49 | { file => "GIF/testimg/expected.gif" }, |
e5ee047b | 50 | { file => "TIFF/testimg/comp8.tif" }, |
b6071a43 TC |
51 | { file => "testimg/winrgb24.bmp" }, |
52 | { file => "testimg/test.tga" }, ); | |
10461f9a TC |
53 | my %writeopts = |
54 | ( | |
97c4effc TC |
55 | gif=> { make_colors=>'webmap', translate=>'closest', gifquant=>'gen', |
56 | gif_delay=>20 }, | |
10461f9a | 57 | ); |
e2cb7e23 | 58 | |
10461f9a | 59 | for my $type (@types) { |
e2cb7e23 | 60 | next unless $hsh{$type}; |
10461f9a | 61 | print "# type $type\n"; |
e2cb7e23 AMH |
62 | my %opts = %{$files{$type}}; |
63 | my @a = map { "$_=>${opts{$_}}" } keys %opts; | |
64 | print "#opening Format: $type, options: @a\n"; | |
10461f9a TC |
65 | ok($img->read( %opts ), "reading from file", $img); |
66 | #or die "failed: ",$img->errstr,"\n"; | |
67 | ||
68 | my %mopts = %opts; | |
69 | delete $mopts{file}; | |
527c0c3e | 70 | |
10461f9a TC |
71 | # read from a file handle |
72 | my $fh = IO::File->new($opts{file}, "r"); | |
73 | if (ok($fh, "opening $opts{file}")) { | |
74 | binmode $fh; | |
75 | my $fhimg = Imager->new; | |
87a572e5 AMH |
76 | if (ok($fhimg->read(fh=>$fh, %mopts), "read from fh")) { |
77 | ok($fh->seek(0, SEEK_SET), "seek after read"); | |
78 | if (ok($fhimg->read(fh=>$fh, %mopts, type=>$type), "read from fh")) { | |
79 | ok(Imager::i_img_diff($img->{IMG}, $fhimg->{IMG}) == 0, | |
80 | "image comparison after fh read"); | |
81 | } | |
82 | else { | |
83 | skip("no image to compare"); | |
84 | } | |
85 | ok($fh->seek(0, SEEK_SET), "seek after read"); | |
10461f9a | 86 | } |
527c0c3e | 87 | |
10461f9a TC |
88 | # read from a fd |
89 | my $fdimg = Imager->new; | |
87a572e5 | 90 | if (ok($fdimg->read(fd=>fileno($fh), %mopts, type=>$type), "read from fd")) { |
10461f9a TC |
91 | ok(Imager::i_img_diff($img->{IMG}, $fdimg->{IMG}) == 0, |
92 | "image comparistion after fd read"); | |
93 | } | |
94 | else { | |
95 | skip("no image to compare"); | |
96 | } | |
97 | ok($fh->seek(0, SEEK_SET), "seek after fd read"); | |
98 | ok($fh->close, "close fh after reads"); | |
99 | } | |
100 | else { | |
101 | skip("couldn't open the damn file: $!", 7); | |
102 | } | |
103 | ||
ec6d8908 TC |
104 | # read from a memory buffer |
105 | open DATA, "< $opts{file}" | |
106 | or die "Cannot open $opts{file}: $!"; | |
107 | binmode DATA; | |
108 | my $data = do { local $/; <DATA> }; | |
109 | close DATA; | |
110 | my $bimg = Imager->new; | |
111 | ||
112 | if (ok($bimg->read(data=>$data, %mopts, type=>$type), "read from buffer", | |
113 | $img)) { | |
114 | ok(Imager::i_img_diff($img->{IMG}, $bimg->{IMG}) == 0, | |
115 | "comparing buffer read image"); | |
10461f9a TC |
116 | } |
117 | else { | |
ec6d8908 | 118 | skip("nothing to compare"); |
10461f9a | 119 | } |
ec6d8908 TC |
120 | |
121 | # read from callbacks, both with minimum and maximum reads | |
122 | my $buf = $data; | |
123 | my $seekpos = 0; | |
124 | my $reader_min = | |
125 | sub { | |
126 | my ($size, $maxread) = @_; | |
127 | my $out = substr($buf, $seekpos, $size); | |
128 | $seekpos += length $out; | |
129 | $out; | |
130 | }; | |
131 | my $reader_max = | |
132 | sub { | |
133 | my ($size, $maxread) = @_; | |
134 | my $out = substr($buf, $seekpos, $maxread); | |
135 | $seekpos += length $out; | |
136 | $out; | |
137 | }; | |
138 | my $seeker = | |
139 | sub { | |
140 | my ($offset, $whence) = @_; | |
141 | #print "io_seeker($offset, $whence)\n"; | |
142 | if ($whence == SEEK_SET) { | |
143 | $seekpos = $offset; | |
144 | } | |
145 | elsif ($whence == SEEK_CUR) { | |
146 | $seekpos += $offset; | |
147 | } | |
148 | else { # SEEK_END | |
149 | $seekpos = length($buf) + $offset; | |
150 | } | |
151 | #print "-> $seekpos\n"; | |
152 | $seekpos; | |
153 | }; | |
154 | my $cbimg = Imager->new; | |
155 | ok($cbimg->read(callback=>$reader_min, seekcb=>$seeker, type=>$type, %mopts), | |
156 | "read from callback min", $cbimg); | |
157 | ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0, | |
158 | "comparing mincb image"); | |
159 | $seekpos = 0; | |
160 | ok($cbimg->read(callback=>$reader_max, seekcb=>$seeker, type=>$type, %mopts), | |
161 | "read from callback max", $cbimg); | |
162 | ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0, | |
163 | "comparing maxcb image"); | |
02d1d628 AMH |
164 | } |
165 | ||
10461f9a TC |
166 | for my $type (@types) { |
167 | next unless $hsh{$type}; | |
168 | ||
169 | print "# write tests for $type\n"; | |
170 | # test writes | |
171 | next unless $hsh{$type}; | |
172 | my $file = "testout/t50out.$type"; | |
173 | my $wimg = Imager->new; | |
174 | # if this doesn't work, we're so screwed up anyway | |
175 | ||
b6071a43 | 176 | ok($wimg->read(file=>"testimg/penguin-base.ppm"), |
10461f9a TC |
177 | "cannot read base file", $wimg); |
178 | ||
179 | # first to a file | |
180 | print "# writing $type to a file\n"; | |
181 | my %extraopts; | |
182 | %extraopts = %{$writeopts{$type}} if $writeopts{$type}; | |
183 | ok($wimg->write(file=>$file, %extraopts), | |
184 | "writing $type to a file $file", $wimg); | |
185 | ||
186 | print "# writing $type to a FH\n"; | |
187 | # to a FH | |
188 | my $fh = IO::File->new($file, "w+") | |
189 | or die "Could not create $file: $!"; | |
190 | binmode $fh; | |
191 | ok($wimg->write(fh=>$fh, %extraopts, type=>$type), | |
192 | "writing $type to a FH", $wimg); | |
193 | ok($fh->seek(0, SEEK_END) > 0, | |
194 | "seek after writing $type to a FH"); | |
195 | ok(print($fh "SUFFIX\n"), | |
196 | "write to FH after writing $type"); | |
197 | ok($fh->close, "closing FH after writing $type"); | |
198 | ||
ec6d8908 TC |
199 | if (ok(open(DATA, "< $file"), "opening data source")) { |
200 | binmode DATA; | |
201 | my $data = do { local $/; <DATA> }; | |
202 | close DATA; | |
203 | ||
204 | # writing to a buffer | |
205 | print "# writing $type to a buffer\n"; | |
206 | my $buf = ''; | |
207 | ok($wimg->write(data=>\$buf, %extraopts, type=>$type), | |
208 | "writing $type to a buffer", $wimg); | |
209 | $buf .= "SUFFIX\n"; | |
210 | open DATA, "> testout/t50_buf.$type" | |
211 | or die "Cannot create $type buffer file: $!"; | |
212 | binmode DATA; | |
213 | print DATA $buf; | |
214 | close DATA; | |
215 | ok($data eq $buf, "comparing file data to buffer"); | |
216 | ||
217 | $buf = ''; | |
218 | my $seekpos = 0; | |
219 | my $did_close; | |
220 | my $writer = | |
221 | sub { | |
222 | my ($what) = @_; | |
223 | if ($seekpos > length $buf) { | |
224 | $buf .= "\0" x ($seekpos - length $buf); | |
225 | } | |
226 | substr($buf, $seekpos, length $what) = $what; | |
227 | $seekpos += length $what; | |
228 | $did_close = 0; # the close must be last | |
229 | 1; | |
230 | }; | |
231 | my $reader_min = | |
232 | sub { | |
233 | my ($size, $maxread) = @_; | |
234 | my $out = substr($buf, $seekpos, $size); | |
235 | $seekpos += length $out; | |
236 | $out; | |
237 | }; | |
238 | my $reader_max = | |
239 | sub { | |
240 | my ($size, $maxread) = @_; | |
241 | my $out = substr($buf, $seekpos, $maxread); | |
242 | $seekpos += length $out; | |
243 | $out; | |
244 | }; | |
245 | use IO::Seekable; | |
246 | my $seeker = | |
247 | sub { | |
248 | my ($offset, $whence) = @_; | |
249 | #print "io_seeker($offset, $whence)\n"; | |
250 | if ($whence == SEEK_SET) { | |
251 | $seekpos = $offset; | |
252 | } | |
253 | elsif ($whence == SEEK_CUR) { | |
254 | $seekpos += $offset; | |
255 | } | |
256 | else { # SEEK_END | |
257 | $seekpos = length($buf) + $offset; | |
258 | } | |
259 | #print "-> $seekpos\n"; | |
260 | $seekpos; | |
261 | }; | |
262 | ||
263 | my $closer = sub { ++$did_close; }; | |
264 | ||
265 | print "# writing $type via callbacks (mb=1)\n"; | |
266 | ok($wimg->write(writecb=>$writer, seekcb=>$seeker, closecb=>$closer, | |
267 | readcb=>$reader_min, | |
268 | %extraopts, type=>$type, maxbuffer=>1), | |
269 | "writing $type to callback (mb=1)", $wimg); | |
270 | ||
271 | ok($did_close, "checking closecb called"); | |
272 | $buf .= "SUFFIX\n"; | |
273 | ok($data eq $buf, "comparing callback output to file data"); | |
274 | print "# writing $type via callbacks (no mb)\n"; | |
275 | $buf = ''; | |
276 | $did_close = 0; | |
277 | $seekpos = 0; | |
278 | # we don't use the closecb here - used to make sure we don't get | |
279 | # a warning/error on an attempt to call an undef close sub | |
280 | ok($wimg->write(writecb=>$writer, seekcb=>$seeker, readcb=>$reader_min, | |
281 | %extraopts, type=>$type), | |
282 | "writing $type to callback (no mb)", $wimg); | |
283 | $buf .= "SUFFIX\n"; | |
284 | ok($data eq $buf, "comparing callback output to file data"); | |
10461f9a TC |
285 | } |
286 | else { | |
ec6d8908 | 287 | skip("couldn't open data source", 7); |
10461f9a TC |
288 | } |
289 | } | |
290 | ||
291 | my $img2 = $img->crop(width=>50, height=>50); | |
895dbd34 | 292 | $img2 -> write(file=> 'testout/t50.ppm', type=>'pnm'); |
02d1d628 AMH |
293 | |
294 | undef($img); | |
295 | ||
10461f9a TC |
296 | # multi image/file tests |
297 | print "# multi-image write tests\n"; | |
298 | for my $type (@mtypes) { | |
299 | next unless $hsh{$type}; | |
300 | print "# $type\n"; | |
301 | ||
302 | my $file = "testout/t50out.$type"; | |
303 | my $wimg = Imager->new; | |
304 | ||
305 | # if this doesn't work, we're so screwed up anyway | |
306 | ok($wimg->read(file=>"testout/t50out.$type"), | |
307 | "reading base file", $wimg); | |
308 | ||
309 | ok(my $wimg2 = $wimg->copy, "copying base image", $wimg); | |
310 | ok($wimg2->flip(dir=>'h'), "flipping base image", $wimg2); | |
311 | ||
312 | my @out = ($wimg, $wimg2); | |
313 | my %extraopts; | |
314 | %extraopts = %{$writeopts{$type}} if $writeopts{$type}; | |
315 | ok(Imager->write_multi({ file=>"testout/t50_multi.$type", %extraopts }, | |
316 | @out), | |
317 | "writing multiple to a file", "Imager"); | |
318 | ||
319 | # make sure we get the same back | |
320 | my @images = Imager->read_multi(file=>"testout/t50_multi.$type"); | |
321 | if (ok(@images == @out, "checking read image count")) { | |
322 | for my $i (0 .. $#out) { | |
323 | my $diff = Imager::i_img_diff($out[$i]{IMG}, $images[$i]{IMG}); | |
324 | print "# diff $diff\n"; | |
325 | ok($diff == 0, "comparing image $i"); | |
326 | } | |
327 | } | |
328 | else { | |
329 | skip("wrong number of images read", 2); | |
330 | } | |
331 | } | |
332 | ||
333 | ||
e2cb7e23 | 334 | Imager::malloc_state(); |
02d1d628 | 335 | |
10461f9a TC |
336 | #print "ok 2\n"; |
337 | ||
338 | sub ok { | |
87a572e5 | 339 | my ($ok, $msg, $img, $why, $skipcount) = @_; |
10461f9a TC |
340 | |
341 | ++$test_num; | |
342 | if ($ok) { | |
343 | print "ok $test_num # $msg\n"; | |
bf1573f9 | 344 | Imager::i_log_entry("ok $test_num # $msg\n", 0); |
10461f9a TC |
345 | } |
346 | else { | |
347 | my $err; | |
348 | $err = $img->errstr if $img; | |
349 | # VMS (if we ever support it) wants the whole line in one print | |
350 | my $line = "not ok $test_num # line ".(caller)[2].": $msg"; | |
351 | $line .= ": $err" if $err; | |
352 | print $line, "\n"; | |
bf1573f9 | 353 | Imager::i_log_entry($line."\n", 0); |
10461f9a | 354 | } |
87a572e5 | 355 | skip($why, $skipcount) if defined $why; |
10461f9a TC |
356 | $ok; |
357 | } | |
358 | ||
359 | sub skip { | |
360 | my ($why, $skipcount) = @_; | |
361 | ||
362 | $skipcount ||= 1; | |
363 | for (1.. $skipcount) { | |
364 | ++$test_num; | |
365 | print "ok $test_num # skipped $why\n"; | |
366 | } | |
367 | } |