This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
TODO tests for opening upgraded scalars
[perl5.git] / ext / PerlIO-scalar / t / scalar.t
CommitLineData
f6c77cf1
NIS
1#!./perl
2
3BEGIN {
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
15use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere.
16
f6c77cf1 17$| = 1;
42bc49da 18
7af8b2b6 19use Test::More tests => 92;
f6c77cf1
NIS
20
21my $fh;
42bc49da
JH
22my $var = "aaa\n";
23ok(open($fh,"+<",\$var));
24
25is(<$fh>, $var);
26
27ok(eof($fh));
28
29ok(seek($fh,0,SEEK_SET));
30ok(!eof($fh));
31
32ok(print $fh "bbb\n");
33is($var, "bbb\n");
f6c77cf1 34$var = "foo\nbar\n";
42bc49da
JH
35ok(seek($fh,0,SEEK_SET));
36ok(!eof($fh));
37is(<$fh>, "foo\n");
38ok(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";
43open $fh, ">", \$var;
42bc49da 44is($var, "");
ae1204bf
BS
45# Check that file offset set to beginning of scalar
46my $off = tell($fh);
42bc49da 47is($off, 0);
ae1204bf
BS
48# Check that writes go where they should and update the offset
49$var = "Something";
50print $fh "Brea";
51$off = tell($fh);
42bc49da
JH
52is($off, 4);
53is($var, "Breathing");
c350b88c 54close $fh;
ae1204bf
BS
55
56# Check that ">>" appends to the scalar
57$var = "Something ";
c350b88c 58open $fh, ">>", \$var;
ae1204bf 59$off = tell($fh);
42bc49da
JH
60is($off, 10);
61is($var, "Something ");
ae1204bf
BS
62# Check that further writes go to the very end of the scalar
63$var .= "else ";
42bc49da
JH
64is($var, "Something else ");
65
ae1204bf 66$off = tell($fh);
42bc49da
JH
67is($off, 10);
68
ae1204bf 69print $fh "is here";
42bc49da 70is($var, "Something else is here");
23a2eb0a
BS
71close $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";
76open $fh, "<", \$var;
77while (<$fh>) {
78 $var = "foo";
79}
80close $fh;
42bc49da 81is($var, "foo");
ecdeb87c
NIS
82
83# Check that dup'ing the handle works
84
85$var = '';
ecdeb87c 86open $fh, "+>", \$var;
42bc49da 87print $fh "xxx\n";
ecdeb87c 88open $dup,'+<&',$fh;
42bc49da
JH
89print $dup "yyy\n";
90seek($dup,0,SEEK_SET);
91is(<$dup>, "xxx\n");
92is(<$dup>, "yyy\n");
ecdeb87c
NIS
93close($fh);
94close($dup);
95
34fcc551 96open $fh, '<', \42;
42bc49da 97is(<$fh>, "42", "reading from non-string scalars");
34fcc551 98close $fh;
c5b94a97 99
ffe0bb5a 100{ package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } sub STORE {} }
c5b94a97 101tie $p, P; open $fh, '<', \$p;
42bc49da 102is(<$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
156my $data = "a non-empty PV";
157$data = undef;
158open(MEM, '<', \$data) or die "Fail: $!\n";
159my $x = join '', <MEM>;
42bc49da 160is($x, '');
5735c168
RGS
161
162{
163 # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread)
164 my $s = <<'EOF';
165line A
166line B
167a third line
168EOF
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 322sub 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
341SKIP: {
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
365SKIP: {
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}