/*
=head1 GV Functions
-
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.
#include "EXTERN.h"
#define PERL_IN_GV_C
#include "perl.h"
-#include "overload.c"
+#include "overload.inc"
#include "keywords.h"
#include "feature.h"
static const char S_autoload[] = "AUTOLOAD";
-static const STRLEN S_autolen = sizeof(S_autoload)-1;
+#define S_autolen (sizeof("AUTOLOAD")-1)
GV *
Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
const U32 flags)
{
- dVAR;
char smallbuf[128];
char *tmpbuf;
const STRLEN tmplen = namelen + 2;
sv_setpvn(GvSV(gv), name, namelen);
#endif
}
- if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
+ if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv))
hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile);
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
inlining, or C<gv> is a placeholder reference that would be promoted to such
a typeglob, then returns the value returned by the sub. Otherwise, returns
-NULL.
+C<NULL>.
=cut
*/
Perl_gv_const_sv(pTHX_ GV *gv)
{
PERL_ARGS_ASSERT_GV_CONST_SV;
+ PERL_UNUSED_CONTEXT;
if (SvTYPE(gv) == SVt_PVGV)
return cv_const_sv(GvCVu(gv));
- return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV ? SvRV(gv) : NULL;
+ return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL;
}
GP *
void
Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
{
- GV * const oldgv = CvGV(cv);
+ GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
HEK *hek;
PERL_ARGS_ASSERT_CVGV_SET;
sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
}
}
- else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek);
+ else if ((hek = CvNAME_HEK(cv))) {
+ unshare_hek(hek);
+ CvLEXICAL_off(cv);
+ }
+ CvNAMED_off(cv);
SvANY(cv)->xcv_gv_u.xcv_gv = gv;
assert(!CvCVGV_RC(cv));
}
}
+/* Convert CvSTASH + CvNAME_HEK into a GV. Conceptually, all subs have a
+ GV, but for efficiency that GV may not in fact exist. This function,
+ called by CvGV, reifies it. */
+
+GV *
+Perl_cvgv_from_hek(pTHX_ CV *cv)
+{
+ GV *gv;
+ SV **svp;
+ PERL_ARGS_ASSERT_CVGV_FROM_HEK;
+ assert(SvTYPE(cv) == SVt_PVCV);
+ if (!CvSTASH(cv)) return NULL;
+ ASSUME(CvNAME_HEK(cv));
+ svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
+ gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
+ if (!isGV(gv))
+ gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
+ HEK_LEN(CvNAME_HEK(cv)),
+ SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
+ if (!CvNAMED(cv)) { /* gv_init took care of it */
+ assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
+ return gv;
+ }
+ unshare_hek(CvNAME_HEK(cv));
+ CvNAMED_off(cv);
+ SvANY(cv)->xcv_gv_u.xcv_gv = gv;
+ if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
+ CvCVGV_RC_on(cv);
+ return gv;
+}
+
/* Assign CvSTASH(cv) = st, handling weak references. */
void
Converts a scalar into a typeglob. This is an incoercible typeglob;
assigning a reference to it will assign to one of its slots, instead of
-overwriting it as happens with typeglobs created by SvSetSV. Converting
-any scalar that is SvOK() may produce unpredictable results and is reserved
+overwriting it as happens with typeglobs created by C<SvSetSV>. Converting
+any scalar that is C<SvOK()> may produce unpredictable results and is reserved
for perl's internal use.
C<gv> is the scalar to be converted.
passed to this function matches the name of the element. If it does not
match, perl's internal bookkeeping will get out of sync.
-C<flags> can be set to SVf_UTF8 if C<name> is a UTF8 string, or
+C<flags> can be set to C<SVf_UTF8> if C<name> is a UTF-8 string, or
the return value of SvUTF8(sv). It can also take the
-GV_ADDMULTI flag, which means to pretend that the GV has been
+C<GV_ADDMULTI> flag, which means to pretend that the GV has been
seen before (i.e., suppress "Used once" warnings).
=for apidoc gv_init
-The old form of gv_init_pvn(). It does not work with UTF8 strings, as it
+The old form of C<gv_init_pvn()>. It does not work with UTF-8 strings, as it
has no flags parameter. If the C<multi> parameter is set, the
-GV_ADDMULTI flag will be passed to gv_init_pvn().
+C<GV_ADDMULTI> flag will be passed to C<gv_init_pvn()>.
=for apidoc gv_init_pv
-Same as gv_init_pvn(), but takes a nul-terminated string for the name
+Same as C<gv_init_pvn()>, but takes a nul-terminated string for the name
instead of separate char * and length parameters.
=for apidoc gv_init_sv
-Same as gv_init_pvn(), but takes an SV * for the name instead of separate
+Same as C<gv_init_pvn()>, but takes an SV * for the name instead of separate
char * and length parameters. C<flags> is currently unused.
=cut
void
Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
{
- dVAR;
const U32 old_type = SvTYPE(gv);
const bool doproto = old_type > SVt_NULL;
char * const proto = (doproto && SvPOK(gv))
assert (!(proto && has_constant));
if (has_constant) {
- /* The constant has to be a simple scalar type. */
+ /* The constant has to be a scalar, array or subroutine. */
switch (SvTYPE(has_constant)) {
case SVt_PVHV:
- case SVt_PVCV:
case SVt_PVFM:
case SVt_PVIO:
Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
sv_reftype(has_constant, 0));
+
default: NOOP;
}
SvRV_set(gv, NULL);
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 (doproto) {
+ if (has_constant && SvTYPE(has_constant) == SVt_PVCV) {
+ /* Not actually a constant. Just a regular sub. */
+ CV * const cv = (CV *)has_constant;
+ GvCV_set(gv,cv);
+ if (CvSTASH(cv) == stash && (
+ CvNAME_HEK(cv) == GvNAME_HEK(gv)
+ || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
+ && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
+ && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
+ && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
+ )
+ ))
+ CvGV_set(cv,gv);
+ }
+ else if (doproto) {
CV *cv;
if (has_constant) {
/* newCONSTSUB takes ownership of the reference from us. */
/* 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;
+ PoisonPADLIST(cv);
}
CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
from PL_curcop. */
- (void)gv_fetchfile(file);
+ /* XSUBs can't be perl lang/perl5db.pl debugged
+ if (PERLDB_LINE_OR_SAVESRC)
+ (void)gv_fetchfile(file); */
CvFILE(cv) = (char *)file;
/* XXX This is inefficient, as doing things this order causes
a prototype check in newATTRSUB. But we have to do
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
GV *
Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags)
{
- char *namepv;
- STRLEN namelen;
- PERL_ARGS_ASSERT_GV_FETCHMETH_SV;
- namepv = SvPV(namesv, namelen);
- if (SvUTF8(namesv))
- flags |= SVf_UTF8;
- return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
+ char *namepv;
+ 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);
+ namepv = SvPV(namesv, namelen);
+ if (SvUTF8(namesv)) flags |= SVf_UTF8;
+ return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags);
}
/*
Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags)
{
PERL_ARGS_ASSERT_GV_FETCHMETH_PV;
- return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags);
+ return gv_fetchmeth_internal(stash, NULL, name, strlen(name), level, flags);
}
/*
Returns the glob with the given C<name> and a defined subroutine or
C<NULL>. The glob lives in the given C<stash>, or in the stashes
-accessible via @ISA and UNIVERSAL::.
+accessible via C<@ISA> and C<UNIVERSAL::>.
The argument C<level> should be either 0 or -1. If C<level==0>, as a
side-effect creates a glob with the given C<name> in the given C<stash>
which in the case of success contains an alias for the subroutine, and sets
up caching info for this glob.
-The only significant values for C<flags> are GV_SUPER and SVf_UTF8.
+The only significant values for C<flags> are C<GV_SUPER> and C<SVf_UTF8>.
-GV_SUPER indicates that we want to look up the method in the superclasses
+C<GV_SUPER> indicates that we want to look up the method in the superclasses
of the C<stash>.
The
/* NOTE: No support for tied ISA */
-GV *
-Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
+PERL_STATIC_INLINE GV*
+S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, I32 level, U32 flags)
{
- dVAR;
GV** gvp;
+ HE* he;
AV* linear_av;
SV** linear_svp;
SV* linear_sv;
CV* cand_cv = NULL;
GV* topgv = NULL;
const char *hvname;
- I32 create = (level >= 0) ? 1 : 0;
+ I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0;
I32 items;
U32 topgen_cmp;
U32 is_utf8 = flags & SVf_UTF8;
- PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
-
/* UNIVERSAL methods should be callable without a stash */
if (!stash) {
create = 0; /* probably appropriate */
Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
assert(hvname);
- assert(name);
+ assert(name || meth);
DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n",
- flags & GV_SUPER ? "SUPER " : "",name,hvname) );
+ flags & GV_SUPER ? "SUPER " : "",
+ name ? name : SvPV_nolen(meth), hvname) );
topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
else cachestash = stash;
/* check locally for a real method or a cache entry */
- gvp = (GV**)hv_fetch(cachestash, name, is_utf8 ? -(I32)len : (I32)len,
- create);
+ he = (HE*)hv_common(
+ cachestash, meth, name, len, (flags & SVf_UTF8) ? HVhek_UTF8 : 0, create, NULL, 0
+ );
+ if (he) gvp = (GV**)&HeVAL(he);
+ else gvp = NULL;
+
if(gvp) {
topgv = *gvp;
have_gv:
assert(topgv);
if (SvTYPE(topgv) != SVt_PVGV)
+ {
+ if (!name)
+ name = SvPV_nomg(meth, len);
gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8);
+ }
if ((cand_cv = GvCV(topgv))) {
/* If genuine method or valid cache entry, use it */
if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
/* Check UNIVERSAL without caching */
if(level == 0 || level == -1) {
- candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags &~GV_SUPER);
+ candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1,
+ flags &~GV_SUPER);
if(candidate) {
cand_cv = GvCV(candidate);
if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
return 0;
}
+GV *
+Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
+{
+ PERL_ARGS_ASSERT_GV_FETCHMETH_PVN;
+ return gv_fetchmeth_internal(stash, NULL, name, len, level, flags);
+}
+
/*
=for apidoc gv_fetchmeth_autoload
/*
=for apidoc gv_fetchmeth_pvn_autoload
-Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too.
+Same as C<gv_fetchmeth_pvn()>, but looks for autoloaded subroutines too.
Returns a glob for the subroutine.
For an autoloaded subroutine without a GV, will create a GV even
-if C<level < 0>. For an autoloaded subroutine without a stub, GvCV()
+if C<level < 0>. For an autoloaded subroutine without a stub, C<GvCV()>
of the result may be zero.
-Currently, the only significant value for C<flags> is SVf_UTF8.
+Currently, the only significant value for C<flags> is C<SVf_UTF8>.
=cut
*/
Returns the glob which contains the subroutine to call to invoke the method
on the C<stash>. In fact in the presence of autoloading this may be the
-glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is
+glob for "AUTOLOAD". In this case the corresponding variable C<$AUTOLOAD> is
already setup.
The third parameter of C<gv_fetchmethod_autoload> determines whether
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 C<$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 *
Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
{
- dVAR;
const char *nend;
const char *nsplit = NULL;
GV* gv;
GV* stubgv;
GV* autogv;
- if (CvANON(cv))
+ if (CvANON(cv) || CvLEXICAL(cv))
stubgv = gv;
else {
stubgv = CvGV(cv);
GV*
Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
{
- dVAR;
GV* gv;
CV* cv;
HV* varstash;
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);
* use that, but for lack of anything better we will use the sub's
* original package to look up $AUTOLOAD.
*/
- varstash = GvSTASH(CvGV(cv));
+ varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
ENTER;
STATIC HV*
S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
{
- dVAR;
HV* stash = gv_stashsv(namesv, 0);
PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
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",
parameter indicates the length of the C<name>, in bytes. C<flags> is passed
to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
created if it does not already exist. If the package does not exist and
-C<flags> is 0 (or any other setting that does not create packages) then NULL
+C<flags> is 0 (or any other setting that does not create packages) then C<NULL>
is returned.
Flags may be one of:
GV_NOEXPAND
GV_ADDMG
-The most important of which are probably GV_ADD and SVf_UTF8.
+The most important of which are probably C<GV_ADD> and C<SVf_UTF8>.
+
+Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
+recommended for performance reasons.
=cut
*/
-HV*
-Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
+/*
+gv_stashpvn_internal
+
+Perform the internal bits of gv_stashsvpvn_cached. You could think of this
+as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
+
+*/
+
+PERL_STATIC_INLINE HV*
+S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
{
char smallbuf[128];
char *tmpbuf;
GV *tmpgv;
U32 tmplen = namelen + 2;
- PERL_ARGS_ASSERT_GV_STASHPVN;
+ PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
if (tmplen <= sizeof smallbuf)
tmpbuf = smallbuf;
tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
- if (!tmpgv)
+ if (!tmpgv || !isGV_with_GP(tmpgv))
return NULL;
stash = GvHV(tmpgv);
if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL;
}
/*
+gv_stashsvpvn_cached
+
+Returns a pointer to the stash for a specified package, possibly
+cached. Implements both C<gv_stashpvn> and C<gc_stashsv>.
+
+Requires one of either namesv or namepv to be non-null.
+
+See C<L</gv_stashpvn>> for details on "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* stash;
+ HE* he;
+
+ PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
+
+ he = (HE *)hv_common(
+ PL_stashcache, namesv, name, namelen,
+ (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
+ );
+
+ if (he) return INT2PTR(HV*,SvIVX(HeVAL(he)));
+ else if (flags & GV_CACHE_ONLY) return NULL;
+
+ if (namesv) {
+ if (SvOK(namesv)) { /* prevent double uninit warning */
+ STRLEN len;
+ name = SvPV_const(namesv, len);
+ namelen = len;
+ flags |= SvUTF8(namesv);
+ } else {
+ name = ""; namelen = 0;
+ }
+ }
+ stash = gv_stashpvn_internal(name, namelen, flags);
+
+ if (stash && namelen) {
+ SV* const ref = newSViv(PTR2IV(stash));
+ (void)hv_store(PL_stashcache, name,
+ (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
+ }
+
+ return stash;
+}
+
+HV*
+Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
+{
+ PERL_ARGS_ASSERT_GV_STASHPVN;
+ return gv_stashsvpvn_cached(NULL, name, namelen, flags);
+}
+
+/*
=for apidoc gv_stashsv
-Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
+Returns a pointer to the stash for a specified package. See
+C<L</gv_stashpvn>>.
+
+Note this interface is strongly preferred over C<gv_stashpvn> for performance
+reasons.
=cut
*/
HV*
Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
{
- STRLEN len;
- const char * const ptr = SvPV_const(sv,len);
-
PERL_ARGS_ASSERT_GV_STASHSV;
-
- return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
+ return gv_stashsvpvn_cached(sv, NULL, 0, flags);
}
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)
!(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)
{
if (!*stash) {
if (add && !PL_in_clean_all) {
- SV * const err = Perl_mess(aTHX_
+ GV *gv;
+ qerror(Perl_mess(aTHX_
"Global symbol \"%s%"UTF8f
- "\" requires explicit package name",
+ "\" requires explicit package name (did you forget to "
+ "declare \"my %s%"UTF8f"\"?)",
(sv_type == SVt_PV ? "$"
: sv_type == SVt_PVAV ? "@"
: sv_type == SVt_PVHV ? "%"
- : ""), UTF8fARG(is_utf8, len, name));
- GV *gv;
- if (is_utf8)
- SvUTF8_on(err);
- qerror(err);
+ : ""), UTF8fARG(is_utf8, len, name),
+ (sv_type == SVt_PV ? "$"
+ : sv_type == SVt_PVAV ? "@"
+ : sv_type == SVt_PVHV ? "%"
+ : ""), UTF8fARG(is_utf8, len, name)));
/* 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
return TRUE;
}
+/* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT. So
+ redefine SvREADONLY_on for that purpose. We don’t use it later on in
+ this file. */
+#undef SvREADONLY_on
+#define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
+
/* 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
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);
+ /* FALLTHROUGH */
default:
goto try_core;
}
} else
#endif
{
- const char * const name2 = name + 1;
+ const char * name2 = name + 1;
switch (*name) {
case 'A':
if (strEQ(name2, "RGV")) {
goto magicalize;
break;
case '\005': /* $^ENCODING */
+ if (*name2 == '_') {
+ name2++;
+ }
if (strEQ(name2, "NCODING"))
goto magicalize;
break;
case '\027': /* $^WARNING_BITS */
if (strEQ(name2, "ARNING_BITS"))
goto magicalize;
+#ifdef WIN32
+ else if (strEQ(name2, "IN32_SLOPPY_STAT"))
+ goto magicalize;
+#endif
break;
case '1':
case '2':
{
/* Ensures that we have an all-digit variable, ${"1foo"} fails
this test */
- /* This snippet is taken from is_gv_magical */
- const char *end = name + len;
- while (--end > name) {
- if (!isDIGIT(*end))
- return addmg;
- }
- paren = strtoul(name, NULL, 10);
+ UV uv;
+ if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX)
+ return addmg;
+ /* XXX why are we using a SSize_t? */
+ paren = (SSize_t)(I32)uv;
goto storeparen;
}
}
case '\023': /* $^S */
ro_magicalize:
SvREADONLY_on(GvSVn(gv));
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case '0': /* $0 */
case '^': /* $^ */
case '~': /* $~ */
SvREFCNT_dec(sv);
}
break;
+ case 'a':
+ case 'b':
+ if (sv_type == SVt_PV)
+ GvMULTI_on(gv);
}
}
return addmg;
}
+/* If we do ever start using this later on in the file, we need to make
+ sure we don’t accidentally use the wrong definition. */
+#undef SvREADONLY_on
+
/* 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
Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
const svtype sv_type)
{
- dVAR;
const char *name = nambeg;
GV *gv = NULL;
GV**gvp;
}
/* 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;
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)
{
- dVAR;
I32 i;
PERL_ARGS_ASSERT_GV_CHECK;
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;
}
}
GV *
Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
{
- dVAR;
PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
assert(!(flags & ~SVf_UTF8));
GP*
Perl_gp_ref(pTHX_ GP *gp)
{
- dVAR;
if (!gp)
return NULL;
gp->gp_refcnt++;
void
Perl_gp_free(pTHX_ GV *gv)
{
- dVAR;
GP* gp;
int attempts = 100;
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;
}
Somehow gp->gp_hv can end up pointing at freed garbage. */
if (hv && SvTYPE(hv) == SVt_PVHV) {
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)
+ if (PL_stashcache && hvname_hek) {
+ DEBUG_o(Perl_deb(aTHX_
+ "gp_free clearing PL_stashcache for '%"HEKf"'\n",
+ HEKfARG(hvname_hek)));
(void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
+ }
SvREFCNT_dec(hv);
}
+ if (io && SvREFCNT(io) == 1 && IoIFP(io)
+ && (IoTYPE(io) == IoTYPE_WRONLY ||
+ IoTYPE(io) == IoTYPE_RDWR ||
+ IoTYPE(io) == IoTYPE_APPEND)
+ && ckWARN_d(WARN_IO)
+ && IoIFP(io) != PerlIO_stdin()
+ && IoIFP(io) != PerlIO_stdout()
+ && IoIFP(io) != PerlIO_stderr()
+ && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+ io_close(io, gv, FALSE, TRUE);
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
Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
{
- dVAR;
MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
AMT amt;
const struct mro_meta* stash_meta = HvMROMETA(stash);
{
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: */
numifying instead of C's "+0". */
gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
cv = 0;
- if (gv && (cv = GvCV(gv))) {
- if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
- const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
- if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
- && strEQ(hvname, "overload")) {
+ if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
+ const HEK * const gvhek =
+ CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(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")) {
/* This is a hack to support autoloading..., while
knowing *which* methods were declared as overloaded. */
/* GvSV contains the name of the method. */
}
}
cv = GvCV(gv = ngv);
- }
}
DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
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,
CV*
Perl_gv_handler(pTHX_ HV *stash, I32 id)
{
- dVAR;
MAGIC *mg;
AMT *amtp;
U32 newgen;
bool
Perl_try_amagic_un(pTHX_ int method, int flags) {
- dVAR;
dSP;
SV* tmpsv;
SV* const arg = TOPs;
SvGETMAGIC(arg);
if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method,
- AMGf_noright | AMGf_unary))) {
+ AMGf_noright | AMGf_unary
+ | (flags & AMGf_numarg))))
+ {
if (flags & AMGf_set) {
SETs(tmpsv);
}
bool
Perl_try_amagic_bin(pTHX_ int method, int flags) {
- dVAR;
dSP;
SV* const left = TOPm1s;
SV* const right = TOPs;
if (SvAMAGIC(left) || SvAMAGIC(right)) {
SV * const tmpsv = amagic_call(left, right, method,
- ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
+ ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0)
+ | (flags & AMGf_numarg));
if (tmpsv) {
if (flags & AMGf_set) {
(void)POPs;
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;
}
case regexp_amg:
/* FAIL safe */
return NULL; /* Delegate operation to standard mechanisms. */
- break;
+
case to_sv_amg:
case to_av_amg:
case to_hv_amg:
case to_cv_amg:
/* FAIL safe */
return left; /* Delegate operation to standard mechanisms. */
- break;
+
default:
goto not_found;
}
case to_cv_amg:
/* FAIL safe */
return left; /* Delegate operation to standard mechanisms. */
- break;
}
if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
notfound = 1; lr = -1;
case band_amg:
case bor_amg:
case bxor_amg:
+ case sband_amg:
+ case sbor_amg:
+ case sbxor_amg:
if (assign)
force_scalar = 1;
break;
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);
PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
AMG_id2namelen(method + assignshift), SVs_TEMP));
}
+ else if (flags & AMGf_numarg)
+ PUSHs(&PL_sv_undef);
+ if (flags & AMGf_numarg)
+ PUSHs(&PL_sv_yes);
PUSHs(MUTABLE_SV(cv));
PUTBACK;
oldmark = TOPMARK;
if (!cv) {
HEK *gvnhek = GvNAME_HEK(gv);
(void)hv_deletehek(stash, gvnhek, G_DISCARD);
- } else if (GvMULTI(gv) && cv &&
+ } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
!SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
- CvSTASH(cv) == stash && CvGV(cv) == gv &&
+ CvSTASH(cv) == stash && !CvNAMED(cv) && 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);
sv_clear((SV*)gv);
SvREFCNT(gv) = 1;
SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported;
+
+ /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */
SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
STRUCT_OFFSET(XPVIV, xiv_iv));
SvRV_set(gv, value);
}
}
+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
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff