- Finished/rewrote Arnar's old SGI RGB file format support, so Imager
[imager.git] / 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 }