the GV directly; instead, you should use the method's CV, which can be
obtained from the GV with the C<GvCV> macro.
+=for apidoc Amnh||GV_SUPER
+
=cut
*/
assert(cstash);
- gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
+ gvp = (GV**)hv_common(
+ cstash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, HV_FETCH_JUST_SV, NULL, 0
+ );
if (!gvp) {
if (len > 1 && HvNAMELEN_get(cstash) == 4) {
const char *hvname = HvNAME(cstash); assert(hvname);
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvENAME_get(stash), name) );
}
- else if (memBEGINs(last_separator - sizeof("::SUPER") - 1,
- sep_len, "::SUPER"))
- {
+ else if ( sep_len >= 7 &&
+ strBEGINs(last_separator - 7, "::SUPER")) {
/* don't autovifify if ->NoSuchStash::SUPER::method */
stash = gv_stashpvn(origname, sep_len - 7, is_utf8);
if (stash) flags |= GV_SUPER;
/* This is the special case that exempts Foo->import and
Foo->unimport from being an error even if there's no
import/unimport subroutine */
- if (strEQ(name,"import") || strEQ(name,"unimport"))
- gv = MUTABLE_GV(&PL_sv_yes);
- else if (autoload)
+ if (strEQ(name,"import") || strEQ(name,"unimport")) {
+ gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL,
+ NULL, 0, 0, NULL));
+ } else if (autoload)
gv = gv_autoload_pvn(
ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
);
if (SvUTF8(cv))
sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
ulen = SvCUR(tmpsv);
- SvCUR(tmpsv)++; /* include null in string */
+ SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */
sv_catpvn_flags(
tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
);
SvTEMP_off(tmpsv);
SvREFCNT_dec_NN(tmpsv);
SvLEN_set(cv, SvCUR(cv) + 1);
- SvCUR(cv) = ulen;
+ SvCUR_set(cv, ulen);
}
else {
sv_setpvn((SV *)cv, name, len);
Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
recommended for performance reasons.
+=for apidoc Amnh||GV_ADD
+
=cut
*/
if (!*stash)
*stash = PL_defstash;
if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
- return FALSE;
+ goto notok;
*len = name_cursor - *name;
if (name_cursor > nambeg) { /* Skip for initial :: or ' */
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) {
- Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
- return FALSE;
+ goto notok;
}
/* here we know that *gv && *gv != &PL_sv_undef */
if (SvTYPE(*gv) != SVt_PVGV)
MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
}
}
- Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
- return TRUE;
+ goto ok;
}
}
}
*len = name_cursor - *name;
+ ok:
+ Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
return TRUE;
+ notok:
+ Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */
+ return FALSE;
}
+
/* Checks if an unqualified name is in the main stash */
PERL_STATIC_INLINE bool
S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
* 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
+ * to work (like %+, %-, %!), so callers must take care of
* that.
*
* It returns true if the gv did turn out to be magical one; i.e.,
sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
SvREADONLY_on(av);
- if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
- require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
+ require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
} else /* %{^CAPTURE_ALL} */
if (memEQs(name, len, "\003APTURE_ALL")) {
- if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
- require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0);
+ require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0);
}
break;
case '\005': /* $^ENCODING */
if (memEQs(name, len, "\005NCODING"))
goto magicalize;
break;
+ case '\006':
+ if (memEQs(name, len, "\006EATURE_BITS"))
+ goto magicalize;
+ break;
case '\007': /* $^GLOBAL_PHASE */
if (memEQs(name, len, "\007LOBAL_PHASE"))
goto ro_magicalize;
goto storeparen;
}
break;
+ case '\023':
+ if (memEQs(name, len, "\023AFE_LOCALES"))
+ goto ro_magicalize;
+ break;
case '\024': /* ${^TAINT} */
if (memEQs(name, len, "\024AINT"))
goto ro_magicalize;
break;
case '*': /* $* */
case '#': /* $# */
- if (sv_type == SVt_PV)
- /* diag_listed_as: $* is no longer supported. Its use will be fatal in Perl 5.30 */
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "$%c is no longer supported. Its use "
- "will be fatal in Perl 5.30", *name);
- break;
+ if (sv_type == SVt_PV)
+ /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
+ Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
+ break;
case '\010': /* $^H */
{
HV *const hv = GvHVn(gv);
hv_magic(hv, NULL, PERL_MAGIC_hints);
}
goto magicalize;
- case '[': /* $[ */
- if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
- && FEATURE_ARYBASE_IS_ENABLED) {
- require_tie_mod_s(gv,'[',"arybase",0);
- }
- else goto magicalize;
- break;
case '\023': /* $^S */
ro_magicalize:
SvREADONLY_on(GvSVn(gv));
case '/': /* $/ */
case '|': /* $| */
case '$': /* $$ */
+ case '[': /* $[ */
case '\001': /* $^A */
case '\003': /* $^C */
case '\004': /* $^D */
require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
} else if (sv_type == SVt_PV) {
if (*name == '*' || *name == '#') {
- /* diag_listed_as: $# is no longer supported. Its use will be fatal in Perl 5.30 */
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
- WARN_SYNTAX),
- "$%c is no longer supported. Its use "
- "will be fatal in Perl 5.30", *name);
+ /* diag_listed_as: $* is no longer supported as of Perl 5.30 */
+ Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name);
}
}
if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
switch (*name) {
- case '[':
- require_tie_mod_s(gv,'[',"arybase",0);
- break;
#ifdef PERL_SAWAMPERSAND
case '`':
PL_sawampersand |= SAWAMPERSAND_LEFT;
/* Implement tryAMAGICun_MG macro.
Do get magic, then see if the stack arg is overloaded and if so call it.
Flags:
- AMGf_set return the arg using SETs rather than assigning to
- the targ
AMGf_numeric apply sv_2num to the stack arg.
*/
AMGf_noright | AMGf_unary
| (flags & AMGf_numarg))))
{
- if (flags & AMGf_set) {
- SETs(tmpsv);
- }
- else {
- dTARGET;
- if (SvPADMY(TARG)) {
- sv_setsv(TARG, tmpsv);
- SETTARG;
- }
- else
- SETs(tmpsv);
- }
+ /* where the op is of the form:
+ * $lex = $x op $y (where the assign is optimised away)
+ * then assign the returned value to targ and return that;
+ * otherwise return the value directly
+ */
+ if ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
+ && (PL_op->op_private & OPpTARGET_MY))
+ {
+ dTARGET;
+ sv_setsv(TARG, tmpsv);
+ SETTARG;
+ }
+ else
+ SETs(tmpsv);
+
PUTBACK;
return TRUE;
}
Do get magic, then see if the two stack args are overloaded and if so
call it.
Flags:
- AMGf_set return the arg using SETs rather than assigning to
- the targ
AMGf_assign op may be called as mutator (eg +=)
AMGf_numeric apply sv_2num to the stack arg.
*/
SvGETMAGIC(right);
if (SvAMAGIC(left) || SvAMAGIC(right)) {
- SV * const tmpsv = amagic_call(left, right, method,
- ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0)
+ SV * tmpsv;
+ /* STACKED implies mutator variant, e.g. $x += 1 */
+ bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED);
+
+ tmpsv = amagic_call(left, right, method,
+ (mutator ? AMGf_assign: 0)
| (flags & AMGf_numarg));
if (tmpsv) {
- if (flags & AMGf_set) {
- (void)POPs;
- SETs(tmpsv);
- }
- else {
- dATARGET;
- (void)POPs;
- if (opASSIGN || SvPADMY(TARG)) {
- sv_setsv(TARG, tmpsv);
- SETTARG;
- }
- else
- SETs(tmpsv);
- }
+ (void)POPs;
+ /* where the op is one of the two forms:
+ * $x op= $y
+ * $lex = $x op $y (where the assign is optimised away)
+ * then assign the returned value to targ and return that;
+ * otherwise return the value directly
+ */
+ if ( mutator
+ || ( (PL_opargs[PL_op->op_type] & OA_TARGLEX)
+ && (PL_op->op_private & OPpTARGET_MY)))
+ {
+ dTARG;
+ TARG = mutator ? *SP : PAD_SV(PL_op->op_targ);
+ sv_setsv(TARG, tmpsv);
+ SETTARG;
+ }
+ else
+ SETs(tmpsv);
+
PUTBACK;
return TRUE;
}
}
+
if(left==right && SvGMAGICAL(left)) {
SV * const left = sv_newmortal();
*(sp-1) = left;
https://perl5.git.perl.org / perl5.git / blobdiff