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
*/
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)
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;
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);
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) {
/* 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