diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | gv.c | 4 | ||||
| -rw-r--r-- | gv.h | 1 | ||||
| -rw-r--r-- | mg.c | 50 | ||||
| -rw-r--r-- | pp_hot.c | 2 | ||||
| -rw-r--r-- | pp_sys.c | 6 | ||||
| -rw-r--r-- | t/io/defout.t | 47 | ||||
| -rw-r--r-- | t/op/tie.t | 12 |
8 files changed, 98 insertions, 25 deletions
@@ -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 @@ -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) { @@ -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) @@ -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) @@ -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)) @@ -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 0000000000..d99b39bd6c --- /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 8daa8b06f1..a2e1d4a27b 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 |