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
1 #!./perl
2
3 BEGIN {
4     unless (find PerlIO::Layer 'perlio') {
5         print "1..0 # Skip: not perlio\n";
6         exit 0;
7     }
8     require Config;
9     if (($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) ){
10         print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n";
11         exit 0;
12     }
13 }
14
15 use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere.
16
17 $| = 1;
18
19 use Test::More tests => 92;
20
21 my $fh;
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");
34 $var = "foo\nbar\n";
35 ok(seek($fh,0,SEEK_SET));
36 ok(!eof($fh));
37 is(<$fh>, "foo\n");
38 ok(close $fh, $!);
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;
44 is($var, "");
45 #  Check that file offset set to beginning of scalar
46 my $off = tell($fh);
47 is($off, 0);
48 # Check that writes go where they should and update the offset
49 $var = "Something";
50 print $fh "Brea";
51 $off = tell($fh);
52 is($off, 4);
53 is($var, "Breathing");
54 close $fh;
55
56 # Check that ">>" appends to the scalar
57 $var = "Something ";
58 open $fh, ">>", \$var;
59 $off = tell($fh);
60 is($off, 10);
61 is($var, "Something ");
62 #  Check that further writes go to the very end of the scalar
63 $var .= "else ";
64 is($var, "Something else ");
65
66 $off = tell($fh);
67 is($off, 10);
68
69 print $fh "is here";
70 is($var, "Something else is here");
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;
81 is($var, "foo");
82
83 # Check that dup'ing the handle works
84
85 $var = '';
86 open $fh, "+>", \$var;
87 print $fh "xxx\n";
88 open $dup,'+<&',$fh;
89 print $dup "yyy\n";
90 seek($dup,0,SEEK_SET);
91 is(<$dup>, "xxx\n");
92 is(<$dup>, "yyy\n");
93 close($fh);
94 close($dup);
95
96 open $fh, '<', \42;
97 is(<$fh>, "42", "reading from non-string scalars");
98 close $fh;
99
100 { package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } sub STORE {} }
101 tie $p, P; open $fh, '<', \$p;
102 is(<$fh>, "shazam", "reading from magic scalars");
103
104 {
105     use warnings;
106     my $warn = 0;
107     local $SIG{__WARN__} = sub { $warn++ };
108     open my $fh, '>', \my $scalar;
109     print $fh "foo";
110     close $fh;
111     is($warn, 0, "no warnings when writing to an undefined scalar");
112 }
113
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 }
135         sub STORE {}
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
156 my $data = "a non-empty PV";
157 $data = undef;
158 open(MEM, '<', \$data) or die "Fail: $!\n";
159 my $x = join '', <MEM>;
160 is($x, '');
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;
173     is($ln, $s, "[perl #35929]");
174 }
175
176 # [perl #40267] PerlIO::scalar doesn't respect readonly-ness
177 {
178     ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!");
179     close F;
180
181     my $ro = \43;
182     ok(!(defined open(F, '>', $ro)), $!);
183     close F;
184     # but we can read from it
185     ok(open(F, '<', $ro), $!);
186     is(<F>, 43);
187     close F;
188 }
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
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');
258     is($s, ':F:S():O:F:S(ABC):P:SK:F:S(DEF):P', 'tied actions - write');
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
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 }
287
288 # Writing to COW scalars and non-PVs
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';
294
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';
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';
311 }
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 }
320
321 # [perl #108398]
322 sub has_trailing_nul(\$) {
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";
340 }
341 SKIP: {
342     if ($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) {
343         skip "no B", 3;
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 }
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";
374   is scalar threads::async(sub { print $fh "b"; $str })->join, "ab",
375     'printing to a cloned in-memory handle works';
376 }
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 }
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 }