X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9f8bf29815397e529be92022542fb51ea86d3fd5..b5ce1198cdc91a8659e421932c6de164a98d9b39:/gv.c diff --git a/gv.c b/gv.c index f43706c..ecc23c3 100644 --- a/gv.c +++ b/gv.c @@ -317,6 +317,9 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) /* newCONSTSUB takes ownership of the reference from us. */ cv = newCONSTSUB(stash, (name0 ? name0 : name), has_constant); + /* In case op.c:S_process_special_blocks stole it: */ + if (!GvCV(gv)) + GvCV(gv) = (CV *)SvREFCNT_inc_simple_NN(cv); assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */ if (name0) Safefree(name0); @@ -715,6 +718,20 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) /* Right now this is exclusively for the benefit of S_method_common in pp_hot.c */ if (stash) { + /* If we can't find an IO::File method, it might be a call on + * a filehandle. If IO:File has not been loaded, try to + * require it first instead of croaking */ + const char *stash_name = HvNAME_get(stash); + if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File") + && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL, + STR_WITH_LEN("IO/File.pm"), 0, + HV_FETCH_ISEXISTS, NULL, 0) + ) { + require_pv("IO/File.pm"); + gv = gv_fetchmeth(stash, name, nend - name, 0); + if (gv) + return gv; + } Perl_croak(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"", name, (int)HvNAMELEN_get(stash), HvNAME_get(stash)); @@ -840,7 +857,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) /* require_tie_mod() internal routine for requiring a module - * that implements the logic of automatical ties like %! and %- + * that implements the logic of automatic ties like %! and %- * * The "gv" parameter should be the glob. * "varpv" holds the name of the var, used for error messages. @@ -1072,9 +1089,17 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, return NULL; if (!(stash = GvHV(gv))) + { stash = GvHV(gv) = newHV(); - - if (!HvNAME_get(stash)) + if (!HvNAME_get(stash)) { + hv_name_set(stash, nambeg, name_cursor-nambeg, 0); + /* If the containing stash has multiple effective + names, see that this one gets them, too. */ + if (HvAUX(GvSTASH(gv))->xhv_name_count) + mro_package_moved(stash, NULL, gv, 1); + } + } + else if (!HvNAME_get(stash)) hv_name_set(stash, nambeg, name_cursor - nambeg, 0); } @@ -1219,6 +1244,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, else if (*name == '-' || *name == '+') require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); } + else if (len == 3 && sv_type == SVt_PVAV + && strnEQ(name, "ISA", 3) + && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) + gv_magicalize_isa(gv); } return gv; } else if (no_init) { @@ -1349,6 +1378,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (strEQ(name2, "NCODING")) goto magicalize; break; + case '\007': /* $^GLOBAL_PHASE */ + if (strEQ(name2, "LOBAL_PHASE")) + goto ro_magicalize; + break; case '\015': /* $^MATCH */ if (strEQ(name2, "ATCH")) goto magicalize; @@ -1358,7 +1391,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case '\020': /* $^PREMATCH $^POSTMATCH */ if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH")) - goto magicalize; + goto magicalize; + break; case '\024': /* ${^TAINT} */ if (strEQ(name2, "AINT")) goto ro_magicalize; @@ -1880,7 +1914,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) do_update: /* If we're looking up a destructor to invoke, we must avoid * that Gv_AMupdate croaks, because we might be dying already */ - if (Gv_AMupdate(stash, id == DESTROY_amg) == -1) { + if (Gv_AMupdate(stash, cBOOL(id == DESTROY_amg)) == -1) { /* and if it didn't found a destructor, we fall back * to a simpler method that will only look for the * destructor instead of the whole magic */ @@ -2010,6 +2044,25 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) { return FALSE; } +SV * +Perl_amagic_deref_call(pTHX_ SV *ref, int method) { + SV *tmpsv = NULL; + + PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL; + + while (SvAMAGIC(ref) && + (tmpsv = amagic_call(ref, &PL_sv_undef, method, + AMGf_noright | AMGf_unary))) { + if (!SvROK(tmpsv)) + Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); + if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) { + /* Bail out if it returns us the same reference. */ + return tmpsv; + } + ref = tmpsv; + } + return tmpsv ? tmpsv : ref; +} SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) @@ -2023,6 +2076,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) int postpr = 0, force_cpy = 0; int assign = AMGf_assign & flags; const int assignshift = assign ? 1 : 0; + int use_default_op = 0; #ifdef DEBUGGING int fl=0; #endif @@ -2186,9 +2240,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) && (cv = cvp[off=method])) { /* Method for right * argument found */ lr=1; - } else if (((ocvp && oamtp->fallback > AMGfallNEVER - && (cvp=ocvp) && (lr = -1)) - || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) + } else if (((cvp && amtp->fallback > AMGfallNEVER) + || (ocvp && oamtp->fallback > AMGfallNEVER)) && !(flags & AMGf_unary)) { /* We look for substitution for * comparison operations and @@ -2216,7 +2269,17 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) off = scmp_amg; break; } - if ((off != -1) && (cv = cvp[off])) + if (off != -1) { + if (ocvp && (oamtp->fallback > AMGfallNEVER)) { + cv = ocvp[off]; + lr = -1; + } + if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) { + cv = cvp[off]; + lr = 1; + } + } + if (cv) postpr = 1; else goto not_found; @@ -2236,7 +2299,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) notfound = 1; lr = -1; } else if (cvp && (cv=cvp[nomethod_amg])) { notfound = 1; lr = 1; - } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) { + } else if ((use_default_op = + (!ocvp || oamtp->fallback >= AMGfallYES) + && (!cvp || amtp->fallback >= AMGfallYES)) + && !DEBUG_o_TEST) { /* Skip generating the "no method found" message. */ return NULL; } else { @@ -2260,7 +2326,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SvAMAGIC(right)? HvNAME_get(SvSTASH(SvRV(right))): "")); - if (amtp && amtp->fallback >= AMGfallYES) { + if (use_default_op) { DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); } else { Perl_croak(aTHX_ "%"SVf, SVfARG(msg)); @@ -2313,7 +2379,15 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) && (assign || (method == inc_amg) || (method == dec_amg))) || force_cpy) { - RvDEEPCP(left); + /* newSVsv does not behave as advertised, so we copy missing + * information by hand */ + SV *tmpRef = SvRV(left); + SV *rv_copy; + if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) { + SvRV_set(left, rv_copy); + SvSETMAGIC(left); + SvREFCNT_dec(tmpRef); + } } { @@ -2592,7 +2666,7 @@ Perl_gv_try_downgrade(pTHX_ GV *gv) /* XXX Why and where does this leave dangling pointers during global destruction? */ - if (PL_dirty) return; + if (PL_phase == PERL_PHASE_DESTRUCT) return; if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) && !SvOBJECT(gv) && !SvREADONLY(gv) &&