}
if (!*where)
+ {
*where = newSV_type(type);
- if (type == SVt_PVAV && GvNAMELEN(gv) == 3
- && strnEQ(GvNAME(gv), "ISA", 3))
- sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
+ if (type == SVt_PVAV && GvNAMELEN(gv) == 3
+ && strnEQ(GvNAME(gv), "ISA", 3))
+ sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
+ }
return gv;
}
#endif
}
if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
- hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
+ hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
return gv;
gp->gp_sv = newSV(0);
#endif
- /* PL_curcop should never be null here. */
- assert(PL_curcop);
- /* But for non-debugging builds play it safe */
+ /* PL_curcop may be null here. E.g.,
+ INIT { bless {} and exit }
+ frees INIT before looking up DESTROY (and creating *DESTROY)
+ */
if (PL_curcop) {
gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */
#ifdef USE_ITHREADS
/* no support for \&CORE::infix;
no support for funcs that do not parse like funcs */
case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD:
- case KEY_BEGIN : case KEY_CHECK : case KEY_cmp: case KEY_CORE :
+ case KEY_BEGIN : case KEY_CHECK : case KEY_cmp:
case KEY_default : case KEY_DESTROY:
case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
case KEY_END : case KEY_eq : case KEY_eval :
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;
}
CvLVALUE_on(cv);
/* newATTRSUB will free the CV and return NULL if we're still
compiling after a syntax error */
- if ((cv = newATTRSUB_flags(
+ if ((cv = newATTRSUB_x(
oldsavestack_ix, (OP *)gv,
NULL,NULL,
coresub_op(
: newSVpvn(name,len),
code, opnum
),
- 1
+ TRUE
)) != NULL) {
assert(GvCV(gv) == orig_cv);
if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS
Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
with a non-zero C<autoload> parameter.
-These functions grant C<"SUPER"> token as a prefix of the method name. Note
+These functions grant C<"SUPER"> token
+as a prefix of the method name. Note
that if you want to keep the returned glob for a long time, you need to
check for it being "AUTOLOAD", since at the later time the call may load a
-different subroutine due to $AUTOLOAD changing its value. Use the glob
-created via a side effect to do this.
+different subroutine due to $AUTOLOAD changing its value. Use the glob
+created as a side effect to do this.
-These functions have the same side-effects and as C<gv_fetchmeth> with
-C<level==0>. C<name> should be writable if contains C<':'> or C<'
-''>. The warning against passing the GV returned by C<gv_fetchmeth> to
-C<call_sv> apply equally to these functions.
+These functions have the same side-effects as C<gv_fetchmeth> with
+C<level==0>. The warning against passing the GV returned by
+C<gv_fetchmeth> to C<call_sv> applies equally to these functions.
=cut
*/
GV* stubgv;
GV* autogv;
- if (CvANON(cv))
+ if (CvANON(cv) || !CvGV(cv))
stubgv = gv;
else {
stubgv = CvGV(cv);
packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER");
}
- if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8)))
+ if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE,
+ is_utf8 | (flags & GV_SUPER))))
return NULL;
cv = GvCV(gv);
so save it. For the moment it's always
a single char. */
const char type = varname == '[' ? '$' : '%';
+#ifdef DEBUGGING
dSP;
+#endif
ENTER;
SAVEFREESV(namesv);
if ( flags & 1 )
save_scalar(gv);
- PUSHSTACKi(PERLSI_MAGIC);
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
- POPSTACK;
+ assert(sp == PL_stack_sp);
stash = gv_stashsv(namesv, 0);
if (!stash)
Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
tmpbuf[(*len)++] = ':';
key = tmpbuf;
}
- gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -(*len) : *len, add);
+ gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add);
*gv = gvp ? *gvp : NULL;
if (*gv && *gv != (const GV *)&PL_sv_undef) {
if (SvTYPE(*gv) != SVt_PVGV)
return TRUE;
}
-/* This function is called if parse_gv_stash_name() failed to
- * find a stash, or if GV_NOTQUAL or an empty name was passed
- * to gv_fetchpvn_flags.
- *
- * It returns FALSE if the default stash can't be found nor created,
- * which might happen during global destruction.
- */
+/* Checks if an unqualified name is in the main stash */
PERL_STATIC_INLINE bool
-S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
- const U32 is_utf8, const I32 add,
- const svtype sv_type)
+S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
{
- PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
+ PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
- /* No stash in name, so see how we can default */
-
/* If it's an alphanumeric variable */
- if (len && isIDFIRST_lazy_if(name, is_utf8)) {
- bool global = FALSE;
-
+ if ( len && isIDFIRST_lazy_if(name, is_utf8) ) {
/* Some "normal" variables are always in main::,
* like INC or STDOUT.
*/
switch (len) {
case 1:
if (*name == '_')
- global = TRUE;
+ return TRUE;
break;
case 3:
if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
|| (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
|| (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
- global = TRUE;
+ return TRUE;
break;
case 4:
if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
&& name[3] == 'V')
- global = TRUE;
+ return TRUE;
break;
case 5:
if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
&& name[3] == 'I' && name[4] == 'N')
- global = TRUE;
+ return TRUE;
break;
case 6:
if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
&&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
- global = TRUE;
+ return TRUE;
break;
case 7:
if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
&& name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
&& name[6] == 'T')
- global = TRUE;
+ return TRUE;
break;
}
+ }
+ /* *{""}, or a special variable like $@ */
+ else
+ return TRUE;
+
+ return FALSE;
+}
+
+
+/* This function is called if parse_gv_stash_name() failed to
+ * find a stash, or if GV_NOTQUAL or an empty name was passed
+ * to gv_fetchpvn_flags.
+ *
+ * It returns FALSE if the default stash can't be found nor created,
+ * which might happen during global destruction.
+ */
+PERL_STATIC_INLINE bool
+S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
+ const U32 is_utf8, const I32 add,
+ const svtype sv_type)
+{
+ PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
+
+ /* No stash in name, so see how we can default */
- if (global)
- *stash = PL_defstash;
- else if (IN_PERL_COMPILETIME) {
+ if ( gv_is_in_main(name, len, is_utf8) ) {
+ *stash = PL_defstash;
+ }
+ else {
+ if (IN_PERL_COMPILETIME) {
*stash = PL_curstash;
if (add && (PL_hints & HINT_STRICT_VARS) &&
sv_type != SVt_PVCV &&
!(len == 1 && sv_type == SVt_PV &&
(*name == 'a' || *name == 'b')) )
{
- GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -len : len,0);
+ GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0);
if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
SvTYPE(*gvp) != SVt_PVGV)
{
*stash = CopSTASH(PL_curcop);
}
}
- /* *{""}, or a special variable like $@ */
- else
- *stash = PL_defstash;
if (!*stash) {
if (add && !PL_in_clean_all) {
if (is_utf8)
SvUTF8_on(err);
qerror(err);
+ /* To maintain the output of errors after the strict exception
+ * above, and to keep compat with older releases, rather than
+ * placing the variables in the pad, we place
+ * them in the <none>:: stash.
+ */
gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
if (!gv) {
/* symbol table under destruction */
return TRUE;
}
-/* magicalize_gv() gets called by gv_fetchpvn_flags when creating a new GV */
-PERL_STATIC_INLINE GV*
-S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
+/* gv_magicalize() is called by gv_fetchpvn_flags when creating
+ * a new GV.
+ * Note that it does not insert the GV into the stash prior to
+ * magicalization, which some variables require need in order
+ * to work (like $[, %+, %-, %!), so callers must take care of
+ * that beforehand.
+ *
+ * The return value has a specific meaning for gv_fetchpvn_flags:
+ * If it returns true, and the gv is empty, it indicates that its
+ * refcount should be decreased.
+ */
+PERL_STATIC_INLINE bool
+S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
bool addmg, const svtype sv_type)
{
SSize_t paren;
- PERL_ARGS_ASSERT_MAGICALIZE_GV;
+ PERL_ARGS_ASSERT_GV_MAGICALIZE;
if (stash != PL_defstash) { /* not the main stash */
- /* We only have to check for three names here: EXPORT, ISA
+ /* We only have to check for a few names here: a, b, EXPORT, ISA
and VERSION. All the others apply only to the main stash or to
CORE (which is checked right after this). */
- if (len > 2) {
+ if (len) {
const char * const name2 = name + 1;
switch (*name) {
case 'E':
if (strEQ(name2, "ERSION"))
GvMULTI_on(gv);
break;
+ case 'a':
+ case 'b':
+ if (len == 1 && sv_type == SVt_PV)
+ GvMULTI_on(gv);
+ /* FALL THROUGH */
default:
goto try_core;
}
- goto add_magical_gv;
+ return addmg;
}
try_core:
if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
/* This snippet is taken from is_gv_magical */
const char *end = name + len;
while (--end > name) {
- if (!isDIGIT(*end)) goto add_magical_gv;
+ if (!isDIGIT(*end))
+ return addmg;
}
paren = strtoul(name, NULL, 10);
goto storeparen;
/* magicalization must be done before require_tie_mod is called */
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
{
- if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
- addmg = 0;
require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+ addmg = FALSE;
}
break;
if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
{
- if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
- addmg = 0;
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+ addmg = FALSE;
}
break;
case '[': /* $[ */
if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
&& FEATURE_ARYBASE_IS_ENABLED) {
- if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
- addmg = 0;
+ addmg = FALSE;
}
else goto magicalize;
break;
SvREFCNT_dec(sv);
}
break;
+ case 'a':
+ case 'b':
+ if (sv_type == SVt_PV)
+ GvMULTI_on(gv);
}
}
- 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_NN(gv), gv = NULL;
+
+ return addmg;
+}
+
+/* This function is called when the stash already holds the GV of the magic
+ * variable we're looking for, but we need to check that it has the correct
+ * kind of magic. For example, if someone first uses $! and then %!, the
+ * latter would end up here, and we add the Errno tie to the HASH slot of
+ * the *! glob.
+ */
+PERL_STATIC_INLINE void
+S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
+{
+ PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
+
+ if (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 (sv_type == SVt_PV) {
+ if (*name == '*' || *name == '#') {
+ /* diag_listed_as: $* is no longer supported */
+ Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
+ WARN_SYNTAX),
+ "$%c is no longer supported", *name);
+ }
+ }
+ if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
+ switch (*name) {
+ case '[':
+ require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+ break;
+#ifdef PERL_SAWAMPERSAND
+ case '`':
+ PL_sawampersand |= SAWAMPERSAND_LEFT;
+ (void)GvSVn(gv);
+ break;
+ case '&':
+ PL_sawampersand |= SAWAMPERSAND_MIDDLE;
+ (void)GvSVn(gv);
+ break;
+ case '\'':
+ PL_sawampersand |= SAWAMPERSAND_RIGHT;
+ (void)GvSVn(gv);
+ break;
+#endif
+ }
}
-
- return gv;
}
GV *
const I32 no_expand = flags & GV_NOEXPAND;
const I32 add = flags & ~GV_NOADD_MASK;
const U32 is_utf8 = flags & SVf_UTF8;
- bool addmg = !!(flags & GV_ADDMG);
+ bool addmg = cBOOL(flags & GV_ADDMG);
const char *const name_end = nambeg + full_len;
U32 faking_it;
}
/* By this point we should have a stash and a name */
- gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
+ gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add);
if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
if (addmg) gv = (GV *)newSV(0);
else return NULL;
symtab yet. */
if (SvTYPE(gv) == SVt_PVGV) {
+ /* The GV already exists, so return it, but check if we need to do
+ * anything else with it before that.
+ */
if (add) {
+ /* This is the heuristic that handles if a variable triggers the
+ * 'used only once' warning. If there's already a GV in the stash
+ * with this name, then we assume that the variable has been used
+ * before and turn its MULTI flag on.
+ * It's a heuristic because it can easily be "tricked", like with
+ * BEGIN { $a = 1; $::{foo} = *a }; () = $foo
+ * not warning about $main::foo being used just once
+ */
GvMULTI_on(gv);
gv_init_svtype(gv, sv_type);
/* You reach this path once the typeglob has already been created,
exist, then (say) referencing $! first, and %! second would
mean that %! was not handled correctly. */
if (len == 1 && stash == PL_defstash) {
- if (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 (sv_type == SVt_PV) {
- if (*name == '*' || *name == '#') {
- /* diag_listed_as: $* is no longer supported */
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
- WARN_SYNTAX),
- "$%c is no longer supported", *name);
- }
- }
- if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
- switch (*name) {
- case '[':
- require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
- break;
-#ifdef PERL_SAWAMPERSAND
- case '`':
- PL_sawampersand |= SAWAMPERSAND_LEFT;
- (void)GvSVn(gv);
- break;
- case '&':
- PL_sawampersand |= SAWAMPERSAND_MIDDLE;
- (void)GvSVn(gv);
- break;
- case '\'':
- PL_sawampersand |= SAWAMPERSAND_RIGHT;
- (void)GvSVn(gv);
- break;
-#endif
- }
- }
+ maybe_multimagic_gv(gv, name, sv_type);
}
else if (len == 3 && sv_type == SVt_PVAV
&& strnEQ(name, "ISA", 3)
} else if (no_init) {
assert(!addmg);
return gv;
- } else if (no_expand && SvROK(gv)) {
+ }
+ /* If GV_NOEXPAND is true and what we got off the stash is a ref,
+ * don't expand it to a glob. This is an optimization so that things
+ * copying constants over, like Exporter, don't have to be rewritten
+ * to take into account that you can store more than just globs in
+ * stashes.
+ */
+ else if (no_expand && SvROK(gv)) {
assert(!addmg);
return gv;
}
UTF8fARG(is_utf8, name_end-nambeg, nambeg));
gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
- if ( isIDFIRST_lazy_if(name, is_utf8)
- && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
+ if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) )
GvMULTI_on(gv) ;
+ /* First, store the gv in the symtab if we're adding magic,
+ * but only for non-empty GVs
+ */
+#define GvEMPTY(gv) !(GvAV(gv) || GvHV(gv) || GvIO(gv) \
+ || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv))))
+
+ if ( addmg && !GvEMPTY(gv) ) {
+ (void)hv_store(stash,name,len,(SV *)gv,0);
+ }
+
/* set up magic where warranted */
- gv = magicalize_gv(gv, stash, name, len, addmg, sv_type);
+ if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) {
+ /* See 23496c6 */
+ if (GvEMPTY(gv)) {
+ if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) {
+ /* The GV was and still is "empty", except that now
+ * it has the magic flags turned on, so we want it
+ * stored in the symtab.
+ */
+ (void)hv_store(stash,name,len,(SV *)gv,0);
+ }
+ else {
+ /* Most likely the temporary GV created above */
+ SvREFCNT_dec_NN(gv);
+ gv = NULL;
+ }
+ }
+ }
if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type);
return gv;
gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
}
+
+/* recursively scan a stash and any nested stashes looking for entries
+ * that need the "only used once" warning raised
+ */
+
void
Perl_gv_check(pTHX_ HV *stash)
{
if (!HvARRAY(stash))
return;
+
+ assert(SvOOK(stash));
+
for (i = 0; i <= (I32) HvMAX(stash); i++) {
const HE *entry;
- /* SvIsCOW is unused on HVs, so we can use it to mark stashes we
- are currently searching through recursively. */
- SvIsCOW_on(stash);
+ /* mark stash is being scanned, to avoid recursing */
+ HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
GV *gv;
HV *hv;
if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
(gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
{
- if (hv != PL_defstash && hv != stash && !SvIsCOW(hv))
+ if (hv != PL_defstash && hv != stash
+ && !(SvOOK(hv)
+ && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH))
+ )
gv_check(hv); /* nested package */
}
else if ( *HeKEY(entry) != '_'
HEKfARG(GvNAME_HEK(gv)));
}
}
- SvIsCOW_off(stash);
+ HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
}
}
pTHX__FORMAT pTHX__VALUE);
return;
}
- if (--gp->gp_refcnt > 0) {
+ if (gp->gp_refcnt > 1) {
+ borrowed:
if (gp->gp_egv == gv)
gp->gp_egv = 0;
+ gp->gp_refcnt--;
GvGP_set(gv, NULL);
return;
}
const HEK *hvname_hek = HvNAME_HEK(hv);
DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek));
if (PL_stashcache && hvname_hek)
- (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
- (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)),
- G_DISCARD);
+ (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
SvREFCNT_dec(hv);
}
SvREFCNT_dec(io);
SvREFCNT_dec(cv);
SvREFCNT_dec(form);
+ /* Possibly reallocated by a destructor */
+ gp = GvGP(gv);
+
if (!gp->gp_file_hek
&& !gp->gp_sv
&& !gp->gp_av
}
}
+ /* Possibly incremented by a destructor doing glob assignment */
+ if (gp->gp_refcnt > 1) goto borrowed;
Safefree(gp);
GvGP_set(gv, NULL);
}
{
int filled = 0;
int i;
+ bool deref_seen = 0;
+
/* Work with "fallback" key, which we assume to be first in PL_AMG_names */
filled = 1;
}
+ assert(SvOOK(stash));
+ /* initially assume the worst */
+ HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
+
for (i = 1; i < NofAMmeth; i++) {
const char * const cooky = PL_AMG_names[i];
/* Human-readable form, for debugging: */
filled = 1;
}
amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
+
+ if (gv) {
+ switch (i) {
+ case to_sv_amg:
+ case to_av_amg:
+ case to_hv_amg:
+ case to_gv_amg:
+ case to_cv_amg:
+ case nomethod_amg:
+ deref_seen = 1;
+ break;
+ }
+ }
}
+ if (!deref_seen)
+ /* none of @{} etc overloaded; we can do $obj->[N] quicker.
+ * NB - aux var invalid here, HvARRAY() could have been
+ * reallocated since it was assigned to */
+ HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
+
if (filled) {
AMT_AMAGIC_on(&amt);
sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
SV *
Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
SV *tmpsv = NULL;
+ HV *stash;
PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
- while (SvAMAGIC(ref) &&
- (tmpsv = amagic_call(ref, &PL_sv_undef, method,
+ if (!SvAMAGIC(ref))
+ return ref;
+ /* return quickly if none of the deref ops are overloaded */
+ stash = SvSTASH(SvRV(ref));
+ assert(SvOOK(stash));
+ if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF)
+ return ref;
+
+ while ((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");
return tmpsv;
}
ref = tmpsv;
+ if (!SvAMAGIC(ref))
+ break;
}
return tmpsv ? tmpsv : ref;
}
PL_op = (OP *) &myop;
if (PERLDB_SUB && PL_curstash != PL_debstash)
PL_op->op_private |= OPpENTERSUB_DB;
- PUTBACK;
Perl_pp_pushmark(aTHX);
EXTEND(SP, notfound + 5);
!GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
return;
+ if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv)
+ return;
if (SvMAGICAL(gv)) {
MAGIC *mg;
/* only backref magic is allowed */
cv = GvCV(gv);
if (!cv) {
HEK *gvnhek = GvNAME_HEK(gv);
- (void)hv_delete(stash, HEK_KEY(gvnhek),
- HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
- } else if (GvMULTI(gv) && cv &&
+ (void)hv_deletehek(stash, gvnhek, G_DISCARD);
+ } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
!SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
CvSTASH(cv) == stash && CvGV(cv) == gv &&
CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
!CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
(namehek = GvNAME_HEK(gv)) &&
- (gvp = hv_fetch(stash, HEK_KEY(namehek),
- HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
+ (gvp = hv_fetchhek(stash, namehek, 0)) &&
*gvp == (SV*)gv) {
SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
const bool imported = !!GvIMPORTED_CV(gv);
}
}
+GV *
+Perl_gv_override(pTHX_ const char * const name, const STRLEN len)
+{
+ GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV);
+ GV * const *gvp;
+ PERL_ARGS_ASSERT_GV_OVERRIDE;
+ if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv;
+ gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE);
+ gv = gvp ? *gvp : NULL;
+ if (gv && !isGV(gv)) {
+ if (!SvPCS_IMPORTED(gv)) return NULL;
+ gv_init(gv, PL_globalstash, name, len, 0);
+ return gv;
+ }
+ return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL;
+}
+
#include "XSUB.h"
static void
https://perl5.git.perl.org / perl5.git / blobdiff