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; } }
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; }
/**************************** * 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)) {