#!./perl
BEGIN {
unless (find PerlIO::Layer 'perlio') {
print "1..0 # Skip: not perlio\n";
exit 0;
}
require Config;
if (($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) ){
print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n";
exit 0;
}
}
use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere.
$| = 1;
use Test::More tests => 79;
my $fh;
my $var = "aaa\n";
ok(open($fh,"+<",\$var));
is(<$fh>, $var);
ok(eof($fh));
ok(seek($fh,0,SEEK_SET));
ok(!eof($fh));
ok(print $fh "bbb\n");
is($var, "bbb\n");
$var = "foo\nbar\n";
ok(seek($fh,0,SEEK_SET));
ok(!eof($fh));
is(<$fh>, "foo\n");
ok(close $fh, $!);
# Test that semantics are similar to normal file-based I/O
# Check that ">" clobbers the scalar
$var = "Something";
open $fh, ">", \$var;
is($var, "");
# Check that file offset set to beginning of scalar
my $off = tell($fh);
is($off, 0);
# Check that writes go where they should and update the offset
$var = "Something";
print $fh "Brea";
$off = tell($fh);
is($off, 4);
is($var, "Breathing");
close $fh;
# Check that ">>" appends to the scalar
$var = "Something ";
open $fh, ">>", \$var;
$off = tell($fh);
is($off, 10);
is($var, "Something ");
# Check that further writes go to the very end of the scalar
$var .= "else ";
is($var, "Something else ");
$off = tell($fh);
is($off, 10);
print $fh "is here";
is($var, "Something else is here");
close $fh;
# Check that updates to the scalar from elsewhere do not
# cause problems
$var = "line one\nline two\line three\n";
open $fh, "<", \$var;
while (<$fh>) {
$var = "foo";
}
close $fh;
is($var, "foo");
# Check that dup'ing the handle works
$var = '';
open $fh, "+>", \$var;
print $fh "xxx\n";
open $dup,'+<&',$fh;
print $dup "yyy\n";
seek($dup,0,SEEK_SET);
is(<$dup>, "xxx\n");
is(<$dup>, "yyy\n");
close($fh);
close($dup);
open $fh, '<', \42;
is(<$fh>, "42", "reading from non-string scalars");
close $fh;
{ package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } sub STORE {} }
tie $p, P; open $fh, '<', \$p;
is(<$fh>, "shazam", "reading from magic scalars");
{
use warnings;
my $warn = 0;
local $SIG{__WARN__} = sub { $warn++ };
open my $fh, '>', \my $scalar;
print $fh "foo";
close $fh;
is($warn, 0, "no warnings when writing to an undefined scalar");
}
{
use warnings;
my $warn = 0;
local $SIG{__WARN__} = sub { $warn++ };
for (1..2) {
open my $fh, '>', \my $scalar;
close $fh;
}
is($warn, 0, "no warnings when reusing a lexical");
}
{
use warnings;
my $warn = 0;
local $SIG{__WARN__} = sub { $warn++ };
my $fetch = 0;
{
package MgUndef;
sub TIESCALAR { bless [] }
sub FETCH { $fetch++; return undef }
sub STORE {}
}
tie my $scalar, MgUndef;
open my $fh, '<', \$scalar;
close $fh;
is($warn, 0, "no warnings reading a magical undef scalar");
is($fetch, 1, "FETCH only called once");
}
{
use warnings;
my $warn = 0;
local $SIG{__WARN__} = sub { $warn++ };
my $scalar = 3;
undef $scalar;
open my $fh, '<', \$scalar;
close $fh;
is($warn, 0, "no warnings reading an undef, allocated scalar");
}
my $data = "a non-empty PV";
$data = undef;
open(MEM, '<', \$data) or die "Fail: $!\n";
my $x = join '', <MEM>;
is($x, '');
{
# [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread)
my $s = <<'EOF';
line A
line B
a third line
EOF
open(F, '<', \$s) or die "Could not open string as a file";
local $/ = "";
my $ln = <F>;
close F;
is($ln, $s, "[perl #35929]");
}
# [perl #40267] PerlIO::scalar doesn't respect readonly-ness
{
ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!");
close F;
my $ro = \43;
ok(!(defined open(F, '>', $ro)), $!);
close F;
# but we can read from it
ok(open(F, '<', $ro), $!);
is(<F>, 43);
close F;
}
{
# Check that we zero fill when needed when seeking,
# and that seeking negative off the string does not do bad things.
my $foo;
ok(open(F, '>', \$foo));
# Seeking forward should zero fill.
ok(seek(F, 50, SEEK_SET));
print F "x";
is(length($foo), 51);
like($foo, qr/^\0{50}x$/);
is(tell(F), 51);
ok(seek(F, 0, SEEK_SET));
is(length($foo), 51);
# Seeking forward again should zero fill but only the new bytes.
ok(seek(F, 100, SEEK_SET));
print F "y";
is(length($foo), 101);
like($foo, qr/^\0{50}x\0{49}y$/);
is(tell(F), 101);
# Seeking back and writing should not zero fill.
ok(seek(F, 75, SEEK_SET));
print F "z";
is(length($foo), 101);
like($foo, qr/^\0{50}x\0{24}z\0{24}y$/);
is(tell(F), 76);
# Seeking negative should not do funny business.
ok(!seek(F, -50, SEEK_SET), $!);
ok(seek(F, 0, SEEK_SET));
ok(!seek(F, -50, SEEK_CUR), $!);
ok(!seek(F, -150, SEEK_END), $!);
}
# RT #43789: should respect tied scalar
{
package TS;
my $s;
sub TIESCALAR { bless \my $x }
sub FETCH { $s .= ':F'; ${$_[0]} }
sub STORE { $s .= ":S($_[1])"; ${$_[0]} = $_[1] }
package main;
my $x;
$s = '';
tie $x, 'TS';
my $fh;
ok(open($fh, '>', \$x), 'open-write tied scalar');
$s .= ':O';
print($fh 'ABC');
$s .= ':P';
ok(seek($fh, 0, SEEK_SET));
$s .= ':SK';
print($fh 'DEF');
$s .= ':P';
ok(close($fh), 'close tied scalar - write');
is($s, ':F:S():O:F:S(ABC):P:SK:F:S(DEF):P', 'tied actions - write');
is($x, 'DEF', 'new value preserved');
$x = 'GHI';
$s = '';
ok(open($fh, '+<', \$x), 'open-read tied scalar');
$s .= ':O';
my $buf;
is(read($fh,$buf,2), 2, 'read1');
$s .= ':R';
is($buf, 'GH', 'buf1');
is(read($fh,$buf,2), 1, 'read2');
$s .= ':R';
is($buf, 'I', 'buf2');
is(read($fh,$buf,2), 0, 'read3');
$s .= ':R';
is($buf, '', 'buf3');
ok(close($fh), 'close tied scalar - read');
is($s, ':F:S(GHI):O:F:R:F:R:F:R', 'tied actions - read');
}
# [perl #78716] Seeking beyond the end of the string, then reading
{
my $str = '1234567890';
open my $strIn, '<', \$str;
seek $strIn, 15, 1;
is read($strIn, my $buffer, 5), 0,
'seek beyond end end of string followed by read';
}
# Writing to COW scalars and non-PVs
{
my $bovid = __PACKAGE__;
open my $handel, ">", \$bovid;
print $handel "the COW with the crumpled horn";
is $bovid, "the COW with the crumpled horn", 'writing to COW scalars';
package lrcg { use overload fallback => 1, '""'=>sub { 'chin' } }
seek $handel, 3, 0;
$bovid = bless [], lrcg::;
print $handel 'mney';
is $bovid, 'chimney', 'writing to refs';
seek $handel, 1, 0;
$bovid = 42; # still has a PV
print $handel 5;
is $bovid, 45, 'writing to numeric scalar';
seek $handel, 1, 0;
undef $bovid;
$bovid = 42; # just IOK
print $handel 5;
is $bovid, 45, 'writing to numeric scalar';
}
# [perl #92706]
{
open my $fh, "<", \(my $f=*f); seek $fh, 2,1;
pass 'seeking on a glob copy';
open my $fh, "<", \(my $f=*f); seek $fh, -2,2;
pass 'seeking on a glob copy from the end';
}
# [perl #108398]
sub has_trailing_nul(\$) {
my ($ref) = @_;
my $sv = B::svref_2object($ref);
return undef if !$sv->isa('B::PV');
my $cur = $sv->CUR;
my $len = $sv->LEN;
return 0 if $cur >= $len;
my $ptrlen = length(pack('P', ''));
my $ptrfmt
= $ptrlen == length(pack('J', 0)) ? 'J'
: $ptrlen == length(pack('I', 0)) ? 'I'
: die "Can't determine pointer format";
my $pv_addr = unpack $ptrfmt, pack 'P', $$ref;
my $trailing = unpack 'P', pack $ptrfmt, $pv_addr+$cur;
return $trailing eq "\0";
}
SKIP: {
if ($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) {
skip "no B", 3;
}
require B;
open my $fh, ">", \my $memfile or die $!;
print $fh "abc";
ok has_trailing_nul $memfile,
'write appends trailing null when growing string';
seek $fh, 0,SEEK_SET;
print $fh "abc";
ok has_trailing_nul $memfile,
'write appends trailing null when not growing string';
seek $fh, 200, SEEK_SET;
print $fh "abc";
ok has_trailing_nul $memfile,
'write appends null when growing string after seek past end';
}