Skip to content

Commit

Permalink
RT 43789: "in memory" files don't call STORE
Browse files Browse the repository at this point in the history 
The code in PerlIO-scalar that implements the open $fh, '>' \$buffer
feature did not, apart from accidentally, support get/set magic and thus
tied buffers. This patch remedies that: mostly by just blindly sprinkling
SvGETMAGIC/SvSETMAGIC about, rather than doing any deep analysis and
understanding of the code. One main change I did was to add a
PerlIOScalar_read() function, rather than rely on the default behaviour
(which implements it in terms of PerlIOScalar_get_ptr() etc), since that
approach had a tendency to call FETCH multiple times
  • Loading branch information
@iabyn
iabyn committed May 5, 2010
1 parent 994d373 commit ffe0bb5
Show file tree
Hide file tree
Showing 2 changed files with 89 additions and 5 deletions.
42 changes: 39 additions & 3 deletions ext/PerlIO-scalar/scalar.xs
View file
Expand Up @@ -52,6 +52,7 @@ PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
s->posn = SvCUR(s->var);
else
s->posn = 0;
SvSETMAGIC(s->var);
return code;
}

Expand Down Expand Up @@ -84,6 +85,7 @@ IV
PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
SvGETMAGIC(s->var);
STRLEN oldcur = SvCUR(s->var);
STRLEN newlen;
switch (whence) {
Expand Down Expand Up @@ -124,6 +126,34 @@ PerlIOScalar_tell(pTHX_ PerlIO * f)
return s->posn;
}


SSize_t
PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
if (!f)
return 0;
if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
SETERRNO(EBADF, SS_IVCHAN);
return 0;
}
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
SV *sv = s->var;
char *p;
STRLEN len, got;
p = SvPV(sv, len);
got = len - (STRLEN)(s->posn);
if (got <= 0)
return 0;
if (got > (STRLEN)count)
got = (STRLEN)count;
Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
s->posn += (Off_t)got;
return (SSize_t)got;
}
}

SSize_t
PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
{
Expand All @@ -132,6 +162,7 @@ PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
SV *sv = s->var;
char *dst;
SvGETMAGIC(sv);
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
dst = SvGROW(sv, SvCUR(sv) + count);
offset = SvCUR(sv);
Expand All @@ -141,14 +172,15 @@ PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
if ((s->posn + count) > SvCUR(sv))
dst = SvGROW(sv, (STRLEN)s->posn + count);
else
dst = SvPV_nolen(sv);
dst = SvPVX(sv);
offset = s->posn;
s->posn += count;
}
Move(vbuf, dst + offset, count, char);
if ((STRLEN) s->posn > SvCUR(sv))
SvCUR_set(sv, (STRLEN)s->posn);
SvPOK_on(s->var);
SvPOK_on(sv);
SvSETMAGIC(sv);
return count;
}
else
Expand All @@ -172,6 +204,7 @@ PerlIOScalar_get_base(pTHX_ PerlIO * f)
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
SvGETMAGIC(s->var);
return (STDCHAR *) SvPV_nolen(s->var);
}
return (STDCHAR *) NULL;
Expand All @@ -192,6 +225,7 @@ PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
{
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
SvGETMAGIC(s->var);
if (SvCUR(s->var) > (STRLEN) s->posn)
return SvCUR(s->var) - (STRLEN)s->posn;
else
Expand All @@ -205,6 +239,7 @@ PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
{
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
SvGETMAGIC(s->var);
return SvCUR(s->var);
}
return 0;
Expand All @@ -214,6 +249,7 @@ void
PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
SvGETMAGIC(s->var);
s->posn = SvCUR(s->var) - cnt;
}

Expand Down Expand Up @@ -277,7 +313,7 @@ PERLIO_FUNCS_DECL(PerlIO_scalar) = {
PerlIOScalar_arg,
PerlIOScalar_fileno,
PerlIOScalar_dup,
PerlIOBase_read,
PerlIOScalar_read,
NULL, /* unread */
PerlIOScalar_write,
PerlIOScalar_seek,
Expand Down
52 changes: 50 additions & 2 deletions ext/PerlIO-scalar/t/scalar.t
View file
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 => 55;
use Test::More tests => 69;

my $fh;
my $var = "aaa\n";
Expand Down Expand Up @@ -97,7 +97,7 @@ open $fh, '<', \42;
is(<$fh>, "42", "reading from non-string scalars");
close $fh;

{ package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } }
{ package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } sub STORE {} }
tie $p, P; open $fh, '<', \$p;
is(<$fh>, "shazam", "reading from magic scalars");

Expand Down Expand Up @@ -132,6 +132,7 @@ is(<$fh>, "shazam", "reading from magic scalars");
package MgUndef;
sub TIESCALAR { bless [] }
sub FETCH { $fetch++; return undef }
sub STORE {}
}
tie my $scalar, MgUndef;

Expand Down Expand Up @@ -229,3 +230,50 @@ EOF
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:F: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');
}


0 comments on commit ffe0bb5

Please sign in to comment.