1 /* vim: set expandtab shiftwidth=4 softtabstop=4 cinoptions='\:2=2': */
2 #ifdef __cplusplus
3 extern "C" {
4 #endif
5 #include "EXTERN.h"
6 #include "perl.h"
7 #include "XSUB.h"
8
9 #include "Python.h"
10 #include "util.h"
11 #ifdef __cplusplus
12 }
13 #endif
14
15 MGVTBL inline_mg_vtbl = {
16 0x0,
17 0x0,
18 0x0,
19 0x0,
20 &free_inline_py_obj,
21 0x0,
22 0x0,
23 0x0
24 };
25
26 /*************************************
27 * UTILITY FUNCTIONS *
28 *************************************/
29
free_inline_py_obj(pTHX_ SV * obj,MAGIC * mg)30 int free_inline_py_obj(pTHX_ SV* obj, MAGIC *mg)
31 {
32 if (mg && mg->mg_type == PERL_MAGIC_ext && Inline_Magic_Check(mg->mg_ptr)) {
33 IV const iv = SvIV(obj);
34 /*Printf(("free_inline_py_obj: %p, iv: %p, ob_prev: %p, ob_next: %p, refcnt: %i\n", obj, iv, ((PyObject *)iv)->_ob_prev, ((PyObject *)iv)->_ob_next, ((PyObject *)iv)->ob_refcnt)); */ /* _ob_prev and _ob_next are only available if Python is compiled with reference debugging enabled */
35 Printf(("free_inline_py_obj: %p, iv: %p, refcnt: %i\n", obj, iv, (int)Py_REFCNT(iv)));
36 Py_XDECREF((PyObject *)iv); /* just in case */
37 }
38 else {
39 croak("ERROR: tried to free a non-Python object. Aborting.");
40 }
41
42 return 0;
43 }
44
get_perl_pkg_subs(PyObject * package)45 PyObject * get_perl_pkg_subs(PyObject *package) {
46 #if PY_MAJOR_VERSION >= 3
47 char * const pkg = PyBytes_AsString(package);
48 #else
49 char * const pkg = PyString_AsString(package);
50 #endif
51 PyObject * const retval = PyList_New(0);
52 HV * const hash = perl_get_hv(pkg, 0);
53 int const len = hv_iterinit(hash);
54 int i;
55
56 for (i=0; i<len; i++) {
57 HE * const next = hv_iternext(hash);
58 I32 n_a;
59 char * const key = hv_iterkey(next,&n_a);
60 char * const test = (char*)malloc((strlen(pkg) + strlen(key) + 1)*sizeof(char));
61 sprintf(test,"%s%s",pkg,key);
62 if (perl_get_cv(test,0)) {
63 #if PY_MAJOR_VERSION >= 3
64 PyList_Append(retval, PyUnicode_FromString(key));
65 #else
66 PyList_Append(retval, PyString_FromString(key));
67 #endif
68 }
69 free(test);
70 }
71
72 return retval;
73 }
74
perl_pkg_exists(char * base,char * pkg)75 int perl_pkg_exists(char *base, char *pkg) {
76 int retval = 0;
77
78 HV * const hash = perl_get_hv(base,0);
79 char * const fpkg = (char*)malloc((strlen(pkg) + strlen("::") + 1)*sizeof(char));
80 sprintf(fpkg,"%s::",pkg);
81
82 Printf(("perl_pkg_exists: %s, %s --> %s\n", base, pkg, fpkg));
83 Printf(("perl_pkg_exists: hash=%p\n", hash));
84
85 if (hash && hv_exists(hash, fpkg, strlen(fpkg))) {
86 /* here -- check if it's a package, not something else? */
87 retval = 1;
88 }
89
90 free(fpkg);
91 return retval;
92 }
93
perl_sub_exists(PyObject * package,PyObject * usub)94 PyObject * perl_sub_exists(PyObject *package, PyObject *usub) {
95 #if PY_MAJOR_VERSION >= 3
96 char * const pkg = PyBytes_AsString(package);
97 char * const sub = PyBytes_AsString(usub);
98 #else
99 char * const pkg = PyString_AsString(package);
100 char * const sub = PyString_AsString(usub);
101 #endif
102 PyObject * retval = Py_None;
103
104 char * const qsub = (char*)malloc((strlen(pkg) + strlen(sub) + 1)*sizeof(char));
105 sprintf(qsub,"%s%s",pkg,sub);
106
107 if (perl_get_cv(qsub,0)) {
108 retval = Py_True;
109 }
110
111 free(qsub);
112
113 Py_INCREF(retval);
114 return retval;
115 }
116
py_is_tuple(SV * arr)117 int py_is_tuple(SV *arr) {
118 if (SvROK(arr) && SvTYPE(SvRV(arr)) == SVt_PVAV) {
119 MAGIC * const mg = mg_find(SvRV(arr), PERL_MAGIC_ext);
120 return (mg && Inline_Magic_Key(mg->mg_ptr) == TUPLE_MAGIC_KEY);
121 }
122 else
123 return 0;
124 }
125