From: David Mitchell <davem@iabyn.com>
Date: Tue, 30 Mar 2010 14:03:50 +0000 (+0100)
Subject: PL_defoutgv isn't always a GV.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=099be4f1d597471eb719c9a344b7c1b55e11ba24;p=p5sagit%2Fp5-mst-13.2.git

PL_defoutgv isn't always a GV.

Nasty code like the following results in PL_defoutgv not pointing
to a valid GV:

    my $x = *STDERR; select($x); $x = 1;

This causes all sorts of SEGVs when PL_defoutgv is subsequently accessed,
because most code assumes that it has a valid gv_gp pointer.  It also
turns out that PL_defoutgv is under-tested; for example, temporarily
hacking pp_close to make an arg-less close() croak didn't cause any
minitest failures.

Add a new test file that does some basic testing of a bad PL_defoutgv,
and fix all the obvious badness in accessing it.

This also fixes #20727, which although ostensibly a tie bug, was due to
PL_defoutgv pointing to a tiedelem scalar, and fun like that described
above happening.
---

diff --git a/MANIFEST b/MANIFEST
index 07e0e0c..e01ecd7 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4223,6 +4223,7 @@ t/io/argv.t			See if ARGV stuff works
 t/io/binmode.t			See if binmode() works
 t/io/crlf.t			See if :crlf works
 t/io/crlf_through.t		See if pipe passes data intact with :crlf
+t/io/defout.t			See if PL_defoutgv works
 t/io/dup.t			See if >& works right
 t/io/errno.t			See if $! is correctly set
 t/io/fflush.t			See if auto-flush on fork/exec/system/qx works
diff --git a/gv.c b/gv.c
index becd1e9..060d8e6 100644
--- a/gv.c
+++ b/gv.c
@@ -1468,7 +1468,7 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
 void
 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
 {
-    const GV * const egv = GvEGV(gv);
+    const GV * const egv = GvEGVx(gv);
 
     PERL_ARGS_ASSERT_GV_EFULLNAME4;
 
@@ -2394,7 +2394,7 @@ Perl_gv_try_downgrade(pTHX_ GV *gv)
 	    isGV_with_GP(gv) && GvGP(gv) &&
 	    !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
 	    !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
-	    GvEGV(gv) == gv && (stash = GvSTASH(gv))))
+	    GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
 	return;
     cv = GvCV(gv);
     if (!cv) {
diff --git a/gv.h b/gv.h
index caef3da..be4290d 100644
--- a/gv.h
+++ b/gv.h
@@ -114,6 +114,7 @@ Return the SV from the GV.
 #define GvFILEGV(gv)	(gv_fetchfile(GvFILE(gv)))
 
 #define GvEGV(gv)	(GvGP(gv)->gp_egv)
+#define GvEGVx(gv)	(isGV_with_GP(gv) ? GvEGV(gv) : NULL)
 #define GvENAME(gv)	GvNAME(GvEGV(gv) ? GvEGV(gv) : gv)
 #define GvESTASH(gv)	GvSTASH(GvEGV(gv) ? GvEGV(gv) : gv)
 
diff --git a/mg.c b/mg.c
index bf8bd53..39d608b 100644
--- a/mg.c
+++ b/mg.c
@@ -991,8 +991,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	}
 	break;
     case '^':
-	if (GvIOp(PL_defoutgv))
-	    s = IoTOP_NAME(GvIOp(PL_defoutgv));
+	if (!isGV_with_GP(PL_defoutgv))
+	    s = "";
+	else if (GvIOp(PL_defoutgv))
+		s = IoTOP_NAME(GvIOp(PL_defoutgv));
 	if (s)
 	    sv_setpv(sv,s);
 	else {
@@ -1001,22 +1003,24 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	}
 	break;
     case '~':
-	if (GvIOp(PL_defoutgv))
+	if (!isGV_with_GP(PL_defoutgv))
+	    s = "";
+	else if (GvIOp(PL_defoutgv))
 	    s = IoFMT_NAME(GvIOp(PL_defoutgv));
 	if (!s)
 	    s = GvENAME(PL_defoutgv);
 	sv_setpv(sv,s);
 	break;
     case '=':
-	if (GvIOp(PL_defoutgv))
+	if (GvIO(PL_defoutgv))
 	    sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
 	break;
     case '-':
-	if (GvIOp(PL_defoutgv))
+	if (GvIO(PL_defoutgv))
 	    sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
 	break;
     case '%':
-	if (GvIOp(PL_defoutgv))
+	if (GvIO(PL_defoutgv))
 	    sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
 	break;
     case ':':
@@ -1027,7 +1031,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
 	break;
     case '|':
