diff options
| -rw-r--r-- | gv.c | 8 | ||||
| -rw-r--r-- | gv.h | 12 | ||||
| -rw-r--r-- | pp_hot.c | 12 | ||||
| -rw-r--r-- | pp_sys.c | 7 | ||||
| -rw-r--r-- | sv.c | 41 | ||||
| -rw-r--r-- | t/op/gv.t | 136 | ||||
| -rw-r--r-- | util.c | 3 |
7 files changed, 185 insertions, 34 deletions
@@ -45,7 +45,13 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) { SV **where; - if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) { + if ( + !gv + || ( + SvTYPE((const SV *)gv) != SVt_PVGV + && SvTYPE((const SV *)gv) != SVt_PVLV + ) + ) { const char *what; if (type == SVt_PVIO) { /* @@ -88,7 +88,17 @@ Return the SV from the GV. #endif #define GvREFCNT(gv) (GvGP(gv)->gp_refcnt) -#define GvIO(gv) ((gv) && SvTYPE((const SV*)gv) == SVt_PVGV && GvGP(gv) ? GvIOp(gv) : NULL) +#define GvIO(gv) \ + ( \ + (gv) \ + && ( \ + SvTYPE((const SV*)(gv)) == SVt_PVGV \ + || SvTYPE((const SV*)(gv)) == SVt_PVLV \ + ) \ + && GvGP(gv) \ + ? GvIOp(gv) \ + : NULL \ + ) #define GvIOp(gv) (GvGP(gv)->gp_io) #define GvIOn(gv) (GvIO(gv) ? GvIOp(gv) : GvIOp(gv_IOadd(gv))) @@ -123,7 +123,7 @@ PP(pp_sassign) if (PL_op->op_private & OPpASSIGN_CV_TO_GV) { SV * const cv = SvRV(left); const U32 cv_type = SvTYPE(cv); - const U32 gv_type = SvTYPE(right); + const bool is_gv = isGV_with_GP(right); const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM; if (!got_coderef) { @@ -133,7 +133,7 @@ PP(pp_sassign) /* Can do the optimisation if right (LVALUE) is not a typeglob, left (RVALUE) is a reference to something, and we're in void context. */ - if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) { + if (!got_coderef && !is_gv && GIMME_V == G_VOID) { /* Is the target symbol table currently empty? */ GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV); if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) { @@ -151,7 +151,7 @@ PP(pp_sassign) } /* Need to fix things up. */ - if (gv_type != SVt_PVGV) { + if (!is_gv) { /* Need to fix GV. */ right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV)); } @@ -201,7 +201,7 @@ PP(pp_sassign) /* Allow glob assignments like *$x = ..., which, when the glob has a SVf_FAKE flag, cannot be distinguished from $x = ... without looking at the op tree. */ - if( SvTYPE(right) == SVt_PVGV && cBINOP->op_last->op_type == OP_RV2GV + if( isGV_with_GP(right) && cBINOP->op_last->op_type == OP_RV2GV && (wasfake = SvFLAGS(right) & SVf_FAKE) ) SvFLAGS(right) &= ~SVf_FAKE; SvSetMagicSV(right, left); @@ -2749,6 +2749,7 @@ PP(pp_entersub) case SVt_PVGV: if (!isGV_with_GP(sv)) DIE(aTHX_ "Not a CODE reference"); + we_have_a_glob: if (!(cv = GvCVu((const GV *)sv))) { HV *stash; cv = sv_2cv(sv, &stash, &gv, 0); @@ -2759,6 +2760,9 @@ PP(pp_entersub) goto try_autoload; } break; + case SVt_PVLV: + if(isGV_with_GP(sv)) goto we_have_a_glob; + /*FALLTHROUGH*/ default: if (sv == &PL_sv_yes) { /* unfound import, ignore */ if (hasargs) @@ -505,7 +505,7 @@ PP(pp_open) GV * const gv = MUTABLE_GV(*++MARK); - if (!isGV(gv)) + if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv))) DIE(aTHX_ PL_no_usym, "filehandle"); if ((io = GvIOp(gv))) { @@ -825,6 +825,7 @@ PP(pp_tie) methname = "TIEARRAY"; break; case SVt_PVGV: + case SVt_PVLV: if (isGV_with_GP(varsv)) { methname = "TIEHANDLE"; how = PERL_MAGIC_tiedscalar; @@ -3336,7 +3337,7 @@ PP(pp_fttty) if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; - else if (isGV(TOPs)) + else if (isGV_with_GP(TOPs)) gv = MUTABLE_GV(POPs); else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = MUTABLE_GV(SvRV(POPs)); @@ -3389,7 +3390,7 @@ PP(pp_fttext) if (PL_op->op_flags & OPf_REF) gv = cGVOP_gv; - else if (isGV(TOPs)) + else if (isGV_with_GP(TOPs)) gv = MUTABLE_GV(POPs); else if (SvROK(TOPs) && isGV(SvRV(TOPs))) gv = MUTABLE_GV(SvRV(POPs)); @@ -3806,7 +3806,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) switch (stype) { case SVt_NULL: undef_sstr: - if (dtype != SVt_PVGV) { + if (dtype != SVt_PVGV && dtype != SVt_PVLV) { (void)SvOK_off(dstr); return; } @@ -3822,6 +3822,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) sv_upgrade(dstr, SVt_PVIV); break; case SVt_PVGV: + case SVt_PVLV: goto end_of_first_switch; } (void)SvIOK_only(dstr); @@ -3853,6 +3854,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) sv_upgrade(dstr, SVt_PVNV); break; case SVt_PVGV: + case SVt_PVLV: goto end_of_first_switch; } SvNV_set(dstr, SvNVX(sstr)); @@ -3905,7 +3907,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) /* case SVt_BIND: */ case SVt_PVLV: case SVt_PVGV: - if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) { + if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) { glob_assign_glob(dstr, sstr, dtype); return; } @@ -3915,12 +3917,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) case SVt_PVMG: if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { mg_get(sstr); - if (SvTYPE(sstr) != stype) { + if (SvTYPE(sstr) != stype) stype = SvTYPE(sstr); - if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) { + if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) { glob_assign_glob(dstr, sstr, dtype); return; - } } } if (stype == SVt_PVLV) @@ -3955,7 +3956,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) else Perl_croak(aTHX_ "Cannot copy to %s", type); } else if (sflags & SVf_ROK) { - if (isGV_with_GP(dstr) && dtype == SVt_PVGV + if (isGV_with_GP(dstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) { sstr = SvRV(sstr); if (sstr == dstr) { @@ -3972,7 +3973,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } if (dtype >= SVt_PV) { - if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { + if (isGV_with_GP(dstr)) { glob_assign_ref(dstr, sstr); return; } @@ -3990,7 +3991,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) assert(!(sflags & SVf_NOK)); assert(!(sflags & SVf_IOK)); } - else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { + else if (isGV_with_GP(dstr)) { if (!(sflags & SVf_OK)) { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob"); @@ -4591,7 +4592,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) #endif if (SvROK(sv)) sv_unref_flags(sv, flags); - else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) + else if (SvFAKE(sv) && isGV_with_GP(sv)) sv_unglob(sv); else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) { /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous @@ -8444,6 +8445,7 @@ Perl_sv_2io(pTHX_ SV *const sv) io = MUTABLE_IO(sv); break; case SVt_PVGV: + case SVt_PVLV: if (isGV_with_GP(sv)) { gv = MUTABLE_GV(sv); io = GvIO(gv); @@ -9047,7 +9049,8 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) return sv; } -/* Downgrades a PVGV to a PVMG. +/* Downgrades a PVGV to a PVMG. If it’s actually a PVLV, we leave the type + * as it is after unglobbing it. */ STATIC void @@ -9060,7 +9063,7 @@ S_sv_unglob(pTHX_ SV *const sv) PERL_ARGS_ASSERT_SV_UNGLOB; - assert(SvTYPE(sv) == SVt_PVGV); + assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV); SvFAKE_off(sv); gv_efullname3(temp, MUTABLE_GV(sv), "*"); @@ -9080,14 +9083,16 @@ S_sv_unglob(pTHX_ SV *const sv) } isGV_with_GP_off(sv); - /* need to keep SvANY(sv) in the right arena */ - xpvmg = new_XPVMG(); - StructCopy(SvANY(sv), xpvmg, XPVMG); - del_XPVGV(SvANY(sv)); - SvANY(sv) = xpvmg; + if(SvTYPE(sv) == SVt_PVGV) { + /* need to keep SvANY(sv) in the right arena */ + xpvmg = new_XPVMG(); + StructCopy(SvANY(sv), xpvmg, XPVMG); + del_XPVGV(SvANY(sv)); + SvANY(sv) = xpvmg; - SvFLAGS(sv) &= ~SVTYPEMASK; - SvFLAGS(sv) |= SVt_PVMG; + SvFLAGS(sv) &= ~SVTYPEMASK; + SvFLAGS(sv) |= SVt_PVMG; + } /* Intentionally not calling any local SET magic, as this isn't so much a set operation as merely an internal storage change. */ @@ -7,12 +7,12 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require './test.pl'; } use warnings; -require './test.pl'; -plan( tests => 194 ); +plan( tests => 219 ); # type coersion on assignment $foo = 'foo'; @@ -253,11 +253,12 @@ is($j[0], 1); # test the assignment of a GLOB to an LVALUE my $e = ''; local $SIG{__DIE__} = sub { $e = $_[0] }; - my $v; + my %v; sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA } - f($v); - is ($v, '*main::DATA'); - my $x = <$v>; + f($v{v}); + is ($v{v}, '*main::DATA'); + is (ref\$v{v}, 'GLOB', 'lvalue assignment preserves globs'); + my $x = readline $v{v}; is ($x, "perl\n"); } @@ -272,6 +273,10 @@ is($j[0], 1); tie my @ary => "T"; $ary[0] = *DATA; is ($ary[0], '*main::DATA'); + is ( + ref\tied(@ary)->[0], 'GLOB', + 'tied elem assignment preserves globs' + ); is ($e, ''); my $x = readline $ary[0]; is($x, "rocks\n"); @@ -652,6 +657,125 @@ EOF ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'"); } +# [perl #77362] various bugs related to globs as PVLVs +{ + no warnings qw 'once void'; + my %h; # We pass a key of this hash to the subroutine to get a PVLV. + sub { for(shift) { + # Set up our glob-as-PVLV + $_ = *hon; + + # Bad symbol for array + ok eval{ @$_; 1 }, 'PVLV glob slots can be autovivified' or diag $@; + + # This should call TIEHANDLE, not TIESCALAR + *thext::TIEHANDLE = sub{}; + ok eval{ tie *$_, 'thext'; 1 }, 'PVLV globs can be tied as handles' + or diag $@; + + # Assigning undef to the glob should not overwrite it... + { + my $w; + local $SIG{__WARN__} = sub { $w = shift }; + *$_ = undef; + is $_, "*main::hon", 'PVLV: assigning undef to the glob does nothing'; + like $w, qr\Undefined value assigned to typeglob\, + 'PVLV: assigning undef to the glob warns'; + } + + # Neither should number assignment... + *$_ = 1; + is $_, "*main::1", "PVLV: integer-to-glob assignment assigns a glob"; + *$_ = 2.0; + is $_, "*main::2", "PVLV: float-to-glob assignment assigns a glob"; + + # Nor reference assignment. + *$_ = \*thit; + is $_, "*main::thit", "PVLV: globref-to-glob assignment assigns a glob"; + *$_ = []; + is $_, "*main::thit", "PVLV: arrayref assignment assigns to the AV slot"; + + # Concatenation should still work. + ok eval { $_ .= 'thlew' }, 'PVLV concatenation does not die' or diag $@; + is $_, '*main::thitthlew', 'PVLV concatenation works'; + + # And we should be able to overwrite it with a string, number, or refer- + # ence, too, if we omit the *. + $_ = *hon; $_ = 'tzor'; + is $_, 'tzor', 'PVLV: assigning a string over a glob'; + $_ = *hon; $_ = 23; + is $_, 23, 'PVLV: assigning an integer over a glob'; + $_ = *hon; $_ = 23.23; + is $_, 23.23, 'PVLV: assigning a float over a glob'; + $_ = *hon; $_ = \my $sthat; + is $_, \$sthat, 'PVLV: assigning a reference over a glob'; + + # This bug was found by code inspection. Could this ever happen in + # real life? :-) + # This duplicates a file handle, accessing it through a PVLV glob, the + # glob having been removed from the symbol table, so a stringified form + # of it does not work. This checks that sv_2io does not stringify a PVLV. + $_ = *quin; + open *quin, "test.pl"; # test.pl is as good a file as any + delete $::{quin}; + ok eval { open my $zow, "<&", $_ }, 'PVLV: sv_2io stringifieth not' + or diag $@; + + # Similar tests to make sure sv_2cv etc. do not stringify. + *$_ = sub { 1 }; + ok eval { &$_ }, "PVLV glob can be called as a sub" or diag $@; + *flelp = sub { 2 }; + $_ = 'flelp'; + is eval { &$_ }, 2, 'PVLV holding a string can be called as a sub' + or diag $@; + + # Coderef-to-glob assignment when the glob is no longer accessible + # under its name: These tests are to make sure the OPpASSIGN_CV_TO_GV + # optimisation takes PVLVs into account, which is why the RHSs have to be + # named subs. + use constant gheen => 'quare'; + $_ = *ming; + delete $::{ming}; + *$_ = \&gheen; + is eval { &$_ }, 'quare', + 'PVLV: constant assignment when the glob is detached from the symtab' + or diag $@; + $_ = *bength; + delete $::{bength}; + *gheck = sub { 'lon' }; + *$_ = \&gheck; + is eval { &$_ }, 'lon', + 'PVLV: coderef assignment when the glob is detached from the symtab' + or diag $@; + + # open should accept a PVLV as its first argument + $_ = *hon; + ok eval { open $_,'<', \my $thlext }, 'PVLV can be the first arg to open' + or diag $@; + + # -t should not stringify + $_ = *thlit; delete $::{thlit}; + *$_ = *STDOUT{IO}; + ok defined -t $_, 'PVLV: -t does not stringify'; + + # neither should -T + open my $quile, "<", 'test.pl'; + $_ = *$quile; + ok -T $_, "PVLV: -T does not stringify"; + + # Unopened file handle + { + my $w; + local $SIG{__WARN__} = sub { $w .= shift }; + $_ = *vor; + close $_; + like $w, qr\unopened filehandle vor\, + 'PVLV globs get their names reported in unopened error messages'; + } + + }}->($h{k}); +} + __END__ Perl Rules @@ -3826,7 +3826,8 @@ Perl_my_fflush_all(pTHX) void Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op) { - const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL; + const char * const name + = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL; if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { if (ckWARN(WARN_IO)) { |