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;
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));
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);
+ CvNAMED_off(cv);
+ CvLEXICAL_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
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",
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. */
GV *
Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
{
- dVAR;
GV** gvp;
AV* linear_av;
SV** linear_svp;
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) || !CvGV(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;
* 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;
The most important of which are probably GV_ADD and 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;
}
/*
+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<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>.
+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);
}
if (!isDIGIT(*end))
return addmg;
}
- paren = strtoul(name, NULL, 10);
+ paren = grok_atou(name, NULL);
goto storeparen;
}
}
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;
void
Perl_gv_check(pTHX_ HV *stash)
{
- dVAR;
I32 i;
PERL_ARGS_ASSERT_GV_CHECK;
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;
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);
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 (gv && (cv = GvCV(gv)) && CvGV(cv)) {
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
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;
bool
Perl_try_amagic_bin(pTHX_ int method, int flags) {
- dVAR;
dSP;
SV* const left = TOPm1s;
SV* const right = TOPs;
https://perl5.git.perl.org / perl5.git / blobdiff