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