SGI/t/20write.t

   1 #!perl -w
   2 use strict;
   3 use Imager;
   4 use Test::More tests => 51;
   5 use Imager::Test qw(test_image test_image_16 is_image);
   6 use Fcntl ':seek';
   7
   8 -d 'testout' or mkdir 'testout';
   9
  10 Imager::init_log('testout/20write.log', 2);
  11
  12 {
  13   my $im = test_image();
  14   ok($im->write(file => 'testout/20verb.rgb'), "write 8-bit verbatim")
  15     or print "# ", $im->errstr, "\n";
  16   my $im2 = Imager->new;
  17   ok($im2->read(file => 'testout/20verb.rgb'), "read it back")
  18     or print "# ", $im2->errstr, "\n";
  19   is_image($im, $im2, "compare");
  20   is($im2->tags(name => 'sgi_rle'), 0, "check not rle");
  21   is($im2->tags(name => 'sgi_bpc'), 1, "check bpc");
  22   is($im2->tags(name => 'i_comment'), undef, "no namestr");
  23
  24   ok($im->write(file => 'testout/20rle.rgb',
  25                 sgi_rle => 1,
  26                 i_comment => "test"), "write 8-bit rle")
  27     or print "# ", $im->errstr, "\n";
  28   my $im3 = Imager->new;
  29   ok($im3->read(file => 'testout/20rle.rgb'), "read it back")
  30     or print "# ", $im3->errstr, "\n";
  31   is_image($im, $im3, "compare");
  32   is($im3->tags(name => 'sgi_rle'), 1, "check not rle");
  33   is($im3->tags(name => 'sgi_bpc'), 1, "check bpc");
  34   is($im3->tags(name => 'i_comment'), 'test', "check i_comment set");
  35 }
  36
  37 {
  38   my $im = test_image_16();
  39   ok($im->write(file => 'testout/20verb16.rgb'), "write 16-bit verbatim")
  40     or print "# ", $im->errstr, "\n";
  41   my $im2 = Imager->new;
  42   ok($im2->read(file => 'testout/20verb16.rgb'), "read it back")
  43     or print "# ", $im2->errstr, "\n";
  44   is_image($im, $im2, "compare");
  45   is($im2->tags(name => 'sgi_rle'), 0, "check not rle");
  46   is($im2->tags(name => 'sgi_bpc'), 2, "check bpc");
  47   is($im2->tags(name => 'i_comment'), undef, "no namestr");
  48
  49   ok($im->write(file => 'testout/20rle16.rgb',
  50                 sgi_rle => 1,
  51                 i_comment => "test"), "write 16-bit rle")
  52     or print "# ", $im->errstr, "\n";
  53   my $im3 = Imager->new;
  54   ok($im3->read(file => 'testout/20rle16.rgb'), "read it back")
  55     or print "# ", $im3->errstr, "\n";
  56   is_image($im, $im3, "compare");
  57   is($im3->tags(name => 'sgi_rle'), 1, "check not rle");
  58   is($im3->tags(name => 'sgi_bpc'), 2, "check bpc");
  59   is($im3->tags(name => 'i_comment'), 'test', "check i_comment set");
  60 }
  61
  62 {
  63   # grey scale check
  64   my $im = test_image()->convert(preset=>'grey');
  65   ok($im->write(file => 'testout/20vgray8.bw'), "write 8-bit verbatim grey")
  66     or print "# ", $im->errstr, "\n";
  67   my $im2 = Imager->new;
  68   ok($im2->read(file => 'testout/20vgray8.bw'), "read it back")
  69     or print "# ", $im2->errstr, "\n";
  70   is_image($im, $im2, "compare");
  71   is($im2->tags(name => 'i_format'), 'sgi', "check we saved as SGI");
  72   is($im2->tags(name => 'sgi_rle'), 0, "check not rle");
  73   is($im2->tags(name => 'sgi_bpc'), 1, "check bpc");
  74   is($im2->tags(name => 'i_comment'), undef, "no namestr");
  75 }
  76
  77 {
  78   # write failure tests
  79   my $rgb8 = test_image();
  80   my $rgb16 = test_image_16();
  81   my $rgb8rle = $rgb8->copy;
  82   $rgb8rle->settag(name => 'sgi_rle', value => 1);
  83   my $grey8 = $rgb8->convert(preset => 'grey');
  84   my $grey16 = $rgb16->convert(preset => 'grey');
  85   my $grey16rle = $grey16->copy;
  86   $grey16rle->settag(name => 'sgi_rle', value => 1);
  87
  88   my @tests =
  89     (
  90      # each entry is: image, limit, expected msg, description
  91      [
  92       $rgb8, 500,
  93       'SGI image: cannot write header',
  94       'writing header'
  95      ],
  96      [
  97       $rgb8, 1024,
  98       'SGI image: error writing image data',
  99       '8-bit image data'
 100      ],
 101      [
 102       $grey8, 513,
 103       'SGI image: error writing image data',
 104       '8-bit image data (grey)'
 105      ],
 106      [
 107       $rgb8rle, 513,
 108       'SGI image: error writing offsets/lengths',
 109       'rle tables, 8 bit',
 110      ],
 111      [
 112       $rgb8rle, 4112,
 113       'SGI image: error writing RLE data',
 114       '8-bit rle data',
 115      ],
 116      [
 117       $rgb8rle, 14707,
 118       'SGI image: cannot write final RLE table',
 119       '8-bit rewrite RLE table',
 120      ],
 121      [
 122       $rgb16, 513,
 123       'SGI image: error writing image data',
 124       '16-bit image data',
 125      ],
 126      [
 127       $grey16rle, 513,
 128       'SGI image: error writing offsets/lengths',
 129       'rle tables, 16 bit',
 130      ],
 131      [
 132       $grey16rle, 1713,
 133       'SGI image: error writing RLE data',
 134       '16-bit rle data',
 135      ],
 136      [
 137       $grey16rle, 10871,
 138       'SGI image: cannot write final RLE table',
 139       '16-bit rewrite RLE table',
 140      ],
 141     );
 142   for my $test (@tests) {
 143     my ($im, $limit, $expected_msg, $desc) = @$test;
 144     my ($writecb, $seekcb) = limited_write($limit);
 145     ok(!$im->write(type => 'sgi', writecb => $writecb,
 146                    seekcb => $seekcb, maxbuffer => 1),
 147        "write should fail - $desc");
 148     is($im->errstr, "$expected_msg: limit reached", "check error - $desc");
 149   }
 150 }
 151
 152 sub limited_write {
 153   my ($limit) = @_;
 154
 155   my $pos = 0;
 156   my $written = 0;
 157   return
 158     (
 159      # write callback
 160      sub {
 161        my ($data) = @_;
 162        # limit total written so we can fail the offset table write for RLE
 163        $written += length $data;
 164        if ($written <= $limit) {
 165          $pos += length $data;
 166          print "# write of ", length $data, " bytes successful (",
 167            $limit - $written, " left)\n";
 168          return 1;
 169        }
 170        else {
 171          print "# write of ", length $data, " bytes failed\n";
 172          Imager::i_push_error(0, "limit reached");
 173          return;
 174        }
 175      },
 176      # seek cb
 177      sub {
 178        my ($position, $whence) = @_;
 179
 180        if ($whence == SEEK_SET) {
 181          $pos = $position;
 182          print "# seek to $pos\n";
 183        }
 184        elsif ($whence == SEEK_END) {
 185          die "SEEK_END not supported\n";
 186        }
 187        elsif ($whence == SEEK_CUR) {
 188          die "SEEK_CUR not supported\n";
 189        }
 190        else {
 191          die "Invalid seek whence $whence";
 192        }
 193
 194        $pos;
 195      }
 196     )
 197 }