Skip to content

Commit

Permalink
[perl #92706] In PerlIO::Scalar::seek, don’t assume SvPOKp
Browse files Browse the repository at this point in the history
Otherwise we get assertion failures.

In fact, since seeking might be just for reading, we can’t coerce and
SvGROW either.

In fact, since the scalar might be modified between seek and write,
there is no *point* in SvGROW during seek, even for SvPOK scalars.

PerlIO::scalar assumes in too many places that the scalar it is using
is its own private scalar that nothing else can modify.  Nothing could
be farther from the truth.

This commit moves the zero-fill that usually happens when seeking past
the end from seek to write.  During a write, if the current position
is past the end of the string, the intervening bytes are zero-filled
at that point, since the seek hasn’t done it.
  • Loading branch information
Father Chrysostomos committed Jan 6, 2012
1 parent 81104cd commit b659727
Show file tree
Hide file tree
Showing 2 changed files with 21 additions and 20 deletions.
29 changes: 11 additions & 18 deletions ext/PerlIO-scalar/scalar.xs
Expand Up @@ -93,11 +93,6 @@ IV
PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
STRLEN oldcur;
STRLEN newlen;

SvGETMAGIC(s->var);
oldcur = SvCUR(s->var);

switch (whence) {
case SEEK_SET:
Expand All @@ -107,26 +102,19 @@ PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
s->posn = offset + s->posn;
break;
case SEEK_END:
s->posn = offset + SvCUR(s->var);
{
STRLEN oldcur;
(void)SvPV(s->var, oldcur);
s->posn = offset + oldcur;
break;
}
}
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. */
}
else if (!SvPVX(s->var)) {
/* ensure there's always a character buffer */
(void)SvGROW(s->var,1);
}
SvPOK_on(s->var);
return 0;
}

Expand Down Expand Up @@ -182,7 +170,12 @@ PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
s->posn = offset + count;
}
else {
if ((s->posn + count) > SvCUR(sv))
STRLEN const cur = SvCUR(sv);
if (s->posn > cur) {
dst = SvGROW(sv, (STRLEN)s->posn + count);
Zero(SvPVX(sv) + cur, (STRLEN)s->posn - cur, char);
}
else if ((s->posn + count) > cur)
dst = SvGROW(sv, (STRLEN)s->posn + count);
else
dst = SvPVX(sv);
Expand Down
12 changes: 10 additions & 2 deletions ext/PerlIO-scalar/t/scalar.t
Expand Up @@ -16,7 +16,7 @@ use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere.

$| = 1;

use Test::More tests => 71;
use Test::More tests => 73;

my $fh;
my $var = "aaa\n";
Expand Down Expand Up @@ -255,7 +255,7 @@ EOF
print($fh 'DEF');
$s .= ':P';
ok(close($fh), 'close tied scalar - write');
is($s, ':F:S():O:F:S(ABC):P:F:SK:F:S(DEF):P', 'tied actions - 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';
Expand Down Expand Up @@ -292,3 +292,11 @@ EOF
print $handel "the COW with the crumpled horn";
is $bovid, "the COW with the crumpled horn", 'writing to COW scalars';
}

# [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';
}

0 comments on commit b659727

Please sign in to comment.