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