#include "EXTERN.h"
#include "perl.h"
/*
* chocolateboy 2009-02-08
*
* for binary compatibility (see perlapi.h), XS modules perform a function call to
* access each and every interpreter variable. So, for instance, an innocuous-looking
* reference to PL_op becomes:
*
* (*Perl_Iop_ptr(my_perl))
*
* This (obviously) impacts performance. Internally, PL_op is accessed as:
*
* my_perl->Iop
*
* (in threaded/multiplicity builds (see intrpvar.h)), which is significantly faster.
*
* defining PERL_CORE gets us the fast version, at the expense of a future maintenance release
* possibly breaking things: http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-04/msg00171.html
*
* Rather than globally defining PERL_CORE, which pokes its fingers into various headers, exposing
* internals we'd rather not see, just define it for XSUB.h, which includes
* perlapi.h, which imposes the speed limit.
*/
#define PERL_CORE
#include "XSUB.h"
#undef PERL_CORE
#define NEED_sv_2pv_flags
#include "ppport.h"
#include "hook_op_check.h"
#include "hook_op_annotation.h"
#include "mro.h"
#include <string.h> /* for strchr and strlen */
/* #define NDEBUG */
#include <assert.h>
#define METHOD_LEXICAL_INSTALLED "Method::Lexical"
#define METHOD_LEXICAL_ENABLED(table, svp) \
((PL_hints & 0x20000) && \
(table = GvHVn(PL_hintgv)) && \
(svp = hv_fetch(table, METHOD_LEXICAL_INSTALLED, sizeof(METHOD_LEXICAL_INSTALLED) - 1, FALSE)) && \
*svp && \
SvOK(*svp) && \
SvROK(*svp) && \
SvRV(*svp) && \
SvTYPE(SvRV(*svp)) == SVt_PVHV)
typedef struct MethodLexicalDataList {
const HV *stash;
U32 generation;
const CV *cv;
const SV * method;
struct MethodLexicalDataList *next;
} MethodLexicalDataList;
typedef struct MethodLexicalData {
HV *hv;
MethodLexicalDataList *list;
U32 dynamic;
U32 autoload;
} MethodLexicalData;
STATIC CV * method_lexical_hash_get(pTHX_ const HV * const hv, const SV * const key);
STATIC HV * method_lexical_get_fqname_stash(pTHX_ SV **method_sv_ptr, char **class_name_ptr);
STATIC HV * method_lexical_get_invocant_stash(pTHX_ SV * const invocant, char **class_name_ptr);
STATIC HV * method_lexical_get_super_stash(pTHX_ const char * const class_name, char **class_name_ptr);
STATIC MethodLexicalData * method_lexical_data_new(pTHX_ HV * const hv, const U32 dynamic, const U32 autoload);
STATIC OP * method_lexical_check_method_dynamic(pTHX_ OP * o);
STATIC OP * method_lexical_check_method(pTHX_ OP * o, void *user_data);
STATIC OP * method_lexical_check_method_static(pTHX_ OP * o);
STATIC OP * method_lexical_method_dynamic(pTHX);
STATIC OP * method_lexical_method_static(pTHX);
STATIC void method_lexical_data_free(pTHX_ void *data);
STATIC void method_lexical_data_list_free(pTHX_ void *vp);
STATIC void method_lexical_enter();
STATIC void method_lexical_leave();
STATIC MethodLexicalDataList * method_lexical_data_list_new(
pTHX_
const HV * const stash,
const U32 generation,
const SV * const method,
const CV * const cv
);
STATIC SV *method_lexical_cache_fetch(
pTHX_
MethodLexicalData *data,
const HV * const stash,
const SV * const method,
U32 * const found
);
STATIC void method_lexical_cache_store(
pTHX_
MethodLexicalData * const data,
const HV * const stash,
const U32 generation,
const SV * const method,
const CV * const cv
);
STATIC SV * method_lexical_method_common(
pTHX_
MethodLexicalData * const data,
const HV * const stash,
const char * const class_name,
const SV * const method
);
STATIC void method_lexical_cache_remove(
pTHX_
MethodLexicalData * const data,
MethodLexicalDataList *prev,
MethodLexicalDataList *head
);
STATIC void method_lexical_set_autoload(
pTHX_
const HV * const stash,
const char * const class_name,
const SV *method,
CV * cv
);
STATIC CV *method_lexical_lookup_method(
pTHX_
const HV * const stash,
const HV * const installed,
const char * const class_name,
const char * const name,
U32 *generation_ptr
);
STATIC hook_op_check_id method_lexical_check_method_id = 0;
STATIC OPAnnotationGroup METHOD_LEXICAL_ANNOTATIONS = NULL;
STATIC U32 METHOD_LEXICAL_COMPILING = 0;
STATIC U32 METHOD_LEXICAL_DEBUG = 0;
STATIC MethodLexicalData * method_lexical_data_new(pTHX_ HV * const hv, const U32 dynamic, const U32 autoload) {
MethodLexicalData *data;
Newx(data, 1, MethodLexicalData);
if (!data) {
croak("Method::Lexical: couldn't allocate annotation data");
}
data->hv = (HV * const)SvREFCNT_inc(hv); /* this is needed to prevent the hash being garbage-collected */
data->dynamic = dynamic;
data->autoload = autoload;
data->list = NULL;
return data;
}
STATIC void method_lexical_data_free(pTHX_ void *vp) {
MethodLexicalData *data = (MethodLexicalData *)vp;
if (data->list) {
method_lexical_data_list_free(aTHX_ data->list);
}
SvREFCNT_dec(data->hv);
Safefree(data);
}
STATIC MethodLexicalDataList * method_lexical_data_list_new(
pTHX_
const HV * const stash,
const U32 generation,
const SV * const method,
const CV * const cv
) {
MethodLexicalDataList *list;
Newx(list, 1, MethodLexicalDataList);
if (!list) {
croak("Method::Lexical: couldn't allocate annotation data list");
}
/* the refcount increments are needed to prevent the values being garbage-collected */
list->stash = (HV *const)SvREFCNT_inc(stash);
list->method = method ? (SV * const)SvREFCNT_inc(method) : method;
list->generation = generation;
list->cv = (CV * const)SvREFCNT_inc(cv);
list->next = NULL;
return list;
}
STATIC void method_lexical_data_list_free(pTHX_ void *vp) {
MethodLexicalDataList *list = (MethodLexicalDataList *)vp;
MethodLexicalDataList *temp;
while (list) {
temp = list->next;
SvREFCNT_dec(list->stash);
SvREFCNT_dec(list->method);
SvREFCNT_dec(list->cv);
Safefree(list);
list = temp;
}
}
/*
* TODO
*
* the method name may be qualified e.g.
*
* $self->Foo::Bar::baz($quux);
*
* in this case, we can turn it into a subroutine call:
*
* Foo::Bar::baz($self, $quux)
*
* XXX: Perl_ck_method does not turn fully-qualified names into OP_METHOD_NAMED
* XXX: Perl_ck_method does not normalize fully-qualified names i.e. need to s/'/::/g
*/
STATIC OP * method_lexical_check_method(pTHX_ OP * o, void * user_data) {
PERL_UNUSED_VAR(user_data);
/*
* Perl_ck_method can upgrade an OP_METHOD to an OP_METHOD_NAMED (perly.y
* channels all method calls through newUNOP(OP_METHOD)),
* so we need to assign the right method op_ppaddr, or bail if the OP's no
* longer a method (i.e. another module has changed it)
*/
if (o->op_type == OP_METHOD_NAMED) {
return method_lexical_check_method_static(aTHX_ o);
} else if (o->op_type == OP_METHOD) {
return method_lexical_check_method_dynamic(aTHX_ o);
}
return o;
}
STATIC OP * method_lexical_check_method_dynamic(pTHX_ OP * o) {
HV * table;
SV ** svp;
/* if there are bindings for the currently-compiling scope in $^H{METHOD_LEXICAL_INSTALLED} */
if (METHOD_LEXICAL_ENABLED(table, svp)) {
MethodLexicalData *data;
HV *installed = (HV *)SvRV(*svp);
/* FIXME autoload == TRUE is hardwired for dynamic lookups for now */
data = method_lexical_data_new(aTHX_ installed, TRUE, TRUE);
op_annotate(METHOD_LEXICAL_ANNOTATIONS, o, (void *)data, method_lexical_data_free);
o->op_ppaddr = method_lexical_method_dynamic;
}
return o;
}
STATIC OP * method_lexical_check_method_static(pTHX_ OP * o) {
HV * table;
SV ** svp;
/* if there are bindings for the currently-compiling scope in $^H{METHOD_LEXICAL_INSTALLED} */
if (METHOD_LEXICAL_ENABLED(table, svp)) {
STRLEN fqnamelen, namelen;
HE *entry;
HV *installed = (HV *)SvRV(*svp);
UV count = 0;
SV *method = cSVOPo->op_sv;
const char *fqname, *name = SvPV_const(method, namelen);
U32 autoload = FALSE;
hv_iterinit(installed);
while ((entry = hv_iternext(installed))) {
const char *rcolon;
fqname = HePV(entry, fqnamelen);
/*
* There are 2 options:
*
* 1) count == 0: the name isn't in the hash: don't change the op_ppaddr
* 2) count > 0: this *may* be a lexical method call - change the op_ppaddr
*/
rcolon = strrchr(fqname, ':');
/* WARN("comparing OP method (%*s) => fqname method (%s)", namelen, name, rcolon + 1); */
/* if (strnEQ(name, rcolon + 1, namelen)) */
if ((strnEQ(rcolon + 1, "AUTOLOAD", 8) && (autoload = TRUE)) || strnEQ(name, rcolon + 1, namelen)) {
++count;
}
}
if (count) {
MethodLexicalData *data;
data = method_lexical_data_new(aTHX_ installed, FALSE, autoload);
op_annotate(METHOD_LEXICAL_ANNOTATIONS, o, (void *)data, method_lexical_data_free);
o->op_ppaddr = method_lexical_method_static;
} /* else no lexical method of this name */
}
return o;
}
/*
* this handles:
*
* 1) $foo->$bar # $bar is a code ref
* 2) $foo->Bar::baz
* 3) $foo->SUPER::bar
* 4) $foo->$bar # $bar is a method name
*
* 1) is quick and easy to handle in all cases as the method CV we're supposed to look up
* has already been supplied
*
* 2) is syntactic sugar for:
*
* &Bar::baz($foo)
*
* perl always turns these into (or rather keeps them as) OP_METHOD rather than OP_METHOD_NAMED.
* ideally, we should rewrite these as static subroutine calls at compile-time in
* method_lexical_check_method, although that's strictly not the responsibility of this module.
* it could be done in another module (Method::Peep?), which we could use
* (it would need to hook PL_check[OP_METHOD] before us). As it currently stands, though, we can't
* determine the stash (Bar) containing the CV (baz) from the invocant ($foo); we need to extract it from
* the method name. So we hand the method name off to method_lexical_get_fqname_stash.
*
* 3) is like 2) but complicated by the peculiar semantics [1] of the SUPER pseudo-package,
* which is handled by method_lexical_get_fqname_stash.
*
* 4) is like a static method call (i.e. we can get the stash from the invocant), but
* we don't know that till we've looked at what's in $bar. Again, method_lexical_get_fqname_stash
* handles this, and delegates to method_lexical_get_invocant_stash if the method name is "simple",
* i.e. not qualified (no double colons or single quotes)
*
* So: 1) is trivial; 2) could be optimized away at compile-time; 3) is a pain that we have
* to deal with (we can't resolve it at compile time, because even though SUPER refers to the
* superclass of the package the SUPER call is compiled in (rather than the invocant's superclass),
* that package's superclass(es) can still be changed at runtime; 4) requires us to scan the string,
* so we may as well handle 2) (for now), and 3) while we're at it.
*
* On the plus side, none of these idioms are especially common. The bareword unqualified method name
* is the common case.
*
* [1] http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00809.html
*/
STATIC OP * method_lexical_method_dynamic(pTHX) {
dSP;
SV * cv;
SV * method_sv = TOPs;
if (SvROK(method_sv) && (cv = SvRV(method_sv)) && (SvTYPE(cv) == SVt_PVCV)) {
SETs(cv);
RETURN;
} else {
char *class_name;
const OPAnnotation * annotation = op_annotation_get(METHOD_LEXICAL_ANNOTATIONS, PL_op);
const HV * const stash = method_lexical_get_fqname_stash(aTHX_ &method_sv, &class_name);
if (stash) {
U32 found;
MethodLexicalData * data;
data = (MethodLexicalData *)annotation->data;
cv = method_lexical_cache_fetch(aTHX_ data, stash, method_sv, &found);
if (!found) {
/* look it up the slow way - caches the result (which may be NULL) */
cv = method_lexical_method_common(aTHX_ data, stash, class_name, method_sv);
}
if (cv) {
SETs(cv);
RETURN;
} /* else cached, but NULL i.e. not a lexical method - fall through */
} /* some weird invocant without a stash: fall through and let perl deal with it */
return annotation->op_ppaddr(aTHX);
}
}
STATIC OP *method_lexical_method_static(pTHX) {
dSP;
char *class_name;
const OPAnnotation * const annotation = op_annotation_get(METHOD_LEXICAL_ANNOTATIONS, PL_op);
SV * const invocant = *(PL_stack_base + TOPMARK + 1);
const HV * const stash = method_lexical_get_invocant_stash(aTHX_ invocant, &class_name);
if (stash) {
U32 found;
const SV * const method = cSVOP_sv;
MethodLexicalData * const data = (MethodLexicalData *)annotation->data;
SV *cv = method_lexical_cache_fetch(aTHX_ data, stash, method, &found);
if (!found) {
/* look it up the slow way - caches the result (which may be NULL) */
cv = method_lexical_method_common(aTHX_ data, stash, class_name, method);
}
if (cv) {
XPUSHs(cv);
RETURN;
} /* else cached, but NULL i.e. not a lexical method - fall through */
} /* some weird invocant without a stash: fall through and let perl deal with it */
return annotation->op_ppaddr(aTHX);
}
STATIC SV * method_lexical_method_common(
pTHX_
MethodLexicalData * const data,
const HV * const stash,
const char * const class_name,
const SV * const method
) {
const char * name;
HV * const installed = data->hv;
CV *cv;
U32 generation;
STRLEN namelen;
name = SvPV((SV *)method, namelen); /* temporarily cast off constness */
cv = method_lexical_lookup_method(aTHX_ stash, installed, class_name, name, &generation);
if (!cv && data->autoload) {
const GV * gv;
generation = mro_get_pkg_gen(stash);
if (METHOD_LEXICAL_DEBUG) {
warn("Method::Lexical: looking up: %s::%s (public)", class_name, name);
}
gv = gv_fetchmethod((HV *)stash, name); /* temporarily cast off constness */
if (gv) {
if (METHOD_LEXICAL_DEBUG) {
warn("Method::Lexical: found: %s::%s (public)", class_name, name);
}
cv = isGV(gv) ? GvCV(gv) : (CV *)gv;
} else {
cv = method_lexical_lookup_method(aTHX_ stash, installed, class_name, "AUTOLOAD", NULL);
if (cv) {
method_lexical_set_autoload(aTHX_ stash, class_name, method, cv);
}
}
}
method_lexical_cache_store(aTHX_ data, stash, generation, method, cv);
return (SV *)cv;
}
STATIC CV * method_lexical_lookup_method(
pTHX_
const HV * const stash,
const HV * const installed,
const char * const class_name,
const char * const name,
U32 *generation_ptr
) {
const SV *key;
CV *cv;
key = sv_2mortal(newSVpvf("%s::%s", class_name, name));
cv = method_lexical_hash_get(aTHX_ installed, key);
if (cv) {
/*
* the installed hash ($^H{'Method::Lexical'}) can't be modified/countermanded
* after the fact, so its lookups can be cached without recourse to the same
* generational invalidation as "public" methods
*/
if (generation_ptr) {
*generation_ptr = 0;
}
} else { /* try superclasses */
U32 items;
SV ** svp;
const AV *isa;
if (generation_ptr) {
*generation_ptr = mro_get_pkg_gen(stash);
}
isa = mro_get_linear_isa((HV *)stash); /* temporarily cast off constness */
items = AvFILLp(isa) + 1; /* add 1 (even though we're skipping self) to include the appended "UNIVERSAL" */
svp = AvARRAY(isa) + 1; /* skip self */
while (items--) { /* always entered, if only for "UNIVERSAL" */
SV *class_name_sv;
if (items == 0) {
class_name_sv = sv_2mortal(newSVpvn("UNIVERSAL", 9));
} else {
class_name_sv = *svp++;
}
key = sv_2mortal(newSVpvf("%s::%s", SvPVX(class_name_sv), name));
cv = method_lexical_hash_get(aTHX_ installed, key);
if (cv) {
break;
}
}
}
return cv;
}
STATIC void method_lexical_set_autoload(
pTHX_
const HV * const stash,
const char * const class_name,
const SV *method,
CV * cv
) {
#ifndef CvISXSUB
# define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE)
#endif
assert(CvROOT(cv) || CvISXSUB(cv));
/* <copypasta file="gv.c" function="gv_autoload4"> */
#ifndef USE_5005THREADS /* chocolateboy: shouldn't be defined after 5.8.x */
if (CvISXSUB(cv)) {
/* rather than lookup/init $AUTOLOAD here
* only to have the XSUB do another lookup for $AUTOLOAD
* and split that value on the last '::',
* pass along the same data via some unused fields in the CV
*/
/* chocolateboy 2011-03-13: portability fix for perl 5.13 */
#ifdef CvSTASH_set
CvSTASH_set(cv, (HV *)stash); /* temporarily cast off constness */
#else
CvSTASH(cv) = (HV *)stash; /* temporarily cast off constness */
#endif
SvPV_set(cv, (char *)SvPVX(method)); /* cast to lose constness warning */
SvCUR_set(cv, SvCUR(method));
return;
} else
#endif
{
HV* varstash;
GV* vargv;
SV* varsv;
/*
* Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
* The subroutine's original name may not be "AUTOLOAD", so we don't
* use that, but for lack of anything better we will use the sub's
* original package to look up $AUTOLOAD.
*/
varstash = GvSTASH(CvGV(cv));
vargv = *(GV**)hv_fetch(varstash, "AUTOLOAD", 8, TRUE);
ENTER;
#ifdef USE_5005THREADS /* chocolateboy: shouldn't be defined after 5.8.x */
sv_lock((SV *)varstash);
#endif
if (!isGV(vargv)) {
gv_init(vargv, varstash, "AUTOLOAD", 8, FALSE);
#ifdef PERL_DONT_CREATE_GVSV
GvSV(vargv) = newSV(0);
#endif
}
LEAVE;
#ifndef GvSVn
# ifdef PERL_DONT_CREATE_GVSV
# define GvSVn(gv) (*(GvGP(gv)->gp_sv ? &(GvGP(gv)->gp_sv) : &(GvGP(gv_SVadd(gv))->gp_sv)))
# else
# define GvSVn(gv) GvSV(gv)
# endif
#endif
varsv = GvSVn(vargv);
#ifdef USE_5005THREADS /* chocolateboy: shouldn't be defined after 5.8.x */
sv_lock(varsv);
#endif
sv_setpv(varsv, class_name);
sv_catpvs(varsv, "::");
/* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */
sv_catpv_mg(varsv, SvPVX(method));
}
/* </copypasta> */
}
STATIC HV *method_lexical_get_invocant_stash(pTHX_ SV * const invocant, char **class_name_ptr) {
HV *stash = NULL;
char *class_name = NULL;
STRLEN packlen;
SvGETMAGIC(invocant);
if (!(invocant && SvOK(invocant))) {
goto done;
}
if (SvROK(invocant)) {
if (SvOBJECT(SvRV(invocant))) { /* blessed reference */
#ifdef HvNAME_HEK
HEK *hek;
if (
(stash = SvSTASH(SvRV(invocant))) &&
(hek = HvNAME_HEK(stash)) &&
(class_name = HEK_KEY(hek))
) {
goto done;
}
#else
if (
((stash = SvSTASH(SvRV(invocant)))) &&
(class_name = HvNAME(stash))
) {
goto done;
}
#endif
} /* unblessed reference */
} else if ((class_name = SvPV(invocant, packlen))) { /* not a reference: try package name */
const HE *const he = hv_fetch_ent(PL_stashcache, invocant, 0, 0);
if (he) {
stash = INT2PTR(HV *, SvIV(HeVAL(he)));
} else if ((stash = gv_stashpvn(class_name, packlen, 0))) {
SV *const sref = newSViv(PTR2IV(stash));
(void)hv_store(PL_stashcache, class_name, packlen, sref, 0);
} /* can't find a stash */
}
done:
if (class_name_ptr) {
*class_name_ptr = class_name;
}
return stash;
}
STATIC HV * method_lexical_get_super_stash(pTHX_ const char * const class_name, char **class_name_ptr) {
SV * const invocant = sv_2mortal(newSVpv(class_name, 0));
HV * stash = method_lexical_get_invocant_stash(aTHX_ invocant, NULL);
if (stash) {
AV * const isa = mro_get_linear_isa((HV *)stash); /* temporarily cast off constness */
/* AvFILL is $#ARRAY i.e. -1 if the array is empty, so > 0 means two or more */
if (isa && ((AvFILL(isa)) > 0)) { /* at least two items: self and the superclass */
SV * const * const svp = AvARRAY(isa) + 1; /* skip self */
if (svp && *svp) {
assert(SvOK(*svp));
return method_lexical_get_invocant_stash(aTHX_ *svp, class_name_ptr);
}
}
}
return stash;
}
STATIC HV * method_lexical_get_fqname_stash(pTHX_ SV **method_sv_ptr, char **class_name_ptr) {
HV * stash = NULL;
const char * fqname;
STRLEN len, last, i, offset = 0; /* XXX bugfix: make sure offset is initialized to 0 */
SV * invocant_sv, *normalized_sv = NULL, *fqmethod_sv = *method_sv_ptr;
fqname = SvPV(fqmethod_sv, len);
last = len - 1;
/*
* kill two birds with one scan:
*
* 1) normalized_sv: normalize the fully-qualified name if it contains '\'' i.e. s/'/::/g
* 2) offset: find the offset (in fqname) of the start of the unqualified method name i.e.
* the offset of "baz" in "Foo::Bar::baz"
*/
for (i = 0; i < last; ++i) {
if ((fqname[i] == ':') && (fqname[i + 1] == ':')) {
offset = i + 2;
++i; /* in conjunction with the ++i above, this skips both colons */
} else if (fqname[i] == '\'') {
STRLEN j;
normalized_sv = sv_2mortal(newSVpv(fqname, i));
sv_catpvs(normalized_sv, "::");
offset = i + 1;
/*
* with
*
* Foo'b
*
* we need to append 'b' to normalized_sv, so j must range
* up to len - 1 (in this case: 4) rather than i's upper bound (above), which
* only ranges up to len - 2 (e.g. 3). In the case above, we're not copying characters,
* and so can use a reduced upper bound to remove a bounds check. In this case we
* are copying, and thus need to scan to the end and include the bounds check.
*/
for (j = offset; j < len; ++j) {
if (fqname[j] == '\'') {
sv_catpvs(normalized_sv, "::");
offset = j + 1;
} else if ((fqname[j] == ':') && (j < last) && (fqname[j + 1] == ':')) {
sv_catpvs(normalized_sv, "::");
offset = j + 2;
++j; /* in conjunction with the ++j above, this skips both colons */
} else {
sv_catpvn(normalized_sv, fqname + j, 1);
}
}
break;
}
}
if (offset) {
/*
* offset might be out of bounds if the name is mangled, which shouldn't happen
* for a static name, but e.g.
*
* my $name = "foo'";
* $self->$name();
*
* so check that the offset (4 in this case) is sane
*/
if (offset == len) {
goto done;
} else {
STRLEN method_len = len - offset;
char *class_name;
STRLEN class_name_len;
if (normalized_sv) {
fqmethod_sv = normalized_sv;
}
*method_sv_ptr = sv_2mortal(newSVpvn(fqname + offset, len - offset));
invocant_sv = sv_2mortal(newSVpvn(SvPVX(fqmethod_sv), SvCUR(fqmethod_sv) - (method_len + 2)));
class_name = SvPV(invocant_sv, class_name_len);
/*
* we need to intercept SUPER before perl gets its hands on the method name
* (in method_lexical_get_invocant_stash) because perl handles SUPER differently,
* autovivifying stashes with a ::SUPER suffix - e.g. %Foo::SUPER:: - to create @Foo::SUPER::ISA
* (see gv_get_super_pkg in gv.c). This causes lookups to succeed when we want them to fail (so that
* we can fall back to perl).
*
* if valid, the class name either a) is "SUPER", b) ends with "::SUPER",
* or c) doesn't contain "SUPER"
*
* if b), make sure it's prefixed with at least one character
*/
if (strnEQ(class_name, "SUPER", 5)) {
assert(CopSTASHPV(PL_curcop)); /* FIXME - CopSTASHPV can be NULL */
return method_lexical_get_super_stash(aTHX_ CopSTASHPV(PL_curcop), class_name_ptr);
} else if ((class_name_len > 7) && strnEQ(class_name + (class_name_len - 7), "::SUPER", 7)) {
class_name[(class_name_len - 7)] = '\0';
return method_lexical_get_super_stash(aTHX_ class_name, class_name_ptr);
}
}
}
/* unqualified method name: don't change the method SV */
invocant_sv = *(PL_stack_base + TOPMARK + 1);
stash = method_lexical_get_invocant_stash(aTHX_ invocant_sv, class_name_ptr);
done:
return stash;
}
STATIC void method_lexical_cache_store(
pTHX_
MethodLexicalData * const data,
const HV * const stash,
const U32 generation,
const SV * const method,
const CV * const cv
) {
MethodLexicalDataList *list;
list = method_lexical_data_list_new(aTHX_ stash, generation, method, cv);
if (data->list) {
list->next = data->list;
}
data->list = list;
}
STATIC void method_lexical_cache_remove(
pTHX_
MethodLexicalData * const data,
MethodLexicalDataList *prev,
MethodLexicalDataList *head
) {
if (prev) { /* not first */
prev->next = head->next;
} else if (head->next) { /* first */
data->list = head->next;
} else { /* only */
data->list = NULL;
}
head->next = NULL;
method_lexical_data_list_free(aTHX_ head);
}
STATIC SV *method_lexical_cache_fetch(
pTHX_
MethodLexicalData *data,
const HV * const stash,
const SV * const method,
U32 * const found
) {
const CV *cv = NULL;
U32 generation = 0;
*found = FALSE;
if (data->list) {
MethodLexicalDataList *head, *prev = NULL;
for (head = data->list; head; prev = head, head = head->next) {
if ((stash == head->stash) &&
(!data->dynamic || sv_eq((SV *)method, (SV *)head->method))) { /* cast off constness */
if (head->generation) {
if (!generation) {
generation = mro_get_pkg_gen(stash);
}
/* fresh: cv may be NULL, indicating (still) not found */
if (head->generation == generation) {
cv = head->cv;
*found = TRUE;
break;
} else { /* stale: remove from list */
method_lexical_cache_remove(aTHX_ data, prev, head);
break;
}
} else {
cv = head->cv;
*found = TRUE;
break;
}
}
}
}
return (SV *)cv;
}
STATIC CV *method_lexical_hash_get(pTHX_ const HV * const hv, const SV * const key) {
HE *he;
if (METHOD_LEXICAL_DEBUG) {
warn("Method::Lexical: looking up: %s (private)", SvPVX(key));
}
he = hv_fetch_ent((HV *)hv, (SV *)key, FALSE, 0); /* don't create an undef value if it doesn't exist */
if (he) {
const SV * const rv = HeVAL(he);
if (METHOD_LEXICAL_DEBUG) {
warn("Method::Lexical: found: %s (private)", SvPVX(key));
}
return (CV *)SvRV(rv);
}
return NULL;
}
STATIC void method_lexical_enter() {
if (METHOD_LEXICAL_COMPILING != 0) {
croak("Method::Lexical: scope overflow");
} else {
METHOD_LEXICAL_COMPILING = 1;
method_lexical_check_method_id = hook_op_check(OP_METHOD, method_lexical_check_method, NULL);
}
}
STATIC void method_lexical_leave() {
if (METHOD_LEXICAL_COMPILING != 1) {
croak("Method::Lexical: scope underflow");
} else {
METHOD_LEXICAL_COMPILING = 0;
hook_op_check_remove(OP_METHOD, method_lexical_check_method_id);
}
}
MODULE = Method::Lexical PACKAGE = Method::Lexical
BOOT:
if (PerlEnv_getenv("METHOD_LEXICAL_DEBUG")) {
METHOD_LEXICAL_DEBUG = 1;
}
METHOD_LEXICAL_ANNOTATIONS = op_annotation_group_new();
void
END()
CODE:
if (METHOD_LEXICAL_ANNOTATIONS) { /* make sure it was initialised */
op_annotation_group_free(aTHX_ METHOD_LEXICAL_ANNOTATIONS);
}
SV *
xs_get_debug()
PROTOTYPE:
CODE:
RETVAL = newSViv(METHOD_LEXICAL_DEBUG);
OUTPUT:
RETVAL
void
xs_set_debug(SV * dbg)
PROTOTYPE:$
CODE:
METHOD_LEXICAL_DEBUG = SvIV(dbg);
char *
xs_signature()
PROTOTYPE:
CODE:
RETVAL = METHOD_LEXICAL_INSTALLED;
OUTPUT:
RETVAL
void
xs_enter()
PROTOTYPE:
CODE:
method_lexical_enter();
void
xs_leave()
PROTOTYPE:
CODE:
method_lexical_leave();