document the new test image functions
[imager.git] / t / t07iolayer.t
CommitLineData
c35f2f76
TC
1#!perl -w
2use strict;
3d6d61d8 3use Test::More tests => 68;
13eb8ccd
TC
4# for SEEK_SET etc, Fcntl doesn't provide these in 5.005_03
5use IO::Seekable;
c35f2f76
TC
6
7BEGIN { use_ok(Imager => ':all') };
4dfa5522 8
40e78f96
TC
9-d "testout" or mkdir "testout";
10
cc59eadc 11Imager->open_log(log => "testout/t07iolayer.log");
4dfa5522
AMH
12
13undef($/);
14# start by testing io buffer
15
c35f2f76
TC
16my $data="P2\n2 2\n255\n 255 0\n0 255\n";
17my $IO = Imager::io_new_buffer($data);
18my $im = Imager::i_readpnm_wiol($IO, -1);
4dfa5522 19
c35f2f76 20ok($im, "read from data io");
4dfa5522
AMH
21
22open(FH, ">testout/t07.ppm") or die $!;
23binmode(FH);
c35f2f76
TC
24my $fd = fileno(FH);
25my $IO2 = Imager::io_new_fd( $fd );
4dfa5522
AMH
26Imager::i_writeppm_wiol($im, $IO2);
27close(FH);
28undef($im);
29
4dfa5522 30open(FH, "<testimg/penguin-base.ppm");
866278a5 31binmode(FH);
4dfa5522
AMH
32$data = <FH>;
33close(FH);
c35f2f76 34my $IO3 = Imager::io_new_buffer($data);
4dfa5522
AMH
35#undef($data);
36$im = Imager::i_readpnm_wiol($IO3, -1);
37
c35f2f76 38ok($im, "read from buffer, for compare");
10461f9a 39undef $IO3;
4dfa5522
AMH
40
41open(FH, "<testimg/penguin-base.ppm") or die $!;
42binmode(FH);
43$fd = fileno(FH);
c35f2f76
TC
44my $IO4 = Imager::io_new_fd( $fd );
45my $im2 = Imager::i_readpnm_wiol($IO4, -1);
4dfa5522
AMH
46close(FH);
47undef($IO4);
48
c35f2f76 49ok($im2, "read from file, for compare");
4dfa5522 50
c35f2f76 51is(i_img_diff($im, $im2), 0, "compare images");
4dfa5522
AMH
52undef($im2);
53
c35f2f76 54my $IO5 = Imager::io_new_bufchain();
4dfa5522 55Imager::i_writeppm_wiol($im, $IO5);
c35f2f76 56my $data2 = Imager::io_slurp($IO5);
4dfa5522
AMH
57undef($IO5);
58
c35f2f76 59ok($data2, "check we got data from bufchain");
4dfa5522 60
c35f2f76
TC
61my $IO6 = Imager::io_new_buffer($data2);
62my $im3 = Imager::i_readpnm_wiol($IO6, -1);
4dfa5522 63
c35f2f76 64is(Imager::i_img_diff($im, $im3), 0, "read from buffer");
10461f9a
TC
65
66my $work = $data;
67my $pos = 0;
68sub io_reader {
69 my ($size, $maxread) = @_;
70 my $out = substr($work, $pos, $maxread);
71 $pos += length $out;
72 $out;
73}
74sub io_reader2 {
75 my ($size, $maxread) = @_;
76 my $out = substr($work, $pos, $maxread);
77 $pos += length $out;
78 $out;
79}
80my $IO7 = Imager::io_new_cb(undef, \&io_reader, undef, undef);
c35f2f76 81ok($IO7, "making readcb object");
10461f9a 82my $im4 = Imager::i_readpnm_wiol($IO7, -1);
c35f2f76
TC
83ok($im4, "read from cb");
84ok(Imager::i_img_diff($im, $im4) == 0, "read from cb image match");
10461f9a
TC
85
86$pos = 0;
87$IO7 = Imager::io_new_cb(undef, \&io_reader2, undef, undef);
c35f2f76 88ok($IO7, "making short readcb object");
10461f9a 89my $im5 = Imager::i_readpnm_wiol($IO7, -1);
c35f2f76
TC
90ok($im4, "read from cb2");
91is(Imager::i_img_diff($im, $im5), 0, "read from cb2 image match");
10461f9a
TC
92
93sub io_writer {
94 my ($what) = @_;
95 substr($work, $pos, $pos+length $what) = $what;
96 $pos += length $what;
97
98 1;
99}
100
101my $did_close;
102sub io_close {
103 ++$did_close;
104}
105
106my $IO8 = Imager::io_new_cb(\&io_writer, undef, undef, \&io_close);
c35f2f76 107ok($IO8, "making writecb object");
10461f9a
TC
108$pos = 0;
109$work = '';
c35f2f76 110ok(Imager::i_writeppm_wiol($im, $IO8), "write to cb");
10461f9a
TC
111# I originally compared this to $data, but that doesn't include the
112# Imager header
5386861e 113is($work, $data2, "write image match");
c35f2f76 114ok($did_close, "did close");
10461f9a
TC
115
116# with a short buffer, no closer
117my $IO9 = Imager::io_new_cb(\&io_writer, undef, undef, undef, 1);
c35f2f76 118ok($IO9, "making short writecb object");
10461f9a
TC
119$pos = 0;
120$work = '';
c35f2f76 121ok(Imager::i_writeppm_wiol($im, $IO9), "write to short cb");
5386861e 122is($work, $data2, "short write image match");
c35f2f76 123
eda1622c
TC
124{
125 my $buf_data = "Test data";
126 my $io9 = Imager::io_new_buffer($buf_data);
127 is(ref $io9, "Imager::IO", "check class");
128 my $work;
129 is($io9->read($work, 4), 4, "read 4 from buffer object");
130 is($work, "Test", "check data read");
131 is($io9->read($work, 5), 5, "read the rest");
132 is($work, " data", "check data read");
133 is($io9->seek(5, SEEK_SET), 5, "seek");
134 is($io9->read($work, 5), 4, "short read");
135 is($work, "data", "check data read");
136 is($io9->seek(-1, SEEK_CUR), 8, "seek relative");
137 is($io9->seek(-5, SEEK_END), 4, "seek relative to end");
138 is($io9->seek(-10, SEEK_CUR), -1, "seek failure");
139 undef $io9;
140}
141{
142 my $io = Imager::io_new_bufchain();
143 is(ref $io, "Imager::IO", "check class");
144 is($io->write("testdata"), 8, "check write");
145 is($io->seek(-8, SEEK_CUR), 0, "seek relative");
146 my $work;
147 is($io->read($work, 8), 8, "check read");
148 is($work, "testdata", "check data read");
149 is($io->seek(-3, SEEK_END), 5, "seek end relative");
150 is($io->read($work, 5), 3, "short read");
151 is($work, "ata", "check read data");
152 is($io->seek(4, SEEK_SET), 4, "absolute seek to write some");
153 is($io->write("testdata"), 8, "write");
154 is($io->seek(0, SEEK_CUR), 12, "check size");
155 $io->close();
156
157 # grab the data
158 my $data = Imager::io_slurp($io);
159 is($data, "testtestdata", "check we have the right data");
160}
1f6c1c10
TC
161
162{ # callback failure checks
163 my $fail_io = Imager::io_new_cb(\&fail_write, \&fail_read, \&fail_seek, undef, 1);
164 # scalar context
165 my $buffer;
166 my $read_result = $fail_io->read($buffer, 10);
167 is($read_result, undef, "read failure undef in scalar context");
168 my @read_result = $fail_io->read($buffer, 10);
169 is(@read_result, 0, "empty list in list context");
170 $read_result = $fail_io->read2(10);
171 is($read_result, undef, "read2 failure (scalar)");
172 @read_result = $fail_io->read2(10);
173 is(@read_result, 0, "read2 failure (list)");
174
175 my $write_result = $fail_io->write("test");
176 is($write_result, -1, "failed write");
177
178 my $seek_result = $fail_io->seek(-1, SEEK_SET);
179 is($seek_result, -1, "failed seek");
180}
181
182{ # callback success checks
183 my $good_io = Imager::io_new_cb(\&good_write, \&good_read, \&good_seek, undef, 1);
184 # scalar context
185 my $buffer;
186 my $read_result = $good_io->read($buffer, 10);
187 is($read_result, 10, "read success (scalar)");
188 is($buffer, "testdatate", "check data");
189 my @read_result = $good_io->read($buffer, 10);
190 is_deeply(\@read_result, [ 10 ], "read success (list)");
191 is($buffer, "testdatate", "check data");
192 $read_result = $good_io->read2(10);
193 is($read_result, "testdatate", "read2 success (scalar)");
194 @read_result = $good_io->read2(10);
195 is_deeply(\@read_result, [ "testdatate" ], "read2 success (list)");
196}
197
198{ # end of file
199 my $eof_io = Imager::io_new_cb(undef, \&eof_read, undef, undef, 1);
200 my $buffer;
201 my $read_result = $eof_io->read($buffer, 10);
202 is($read_result, 0, "read eof (scalar)");
203 is($buffer, '', "check data");
204 my @read_result = $eof_io->read($buffer, 10);
205 is_deeply(\@read_result, [ 0 ], "read eof (list)");
206 is($buffer, '', "check data");
207}
208
209{ # no callbacks
210 my $none_io = Imager::io_new_cb(undef, undef, undef, undef, 0);
211 is($none_io->write("test"), -1, "write with no writecb should fail");
212 my $buffer;
213 is($none_io->read($buffer, 10), undef, "read with no readcb should fail");
214 is($none_io->seek(0, SEEK_SET), -1, "seek with no seekcb should fail");
215}
216
217SKIP:
218{ # make sure we croak when trying to write a string with characters over 0xff
219 # the write callback shouldn't get called
220 skip("no native UTF8 support in this version of perl", 2)
221 unless $] >= 5.006;
222 my $io = Imager::io_new_cb(\&good_write, undef, undef, 1);
223 my $data = chr(0x100);
224 is(ord $data, 0x100, "make sure we got what we expected");
225 my $result =
226 eval {
227 $io->write($data);
228 };
229 ok($@, "should have croaked")
230 and print "# $@\n";
231}
232
3d6d61d8
TC
233{ # 0.52 left some debug code in a path that wasn't tested, make sure
234 # that path is tested
235 # http://rt.cpan.org/Ticket/Display.html?id=20705
236 my $io = Imager::io_new_cb
237 (
238 sub {
239 print "# write $_[0]\n";
240 1
241 },
242 sub {
243 print "# read $_[0], $_[1]\n";
244 "x" x $_[1]
245 },
246 sub { print "# seek\n"; 0 },
247 sub { print "# close\n"; 1 });
248 my $buffer;
249 is($io->read($buffer, 10), 10, "read 10");
250 is($buffer, "xxxxxxxxxx", "read value");
251 ok($io->write("foo"), "write");
252 is($io->close, 0, "close");
253}
254
cc59eadc
TC
255Imager->close_log;
256
257unless ($ENV{IMAGER_KEEP_FILES}) {
258 unlink "testout/t07.ppm", "testout/t07iolayer.log";
259}
260
1f6c1c10
TC
261sub eof_read {
262 my ($max_len) = @_;
263
264 return '';
265}
266
267sub good_read {
268 my ($max_len) = @_;
269
270 my $data = "testdata";
271 length $data <= $max_len or substr($data, $max_len) = '';
272
273 print "# good_read ($max_len) => $data\n";
274
275 return $data;
276}
277
278sub fail_write {
279 return;
280}
281
282sub fail_read {
283 return;
284}
285
286sub fail_seek {
287 return -1;
288}