Commit | Line | Data |
---|---|---|
f6c77cf1 NIS |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
0c4f7ff0 | 4 | unless (find PerlIO::Layer 'perlio') { |
f6c77cf1 NIS |
5 | print "1..0 # Skip: not perlio\n"; |
6 | exit 0; | |
7 | } | |
740dabb8 | 8 | require Config; |
98641f60 | 9 | if (($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) ){ |
740dabb8 NC |
10 | print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n"; |
11 | exit 0; | |
12 | } | |
f6c77cf1 NIS |
13 | } |
14 | ||
42bc49da JH |
15 | use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere. |
16 | ||
f6c77cf1 | 17 | $| = 1; |
42bc49da | 18 | |
7af8b2b6 | 19 | use Test::More tests => 92; |
f6c77cf1 NIS |
20 | |
21 | my $fh; | |
42bc49da JH |
22 | my $var = "aaa\n"; |
23 | ok(open($fh,"+<",\$var)); | |
24 | ||
25 | is(<$fh>, $var); | |
26 | ||
27 | ok(eof($fh)); | |
28 | ||
29 | ok(seek($fh,0,SEEK_SET)); | |
30 | ok(!eof($fh)); | |
31 | ||
32 | ok(print $fh "bbb\n"); | |
33 | is($var, "bbb\n"); | |
f6c77cf1 | 34 | $var = "foo\nbar\n"; |
42bc49da JH |
35 | ok(seek($fh,0,SEEK_SET)); |
36 | ok(!eof($fh)); | |
37 | is(<$fh>, "foo\n"); | |
38 | ok(close $fh, $!); | |
ae1204bf BS |
39 | |
40 | # Test that semantics are similar to normal file-based I/O | |
41 | # Check that ">" clobbers the scalar | |
42 | $var = "Something"; | |
43 | open $fh, ">", \$var; | |
42bc49da | 44 | is($var, ""); |
ae1204bf BS |
45 | # Check that file offset set to beginning of scalar |
46 | my $off = tell($fh); | |
42bc49da | 47 | is($off, 0); |
ae1204bf BS |
48 | # Check that writes go where they should and update the offset |
49 | $var = "Something"; | |
50 | print $fh "Brea"; | |
51 | $off = tell($fh); | |
42bc49da JH |
52 | is($off, 4); |
53 | is($var, "Breathing"); | |
c350b88c | 54 | close $fh; |
ae1204bf BS |
55 | |
56 | # Check that ">>" appends to the scalar | |
57 | $var = "Something "; | |
c350b88c | 58 | open $fh, ">>", \$var; |
ae1204bf | 59 | $off = tell($fh); |
42bc49da JH |
60 | is($off, 10); |
61 | is($var, "Something "); | |
ae1204bf BS |
62 | # Check that further writes go to the very end of the scalar |
63 | $var .= "else "; | |
42bc49da JH |
64 | is($var, "Something else "); |
65 | ||
ae1204bf | 66 | $off = tell($fh); |
42bc49da JH |
67 | is($off, 10); |
68 | ||
ae1204bf | 69 | print $fh "is here"; |
42bc49da | 70 | is($var, "Something else is here"); |
23a2eb0a BS |
71 | close $fh; |
72 | ||
73 | # Check that updates to the scalar from elsewhere do not | |
74 | # cause problems | |
75 | $var = "line one\nline two\line three\n"; | |
76 | open $fh, "<", \$var; | |
77 | while (<$fh>) { | |
78 | $var = "foo"; | |
79 | } | |
80 | close $fh; | |
42bc49da | 81 | is($var, "foo"); |
ecdeb87c NIS |
82 | |
83 | # Check that dup'ing the handle works | |
84 | ||
85 | $var = ''; | |
ecdeb87c | 86 | open $fh, "+>", \$var; |
42bc49da | 87 | print $fh "xxx\n"; |
ecdeb87c | 88 | open $dup,'+<&',$fh; |
42bc49da JH |
89 | print $dup "yyy\n"; |
90 | seek($dup,0,SEEK_SET); | |
91 | is(<$dup>, "xxx\n"); | |
92 | is(<$dup>, "yyy\n"); | |
ecdeb87c NIS |
93 | close($fh); |
94 | close($dup); | |
95 | ||
34fcc551 | 96 | open $fh, '<', \42; |
42bc49da | 97 | is(<$fh>, "42", "reading from non-string scalars"); |
34fcc551 | 98 | close $fh; |
c5b94a97 | 99 | |
ffe0bb5a | 100 | { package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } sub STORE {} } |
c5b94a97 | 101 | tie $p, P; open $fh, '<', \$p; |
42bc49da | 102 | is(<$fh>, "shazam", "reading from magic scalars"); |
03aa69f9 RGS |
103 | |
104 | { | |
105 | use warnings; | |
42bc49da JH |
106 | my $warn = 0; |
107 | local $SIG{__WARN__} = sub { $warn++ }; | |
03aa69f9 RGS |
108 | open my $fh, '>', \my $scalar; |
109 | print $fh "foo"; | |
110 | close $fh; | |
42bc49da | 111 | is($warn, 0, "no warnings when writing to an undefined scalar"); |
03aa69f9 | 112 | } |
47cc46ee | 113 | |
22ccb26d BM |
114 | { |
115 | use warnings; | |
116 | my $warn = 0; | |
117 | local $SIG{__WARN__} = sub { $warn++ }; | |
118 | for (1..2) { | |
119 | open my $fh, '>', \my $scalar; | |
120 | close $fh; | |
121 | } | |
122 | is($warn, 0, "no warnings when reusing a lexical"); | |
123 | } | |
124 | ||
125 | { | |
126 | use warnings; | |
127 | my $warn = 0; | |
128 | local $SIG{__WARN__} = sub { $warn++ }; | |
129 | ||
130 | my $fetch = 0; | |
131 | { | |
132 | package MgUndef; | |
133 | sub TIESCALAR { bless [] } | |
134 | sub FETCH { $fetch++; return undef } | |
ffe0bb5a | 135 | sub STORE {} |
22ccb26d BM |
136 | } |
137 | tie my $scalar, MgUndef; | |
138 | ||
139 | open my $fh, '<', \$scalar; | |
140 | close $fh; | |
141 | is($warn, 0, "no warnings reading a magical undef scalar"); | |
142 | is($fetch, 1, "FETCH only called once"); | |
143 | } | |
144 | ||
145 | { | |
146 | use warnings; | |
147 | my $warn = 0; | |
148 | local $SIG{__WARN__} = sub { $warn++ }; | |
149 | my $scalar = 3; | |
150 | undef $scalar; | |
151 | open my $fh, '<', \$scalar; | |
152 | close $fh; | |
153 | is($warn, 0, "no warnings reading an undef, allocated scalar"); | |
154 | } | |
155 | ||
47cc46ee RGS |
156 | my $data = "a non-empty PV"; |
157 | $data = undef; | |
158 | open(MEM, '<', \$data) or die "Fail: $!\n"; | |
159 | my $x = join '', <MEM>; | |
42bc49da | 160 | is($x, ''); |
5735c168 RGS |
161 | |
162 | { | |
163 | # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread) | |
164 | my $s = <<'EOF'; | |
165 | line A | |
166 | line B | |
167 | a third line | |
168 | EOF | |
169 | open(F, '<', \$s) or die "Could not open string as a file"; | |
170 | local $/ = ""; | |
171 | my $ln = <F>; | |
172 | close F; | |
42bc49da | 173 | is($ln, $s, "[perl #35929]"); |
5735c168 | 174 | } |
b35bc0c6 RGS |
175 | |
176 | # [perl #40267] PerlIO::scalar doesn't respect readonly-ness | |
177 | { | |
42bc49da | 178 | ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!"); |
b35bc0c6 | 179 | close F; |
42bc49da | 180 | |
b35bc0c6 | 181 | my $ro = \43; |
42bc49da | 182 | ok(!(defined open(F, '>', $ro)), $!); |
b35bc0c6 RGS |
183 | close F; |
184 | # but we can read from it | |
42bc49da JH |
185 | ok(open(F, '<', $ro), $!); |
186 | is(<F>, 43); | |
b35bc0c6 RGS |
187 | close F; |
188 | } | |
42bc49da JH |
189 | |
190 | { | |
191 | # Check that we zero fill when needed when seeking, | |
192 | # and that seeking negative off the string does not do bad things. | |
193 | ||
194 | my $foo; | |
195 | ||
196 | ok(open(F, '>', \$foo)); | |
197 | ||
198 | # Seeking forward should zero fill. | |
199 | ||
200 | ok(seek(F, 50, SEEK_SET)); | |
201 | print F "x"; | |
202 | is(length($foo), 51); | |
203 | like($foo, qr/^\0{50}x$/); | |
204 | ||
205 | is(tell(F), 51); | |
206 | ok(seek(F, 0, SEEK_SET)); | |
207 | is(length($foo), 51); | |
208 | ||
209 | # Seeking forward again should zero fill but only the new bytes. | |
210 | ||
211 | ok(seek(F, 100, SEEK_SET)); | |
212 | print F "y"; | |
213 | is(length($foo), 101); | |
214 | like($foo, qr/^\0{50}x\0{49}y$/); | |
215 | is(tell(F), 101); | |
216 | ||
217 | # Seeking back and writing should not zero fill. | |
218 | ||
219 | ok(seek(F, 75, SEEK_SET)); | |
220 | print F "z"; | |
221 | is(length($foo), 101); | |
222 | like($foo, qr/^\0{50}x\0{24}z\0{24}y$/); | |
223 | is(tell(F), 76); | |
224 | ||
225 | # Seeking negative should not do funny business. | |
226 | ||
227 | ok(!seek(F, -50, SEEK_SET), $!); | |
228 | ok(seek(F, 0, SEEK_SET)); | |
229 | ok(!seek(F, -50, SEEK_CUR), $!); | |
230 | ok(!seek(F, -150, SEEK_END), $!); | |
231 | } | |
232 | ||
ffe0bb5a DM |
233 | # RT #43789: should respect tied scalar |
234 | ||
235 | { | |
236 | package TS; | |
237 | my $s; | |
238 | sub TIESCALAR { bless \my $x } | |
239 | sub FETCH { $s .= ':F'; ${$_[0]} } | |
240 | sub STORE { $s .= ":S($_[1])"; ${$_[0]} = $_[1] } | |
241 | ||
242 | package main; | |
243 | ||
244 | my $x; | |
245 | $s = ''; | |
246 | tie $x, 'TS'; | |
247 | my $fh; | |
248 | ||
249 | ok(open($fh, '>', \$x), 'open-write tied scalar'); | |
250 | $s .= ':O'; | |
251 | print($fh 'ABC'); | |
252 | $s .= ':P'; | |
253 | ok(seek($fh, 0, SEEK_SET)); | |
254 | $s .= ':SK'; | |
255 | print($fh 'DEF'); | |
256 | $s .= ':P'; | |
257 | ok(close($fh), 'close tied scalar - write'); | |
b6597275 | 258 | is($s, ':F:S():O:F:S(ABC):P:SK:F:S(DEF):P', 'tied actions - write'); |
ffe0bb5a DM |
259 | is($x, 'DEF', 'new value preserved'); |
260 | ||
261 | $x = 'GHI'; | |
262 | $s = ''; | |
263 | ok(open($fh, '+<', \$x), 'open-read tied scalar'); | |
264 | $s .= ':O'; | |
265 | my $buf; | |
266 | is(read($fh,$buf,2), 2, 'read1'); | |
267 | $s .= ':R'; | |
268 | is($buf, 'GH', 'buf1'); | |
269 | is(read($fh,$buf,2), 1, 'read2'); | |
270 | $s .= ':R'; | |
271 | is($buf, 'I', 'buf2'); | |
272 | is(read($fh,$buf,2), 0, 'read3'); | |
273 | $s .= ':R'; | |
274 | is($buf, '', 'buf3'); | |
275 | ok(close($fh), 'close tied scalar - read'); | |
276 | is($s, ':F:S(GHI):O:F:R:F:R:F:R', 'tied actions - read'); | |
277 | } | |
278 | ||
ab9f1586 FC |
279 | # [perl #78716] Seeking beyond the end of the string, then reading |
280 | { | |
281 | my $str = '1234567890'; | |
282 | open my $strIn, '<', \$str; | |
283 | seek $strIn, 15, 1; | |
284 | is read($strIn, my $buffer, 5), 0, | |
285 | 'seek beyond end end of string followed by read'; | |
286 | } | |
47d6f3d6 | 287 | |
c5a04db8 | 288 | # Writing to COW scalars and non-PVs |
47d6f3d6 FC |
289 | { |
290 | my $bovid = __PACKAGE__; | |
291 | open my $handel, ">", \$bovid; | |
292 | print $handel "the COW with the crumpled horn"; | |
293 | is $bovid, "the COW with the crumpled horn", 'writing to COW scalars'; | |
c5a04db8 | 294 | |
726c8e76 FC |
295 | package lrcg { use overload fallback => 1, '""'=>sub { 'chin' } } |
296 | seek $handel, 3, 0; | |
297 | $bovid = bless [], lrcg::; | |
298 | print $handel 'mney'; | |
299 | is $bovid, 'chimney', 'writing to refs'; | |
c5a04db8 FC |
300 | |
301 | seek $handel, 1, 0; | |
302 | $bovid = 42; # still has a PV | |
303 | print $handel 5; | |
304 | is $bovid, 45, 'writing to numeric scalar'; | |
305 | ||
306 | seek $handel, 1, 0; | |
307 | undef $bovid; | |
308 | $bovid = 42; # just IOK | |
309 | print $handel 5; | |
310 | is $bovid, 45, 'writing to numeric scalar'; | |
47d6f3d6 | 311 | } |
b6597275 FC |
312 | |
313 | # [perl #92706] | |
314 | { | |
315 | open my $fh, "<", \(my $f=*f); seek $fh, 2,1; | |
316 | pass 'seeking on a glob copy'; | |
317 | open my $fh, "<", \(my $f=*f); seek $fh, -2,2; | |
318 | pass 'seeking on a glob copy from the end'; | |
319 | } | |
84da5602 | 320 | |
66ad6b0e | 321 | # [perl #108398] |
84da5602 | 322 | sub has_trailing_nul(\$) { |
91087fe5 EB |
323 | my ($ref) = @_; |
324 | my $sv = B::svref_2object($ref); | |
325 | return undef if !$sv->isa('B::PV'); | |
326 | ||
327 | my $cur = $sv->CUR; | |
328 | my $len = $sv->LEN; | |
329 | return 0 if $cur >= $len; | |
330 | ||
331 | my $ptrlen = length(pack('P', '')); | |
332 | my $ptrfmt | |
333 | = $ptrlen == length(pack('J', 0)) ? 'J' | |
334 | : $ptrlen == length(pack('I', 0)) ? 'I' | |
335 | : die "Can't determine pointer format"; | |
336 | ||
337 | my $pv_addr = unpack $ptrfmt, pack 'P', $$ref; | |
338 | my $trailing = unpack 'P', pack $ptrfmt, $pv_addr+$cur; | |
339 | return $trailing eq "\0"; | |
84da5602 | 340 | } |
66ad6b0e FC |
341 | SKIP: { |
342 | if ($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) { | |
57121c06 | 343 | skip "no B", 3; |
66ad6b0e FC |
344 | } |
345 | require B; | |
346 | ||
347 | open my $fh, ">", \my $memfile or die $!; | |
348 | ||
349 | print $fh "abc"; | |
350 | ok has_trailing_nul $memfile, | |
351 | 'write appends trailing null when growing string'; | |
352 | ||
353 | seek $fh, 0,SEEK_SET; | |
354 | print $fh "abc"; | |
355 | ok has_trailing_nul $memfile, | |
356 | 'write appends trailing null when not growing string'; | |
357 | ||
358 | seek $fh, 200, SEEK_SET; | |
359 | print $fh "abc"; | |
360 | ok has_trailing_nul $memfile, | |
361 | 'write appends null when growing string after seek past end'; | |
362 | } | |
49b69fb3 FC |
363 | |
364 | # [perl #112780] Cloning of in-memory handles | |
365 | SKIP: { | |
366 | skip "no threads", 2 if !$Config::Config{useithreads}; | |
367 | require threads; | |
368 | my $str = ''; | |
369 | open my $fh, ">", \$str; | |
370 | $str = 'a'; | |
371 | is scalar threads::async(sub { my $foo = $str; $foo })->join, "a", | |
372 | 'scalars behind in-memory handles are cloned properly'; | |
373 | print $fh "a"; | |
ed260fbb | 374 | is scalar threads::async(sub { print $fh "b"; $str })->join, "ab", |
49b69fb3 FC |
375 | 'printing to a cloned in-memory handle works'; |
376 | } | |
7b3cf1c0 FC |
377 | |
378 | # [perl #113764] Duping via >&= (broken by the fix for #112870) | |
379 | { | |
380 | open FILE, '>', \my $content or die "Couldn't open scalar filehandle"; | |
381 | open my $fh, ">&=FILE" or die "Couldn't open: $!"; | |
382 | print $fh "Foo-Bar\n"; | |
383 | close $fh; | |
384 | close FILE; | |
385 | is $content, "Foo-Bar\n", 'duping via >&='; | |
386 | } | |
7af8b2b6 TC |
387 | |
388 | # [perl #109828] PerlIO::scalar does not handle UTF-8 | |
389 | { | |
390 | use Errno qw(EINVAL); | |
391 | my $todo = "open doesn't know about UTf-8 scalars"; | |
392 | local $TODO = $todo; | |
393 | my @warnings; | |
394 | local $SIG{__WARN__} = sub { push @warnings, "@_" }; | |
395 | my $content = "12\x{101}"; | |
396 | $! = 0; | |
397 | ok(!open(my $fh, "<", \$content), "non-byte open should fail"); | |
398 | is(0+$!, EINVAL, "check \$! is updated"); | |
399 | undef $TODO; | |
400 | is_deeply(\@warnings, [], "should be no warnings (yet)"); | |
401 | use warnings "utf8"; | |
402 | $TODO = $todo; | |
403 | $! = 0; | |
404 | ok(!open(my $fh, "<", \$content), "non byte open should fail (and warn)"); | |
405 | is(0+$!, EINVAL, "check \$! is updated even when we warn"); | |
406 | $TODO = $todo; | |
407 | my $warning = "Strings with code points over 0xFF may not be mapped into in-memory file handles\n"; | |
408 | is_deeply(\@warnings, [ $warning ], "should have warned"); | |
409 | @warnings = (); | |
410 | $content = "12\xA1"; | |
411 | utf8::upgrade($content); | |
412 | undef $TODO; | |
413 | ok(open(my $fh, "<", \$content), "open upgraded scalar"); | |
414 | $TODO = $todo; | |
415 | my $tmp; | |
416 | is(read($fh, $tmp, 4), 3, "read should get the downgraded bytes"); | |
417 | is($tmp, "12\xA1", "check we got the expected bytes"); | |
418 | close $fh; | |
419 | undef $TODO; | |
420 | is_deeply(\@warnings, [], "should be no more warnings"); | |
421 | } |