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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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 (file)
--- 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