5.005_03 compatible access to SEEK_* constants
[imager.git] / SGI / t / 20write.t
CommitLineData
d5477d3d
TC
1#!perl -w
2use strict;
3use Imager;
4use Test::More tests => 51;
5use Imager::Test qw(test_image test_image_16 is_image);
b69208ce 6use IO::Seekable;
d5477d3d
TC
7
8-d 'testout' or mkdir 'testout';
9
10Imager::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
152sub 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}