-	if (GvIOp(PL_defoutgv))
+	if (GvIO(PL_defoutgv))
 	    sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 	break;
     case '\\':
@@ -2523,29 +2527,37 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
 	break;
     case '^':
-	Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
-	s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
-	IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+	if (isGV_with_GP(PL_defoutgv)) {
+	    Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
+	    s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
+	    IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+	}
 	break;
     case '~':
-	Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
-	s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
-	IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+	if (isGV_with_GP(PL_defoutgv)) {
+	    Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
+	    s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
+	    IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+	}
 	break;
     case '=':
-	IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
+	if (isGV_with_GP(PL_defoutgv))
+	    IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
 	break;
     case '-':
-	IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
-	if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
-	    IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
+	if (isGV_with_GP(PL_defoutgv)) {
+	    IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
+	    if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
+		IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
+	}
 	break;
     case '%':
-	IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
+	if (isGV_with_GP(PL_defoutgv))
+	    IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
 	break;
     case '|':
 	{
-	    IO * const io = GvIOp(PL_defoutgv);
+	    IO * const io = GvIO(PL_defoutgv);
 	    if(!io)
 	      break;
 	    if ((SvIV(sv)) == 0)
diff --git a/pp_hot.c b/pp_hot.c
index 8f8af53..70d3556 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -734,7 +734,7 @@ PP(pp_print)
 	RETURN;
     }
     if (!(io = GvIO(gv))) {
-        if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
+        if ((GvEGVx(gv)) && (io = GvIO(GvEGV(gv)))
 	    && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
             goto had_magic;
 	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
diff --git a/pp_sys.c b/pp_sys.c
index e7cdb59..8dd8bc0 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1170,11 +1170,11 @@ PP(pp_select)
     dVAR; dSP; dTARGET;
     HV *hv;
     GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
-    GV * egv = GvEGV(PL_defoutgv);
+    GV * egv = GvEGVx(PL_defoutgv);
 
     if (!egv)
 	egv = PL_defoutgv;
-    hv = GvSTASH(egv);
+    hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
     if (! hv)
 	XPUSHs(&PL_sv_undef);
     else {
@@ -2017,7 +2017,7 @@ PP(pp_eof)
     if (MAXARG)
 	gv = PL_last_in_gv = MUTABLE_GV(POPs);	/* eof(FH) */
     else if (PL_op->op_flags & OPf_SPECIAL)
-	gv = PL_last_in_gv = GvEGV(PL_argvgv);	/* eof() - ARGV magic */
+	gv = PL_last_in_gv = GvEGVx(PL_argvgv);	/* eof() - ARGV magic */
     else
 	gv = PL_last_in_gv;			/* eof */
 
diff --git a/t/io/defout.t b/t/io/defout.t
new file mode 100644
index 0000000..d99b39b
--- /dev/null
+++ b/t/io/defout.t
@@ -0,0 +1,47 @@
+#!./perl
+#
+# tests for default output handle
+
+# DAPM 30/4/10 this area seems to have been undertested. For now, the only
+# tests are ensuring things don't crash when PL_defoutgv isn't a GV;
+# it probably needs expanding at some point to cover other stuff.
+
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+plan tests => 16;
+
+
+my $stderr = *STDERR;
+select($stderr);
+$stderr = 1; # whoops, PL_defoutgv no longer a GV!
+
+# note that in the tests below, the return values aren't as important
+# as the fact that they don't crash
+
+ok !print(""), 'print';
+ok !select(), 'select';
+$a = 'fooo';
+format STDERR =
+#@<<
+$a;
+.
+ok ! write(), 'write';
+
+is($^, "",     '$^');
+is($~, "",     '$~');
+is($=, undef,  '$=');
+is($-, undef,  '$-');
+is($%, undef,  '$%');
+is($|, 0,      '$|');
+$^ = 1; pass '$^ = 1';
+$~ = 1; pass '$~ = 1';
+$= = 1; pass '$= = 1';
+$- = 1; pass '$- = 1';
+$% = 1; pass '$% = 1';
+$| = 1; pass '$| = 1';
+ok !close(), 'close';
+
diff --git a/t/op/tie.t b/t/op/tie.t
index 8daa8b0..a2e1d4a 100644
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -646,3 +646,15 @@ sub TIEHASH { bless [], 'main' }
 }
 print "tied\n" if tied %h;
 EXPECT
+########
+# RT 20727: PL_defoutgv is left as a tied element
+sub TIESCALAR { return bless {}, 'main' }
+
+sub STORE {
+    select($_[1]);
+    $_[1] = 1;
+    select(); # this used to coredump or assert fail
+}
+tie $SELECT, 'main';
+$SELECT = *STDERR;
+EXPECT