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

p4raw-id: //depot/perl@28798
Perl · Sep 7, 2006 · b35bc0c · b35bc0c
1 parent 4eb3f1b
commit b35bc0c
Show file tree

Hide file tree

Showing 2 changed files with 34 additions and 1 deletion.
diff --git 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
@@ -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;
+}