#include "perl.h"
#include "overload.c"
#include "keywords.h"
+#include "feature.h"
static const char S_autoload[] = "AUTOLOAD";
static const STRLEN S_autolen = sizeof(S_autoload)-1;
*/
what = OP_IS_DIRHOP(PL_op->op_type) ?
"dirhandle" : "filehandle";
- /* diag_listed_as: Bad symbol for filehandle */
} else if (type == SVt_PVHV) {
what = "hash";
} else {
what = type == SVt_PVAV ? "array" : "scalar";
}
+ /* diag_listed_as: Bad symbol for filehandle */
Perl_croak(aTHX_ "Bad symbol for %s", what);
}
dVAR;
const U32 old_type = SvTYPE(gv);
const bool doproto = old_type > SVt_NULL;
- char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
+ char * const proto = (doproto && SvPOK(gv))
+ ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
+ : NULL;
const STRLEN protolen = proto ? SvCUR(gv) : 0;
const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
CV *cv;
ENTER;
if (has_constant) {
- char *name0 = NULL;
- if (name[len])
- /* newCONSTSUB doesn't take a len arg, so make sure we
- * give it a \0-terminated string */
- name0 = savepvn(name,len);
-
/* newCONSTSUB takes ownership of the reference from us. */
- cv = newCONSTSUB_flags(stash, (name0 ? name0 : name), flags, has_constant);
+ cv = newCONSTSUB_flags(stash, name, len, flags, 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);
/* If this reference was a copy of another, then the subroutine
must have been "imported", by a Perl space assignment to a GV
from a reference to 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 char * const name, const STRLEN len)
{
const int code = keyword(name, len, 1);
static const char file[] = __FILE__;
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;
gv = (GV *)newSV(0);
gv_init(gv, stash, name, len, TRUE);
}
+ GvMULTI_on(gv);
if (ampable) {
ENTER;
oldcurcop = PL_curcop;
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))
+ if (stash)
(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),
+ newATTRSUB_flags(
+ oldsavestack_ix, (OP *)gv,
NULL,NULL,
coresub_op(
opnum
? newSVuv((UV)opnum)
: newSVpvn(name,len),
code, opnum
- )
+ ),
+ 1
);
assert(GvCV(gv) == cv);
if (opnum != OP_VEC && opnum != OP_SUBSTR)
}
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))
+ && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
goto have_gv;
}
const char *hvname = HvNAME(cstash); assert(hvname);
if (strnEQ(hvname, "CORE", 4)
&& (candidate =
- S_maybe_add_coresub(aTHX_ cstash,NULL,name,len,0,0)
+ S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
))
goto have_candidate;
}
* via the SvPVX field in the CV, and the stash in CvSTASH.
*
* Due to an unfortunate accident of history, the SvPVX field
- * serves two purposes. It is also used for the subroutine’s pro-
+ * serves two purposes. It is also used for the subroutine's pro-
* type. Since SvPVX has been documented as returning the sub name
* for a long time, but not as returning the prototype, we have
* to preserve the SvPVX AUTOLOAD behaviour and put the prototype
tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
sv_catpvn_flags(
varsv, name, len,
- SV_GMAGIC|SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
+ SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
);
if (is_utf8)
SvUTF8_on(varsv);
PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
- if (!stash || !(gv_fetchmethod(stash, methpv))) {
+ if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
SV *module = newSVsv(namesv);
char varname = *varpv; /* varpv might be clobbered by load_module,
so save it. For the moment it's always
else if (*name == '-' || *name == '+')
require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
}
- if ((sv_type==SVt_PV || sv_type==SVt_PVGV) && *name == '[')
+ if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
+ if (*name == '[')
require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+ else if (*name == '&' || *name == '`' || *name == '\'') {
+ PL_sawampersand = TRUE;
+ (void)GvSVn(gv);
+ }
+ }
}
else if (len == 3 && sv_type == SVt_PVAV
&& strnEQ(name, "ISA", 3)
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;
+ if (strnEQ(stashname, "CORE", 4))
+ S_maybe_add_coresub(aTHX_ 0, gv, name, len);
}
}
else if (len > 1) {
case '&': /* $& */
case '`': /* $` */
case '\'': /* $' */
- if (
+ if (!(
sv_type == SVt_PVAV ||
sv_type == SVt_PVHV ||
sv_type == SVt_PVCV ||
sv_type == SVt_PVFM ||
sv_type == SVt_PVIO
- ) { break; }
- PL_sawampersand = TRUE;
+ )) { PL_sawampersand = TRUE; }
goto magicalize;
case ':': /* $: */
/* 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);
+ }
break;
case '-': /* $- */
SvREADONLY_on(av);
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);
+ }
break;
}
case '*': /* $* */
case '#': /* $# */
if (sv_type == SVt_PV)
+ /* diag_listed_as: $* is no longer supported */
Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"$%c is no longer supported", *name);
break;
}
goto magicalize;
case '[': /* $[ */
- if (sv_type == SVt_PV || sv_type == SVt_PVGV) {
+ 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;
}
+ else goto magicalize;
break;
case '\023': /* $^S */
ro_magicalize:
PERL_ARGS_ASSERT_GV_FULLNAME4;
- if (!hv) {
- SvOK_off(sv);
- return;
- }
sv_setpv(sv, prefix ? prefix : "");
- if ((name = HvNAME(hv))) {
+ if (hv && (name = HvNAME(hv))) {
const STRLEN len = HvNAMELEN(hv);
if (keepmain || strnNE(name, "main", len)) {
sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
const SV * const name = (gvsv && SvPOK(gvsv))
? gvsv
: newSVpvs_flags("???", SVs_TEMP);
+ /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
Perl_croak(aTHX_ "%s method \"%"SVf256
"\" overloading \"%s\" "\
"in package \"%"HEKf256"\"",
return tmpsv ? tmpsv : ref;
}
+bool
+Perl_amagic_is_enabled(pTHX_ int method)
+{
+ SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
+
+ assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
+
+ if ( !lex_mask || !SvOK(lex_mask) )
+ /* overloading lexically disabled */
+ return FALSE;
+ else if ( lex_mask && SvPOK(lex_mask) ) {
+ /* we have an entry in the hints hash, check if method has been
+ * masked by overloading.pm */
+ STRLEN len;
+ const int offset = method / 8;
+ const int bit = method % 8;
+ char *pv = SvPV(lex_mask, len);
+
+ /* Bit set, so this overloading operator is disabled */
+ if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
+ return FALSE;
+ }
+ return TRUE;
+}
+
SV*
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
{
PERL_ARGS_ASSERT_AMAGIC_CALL;
if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
- SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
-
- if ( !lex_mask || !SvOK(lex_mask) )
- /* overloading lexically disabled */
- return NULL;
- else if ( lex_mask && SvPOK(lex_mask) ) {
- /* we have an entry in the hints hash, check if method has been
- * masked by overloading.pm */
- STRLEN len;
- const int offset = method / 8;
- const int bit = method % 8;
- char *pv = SvPV(lex_mask, len);
-
- /* Bit set, so this overloading operator is disabled */
- if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
- return NULL;
- }
+ if (!amagic_is_enabled(method)) return NULL;
}
if (!(AMGf_noleft & flags) && SvAMAGIC(left)
/* off is method, method+assignshift, or a result of opcode substitution.
* In the latter case assignshift==0, so only notfound case is important.
*/
- if (( (method + assignshift == off)
+ if ( (lr == -1) && ( ( (method + assignshift == off)
&& (assign || (method == inc_amg) || (method == dec_amg)))
- || force_cpy)
+ || force_cpy) )
{
/* newSVsv does not behave as advertised, so we copy missing
* information by hand */
https://perl5.git.perl.org / perl5.git / blobdiff