Skip to content

Commit

Permalink
PerlIO::scalar (aka open(my $fh, >\$foo)): zero-filling seekand don't…
Browse files Browse the repository at this point in the history 
… talk to negative strangers

Message-ID: <451D3098.1000305@iki.fi>

p4raw-id: //depot/perl@28903
  • Loading branch information
@jhi @smpeters
jhi authored and smpeters committed Sep 29, 2006
1 parent f2f7849 commit 42bc49d
Show file tree
Hide file tree
Showing 3 changed files with 116 additions and 104 deletions.
24 changes: 18 additions & 6 deletions ext/PerlIO/scalar/scalar.xs
View file
Expand Up @@ -27,7 +27,7 @@ PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER), PL_no_modify);
errno = EINVAL;
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
s->var = SvREFCNT_inc(SvRV(arg));
Expand Down Expand Up @@ -83,20 +83,32 @@ IV
PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
STRLEN oldcur = SvCUR(s->var);
STRLEN newlen;
switch (whence) {
case 0:
case SEEK_SET:
s->posn = offset;
break;
case 1:
case SEEK_CUR:
s->posn = offset + s->posn;
break;
case 2:
case SEEK_END:
s->posn = offset + SvCUR(s->var);
break;
}
if ((STRLEN) s->posn > SvCUR(s->var)) {
(void) SvGROW(s->var, (STRLEN) s->posn);
if (s->posn < 0) {
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
newlen = (STRLEN) s->posn;
if (newlen > oldcur) {
(void) SvGROW(s->var, newlen);
Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
/* No SvCUR_set(), though. This is just a seek, not a write. */
}
SvPOK_on(s->var);
return 0;
}

Expand Down
188 changes: 94 additions & 94 deletions ext/PerlIO/t/scalar.t
View file
Expand Up @@ -14,83 +14,62 @@ BEGIN {
}
}

use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere.

$| = 1;
print "1..30\n";

use Test::More tests => 51;

my $fh;
my $var = "ok 2\n";
open($fh,"+<",\$var) or print "not ";
print "ok 1\n";
print <$fh>;
print "not " unless eof($fh);
print "ok 3\n";
seek($fh,0,0) or print "not ";
print "not " if eof($fh);
print "ok 4\n";
print "ok 5\n";
print $fh "ok 7\n" or print "not ";
print "ok 6\n";
print $var;
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";
seek($fh,0,0) or print "not ";
print "not " if eof($fh);
print "ok 8\n";
print "not " unless <$fh> eq "foo\n";
print "ok 9\n";
my $rv = close $fh;
if (!$rv) {
print "# Close on scalar failed: $!\n";
print "not ";
}
print "ok 10\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;
print "# Got [$var], expect []\n";
print "not " unless $var eq "";
print "ok 11\n";
is($var, "");
# Check that file offset set to beginning of scalar
my $off = tell($fh);
print "# Got $off, expect 0\n";
print "not " unless $off == 0;
print "ok 12\n";
is($off, 0);
# Check that writes go where they should and update the offset
$var = "Something";
print $fh "Brea";
$off = tell($fh);
print "# Got $off, expect 4\n";
print "not " unless $off == 4;
print "ok 13\n";
print "# Got [$var], expect [Breathing]\n";
print "not " unless $var eq "Breathing";
print "ok 14\n";
is($off, 4);
is($var, "Breathing");
close $fh;

# Check that ">>" appends to the scalar
$var = "Something ";
open $fh, ">>", \$var;
$off = tell($fh);
print "# Got $off, expect 10\n";
print "not " unless $off == 10;
print "ok 15\n";
print "# Got [$var], expect [Something ]\n";
print "not " unless $var eq "Something ";
print "ok 16\n";
is($off, 10);
is($var, "Something ");
# Check that further writes go to the very end of the scalar
$var .= "else ";
print "# Got [$var], expect [Something else ]\n";
print "not " unless $var eq "Something else ";
print "ok 17\n";
is($var, "Something else ");

$off = tell($fh);
print "# Got $off, expect 10\n";
print "not " unless $off == 10;
print "ok 18\n";
is($off, 10);

print $fh "is here";
print "# Got [$var], expect [Something else is here]\n";
print "not " unless $var eq "Something else is here";
print "ok 19\n";
is($var, "Something else is here");
close $fh;

# Check that updates to the scalar from elsewhere do not
Expand All @@ -101,54 +80,44 @@ while (<$fh>) {
$var = "foo";
}
close $fh;
print "# Got [$var], expect [foo]\n";
print "not " unless $var eq "foo";
print "ok 20\n";
is($var, "foo");

# Check that dup'ing the handle works

$var = '';

open $fh, "+>", \$var;
print $fh "ok 21\n";
print $fh "xxx\n";
open $dup,'+<&',$fh;
print $dup "ok 22\n";
seek($dup,0,0);
while (<$dup>) {
print;
}
print $dup "yyy\n";
seek($dup,0,SEEK_SET);
is(<$dup>, "xxx\n");
is(<$dup>, "yyy\n");
close($fh);
close($dup);

# Check reading from non-string scalars

open $fh, '<', \42;
print <$fh> eq "42" ? "ok 23\n" : "not ok 23\n";
is(<$fh>, "42", "reading from non-string scalars");
close $fh;

# reading from magic scalars

{ package P; sub TIESCALAR {bless{}} sub FETCH {"ok 24\n"} }
{ package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } }
tie $p, P; open $fh, '<', \$p;
print <$fh>;

# don't warn when writing to an undefined scalar
is(<$fh>, "shazam", "reading from magic scalars");

{
use warnings;
my $ok = 1;
local $SIG{__WARN__} = sub { $ok = 0; };
my $warn = 0;
local $SIG{__WARN__} = sub { $warn++ };
open my $fh, '>', \my $scalar;
print $fh "foo";
close $fh;
print $ok ? "ok 25\n" : "not ok 25\n";
is($warn, 0, "no warnings when writing to an undefined scalar");
}

my $data = "a non-empty PV";
$data = undef;
open(MEM, '<', \$data) or die "Fail: $!\n";
my $x = join '', <MEM>;
print $x eq '' ? "ok 26\n" : "not ok 26\n";
is($x, '');

{
# [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread)
Expand All @@ -161,32 +130,63 @@ EOF
local $/ = "";
my $ln = <F>;
close F;
print $ln eq $s ? "ok 27\n" : "not ok 27\n";
is($ln, $s, "[perl #35929]");
}

# [perl #40267] PerlIO::scalar doesn't respect readonly-ness
{
if (open(F, '>', \undef)) {
print "not ok 28\n";
}
else {
print "ok 28 - \$! is $!\n";
}
ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!");
close F;

my $ro = \43;
if (open(F, '>', $ro)) {
print "not ok 29\n";
}
else {
print "ok 29 - \$! is $!\n";
}
ok(!(defined open(F, '>', $ro)), $!);
close F;
# but we can read from it
if (open(F, '<', $ro)) {
print "ok 30\n";
}
else {
print "not ok 30 - \$! is $!\n";
}
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), $!);
}

8 changes: 4 additions & 4 deletions pod/perldiag.pod
View file
Expand Up @@ -2764,10 +2764,10 @@ which is odd, because hashes come in key/value pairs.

=item Offset outside string

(F) You tried to do a read/write/send/recv operation with an offset
pointing outside the buffer. This is difficult to imagine. The sole
exception to this is that C<sysread()>ing past the buffer will extend
the buffer and zero pad the new area.
(F, W layer) You tried to do a read/write/send/recv/seek operation
with an offset pointing outside the buffer. This is difficult to
imagine. The sole exception to this is that C<sysread()>ing past the
buffer will extend the buffer and zero pad the new area.

=item %s() on unopened %s

Expand Down

0 comments on commit 42bc49d

Please sign in to comment.