bool Stash::can(Raw_string name) const {
if (stash) {
GV* gv = gv_fetchmeth_autoload(stash, name.value, name.length, -1);
return gv && isGV(gv) && CvGV(gv);
}
return false;
}
GV *
Perl_gv_fetchfile(pTHX_ const char *name)
{
char smallbuf[256];
char *tmpbuf;
STRLEN tmplen;
GV *gv;
if (!PL_defstash)
return Nullgv;
tmplen = strlen(name) + 2;
if (tmplen < sizeof smallbuf)
tmpbuf = smallbuf;
else
New(603, tmpbuf, tmplen + 1, char);
tmpbuf[0] = '_';
tmpbuf[1] = '<';
strcpy(tmpbuf + 2, name);
gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
if (!isGV(gv)) {
gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
sv_setpv(GvSV(gv), name);
if (PERLDB_LINE)
hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, 'L');
}
if (tmpbuf != smallbuf)
Safefree(tmpbuf);
return gv;
}
/* helper to return the stash for a svref, (Sv|Cv|Gv|GvE)STASH */
static HV*
S_guess_stash(pTHX_ SV* sv)
{
if (SvOBJECT(sv)) {
return SvSTASH(sv);
}
else {
HV *stash = NULL;
switch (SvTYPE(sv)) {
case SVt_PVCV:
if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
return GvSTASH(CvGV(sv));
else if (/* !CvANON(sv) && */ CvSTASH(sv))
return CvSTASH(sv);
break;
case SVt_PVGV:
if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
return GvESTASH(MUTABLE_GV(sv));
break;
default:
break;
}
return stash;
}
}
const Ref<Code>::Temp Stash::get_method(Raw_string name) const {
GV* const glob = gv_fetchmeth_autoload(stash, name.value, name.length, -1);
if (glob == NULL || !isGV(glob) || CvGV(glob) == NULL) {
throw Runtime_exception("method doesn't exist");//TODO No such method exception??
}
CV* const codeval = GvCV(glob);
return Code::Value(interp, codeval).take_ref();
}
GV *p5_look_up_method(PerlInterpreter *my_perl, SV *obj, char *name) {
PERL_SET_CONTEXT(my_perl);
{
HV * const pkg = SvSTASH((SV*)SvRV(obj));
GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
if (gv && isGV(gv))
return gv;
return NULL;
}
}
GV *p5_look_up_package_method(PerlInterpreter *my_perl, char *module, char *name) {
PERL_SET_CONTEXT(my_perl);
{
HV * const pkg = gv_stashpvn(module, strlen(module), 0);
GV * const gv = gv_fetchmeth_pvn(pkg, name, strlen(name), -1, SVf_UTF8);
if (gv && isGV(gv))
return gv;
return NULL;
}
}
GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
char autoload[] = "AUTOLOAD";
STRLEN autolen = sizeof(autoload)-1;
GV* gv;
CV* cv;
HV* varstash;
GV* vargv;
SV* varsv;
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
if (!CvROOT(cv))
return Nullgv;
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
if (ckWARN(WARN_DEPRECATED) && !method &&
(GvCVGEN(gv) || GvSTASH(gv) != stash))
Perl_warner(aTHX_ WARN_DEPRECATED,
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
HvNAME(stash), (int)len, name);
/*
* 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, autolen, TRUE);
ENTER;
#ifdef USE_THREADS
sv_lock((SV *)varstash);
#endif
if (!isGV(vargv))
gv_init(vargv, varstash, autoload, autolen, FALSE);
LEAVE;
varsv = GvSV(vargv);
#ifdef USE_THREADS
sv_lock(varsv);
#endif
sv_setpv(varsv, HvNAME(stash));
sv_catpvn(varsv, "::", 2);
sv_catpvn(varsv, name, len);
SvTAINTED_off(varsv);
return gv;
}
void
mop_get_package_symbols (HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud)
{
HE *he;
(void)hv_iterinit(stash);
if (filter == TYPE_FILTER_NONE) {
while ( (he = hv_iternext(stash)) ) {
STRLEN keylen;
const char *key = HePV(he, keylen);
if (!cb(key, keylen, HeVAL(he), ud)) {
return;
}
}
return;
}
while ( (he = hv_iternext(stash)) ) {
GV * const gv = (GV*)HeVAL(he);
STRLEN keylen;
const char * const key = HePV(he, keylen);
SV *sv = NULL;
if(isGV(gv)){
switch (filter) {
case TYPE_FILTER_CODE: sv = (SV *)GvCVu(gv); break;
case TYPE_FILTER_ARRAY: sv = (SV *)GvAV(gv); break;
case TYPE_FILTER_IO: sv = (SV *)GvIO(gv); break;
case TYPE_FILTER_HASH: sv = (SV *)GvHV(gv); break;
case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv); break;
default:
croak("Unknown type");
}
}
/* expand the gv into a real typeglob if it
* contains stub functions or constants and we
* were asked to return CODE references */
else if (filter == TYPE_FILTER_CODE) {
gv_init(gv, stash, key, keylen, GV_ADDMULTI);
sv = (SV *)GvCV(gv);
}
if (sv) {
if (!cb(key, keylen, sv, ud)) {
return;
}
}
}
}
SV *p5_call_parent_method(PerlInterpreter *my_perl, char *package, SV *obj, I32 context, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
int i;
SV * retval = NULL;
int flags = (context ? G_SCALAR : G_ARRAY) | G_EVAL;
ENTER;
SAVETMPS;
HV * const pkg = package != NULL ? gv_stashpv(package, 0) : SvSTASH((SV*)SvRV(obj));
GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
if (gv && isGV(gv)) {
PUSHMARK(SP);
if (len > 1) {
XPUSHs(package != NULL ? sv_2mortal(args[0]) : args[0]);
for (i = 1; i < len; i++) {
if (args[i] != NULL) /* skip Nil which gets turned into NULL */
XPUSHs(sv_2mortal(args[i]));
}
}
else if (len > 0)
if (args != NULL) /* skip Nil which gets turned into NULL */
XPUSHs(package != NULL ? sv_2mortal((SV*)args) : (SV*)args);
PUTBACK;
SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
*count = call_sv(rv, flags);
SPAGAIN;
handle_p5_error(err);
retval = pop_return_values(my_perl, sp, *count, type);
SPAGAIN;
}
else {
ERRSV = newSVpvf("Could not find method \"%s\" of \"%s\" object", name, HvNAME(pkg));
}
PUTBACK;
FREETMPS;
LEAVE;
return retval;
}
}
AV *p5_call_method(PerlInterpreter *my_perl, char *package, SV *obj, char *name, int len, SV *args[]) {
dSP;
int i;
AV * const retval = newAV();
int flags = G_ARRAY | G_EVAL;
PERL_SET_CONTEXT(my_perl);
ENTER;
SAVETMPS;
HV * const pkg = package != NULL ? gv_stashpv(package, 0) : SvSTASH((SV*)SvRV(obj));
GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
if (gv && isGV(gv)) {
I32 count;
PUSHMARK(SP);
for (i = 0; i < len; i++) {
XPUSHs(sv_2mortal(args[i]));
}
PUTBACK;
SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
count = call_sv(rv, flags);
SPAGAIN;
if (count > 0)
av_extend(retval, count - 1);
for (i = count - 1; i >= 0; i--) {
SV * const next = POPs;
SvREFCNT_inc(next);
if (av_store(retval, i, next) == NULL)
SvREFCNT_dec(next); /* see perlguts Working with AVs */
}
}
else {
ERRSV = newSVpvf("Could not find method \"%s\" of \"%s\" object", name, HvNAME(pkg));
}
PUTBACK;
FREETMPS;
LEAVE;
return retval;
}
GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
char autoload[] = "AUTOLOAD";
STRLEN autolen = sizeof(autoload)-1;
GV* gv;
CV* cv;
HV* varstash;
GV* vargv;
SV* varsv;
char *packname = "";
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
if (stash) {
if (SvTYPE(stash) < SVt_PVHV) {
packname = SvPV_nolen((SV*)stash);
stash = Nullhv;
}
else {
packname = HvNAME(stash);
}
}
if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
if (!(CvROOT(cv) || CvXSUB(cv)))
return Nullgv;
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
(GvCVGEN(gv) || GvSTASH(gv) != stash))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
packname, (int)len, name);
if (CvXSUB(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
*/
CvSTASH(cv) = stash;
SvPVX(cv) = (char *)name; /* cast to lose constness warning */
SvCUR(cv) = len;
return gv;
}
/*
* 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, autolen, TRUE);
ENTER;
if (!isGV(vargv))
gv_init(vargv, varstash, autoload, autolen, FALSE);
LEAVE;
varsv = GvSV(vargv);
sv_setpv(varsv, packname);
sv_catpvn(varsv, "::", 2);
sv_catpvn(varsv, name, len);
SvTAINTED_off(varsv);
return gv;
}
/****************************
* SV* Py2Pl(PyObject *obj)
*
* Converts arbitrary Python data structures to Perl data structures
* Note on references: does not Py_DECREF(obj).
*
* Modifications by Eric Wilhelm 2004-07-11 marked as elw
*
****************************/
SV *Py2Pl(PyObject * const obj) {
/* elw: see what python says things are */
#if PY_MAJOR_VERSION >= 3
int const is_string = PyBytes_Check(obj) || PyUnicode_Check(obj);
#else
int const is_string = PyString_Check(obj) || PyUnicode_Check(obj);
#endif
#ifdef I_PY_DEBUG
PyObject *this_type = PyObject_Type(obj); /* new reference */
PyObject *t_string = PyObject_Str(this_type); /* new reference */
#if PY_MAJOR_VERSION >= 3
PyObject *type_str_bytes = PyUnicode_AsUTF8String(t_string); /* new reference */
char *type_str = PyBytes_AsString(type_str_bytes);
#else
char *type_str = PyString_AsString(t_string);
#endif
Printf(("type is %s\n", type_str));
printf("Py2Pl object:\n\t");
PyObject_Print(obj, stdout, Py_PRINT_RAW);
printf("\ntype:\n\t");
PyObject_Print(this_type, stdout, Py_PRINT_RAW);
printf("\n");
Printf(("String check: %i\n", is_string));
Printf(("Number check: %i\n", PyNumber_Check(obj)));
Printf(("Int check: %i\n", PyInt_Check(obj)));
Printf(("Long check: %i\n", PyLong_Check(obj)));
Printf(("Float check: %i\n", PyFloat_Check(obj)));
Printf(("Type check: %i\n", PyType_Check(obj)));
#if PY_MAJOR_VERSION < 3
Printf(("Class check: %i\n", PyClass_Check(obj)));
Printf(("Instance check: %i\n", PyInstance_Check(obj)));
#endif
Printf(("Dict check: %i\n", PyDict_Check(obj)));
Printf(("Mapping check: %i\n", PyMapping_Check(obj)));
Printf(("Sequence check: %i\n", PySequence_Check(obj)));
Printf(("Iter check: %i\n", PyIter_Check(obj)));
Printf(("Function check: %i\n", PyFunction_Check(obj)));
Printf(("Module check: %i\n", PyModule_Check(obj)));
Printf(("Method check: %i\n", PyMethod_Check(obj)));
#if PY_MAJOR_VERSION < 3
if ((obj->ob_type->tp_flags & Py_TPFLAGS_HEAPTYPE))
printf("heaptype true\n");
if ((obj->ob_type->tp_flags & Py_TPFLAGS_HAVE_CLASS))
printf("has class\n");
#else
Py_DECREF(type_str_bytes);
#endif
Py_DECREF(t_string);
Py_DECREF(this_type);
#endif
/* elw: this needs to be early */
/* None (like undef) */
if (!obj || obj == Py_None) {
Printf(("Py2Pl: Py_None\n"));
return &PL_sv_undef;
}
else
#ifdef EXPOSE_PERL
/* unwrap Perl objects */
if (PerlObjObject_Check(obj)) {
Printf(("Py2Pl: Obj_object\n"));
return ((PerlObj_object *) obj)->obj;
}
/* unwrap Perl code refs */
else if (PerlSubObject_Check(obj)) {
Printf(("Py2Pl: Sub_object\n"));
SV * ref = ((PerlSub_object *) obj)->ref;
if (! ref) { /* probably an inherited method */
if (! ((PerlSub_object *) obj)->obj)
croak("Error: could not find a code reference or object method for PerlSub");
SV * const sub_obj = (SV*)SvRV(((PerlSub_object *) obj)->obj);
HV * const pkg = SvSTASH(sub_obj);
#if PY_MAJOR_VERSION >= 3
char * const sub = PyBytes_AsString(((PerlSub_object *) obj)->sub);
#else
PyObject *obj_sub_str = PyObject_Str(((PerlSub_object *) obj)->sub); /* new ref. */
char * const sub = PyString_AsString(obj_sub_str);
#endif
GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, sub, TRUE);
if (gv && isGV(gv)) {
ref = (SV *)GvCV(gv);
}
#if PY_MAJOR_VERSION < 3
Py_DECREF(obj_sub_str);
#endif
}
return newRV_inc((SV *) ref);
}
else
#endif
/* wrap an instance of a Python class */
/* elw: here we need to make these look like instances: */
if ((obj->ob_type->tp_flags & Py_TPFLAGS_HEAPTYPE)
#if PY_MAJOR_VERSION < 3
|| PyInstance_Check(obj)
#endif
) {
/* This is a Python class instance -- bless it into an
* Inline::Python::Object. If we're being called from an
* Inline::Python class, it will be re-blessed into whatever
* class that is.
*/
SV * const inst_ptr = newSViv(0);
SV * const inst = newSVrv(inst_ptr, "Inline::Python::Object");;
_inline_magic priv;
/* set up magic */
priv.key = INLINE_MAGIC_KEY;
sv_magic(inst, inst, PERL_MAGIC_ext, (char *) &priv, sizeof(priv));
MAGIC * const mg = mg_find(inst, PERL_MAGIC_ext);
mg->mg_virtual = &inline_mg_vtbl;
sv_setiv(inst, (IV) obj);
/*SvREADONLY_on(inst); */ /* to uncomment this means I can't
re-bless it */
Py_INCREF(obj);
Printf(("Py2Pl: Instance. Obj: %p, inst_ptr: %p\n", obj, inst_ptr));
sv_2mortal(inst_ptr);
return inst_ptr;
}
/* a tuple or a list */
else if (PySequence_Check(obj) && !is_string) {
AV * const retval = newAV();
int i;
int const sz = PySequence_Length(obj);
Printf(("sequence (%i)\n", sz));
for (i = 0; i < sz; i++) {
PyObject * const tmp = PySequence_GetItem(obj, i); /* new reference */
SV * const next = Py2Pl(tmp);
av_push(retval, next);
if (sv_isobject(next)) // needed because objects get mortalized in Py2Pl
SvREFCNT_inc(next);
Py_DECREF(tmp);
}
if (PyTuple_Check(obj)) {
_inline_magic priv;
priv.key = TUPLE_MAGIC_KEY;
sv_magic((SV * const)retval, (SV * const)NULL, PERL_MAGIC_ext, (char *) &priv, sizeof(priv));
}
return newRV_noinc((SV *) retval);
}
/* a dictionary or fake Mapping object */
/* elw: PyMapping_Check() now returns true for strings */
else if (! is_string && PyMapping_Check(obj)) {
HV * const retval = newHV();
int i;
int const sz = PyMapping_Length(obj);
PyObject * const keys = PyMapping_Keys(obj); /* new reference */
PyObject * const vals = PyMapping_Values(obj); /* new reference */
Printf(("Py2Pl: dict/map\n"));
Printf(("mapping (%i)\n", sz));
for (i = 0; i < sz; i++) {
PyObject * const key = PySequence_GetItem(keys, i), /* new reference */
* const val = PySequence_GetItem(vals, i); /* new reference */
SV * const sv_val = Py2Pl(val);
char * key_val;
if (PyUnicode_Check(key)) {
PyObject * const utf8_string = PyUnicode_AsUTF8String(key); /* new reference */
#if PY_MAJOR_VERSION >= 3
key_val = PyBytes_AsString(utf8_string);
SV * const utf8_key = newSVpv(key_val, PyBytes_Size(utf8_string));
#else
key_val = PyString_AsString(utf8_string);
SV * const utf8_key = newSVpv(key_val, PyString_Size(utf8_string));
#endif
SvUTF8_on(utf8_key);
hv_store_ent(retval, utf8_key, sv_val, 0);
Py_DECREF(utf8_string);
}
else {
PyObject * s = NULL;
#if PY_MAJOR_VERSION >= 3
PyObject * s_bytes = NULL;
if (PyBytes_Check(key)) {
key_val = PyBytes_AsString(key);
#else
if (PyString_Check(key)) {
key_val = PyString_AsString(key);
#endif
}
else {
/* Warning -- encountered a non-string key value while converting a
* Python dictionary into a Perl hash. Perl can only use strings as
* key values. Using Python's string representation of the key as
* Perl's key value.
*/
s = PyObject_Str(key); /* new reference */
#if PY_MAJOR_VERSION >= 3
s_bytes = PyUnicode_AsUTF8String(s); /* new reference */
key_val = PyBytes_AsString(s_bytes);
#else
key_val = PyString_AsString(s);
#endif
Py_DECREF(s);
if (PL_dowarn)
warn("Stringifying non-string hash key value: '%s'",
key_val);
}
if (!key_val) {
croak("Invalid key on key %i of mapping\n", i);
}
hv_store(retval, key_val, strlen(key_val), sv_val, 0);
#if PY_MAJOR_VERSION >= 3
Py_XDECREF(s_bytes);
#endif
Py_XDECREF(s);
}
if (sv_isobject(sv_val)) // needed because objects get mortalized in Py2Pl
SvREFCNT_inc(sv_val);
Py_DECREF(key);
Py_DECREF(val);
}
Py_DECREF(keys);
Py_DECREF(vals);
return newRV_noinc((SV *) retval);
}
/* a boolean */
else if (PyBool_Check(obj)) {
STATIC void
S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
HV *stash, HV *oldstash, SV *namesv)
{
XPVHV* xhv;
HE *entry;
I32 riter = -1;
I32 items = 0;
const bool stash_had_name = stash && HvENAME(stash);
bool fetched_isarev = FALSE;
HV *seen = NULL;
HV *isarev = NULL;
SV **svp = NULL;
PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
/* We use the seen_stashes hash to keep track of which packages have
been encountered so far. This must be separate from the main list of
stashes, as we need to distinguish between stashes being assigned
and stashes being replaced/deleted. (A nested stash can be on both
sides of an assignment. We cannot simply skip iterating through a
stash on the right if we have seen it on the left, as it will not
get its ename assigned to it.)
To avoid allocating extra SVs, instead of a bitfield we can make
bizarre use of immortals:
&PL_sv_undef: seen on the left (oldstash)
&PL_sv_no : seen on the right (stash)
&PL_sv_yes : seen on both sides
*/
if(oldstash) {
/* Add to the big list. */
struct mro_meta * meta;
HE * const entry
= (HE *)
hv_common(
seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
);
if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
oldstash = NULL;
goto check_stash;
}
HeVAL(entry)
= HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
meta = HvMROMETA(oldstash);
(void)
hv_store(
stashes, (const char *)&oldstash, sizeof(HV *),
meta->isa
? SvREFCNT_inc_simple_NN((SV *)meta->isa)
: &PL_sv_yes,
0
);
CLEAR_LINEAR(meta);
/* Update the effective name. */
if(HvENAME_get(oldstash)) {
const HEK * const enamehek = HvENAME_HEK(oldstash);
if(SvTYPE(namesv) == SVt_PVAV) {
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
}
else {
items = 1;
svp = &namesv;
}
while (items--) {
const U32 name_utf8 = SvUTF8(*svp);
STRLEN len;
const char *name = SvPVx_const(*svp, len);
if(PL_stashcache) {
DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"SVf"'\n",
SVfARG(*svp)));
(void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
}
++svp;
hv_ename_delete(oldstash, name, len, name_utf8);
if (!fetched_isarev) {
/* If the name deletion caused a name change, then we
* are not going to call mro_isa_changed_in with this
* name (and not at all if it has become anonymous) so
* we need to delete old isarev entries here, both
* those in the superclasses and this class's own list
* of subclasses. We simply delete the latter from
* PL_isarev, since we still need it. hv_delete morti-
* fies it for us, so sv_2mortal is not necessary. */
if(HvENAME_HEK(oldstash) != enamehek) {
if(meta->isa && HvARRAY(meta->isa))
mro_clean_isarev(meta->isa, name, len, 0, 0,
name_utf8 ? HVhek_UTF8 : 0);
isarev = (HV *)hv_delete(PL_isarev, name,
name_utf8 ? -(I32)len : (I32)len, 0);
fetched_isarev=TRUE;
}
}
}
}
}
check_stash:
if(stash) {
if(SvTYPE(namesv) == SVt_PVAV) {
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
}
else {
items = 1;
svp = &namesv;
}
while (items--) {
const U32 name_utf8 = SvUTF8(*svp);
STRLEN len;
const char *name = SvPVx_const(*svp++, len);
hv_ename_add(stash, name, len, name_utf8);
}
/* Add it to the big list if it needs
* mro_isa_changed_in called on it. That happens if it was
* detached from the symbol table (so it had no HvENAME) before
* being assigned to the spot named by the 'name' variable, because
* its cached isa linearisation is now stale (the effective name
* having changed), and subclasses will then use that cache when
* mro_package_moved calls mro_isa_changed_in. (See
* [perl #77358].)
*
* If it did have a name, then its previous name is still
* used in isa caches, and there is no need for
* mro_package_moved to call mro_isa_changed_in.
*/
entry
= (HE *)
hv_common(
seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
);
if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
stash = NULL;
else {
HeVAL(entry)
= HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
if(!stash_had_name)
{
struct mro_meta * const meta = HvMROMETA(stash);
(void)
hv_store(
stashes, (const char *)&stash, sizeof(HV *),
meta->isa
? SvREFCNT_inc_simple_NN((SV *)meta->isa)
: &PL_sv_yes,
0
);
CLEAR_LINEAR(meta);
}
}
}
if(!stash && !oldstash)
/* Both stashes have been encountered already. */
return;
/* Add all the subclasses to the big list. */
if(!fetched_isarev) {
/* If oldstash is not null, then we can use its HvENAME to look up
the isarev hash, since all its subclasses will be listed there.
It will always have an HvENAME. It the HvENAME was removed
above, then fetch_isarev will be true, and this code will not be
reached.
If oldstash is null, then this is an empty spot with no stash in
it, so subclasses could be listed in isarev hashes belonging to
any of the names, so we have to check all of them.
*/
assert(!oldstash || HvENAME(oldstash));
if (oldstash) {
/* Extra variable to avoid a compiler warning */
const HEK * const hvename = HvENAME_HEK(oldstash);
fetched_isarev = TRUE;
svp = hv_fetchhek(PL_isarev, hvename, 0);
if (svp) isarev = MUTABLE_HV(*svp);
}
else if(SvTYPE(namesv) == SVt_PVAV) {
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
}
else {
items = 1;
svp = &namesv;
}
}
if(
isarev || !fetched_isarev
) {
while (fetched_isarev || items--) {
HE *iter;
if (!fetched_isarev) {
HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
}
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct mro_meta * meta;
if(!revstash) continue;
meta = HvMROMETA(revstash);
(void)
hv_store(
stashes, (const char *)&revstash, sizeof(HV *),
meta->isa
? SvREFCNT_inc_simple_NN((SV *)meta->isa)
: &PL_sv_yes,
0
);
CLEAR_LINEAR(meta);
}
if (fetched_isarev) break;
}
}
/* This is partly based on code in hv_iternext_flags. We are not call-
ing that here, as we want to avoid resetting the hash iterator. */
/* Skip the entire loop if the hash is empty. */
if(oldstash && HvUSEDKEYS(oldstash)) {
xhv = (XPVHV*)SvANY(oldstash);
seen = (HV *) sv_2mortal((SV *)newHV());
/* Iterate through entries in the oldstash, adding them to the
list, meanwhile doing the equivalent of $seen{$key} = 1.
*/
while (++riter <= (I32)xhv->xhv_max) {
entry = (HvARRAY(oldstash))[riter];
/* Iterate through the entries in this list */
for(; entry; entry = HeNEXT(entry)) {
const char* key;
I32 len;
/* If this entry is not a glob, ignore it.
Try the next. */
if (!isGV(HeVAL(entry))) continue;
key = hv_iterkey(entry, &len);
if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
|| (len == 1 && key[0] == ':')) {
HV * const oldsubstash = GvHV(HeVAL(entry));
SV ** const stashentry
= stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
HV *substash = NULL;
/* Avoid main::main::main::... */
if(oldsubstash == oldstash) continue;
if(
(
stashentry && *stashentry && isGV(*stashentry)
&& (substash = GvHV(*stashentry))
)
|| (oldsubstash && HvENAME_get(oldsubstash))
)
{
/* Add :: and the key (minus the trailing ::)
to each name. */
SV *subname;
if(SvTYPE(namesv) == SVt_PVAV) {
SV *aname;
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
subname = sv_2mortal((SV *)newAV());
while (items--) {
aname = newSVsv(*svp++);
if (len == 1)
sv_catpvs(aname, ":");
else {
sv_catpvs(aname, "::");
sv_catpvn_flags(
aname, key, len-2,
HeUTF8(entry)
? SV_CATUTF8 : SV_CATBYTES
);
}
av_push((AV *)subname, aname);
}
}
else {
subname = sv_2mortal(newSVsv(namesv));
if (len == 1) sv_catpvs(subname, ":");
else {
sv_catpvs(subname, "::");
sv_catpvn_flags(
subname, key, len-2,
HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
);
}
}
mro_gather_and_rename(
stashes, seen_stashes,
substash, oldsubstash, subname
);
}
(void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
}
}
}
}
/* Skip the entire loop if the hash is empty. */
if (stash && HvUSEDKEYS(stash)) {
xhv = (XPVHV*)SvANY(stash);
riter = -1;
/* Iterate through the new stash, skipping $seen{$key} items,
calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
while (++riter <= (I32)xhv->xhv_max) {
entry = (HvARRAY(stash))[riter];
/* Iterate through the entries in this list */
for(; entry; entry = HeNEXT(entry)) {
const char* key;
I32 len;
/* If this entry is not a glob, ignore it.
Try the next. */
if (!isGV(HeVAL(entry))) continue;
key = hv_iterkey(entry, &len);
if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
|| (len == 1 && key[0] == ':')) {
HV *substash;
/* If this entry was seen when we iterated through the
oldstash, skip it. */
if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;
/* We get here only if this stash has no corresponding
entry in the stash being replaced. */
substash = GvHV(HeVAL(entry));
if(substash) {
SV *subname;
/* Avoid checking main::main::main::... */
if(substash == stash) continue;
/* Add :: and the key (minus the trailing ::)
to each name. */
if(SvTYPE(namesv) == SVt_PVAV) {
SV *aname;
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
subname = sv_2mortal((SV *)newAV());
while (items--) {
aname = newSVsv(*svp++);
if (len == 1)
sv_catpvs(aname, ":");
else {
sv_catpvs(aname, "::");
sv_catpvn_flags(
aname, key, len-2,
HeUTF8(entry)
? SV_CATUTF8 : SV_CATBYTES
);
}
av_push((AV *)subname, aname);
}
}
else {
subname = sv_2mortal(newSVsv(namesv));
if (len == 1) sv_catpvs(subname, ":");
else {
sv_catpvs(subname, "::");
sv_catpvn_flags(
subname, key, len-2,
HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
);
}
}
mro_gather_and_rename(
stashes, seen_stashes,
substash, NULL, subname
);
}
}
}
}
}
}
