SGI/t/20write.t

   1 #!perl -w
   2 use strict;
   3 use Imager;
   4 use Test::More tests => 57;
   5 use Imager::Test qw(test_image test_image_16 is_image);
   6 use IO::Seekable;
   7
   8 -d 'testout' or mkdir 'testout', 0777;
   9
  10 Imager::init_log('testout/20write.log', 2);
  11
  12 {
  13   my $im = test_image();
  14   $im->line(x1 => 0, y1 => 0, x2 => 150, y2 => 150, color => 'FF0000');
  15   ok($im->write(file => 'testout/20verb.rgb'), "write 8-bit verbatim")
  16     or print "# ", $im->errstr, "\n";
  17   my $im2 = Imager->new;
  18   ok($im2->read(file => 'testout/20verb.rgb'), "read it back")
  19     or print "# ", $im2->errstr, "\n";
  20   is_image($im, $im2, "compare");
  21   is($im2->tags(name => 'sgi_rle'), 0, "check not rle");
  22   is($im2->tags(name => 'sgi_bpc'), 1, "check bpc");
  23   is($im2->tags(name => 'i_comment'), undef, "no namestr");
  24
  25   ok($im->write(file => 'testout/20rle.rgb',
  26                 sgi_rle => 1,
  27                 i_comment => "test"), "write 8-bit rle")
  28     or print "# ", $im->errstr, "\n";
  29   my $im3 = Imager->new;
  30   ok($im3->read(file => 'testout/20rle.rgb'), "read it back")
  31     or print "# ", $im3->errstr, "\n";
  32   is_image($im, $im3, "compare");
  33   is($im3->tags(name => 'sgi_rle'), 1, "check not rle");
  34   is($im3->tags(name => 'sgi_bpc'), 1, "check bpc");
  35   is($im3->tags(name => 'i_comment'), 'test', "check i_comment set");
  36 }
  37
  38 {
  39   my $im = test_image_16();
  40   $im->line(x1 => 0, y1 => 0, x2 => 150, y2 => 150, color => 'FF0000');
  41   ok($im->write(file => 'testout/20verb16.rgb'), "write 16-bit verbatim")
  42     or print "# ", $im->errstr, "\n";
  43   my $im2 = Imager->new;
  44   ok($im2->read(file => 'testout/20verb16.rgb'), "read it back")
  45     or print "# ", $im2->errstr, "\n";
  46   is_image($im, $im2, "compare");
  47   is($im2->tags(name => 'sgi_rle'), 0, "check not rle");
  48   is($im2->tags(name => 'sgi_bpc'), 2, "check bpc");
  49   is($im2->tags(name => 'i_comment'), undef, "no namestr");
  50
  51   ok($im->write(file => 'testout/20rle16.rgb',
  52                 sgi_rle => 1,
  53                 i_comment => "test"), "write 16-bit rle")
  54     or print "# ", $im->errstr, "\n";
  55   my $im3 = Imager->new;
  56   ok($im3->read(file => 'testout/20rle16.rgb'), "read it back")
  57     or print "# ", $im3->errstr, "\n";
  58   is_image($im, $im3, "compare");
  59   is($im3->tags(name => 'sgi_rle'), 1, "check not rle");
  60   is($im3->tags(name => 'sgi_bpc'), 2, "check bpc");
  61   is($im3->tags(name => 'i_comment'), 'test', "check i_comment set");
  62
  63   my $imbig = Imager->new(xsize => 300, ysize => 300, bits => 16);
  64   $imbig->paste(src => $im, tx => 0,   ty => 0);
  65   $imbig->paste(src => $im, tx => 150, ty => 0);
  66   $imbig->paste(src => $im, tx => 0,   ty => 150);
  67   $imbig->paste(src => $im, tx => 150, ty => 150);
  68   for my $t (0 .. 74) {
  69     $imbig->line(x1 => $t*4, y1 => 0, x2 => 3+$t*4, y2 => 299,
  70                  color => [ 255 - $t, 0, 0 ]);
  71   }
  72   my $data;
  73   ok($imbig->write(data => \$data, type => 'sgi', sgi_rle => 1),
  74      "write larger image");
  75   cmp_ok(length($data), '>', 0x10000, "check output large enough for test");
  76   print "# ", length $data, "\n";
  77   my $imbigcmp = Imager->new;
  78   ok($imbigcmp->read(data => $data), "read larger image");
  79   is_image($imbig, $imbigcmp, "check large image matches");
  80 }
  81
  82 {
  83   # grey scale check
  84   my $im = test_image()->convert(preset=>'grey');
  85   ok($im->write(file => 'testout/20vgray8.bw'), "write 8-bit verbatim grey")
  86     or print "# ", $im->errstr, "\n";
  87   my $im2 = Imager->new;
  88   ok($im2->read(file => 'testout/20vgray8.bw'), "read it back")
  89     or print "# ", $im2->errstr, "\n";
  90   is_image($im, $im2, "compare");
  91   is($im2->tags(name => 'i_format'), 'sgi', "check we saved as SGI");
  92   is($im2->tags(name => 'sgi_rle'), 0, "check not rle");
  93   is($im2->tags(name => 'sgi_bpc'), 1, "check bpc");
  94   is($im2->tags(name => 'i_comment'), undef, "no namestr");
  95 }
  96
  97 {
  98   # write failure tests
  99   my $rgb8 = test_image();
 100   my $rgb16 = test_image_16();
 101   my $rgb8rle = $rgb8->copy;
 102   $rgb8rle->settag(name => 'sgi_rle', value => 1);
 103   my $grey8 = $rgb8->convert(preset => 'grey');
 104   my $grey16 = $rgb16->convert(preset => 'grey');
 105   my $grey16rle = $grey16->copy;
 106   $grey16rle->settag(name => 'sgi_rle', value => 1);
 107
 108   my @tests =
 109     (
 110      # each entry is: image, limit, expected msg, description
 111      [
 112       $rgb8, 500,
 113       'SGI image: cannot write header',
 114       'writing header'
 115      ],
 116      [
 117       $rgb8, 1024,
 118       'SGI image: error writing image data',
 119       '8-bit image data'
 120      ],
 121      [
 122       $grey8, 513,
 123       'SGI image: error writing image data',
 124       '8-bit image data (grey)'
 125      ],
 126      [
 127       $rgb8rle, 513,
 128       'SGI image: error writing offsets/lengths',
 129       'rle tables, 8 bit',
 130      ],
 131      [
 132       $rgb8rle, 4112,
 133       'SGI image: error writing RLE data',
 134       '8-bit rle data',
 135      ],
 136      [
 137       $rgb8rle, 14707,
 138       'SGI image: cannot write final RLE table',
 139       '8-bit rewrite RLE table',
 140      ],
 141      [
 142       $rgb16, 513,
 143       'SGI image: error writing image data',
 144       '16-bit image data',
 145      ],
 146      [
 147       $grey16rle, 513,
 148       'SGI image: error writing offsets/lengths',
 149       'rle tables, 16 bit',
 150      ],
 151      [
 152       $grey16rle, 1713,
 153       'SGI image: error writing RLE data',
 154       '16-bit rle data',
 155      ],
 156      [
 157       $grey16rle, 10871,
 158       'SGI image: cannot write final RLE table',
 159       '16-bit rewrite RLE table',
 160      ],
 161     );
 162   for my $test (@tests) {
 163     my ($im, $limit, $expected_msg, $desc) = @$test;
 164     my $io = limited_write_io($limit);
 165     ok(!$im->write(type => 'sgi', io => $io),
 166        "write should fail - $desc");
 167     is($im->errstr, "$expected_msg: limit reached", "check error - $desc");
 168   }
 169 }
 170
 171
 172 { # check close failures are handled correctly
 173   my $im = test_image();
 174   my $fail_close = sub {
 175     Imager::i_push_error(0, "synthetic close failure");
 176     return 0;
 177   };
 178   ok(!$im->write(type => "sgi", callback => sub { 1 },
 179                  closecb => $fail_close),
 180      "check failing close fails");
 181     like($im->errstr, qr/synthetic close failure/,
 182          "check error message");
 183 }
 184
 185 sub limited_write_io {
 186   my ($limit) = @_;
 187
 188   my ($writecb, $seekcb) = limited_write($limit);
 189
 190   my $io = Imager::io_new_cb($writecb, undef, $seekcb, undef, 1);
 191   $io->set_buffered(0);
 192
 193   return $io;
 194 }
 195
 196 sub limited_write {
 197   my ($limit) = @_;
 198
 199   my $pos = 0;
 200   my $written = 0;
 201   return
 202     (
 203      # write callback
 204      sub {
 205        my ($data) = @_;
 206        # limit total written so we can fail the offset table write for RLE
 207        $written += length $data;
 208        if ($written <= $limit) {
 209          $pos += length $data;
 210          print "# write of ", length $data, " bytes successful (",
 211            $limit - $written, " left)\n";
 212          return 1;
 213        }
 214        else {
 215          print "# write of ", length $data, " bytes failed\n";
 216          Imager::i_push_error(0, "limit reached");
 217          return;
 218        }
 219      },
 220      # seek cb
 221      sub {
 222        my ($position, $whence) = @_;
 223
 224        if ($whence == SEEK_SET) {
 225          $pos = $position;
 226          print "# seek to $pos\n";
 227        }
 228        elsif ($whence == SEEK_END) {
 229          die "SEEK_END not supported\n";
 230        }
 231        elsif ($whence == SEEK_CUR) {
 232          die "SEEK_CUR not supported\n";
 233        }
 234        else {
 235          die "Invalid seek whence $whence";
 236        }
 237
 238        $pos;
 239      }
 240     )
 241 }