*/
/*
-=head1 GV Functions
+=head1 GV Handling
A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
It is a structure that holds a pointer to a scalar, an array, a hash etc,
corresponding to $foo, @foo, %foo.
GVs are usually found as values in stashes (symbol table hashes) where
Perl stores its global variables.
+=for apidoc Ayh||GV
+
=cut
*/
if (!*where)
{
*where = newSV_type(type);
- if (type == SVt_PVAV && GvNAMELEN(gv) == 3
- && strEQs(GvNAME(gv), "ISA"))
+ if (type == SVt_PVAV
+ && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
}
return gv;
#ifndef USE_ITHREADS
GV *filegv;
#endif
- dVAR;
PERL_ARGS_ASSERT_NEWGP;
Newxz(gp, 1, GP);
C<GV_ADDMULTI> flag, which means to pretend that the GV has been
seen before (i.e., suppress "Used once" warnings).
+=for apidoc Amnh||GV_ADDMULTI
+
=for apidoc gv_init
The old form of C<gv_init_pvn()>. It does not work with UTF-8 strings, as it
const U32 proto_utf8 = proto ? SvUTF8(gv) : 0;
SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
+ const bool really_sub =
+ has_constant && SvTYPE(has_constant) == SVt_PVCV;
+ COP * const old = PL_curcop;
PERL_ARGS_ASSERT_GV_INIT_PVN;
assert (!(proto && has_constant));
case SVt_PVIO:
Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
sv_reftype(has_constant, 0));
+ NOT_REACHED; /* NOTREACHED */
break;
default: NOOP;
SvIOK_off(gv);
isGV_with_GP_on(gv);
+ if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant)
+ && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE
+ || CvSTART(has_constant)->op_type == OP_DBSTATE))
+ PL_curcop = (COP *)CvSTART(has_constant);
GvGP_set(gv, Perl_newGP(aTHX_ gv));
+ PL_curcop = old;
GvSTASH(gv) = stash;
if (stash)
Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
if (flags & GV_ADDMULTI || doproto) /* doproto means it */
GvMULTI_on(gv); /* _was_ mentioned */
- if (has_constant && SvTYPE(has_constant) == SVt_PVCV) {
+ if (really_sub) {
/* Not actually a constant. Just a regular sub. */
CV * const cv = (CV *)has_constant;
GvCV_set(gv,cv);
case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif :
case KEY_END : case KEY_eq : case KEY_eval :
case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge :
- case KEY_given : case KEY_goto : case KEY_grep :
- case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le:
- case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my:
+ case KEY_given : case KEY_goto : case KEY_grep : case KEY_gt :
+ case KEY_if : case KEY_isa : case KEY_INIT : case KEY_last :
+ case KEY_le : case KEY_local : case KEY_lt : case KEY_m :
+ case KEY_map : case KEY_my:
case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our:
case KEY_package: case KEY_print: case KEY_printf:
case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw :
PL_compcv = oldcompcv;
}
if (cv) {
- SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL;
- cv_set_call_checker(
- cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv
- );
- SvREFCNT_dec(opnumsv);
+ SV *opnumsv = newSViv(
+ (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ?
+ (OP_ENTEREVAL | (1<<16))
+ : opnum ? opnum : (((I32)name[2]) << 16));
+ cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0);
+ SvREFCNT_dec_NN(opnumsv);
}
return gv;
STRLEN namelen;
PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
if (LIKELY(SvPOK_nog(namesv))) /* common case */
- return gv_fetchmeth_internal(stash, namesv, NULL, 0, level, flags);
+ return gv_fetchmeth_internal(stash, namesv, NULL, 0, level,
+ flags | SvUTF8(namesv));
namepv = SvPV(namesv, namelen);
if (SvUTF8(namesv)) flags |= SVf_UTF8;
return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
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
*/
CV* cand_cv = NULL;
GV* topgv = NULL;
const char *hvname;
+ STRLEN hvnamelen;
I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
I32 items;
U32 topgen_cmp;
assert(stash);
hvname = HvNAME_get(stash);
+ hvnamelen = HvNAMELEN_get(stash);
if (!hvname)
Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
return 0;
}
else if (stash == cachestash
- && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
- && strEQs(hvname, "CORE")
+ && len > 1 /* shortest is uc */
+ && memEQs(hvname, HvNAMELEN_get(stash), "CORE")
&& S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
goto have_gv;
}
cstash = gv_stashsv(linear_sv, 0);
if (!cstash) {
- Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Can't locate package %" SVf " for @%" HEKf "::ISA",
- SVfARG(linear_sv),
- HEKfARG(HvNAME_HEK(stash)));
+ if ( ckWARN(WARN_SYNTAX)) {
+ if( /* these are loaded from Perl_Gv_AMupdate() one way or another */
+ ( len && name[0] == '(' ) /* overload.pm related, in particular "()" */
+ || ( memEQs( name, len, "DESTROY") )
+ ) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Can't locate package %" SVf " for @%" HEKf "::ISA",
+ SVfARG(linear_sv),
+ HEKfARG(HvNAME_HEK(stash)));
+
+ } else if( memEQs( name, len, "AUTOLOAD") ) {
+ /* gobble this warning */
+ } else {
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "While trying to resolve method call %.*s->%.*s()"
+ " can not locate package \"%" SVf "\" yet it is mentioned in @%.*s::ISA"
+ " (perhaps you forgot to load \"%" SVf "\"?)",
+ (int) hvnamelen, hvname,
+ (int) len, name,
+ SVfARG(linear_sv),
+ (int) hvnamelen, hvname,
+ SVfARG(linear_sv));
+ }
+ }
continue;
}
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);
- if (strEQs(hvname, "CORE")
+ if (strBEGINs(hvname, "CORE")
&& (candidate =
S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
))
origname, HvENAME_get(stash), name) );
}
else if ( sep_len >= 7 &&
- strEQs(last_separator - 7, "::SUPER")) {
+ 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
);
return NULL;
/*
- * Inheriting AUTOLOAD for non-methods works ... for now.
+ * Inheriting AUTOLOAD for non-methods no longer works
*/
if (
!(flags & GV_AUTOLOAD_ISMETHOD)
&& (GvCVGEN(gv) || GvSTASH(gv) != stash)
)
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Use of inherited AUTOLOAD for non-method %" SVf
- "::%" UTF8f "() is deprecated. This will be "
- "fatal in Perl 5.28",
+ Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf
+ "::%" UTF8f "() is no longer allowed",
SVfARG(packname),
UTF8fARG(is_utf8, len, name));
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)
);
sv_setsv_nomg((SV *)cv, tmpsv);
SvTEMP_off(tmpsv);
SvREFCNT_dec_NN(tmpsv);
- SvLEN(cv) = SvCUR(cv) + 1;
- SvCUR(cv) = ulen;
+ SvLEN_set(cv, SvCUR(cv) + 1);
+ SvCUR_set(cv, ulen);
}
else {
sv_setpvn((SV *)cv, name, len);
GV **gvp;
dSP;
+ PUSHSTACKi(PERLSI_MAGIC);
ENTER;
-#define HV_FETCH_TIE_FUNC (GV **)hv_fetchs(stash, "_tie_it", 0)
+#define GET_HV_FETCH_TIE_FUNC \
+ ( (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0)) \
+ && *gvp \
+ && ( (isGV(*gvp) && GvCV(*gvp)) \
+ || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV) ) \
+ )
/* Load the module if it is not loaded. */
if (!(stash = gv_stashpvn(name, len, 0))
- || !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
+ || ! GET_HV_FETCH_TIE_FUNC)
{
SV * const module = newSVpvn(name, len);
const char type = varname == '[' ? '$' : '%';
if (!stash)
Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available",
type, varname, name);
- else if (!(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp))
+ else if (! GET_HV_FETCH_TIE_FUNC)
Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it",
type, varname, name);
}
/* Now call the tie function. It should be in *gvp. */
- assert(gvp); assert(*gvp); assert(GvCV(*gvp));
+ assert(gvp); assert(*gvp);
PUSHMARK(SP);
XPUSHs((SV *)gv);
PUTBACK;
call_sv((SV *)*gvp, G_VOID|G_DISCARD);
LEAVE;
+ POPSTACK;
}
}
Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
recommended for performance reasons.
+=for apidoc Amnh||GV_ADD
+=for apidoc Amnh||GV_NOADD_NOINIT
+=for apidoc Amnh||GV_NOINIT
+=for apidoc Amnh||GV_NOEXPAND
+=for apidoc Amnh||GV_ADDMG
+=for apidoc Amnh||SVf_UTF8
+
=cut
*/
gv_stashsvpvn_cached
Returns a pointer to the stash for a specified package, possibly
-cached. Implements both C<gv_stashpvn> and C<gv_stashsv>.
+cached. Implements both C<L</gv_stashpvn>> and C<L</gv_stashsv>>.
-Requires one of either namesv or namepv to be non-null.
+Requires one of either C<namesv> or C<namepv> to be non-null.
-See C<L</gv_stashpvn>> for details on "flags".
+See C<L</gv_stashpvn>> for details on C<flags>.
Note the sv interface is strongly preferred for performance reasons.
#define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
assert(namesv || name)
-PERL_STATIC_INLINE HV*
-S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
+HV*
+Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
{
HV* stash;
HE* he;
PERL_ARGS_ASSERT_GV_STASHSV;
return gv_stashsvpvn_cached(sv, NULL, 0, flags);
}
-
-
GV *
-Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
+Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 flags, const svtype sv_type) {
PERL_ARGS_ASSERT_GV_FETCHPV;
- return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
+ return gv_fetchpvn_flags(nambeg, strlen(nambeg), flags, sv_type);
}
GV *
STRLEN *len, const char *nambeg, STRLEN full_len,
const U32 is_utf8, const I32 add)
{
+ char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */
const char *name_cursor;
const char *const name_end = nambeg + full_len;
const char *const name_em1 = name_end - 1;
+ char smallbuf[64]; /* small buffer to avoid a malloc when possible */
PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
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 ' */
key = *name;
*len += 2;
}
- else {
+ else { /* using ' for package separator */
+ /* use our pre-allocated buffer when possible to save a malloc */
char *tmpbuf;
- Newx(tmpbuf, *len+2, char);
+ if ( *len+2 <= sizeof smallbuf)
+ tmpbuf = smallbuf;
+ else {
+ /* only malloc once if needed */
+ if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */
+ Newx(tmpfullbuf, full_len+2, char);
+ tmpbuf = tmpfullbuf;
+ }
Copy(*name, tmpbuf, *len, char);
tmpbuf[(*len)++] = ':';
tmpbuf[(*len)++] = ':';
}
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)
- gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
- else
- GvMULTI_on(*gv);
+ if (!*gv || *gv == (const GV *)&PL_sv_undef) {
+ goto notok;
}
- if (key != *name)
- Safefree(key);
- if (!*gv || *gv == (const GV *)&PL_sv_undef)
- return FALSE;
+ /* here we know that *gv && *gv != &PL_sv_undef */
+ if (SvTYPE(*gv) != SVt_PVGV)
+ gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
+ else
+ GvMULTI_on(*gv);
if (!(*stash = GvHV(*gv))) {
*stash = GvHV(*gv) = newHV();
if (!HvNAME_get(*stash)) {
if (GvSTASH(*gv) == PL_defstash && *len == 6
- && strEQs(*name, "CORE"))
+ && strBEGINs(*name, "CORE"))
hv_name_sets(*stash, "CORE", 0);
else
hv_name_set(
MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash));
}
}
- 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.,
if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
/* Avoid null warning: */
const char * const stashname = HvNAME(stash); assert(stashname);
- if (strEQs(stashname, "CORE"))
+ if (strBEGINs(stashname, "CORE"))
S_maybe_add_coresub(aTHX_ 0, gv, name, len);
}
}
/* @{^CAPTURE} %{^CAPTURE} */
if (memEQs(name, len, "\003APTURE")) {
AV* const av = GvAVn(gv);
- UV uv= *name;
+ const Size_t n = *name;
- sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0);
+ 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 */
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;
}
{ /* @- @+ */
AV* const av = GvAVn(gv);
- const UV uv = (UV)*name;
+ const Size_t n = *name;
- sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0);
+ sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0);
SvREADONLY_on(av);
}
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;
}
}
+/*
+=for apidoc gv_fetchpv
+=for apidoc_item |GV *|gv_fetchpvn|const char * nambeg|STRLEN full_len|I32 flags|const svtype sv_type
+=for apidoc_item ||gv_fetchpvn_flags
+=for apidoc_item |GV *|gv_fetchpvs|"name"|I32 flags|const svtype sv_type
+=for apidoc_item ||gv_fetchsv
+=for apidoc_item |GV *|gv_fetchsv_nomg|SV *name|I32 flags|const svtype sv_type
+
+These all return the GV of type C<sv_type> whose name is given by the inputs,
+or NULL if no GV of that name and type could be found. See L<perlguts/Stashes
+and Globs>.
+
+The only differences are how the input name is specified, and if 'get' magic is
+normally used in getting that name.
+
+Don't be fooled by the fact that only one form has C<flags> in its name. They
+all have a C<flags> parameter in fact, and all the flag bits have the same
+meanings for all
+
+If any of the flags C<GV_ADD>, C<GV_ADDMG>, C<GV_ADDWARN>, C<GV_ADDMULTI>, or
+C<GV_NOINIT> is set, a GV is created if none already exists for the input name
+and type. However, C<GV_ADDMG> will only do the creation for magical GV's.
+For all of these flags except C<GV_NOINIT>, C<L</gv_init_pvn>> is called after
+the addition. C<GV_ADDWARN> is used when the caller expects that adding won't
+be necessary because the symbol should already exist; but if not, add it
+anyway, with a warning that it was unexpectedly absent. The C<GV_ADDMULTI>
+flag means to pretend that the GV has been seen before (I<i.e.>, suppress "Used
+once" warnings).
+
+The flag C<GV_NOADD_NOINIT> causes C<L</gv_init_pvn>> not be to called if the
+GV existed but isn't PVGV.
+
+If the C<SVf_UTF8> bit is set, the name is treated as being encoded in UTF-8;
+otherwise the name won't be considered to be UTF-8 in the C<pv>-named forms,
+and the UTF-8ness of the underlying SVs will be used in the C<sv> forms.
+
+If the flag C<GV_NOTQUAL> is set, the caller warrants that the input name is a
+plain symbol name, not qualified with a package, otherwise the name is checked
+for being a qualified one.
+
+In C<gv_fetchpv>, C<nambeg> is a C string, NUL-terminated with no intermediate
+NULs.
+
+In C<gv_fetchpvs>, C<name> is a literal C string, hence is enclosed in
+double quotes.
+
+C<gv_fetchpvn> and C<gv_fetchpvn_flags> are identical. In these, <nambeg> is
+a Perl string whose byte length is given by C<full_len>, and may contain
+embedded NULs.
+
+In C<gv_fetchsv> and C<gv_fetchsv_nomg>, the name is extracted from the PV of
+the input C<name> SV. The only difference between these two forms is that
+'get' magic is normally done on C<name> in C<gv_fetchsv>, and always skipped
+with C<gv_fetchsv_nomg>. Including C<GV_NO_SVGMAGIC> in the C<flags> parameter
+to C<gv_fetchsv> makes it behave identically to C<gv_fetchsv_nomg>.
+
+=for apidoc Amnh||GV_ADD
+=for apidoc Amnh||GV_ADDMG
+=for apidoc Amnh||GV_ADDMULTI
+=for apidoc Amnh||GV_ADDWARN
+=for apidoc Amnh||GV_NOADD_NOINIT
+=for apidoc Amnh||GV_NOINIT
+=for apidoc Amnh||GV_NOTQUAL
+=for apidoc Amnh||GV_NO_SVGMAGIC
+=for apidoc Amnh||SVf_UTF8
+
+=cut
+*/
+
GV *
Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
const svtype sv_type)
/* By this point we should have a stash and a name */
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);
+ if (addmg) gv = (GV *)newSV(0); /* tentatively */
else return NULL;
}
else gv = *gvp, addmg = 0;
if (len == 1 && stash == PL_defstash) {
maybe_multimagic_gv(gv, name, sv_type);
}
- else if (len == 3 && sv_type == SVt_PVAV
- && strEQs(name, "ISA")
+ else if (sv_type == SVt_PVAV
+ && memEQs(name, len, "ISA")
&& (!GvAV(gv) || !SvSMAGICAL(GvAV(gv))))
gv_magicalize_isa(gv);
}
if (hv && (name = HvNAME(hv))) {
const STRLEN len = HvNAMELEN(hv);
- if (keepmain || strnNE(name, "main", len)) {
+ if (keepmain || ! memBEGINs(name, len, "main")) {
sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
sv_catpvs(sv,"::");
}
gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
cv = 0;
if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
- const HEK * const gvhek =
- CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(cv));
+ const HEK * const gvhek = CvGvNAME_HEK(cv);
const HEK * const stashek =
HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
- if (HEK_LEN(gvhek) == 3 && strEQ(HEK_KEY(gvhek), "nil")
- && stashek && HEK_LEN(stashek) == 8
- && strEQ(HEK_KEY(stashek), "overload")) {
+ if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil")
+ && stashek
+ && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) {
/* This is a hack to support autoloading..., while
knowing *which* methods were declared as overloaded. */
/* GvSV contains the name of the method. */
/* 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;
SV*
Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
{
- dVAR;
MAGIC *mg;
CV *cv=NULL;
CV **cvp=NULL, **ocvp=NULL;
case abs_amg:
if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
&& ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
- SV* const nullsv=sv_2mortal(newSViv(0));
+ SV* const nullsv=&PL_sv_zero;
if (off1==lt_amg) {
SV* const lessp = amagic_call(left,nullsv,
lt_amg,AMGf_noright);
- logic = SvTRUE(lessp);
+ logic = SvTRUE_NN(lessp);
} else {
SV* const lessp = amagic_call(left,nullsv,
ncmp_amg,AMGf_noright);
case neg_amg:
if ((cv = cvp[off=subtr_amg])) {
right = left;
- left = sv_2mortal(newSViv(0));
+ left = &PL_sv_zero;
lr = 1;
}
break;
SV* res;
const bool oldcatch = CATCH_GET;
I32 oldmark, nret;
- U8 gimme = force_scalar ? G_SCALAR : GIMME_V;
+ /* for multiconcat, we may call overload several times,
+ * with the context of individual concats being scalar,
+ * regardless of the overall context of the multiconcat op
+ */
+ U8 gimme = (force_scalar || PL_op->op_type == OP_MULTICONCAT)
+ ? G_SCALAR : GIMME_V;
CATCH_SET(TRUE);
Zero(&myop, 1, BINOP);
res = &PL_sv_undef;
SP = PL_stack_base + oldmark;
break;
- case G_ARRAY: {
+ case G_ARRAY:
if (flags & AMGf_want_list) {
res = sv_2mortal((SV *)newAV());
av_extend((AV *)res, nret);
break;
}
/* FALLTHROUGH */
- }
default:
res = POPs;
break;
case dec_amg:
SvSetSV(left,res); return left;
case not_amg:
- ans=!SvTRUE(res); break;
+ ans=!SvTRUE_NN(res); break;
default:
ans=0; break;
}
void
Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
{
- dVAR;
U32 hash;
PERL_ARGS_ASSERT_GV_NAME_SET;
https://perl5.git.perl.org / perl5.git / blobdiff