4 unless (find PerlIO::Layer 'perlio') {
5 print "1..0 # Skip: not perlio\n";
9 if (($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) ){
10 print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n";
15 use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere.
19 use Test::More tests => 82;
23 ok(open($fh,"+<",\$var));
29 ok(seek($fh,0,SEEK_SET));
32 ok(print $fh "bbb\n");
35 ok(seek($fh,0,SEEK_SET));
40 # Test that semantics are similar to normal file-based I/O
41 # Check that ">" clobbers the scalar
45 # Check that file offset set to beginning of scalar
48 # Check that writes go where they should and update the offset
53 is($var, "Breathing");
56 # Check that ">>" appends to the scalar
58 open $fh, ">>", \$var;
61 is($var, "Something ");
62 # Check that further writes go to the very end of the scalar
64 is($var, "Something else ");
70 is($var, "Something else is here");
73 # Check that updates to the scalar from elsewhere do not
75 $var = "line one\nline two\line three\n";
83 # Check that dup'ing the handle works
86 open $fh, "+>", \$var;
90 seek($dup,0,SEEK_SET);
97 is(<$fh>, "42", "reading from non-string scalars");
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");
107 local $SIG{__WARN__} = sub { $warn++ };
108 open my $fh, '>', \my $scalar;
111 is($warn, 0, "no warnings when writing to an undefined scalar");
117 local $SIG{__WARN__} = sub { $warn++ };
119 open my $fh, '>', \my $scalar;
122 is($warn, 0, "no warnings when reusing a lexical");
128 local $SIG{__WARN__} = sub { $warn++ };
133 sub TIESCALAR { bless [] }
134 sub FETCH { $fetch++; return undef }
137 tie my $scalar, MgUndef;
139 open my $fh, '<', \$scalar;
141 is($warn, 0, "no warnings reading a magical undef scalar");
142 is($fetch, 1, "FETCH only called once");
148 local $SIG{__WARN__} = sub { $warn++ };
151 open my $fh, '<', \$scalar;
153 is($warn, 0, "no warnings reading an undef, allocated scalar");
156 my $data = "a non-empty PV";
158 open(MEM, '<', \$data) or die "Fail: $!\n";
159 my $x = join '', <MEM>;
163 # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread)
169 open(F, '<', \$s) or die "Could not open string as a file";
173 is($ln, $s, "[perl #35929]");
176 # [perl #40267] PerlIO::scalar doesn't respect readonly-ness
178 ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!");
182 ok(!(defined open(F, '>', $ro)), $!);
184 # but we can read from it
185 ok(open(F, '<', $ro), $!);
191 # Check that we zero fill when needed when seeking,
192 # and that seeking negative off the string does not do bad things.
196 ok(open(F, '>', \$foo));
198 # Seeking forward should zero fill.
200 ok(seek(F, 50, SEEK_SET));
202 is(length($foo), 51);
203 like($foo, qr/^\0{50}x$/);
206 ok(seek(F, 0, SEEK_SET));
207 is(length($foo), 51);
209 # Seeking forward again should zero fill but only the new bytes.
211 ok(seek(F, 100, SEEK_SET));
213 is(length($foo), 101);
214 like($foo, qr/^\0{50}x\0{49}y$/);
217 # Seeking back and writing should not zero fill.
219 ok(seek(F, 75, SEEK_SET));
221 is(length($foo), 101);
222 like($foo, qr/^\0{50}x\0{24}z\0{24}y$/);
225 # Seeking negative should not do funny business.
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), $!);
233 # RT #43789: should respect tied scalar
238 sub TIESCALAR { bless \my $x }
239 sub FETCH { $s .= ':F'; ${$_[0]} }
240 sub STORE { $s .= ":S($_[1])"; ${$_[0]} = $_[1] }
249 ok(open($fh, '>', \$x), 'open-write tied scalar');
253 ok(seek($fh, 0, SEEK_SET));
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');
263 ok(open($fh, '+<', \$x), 'open-read tied scalar');
266 is(read($fh,$buf,2), 2, 'read1');
268 is($buf, 'GH', 'buf1');
269 is(read($fh,$buf,2), 1, 'read2');
271 is($buf, 'I', 'buf2');
272 is(read($fh,$buf,2), 0, 'read3');
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');
279 # [perl #78716] Seeking beyond the end of the string, then reading
281 my $str = '1234567890';
282 open my $strIn, '<', \$str;
284 is read($strIn, my $buffer, 5), 0,
285 'seek beyond end end of string followed by read';
288 # Writing to COW scalars and non-PVs
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';
295 package lrcg { use overload fallback => 1, '""'=>sub { 'chin' } }
297 $bovid = bless [], lrcg::;
298 print $handel 'mney';
299 is $bovid, 'chimney', 'writing to refs';
302 $bovid = 42; # still has a PV
304 is $bovid, 45, 'writing to numeric scalar';
308 $bovid = 42; # just IOK
310 is $bovid, 45, 'writing to numeric scalar';
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';
322 sub has_trailing_nul(\$) {
324 my $sv = B::svref_2object($ref);
325 return undef if !$sv->isa('B::PV');
329 return 0 if $cur >= $len;
331 my $ptrlen = length(pack('P', ''));
333 = $ptrlen == length(pack('J', 0)) ? 'J'
334 : $ptrlen == length(pack('I', 0)) ? 'I'
335 : die "Can't determine pointer format";
337 my $pv_addr = unpack $ptrfmt, pack 'P', $$ref;
338 my $trailing = unpack 'P', pack $ptrfmt, $pv_addr+$cur;
339 return $trailing eq "\0";
342 if ($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) {
347 open my $fh, ">", \my $memfile or die $!;
350 ok has_trailing_nul $memfile,
351 'write appends trailing null when growing string';
353 seek $fh, 0,SEEK_SET;
355 ok has_trailing_nul $memfile,
356 'write appends trailing null when not growing string';
358 seek $fh, 200, SEEK_SET;
360 ok has_trailing_nul $memfile,
361 'write appends null when growing string after seek past end';
364 # [perl #112780] Cloning of in-memory handles
366 skip "no threads", 2 if !$Config::Config{useithreads};
369 open my $fh, ">", \$str;
371 is scalar threads::async(sub { my $foo = $str; $foo })->join, "a",
372 'scalars behind in-memory handles are cloned properly';
374 is scalar threads::async(sub { print $fh "b"; $str })->join, "ab",
375 'printing to a cloned in-memory handle works';
378 # [perl #113764] Duping via >&= (broken by the fix for #112870)
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";
385 is $content, "Foo-Bar\n", 'duping via >&=';