RT 43789: "in memory" files don't call STORE

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

diff --git a/ext/PerlIO-scalar/scalar.xs b/ext/PerlIO-scalar/scalar.xs
index d9574d7..67f674a 100644 (file)
--- a/ext/PerlIO-scalar/scalar.xs
+++ b/ext/PerlIO-scalar/scalar.xs
@@ -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;
 }
 
@@ -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) {
@@ -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)
 {
@@ -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);
@@ -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
@@ -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;
@@ -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
@@ -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;
@@ -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;
 }
 
@@ -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,

diff --git a/ext/PerlIO-scalar/t/scalar.t b/ext/PerlIO-scalar/t/scalar.t
index d2d86b5..adc5b8e 100644 (file)
--- a/ext/PerlIO-scalar/t/scalar.t
+++ b/ext/PerlIO-scalar/t/scalar.t
@@ -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";
@@ -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");
 
@@ -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;
 
@@ -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');
+}
+
+