From: Rafael Garcia-Suarez <rgarciasuarez@gmail.com>
Date: Thu, 7 Sep 2006 11:45:36 +0000 (+0000)
Subject: Fix for [perl #40267] PerlIO::scalar doesn't respect readonly-ness
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b35bc0c6c55657527d346e6d05f46024491a31b0;p=p5sagit%2Fp5-mst-13.2.git

Fix for [perl #40267] PerlIO::scalar doesn't respect readonly-ness

p4raw-id: //depot/perl@28798
---

diff --git a/ext/PerlIO/scalar/scalar.xs b/ext/PerlIO/scalar/scalar.xs
index 160deb2..50a718f 100644
--- a/ext/PerlIO/scalar/scalar.xs
+++ b/ext/PerlIO/scalar/scalar.xs
@@ -24,6 +24,12 @@ PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
      */
     if (arg) {
 	if (SvROK(arg)) {
+	    if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
+		if (ckWARN(WARN_LAYER))
+		    Perl_warner(aTHX_ packWARN(WARN_LAYER), PL_no_modify);
+		errno = EINVAL;
+		return -1;
+	    }
 	    s->var = SvREFCNT_inc(SvRV(arg));
 	    if (!SvPOK(s->var) && SvTYPE(SvRV(arg)) > SVt_NULL)
 		(void)SvPV_nolen(s->var);
diff --git a/ext/PerlIO/t/scalar.t b/ext/PerlIO/t/scalar.t
index 8b43acb..626fe4c 100644
--- a/ext/PerlIO/t/scalar.t
+++ b/ext/PerlIO/t/scalar.t
@@ -15,7 +15,7 @@ BEGIN {
 }
 
 $| = 1;
-print "1..27\n";
+print "1..30\n";
 
 my $fh;
 my $var = "ok 2\n";
@@ -163,3 +163,30 @@ EOF
     close F;
     print $ln eq $s ? "ok 27\n" : "not ok 27\n";
 }
+
+# [perl #40267] PerlIO::scalar doesn't respect readonly-ness
+{
+    if (open(F, '>', \undef)) {
+	print "not ok 28\n";
+    }
+    else {
+	print "ok 28 - \$! is $!\n";
+    }
+    close F;
+    my $ro = \43;
+    if (open(F, '>', $ro)) {
+	print "not ok 29\n";
+    }
+    else {
+	print "ok 29 - \$! is $!\n";
+    }
+    close F;
+    # but we can read from it
+    if (open(F, '<', $ro)) {
+	print "ok 30\n";
+    }
+    else {
+	print "not ok 30 - \$! is $!\n";
+    }
+    close F;
+}