From: David Mitchell Date: Wed, 5 May 2010 21:39:24 +0000 (+0100) Subject: RT 43789: "in memory" files don't call STORE X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ffe0bb5ab7ece4bcdcb968ad795cd58d265b845b;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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'); +} + +