X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c68d956458c78806cbdba85dfe23247f62e143d5..be48bbe8d671b6841c3ec7cb734b98071afe3cd9:/gv.c diff --git a/gv.c b/gv.c index ab43177..19059bc 100644 --- a/gv.c +++ b/gv.c @@ -16,7 +16,7 @@ * history of Middle-earth and Over-heaven and of the Sundering Seas,' * laughed Pippin. * - * [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"] + * [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"] */ /* @@ -36,6 +36,7 @@ Perl stores its global variables. #define PERL_IN_GV_C #include "perl.h" #include "overload.c" +#include "keywords.h" static const char S_autoload[] = "AUTOLOAD"; static const STRLEN S_autolen = sizeof(S_autoload)-1; @@ -58,11 +59,7 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) * if it walks like a dirhandle, then let's assume that * this is a dirhandle. */ - what = PL_op->op_type == OP_READDIR || - PL_op->op_type == OP_TELLDIR || - PL_op->op_type == OP_SEEKDIR || - PL_op->op_type == OP_REWINDDIR || - PL_op->op_type == OP_CLOSEDIR ? + what = OP_IS_DIRHOP(PL_op->op_type) ? "dirhandle" : "filehandle"; /* diag_listed_as: Bad symbol for filehandle */ } else if (type == SVt_PVHV) { @@ -298,7 +295,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) SvIOK_off(gv); isGV_with_GP_on(gv); - GvGP(gv) = Perl_newGP(aTHX_ gv); + GvGP_set(gv, Perl_newGP(aTHX_ gv)); GvSTASH(gv) = stash; if (stash) Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); @@ -317,6 +314,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_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv)); assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */ if (name0) Safefree(name0); @@ -328,7 +328,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) } else { (void) start_subparse(0,0); /* Create empty CV in compcv. */ cv = PL_compcv; - GvCV(gv) = cv; + GvCV_set(gv,cv); } LEAVE; @@ -374,6 +374,127 @@ S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type) } } +static void core_xsub(pTHX_ CV* cv); + +static GV * +S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, + const char * const name, const STRLEN len, + const char * const fullname, STRLEN const fullen) +{ + const int code = keyword(name, len, 1); + static const char file[] = __FILE__; + CV *cv, *oldcompcv; + int opnum = 0; + SV *opnumsv; + bool ampable = TRUE; /* &{}-able */ + COP *oldcurcop; + yy_parser *oldparser; + I32 oldsavestack_ix; + + assert(gv || stash); + assert(name); + assert(stash || fullname); + + if (!fullname && !HvENAME(stash)) return NULL; /* pathological case + that would require + inlining newATTRSUB */ + if (code >= 0) return NULL; /* not overridable */ + switch (-code) { + /* no support for \&CORE::infix; + no support for funcs that take labels, as their parsing is + weird */ + case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump: + case KEY_eq: case KEY_ge: + case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne: + case KEY_or: case KEY_x: case KEY_xor: + return NULL; + case KEY_chdir: + case KEY_chomp: case KEY_chop: + case KEY_each: case KEY_eof: case KEY_exec: + case KEY_keys: + case KEY_lstat: + case KEY_pop: + case KEY_push: + case KEY_shift: + case KEY_splice: + case KEY_stat: + case KEY_system: + case KEY_truncate: case KEY_unlink: + case KEY_unshift: + case KEY_values: + ampable = FALSE; + } + if (!gv) { + gv = (GV *)newSV(0); + gv_init(gv, stash, name, len, TRUE); + } + if (ampable) { + ENTER; + oldcurcop = PL_curcop; + oldparser = PL_parser; + lex_start(NULL, NULL, 0); + oldcompcv = PL_compcv; + PL_compcv = NULL; /* Prevent start_subparse from setting + CvOUTSIDE. */ + oldsavestack_ix = start_subparse(FALSE,0); + cv = PL_compcv; + } + else { + /* Avoid calling newXS, as it calls us, and things start to + get hairy. */ + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + GvCV_set(gv,cv); + GvCVGEN(gv) = 0; + mro_method_changed_in(GvSTASH(gv)); + CvISXSUB_on(cv); + CvXSUB(cv) = core_xsub; + } + CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE + from PL_curcop. */ + (void)gv_fetchfile(file); + CvFILE(cv) = (char *)file; + /* XXX This is inefficient, as doing things this order causes + a prototype check in newATTRSUB. But we have to do + it this order as we need an op number before calling + new ATTRSUB. */ + (void)core_prototype((SV *)cv, name, code, &opnum); + if (stash && (fullname || !fullen)) + (void)hv_store(stash,name,len,(SV *)gv,0); + if (ampable) { + SV *tmpstr; + CvLVALUE_on(cv); + if (!fullname) { + tmpstr = newSVhek(HvENAME_HEK(stash)); + sv_catpvs(tmpstr, "::"); + sv_catpvn(tmpstr,name,len); + } + else tmpstr = newSVpvn_share(fullname,fullen,0); + newATTRSUB(oldsavestack_ix, + newSVOP(OP_CONST, 0, tmpstr), + NULL,NULL, + coresub_op( + opnum + ? newSVuv((UV)opnum) + : newSVpvn(name,len), + code, opnum + ) + ); + assert(GvCV(gv) == cv); + if (opnum != OP_VEC && opnum != OP_SUBSTR) + CvLVALUE_off(cv); /* Now *that* was a neat trick. */ + LEAVE; + PL_parser = oldparser; + PL_curcop = oldcurcop; + PL_compcv = oldcompcv; + } + opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL; + cv_set_call_checker( + cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv + ); + SvREFCNT_dec(opnumsv); + return gv; +} + /* =for apidoc gv_fetchmeth @@ -408,7 +529,6 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) HV* cstash; GV* candidate = NULL; CV* cand_cv = NULL; - CV* old_cv; GV* topgv = NULL; const char *hvname; I32 create = (level >= 0) ? 1 : 0; @@ -442,6 +562,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) gvp = (GV**)hv_fetch(stash, name, len, create); if(gvp) { topgv = *gvp; + have_gv: assert(topgv); if (SvTYPE(topgv) != SVt_PVGV) gv_init(topgv, stash, name, len, TRUE); @@ -453,7 +574,8 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) else { /* stale cache entry, junk it and move on */ SvREFCNT_dec(cand_cv); - GvCV(topgv) = cand_cv = NULL; + GvCV_set(topgv, NULL); + cand_cv = NULL; GvCVGEN(topgv) = 0; } } @@ -461,6 +583,10 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* cache indicates no such method definitively */ return 0; } + else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4 + && strnEQ(hvname, "CORE", 4) + && S_maybe_add_coresub(aTHX_ stash,topgv,name,len,0,1)) + goto have_gv; } packlen = HvNAMELEN_get(stash); @@ -490,8 +616,19 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) assert(cstash); gvp = (GV**)hv_fetch(cstash, name, len, 0); - if (!gvp) continue; - candidate = *gvp; + if (!gvp) { + if (len > 1 && HvNAMELEN_get(cstash) == 4) { + const char *hvname = HvNAME(cstash); assert(hvname); + if (strnEQ(hvname, "CORE", 4) + && (candidate = + S_maybe_add_coresub(aTHX_ cstash,NULL,name,len,0,0) + )) + goto have_candidate; + } + continue; + } + else candidate = *gvp; + have_candidate: assert(candidate); if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE); if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { @@ -501,9 +638,10 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) * 2. method isn't a stub (else AUTOLOAD fails spectacularly) */ if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { - if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); + CV *old_cv = GvCV(topgv); + SvREFCNT_dec(old_cv); SvREFCNT_inc_simple_void_NN(cand_cv); - GvCV(topgv) = cand_cv; + GvCV_set(topgv, cand_cv); GvCVGEN(topgv) = topgen_cmp; } return candidate; @@ -516,9 +654,10 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) if(candidate) { cand_cv = GvCV(candidate); if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { - if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); + CV *old_cv = GvCV(topgv); + SvREFCNT_dec(old_cv); SvREFCNT_inc_simple_void_NN(cand_cv); - GvCV(topgv) = cand_cv; + GvCV_set(topgv, cand_cv); GvCVGEN(topgv) = topgen_cmp; } return candidate; @@ -715,6 +854,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)); @@ -834,13 +987,15 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) varsv = GvSVn(vargv); sv_setpvn(varsv, packname, packname_len); sv_catpvs(varsv, "::"); - sv_catpvn(varsv, name, len); + /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear + tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */ + sv_catpvn_mg(varsv, name, len); return gv; } /* 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. @@ -939,8 +1094,17 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) if (!tmpgv) return NULL; stash = GvHV(tmpgv); + if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL; assert(stash); - assert(HvNAME_get(stash)); + if (!HvNAME_get(stash)) { + hv_name_set(stash, name, namelen, 0); + + /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ + /* If the containing stash has multiple effective + names, see that this one gets them, too. */ + if (HvAUX(GvSTASH(tmpgv))->xhv_name_count) + mro_package_moved(stash, NULL, tmpgv, 1); + } return stash; } @@ -973,7 +1137,8 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) { GV * Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) { STRLEN len; - const char * const nambeg = SvPV_const(name, len); + const char * const nambeg = + SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC); PERL_ARGS_ASSERT_GV_FETCHSV; return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); } @@ -1017,6 +1182,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); const I32 no_expand = flags & GV_NOEXPAND; const I32 add = flags & ~GV_NOADD_MASK; + bool addmg = !!(flags & GV_ADDMG); const char *const name_end = nambeg + full_len; const char *const name_em1 = name_end - 1; U32 faking_it; @@ -1035,9 +1201,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } for (name_cursor = name; name_cursor < name_end; name_cursor++) { - if ((*name_cursor == ':' && name_cursor < name_em1 + if (name_cursor < name_em1 && + ((*name_cursor == ':' && name_cursor[1] == ':') - || (*name_cursor == '\'' && name_cursor[1])) + || *name_cursor == '\'')) { if (!stash) stash = PL_defstash; @@ -1045,7 +1212,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, return NULL; len = name_cursor - name; - if (len > 0) { + if (name_cursor > nambeg) { /* Skip for initial :: or ' */ const char *key; if (*name_cursor == ':') { key = name; @@ -1067,21 +1234,34 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, GvMULTI_on(gv); } if (key != name) - Safefree((char *)key); + Safefree(key); if (!gv || gv == (const GV *)&PL_sv_undef) return NULL; if (!(stash = GvHV(gv))) + { stash = GvHV(gv) = newHV(); - - if (!HvNAME_get(stash)) + if (!HvNAME_get(stash)) { + if (GvSTASH(gv) == PL_defstash && len == 6 + && strnEQ(name, "CORE", 4)) + hv_name_set(stash, "CORE", 4, 0); + else + 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); } if (*name_cursor == ':') name_cursor++; - name_cursor++; - name = name_cursor; + name = name_cursor+1; if (name == name_end) return gv ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); @@ -1206,24 +1386,36 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, return NULL; gvp = (GV**)hv_fetch(stash,name,len,add); - if (!gvp || *gvp == (const GV *)&PL_sv_undef) - return NULL; - gv = *gvp; + if (!gvp || *gvp == (const GV *)&PL_sv_undef) { + if (addmg) gv = (GV *)newSV(0); + else return NULL; + } + else gv = *gvp, addmg = 0; + /* From this point on, addmg means gv has not been inserted in the + symtab yet. */ + if (SvTYPE(gv) == SVt_PVGV) { if (add) { GvMULTI_on(gv); gv_init_sv(gv, sv_type); - if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) { + if (len == 1 && stash == PL_defstash + && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) { if (*name == '!') require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); 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) { + assert(!addmg); return gv; } else if (no_expand && SvROK(gv)) { + assert(!addmg); return gv; } @@ -1239,7 +1431,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (add & GV_ADDWARN) Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg); gv_init(gv, stash, name, len, add & GV_ADDMULTI); - gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type); if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) ) @@ -1248,8 +1439,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* set up magic where warranted */ if (stash != PL_defstash) { /* not the main stash */ /* We only have to check for four names here: EXPORT, ISA, OVERLOAD - and VERSION. All the others apply only to the main stash. */ - if (len > 1) { + and VERSION. All the others apply only to the main stash or to + CORE (which is checked right after this). */ + if (len > 2) { const char * const name2 = name + 1; switch (*name) { case 'E': @@ -1268,7 +1460,20 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (strEQ(name2, "ERSION")) GvMULTI_on(gv); break; + default: + goto try_core; } + goto add_magical_gv; + } + try_core: + if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { + /* Avoid null warning: */ + const char * const stashname = HvNAME(stash); assert(stashname); + if (strnEQ(stashname, "CORE", 4) + && S_maybe_add_coresub(aTHX_ + addmg ? stash : 0, gv, name, len, nambeg, full_len + )) + addmg = 0; } } else if (len > 1) { @@ -1349,6 +1554,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 +1567,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; @@ -1390,7 +1600,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* This snippet is taken from is_gv_magical */ const char *end = name + len; while (--end > name) { - if (!isDIGIT(*end)) return gv; + if (!isDIGIT(*end)) goto add_magical_gv; } goto magicalize; } @@ -1494,6 +1704,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '>': /* $> */ case '\\': /* $\ */ case '/': /* $/ */ + case '$': /* $$ */ case '\001': /* $^A */ case '\003': /* $^C */ case '\004': /* $^D */ @@ -1518,7 +1729,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case ']': /* $] */ { - SV * const sv = GvSVn(gv); + SV * const sv = GvSV(gv); if (!sv_derived_from(PL_patchlevel, "version")) upg_version(PL_patchlevel, TRUE); GvSV(gv) = vnumify(PL_patchlevel); @@ -1528,7 +1739,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case '\026': /* $^V */ { - SV * const sv = GvSVn(gv); + SV * const sv = GvSV(gv); GvSV(gv) = new_version(PL_patchlevel); SvREADONLY_on(GvSV(gv)); SvREFCNT_dec(sv); @@ -1536,6 +1747,15 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; } } + add_magical_gv: + if (addmg) { + if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || ( + GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))) + )) + (void)hv_store(stash,name,len,(SV *)gv,0); + else SvREFCNT_dec(gv), gv = NULL; + } + if (gv) gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type); return gv; } @@ -1659,6 +1879,7 @@ Perl_gp_free(pTHX_ GV *gv) { dVAR; GP* gp; + int attempts = 100; if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) return; @@ -1671,29 +1892,65 @@ Perl_gp_free(pTHX_ GV *gv) if (--gp->gp_refcnt > 0) { if (gp->gp_egv == gv) gp->gp_egv = 0; - GvGP(gv) = 0; + GvGP_set(gv, NULL); return; } - if (gp->gp_file_hek) - unshare_hek(gp->gp_file_hek); - SvREFCNT_dec(gp->gp_sv); - SvREFCNT_dec(gp->gp_av); - /* FIXME - another reference loop GV -> symtab -> GV ? - Somehow gp->gp_hv can end up pointing at freed garbage. */ - if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) { - const char *hvname = HvNAME_get(gp->gp_hv); + while (1) { + /* Copy and null out all the glob slots, so destructors do not see + freed SVs. */ + HEK * const file_hek = gp->gp_file_hek; + SV * const sv = gp->gp_sv; + AV * const av = gp->gp_av; + HV * const hv = gp->gp_hv; + IO * const io = gp->gp_io; + CV * const cv = gp->gp_cv; + CV * const form = gp->gp_form; + + gp->gp_file_hek = NULL; + gp->gp_sv = NULL; + gp->gp_av = NULL; + gp->gp_hv = NULL; + gp->gp_io = NULL; + gp->gp_cv = NULL; + gp->gp_form = NULL; + + if (file_hek) + unshare_hek(file_hek); + + SvREFCNT_dec(sv); + SvREFCNT_dec(av); + /* FIXME - another reference loop GV -> symtab -> GV ? + Somehow gp->gp_hv can end up pointing at freed garbage. */ + if (hv && SvTYPE(hv) == SVt_PVHV) { + const char *hvname = HvNAME_get(hv); if (PL_stashcache && hvname) - (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv), + (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv), G_DISCARD); - SvREFCNT_dec(gp->gp_hv); + SvREFCNT_dec(hv); + } + SvREFCNT_dec(io); + SvREFCNT_dec(cv); + SvREFCNT_dec(form); + + if (!gp->gp_file_hek + && !gp->gp_sv + && !gp->gp_av + && !gp->gp_hv + && !gp->gp_io + && !gp->gp_cv + && !gp->gp_form) break; + + if (--attempts == 0) { + Perl_die(aTHX_ + "panic: gp_free failed to free glob pointer - " + "something is repeatedly re-creating entries" + ); + } } - SvREFCNT_dec(gp->gp_io); - SvREFCNT_dec(gp->gp_cv); - SvREFCNT_dec(gp->gp_form); Safefree(gp); - GvGP(gv) = 0; + GvGP_set(gv, NULL); } int @@ -1880,7 +2137,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 */ @@ -1934,7 +2191,8 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { SvGETMAGIC(arg); - if (SvAMAGIC(arg) && (tmpsv = AMG_CALLun_var(arg,method))) { + if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method, + AMGf_noright | AMGf_unary))) { if (flags & AMGf_set) { SETs(tmpsv); } @@ -2000,15 +2258,46 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) { return TRUE; } } + if(left==right && SvGMAGICAL(left)) { + SV * const left = sv_newmortal(); + *(sp-1) = left; + /* Print the uninitialized warning now, so it includes the vari- + able name. */ + if (!SvOK(right)) { + if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right); + sv_setsv_flags(left, &PL_sv_no, 0); + } + else sv_setsv_flags(left, right, 0); + SvGETMAGIC(right); + } if (flags & AMGf_numeric) { - if (SvROK(left)) - *(sp-1) = sv_2num(left); + if (SvROK(TOPm1s)) + *(sp-1) = sv_2num(TOPm1s); if (SvROK(right)) *sp = sv_2num(right); } 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) @@ -2022,6 +2311,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 @@ -2185,9 +2475,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 @@ -2215,7 +2504,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; @@ -2235,7 +2534,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 { @@ -2259,7 +2561,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)); @@ -2312,7 +2614,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); + } } { @@ -2334,7 +2644,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (PERLDB_SUB && PL_curstash != PL_debstash) PL_op->op_private |= OPpENTERSUB_DB; PUTBACK; - pp_pushmark(); + Perl_pp_pushmark(aTHX); EXTEND(SP, notfound + 5); PUSHs(lr>0? right: left); @@ -2398,148 +2708,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } } -/* -=for apidoc is_gv_magical_sv - -Returns C if given the name of a magical GV. - -Currently only useful internally when determining if a GV should be -created even in rvalue contexts. - -C is not used at present but available for future extension to -allow selecting particular classes of magical variable. - -Currently assumes that C is NUL terminated (as well as len being valid). -This assumption is met by all callers within the perl core, which all pass -pointers returned by SvPV. - -=cut -*/ - -bool -Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags) -{ - STRLEN len; - const char *const name = SvPV_const(name_sv, len); - - PERL_UNUSED_ARG(flags); - PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV; - - if (len > 1) { - const char * const name1 = name + 1; - switch (*name) { - case 'I': - if (len == 3 && name[1] == 'S' && name[2] == 'A') - goto yes; - break; - case 'O': - if (len == 8 && strEQ(name1, "VERLOAD")) - goto yes; - break; - case 'S': - if (len == 3 && name[1] == 'I' && name[2] == 'G') - goto yes; - break; - /* Using ${^...} variables is likely to be sufficiently rare that - it seems sensible to avoid the space hit of also checking the - length. */ - case '\017': /* ${^OPEN} */ - if (strEQ(name1, "PEN")) - goto yes; - break; - case '\024': /* ${^TAINT} */ - if (strEQ(name1, "AINT")) - goto yes; - break; - case '\025': /* ${^UNICODE} */ - if (strEQ(name1, "NICODE")) - goto yes; - if (strEQ(name1, "TF8LOCALE")) - goto yes; - break; - case '\027': /* ${^WARNING_BITS} */ - if (strEQ(name1, "ARNING_BITS")) - goto yes; - break; - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - { - const char *end = name + len; - while (--end > name) { - if (!isDIGIT(*end)) - return FALSE; - } - goto yes; - } - } - } else { - /* Because we're already assuming that name is NUL terminated - below, we can treat an empty name as "\0" */ - switch (*name) { - case '&': - case '`': - case '\'': - case ':': - case '?': - case '!': - case '-': - case '#': - case '[': - case '^': - case '~': - case '=': - case '%': - case '.': - case '(': - case ')': - case '<': - case '>': - case '\\': - case '/': - case '|': - case '+': - case ';': - case ']': - case '\001': /* $^A */ - case '\003': /* $^C */ - case '\004': /* $^D */ - case '\005': /* $^E */ - case '\006': /* $^F */ - case '\010': /* $^H */ - case '\011': /* $^I, NOT \t in EBCDIC */ - case '\014': /* $^L */ - case '\016': /* $^N */ - case '\017': /* $^O */ - case '\020': /* $^P */ - case '\023': /* $^S */ - case '\024': /* $^T */ - case '\026': /* $^V */ - case '\027': /* $^W */ - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - yes: - return TRUE; - default: - break; - } - } - return FALSE; -} - void Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) { @@ -2591,7 +2759,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) && @@ -2635,6 +2803,16 @@ Perl_gv_try_downgrade(pTHX_ GV *gv) } } +#include "XSUB.h" + +static void +core_xsub(pTHX_ CV* cv) +{ + Perl_croak(aTHX_ + "&CORE::%s cannot be called directly", GvNAME(CvGV(cv)) + ); +} + /* * Local variables: * c-indentation-style: bsd