1 /* vim: set shiftwidth=4 softtabstop=4 expandtab: */
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 "perlmodule.h"
11 #include "py2pl.h"
12 #include "util.h"
13 #ifdef __cplusplus
14 }
15 #endif
16
17 #ifdef CREATE_PERL
18 static PerlInterpreter *my_perl;
19 #endif
20
21 staticforward PyObject * special_perl_eval(PyObject *, PyObject *);
22 staticforward PyObject * special_perl_use(PyObject *, PyObject *);
23 staticforward PyObject * special_perl_require(PyObject *, PyObject *);
24
25 /***************************************
26 * METHOD DECLARATIONS *
27 ***************************************/
28
29 PyObject * newPerlPkg_object(PyObject *base, PyObject *pkg);
30 staticforward void PerlPkg_dealloc(PerlPkg_object *self);
31 staticforward PyObject * PerlPkg_repr(PerlPkg_object *self, PyObject *args);
32 staticforward PyObject * PerlPkg_getattr(PerlPkg_object *self, char *name);
33
34 PyObject * newPerlObj_object(SV *obj, PyObject *pkg);
35 staticforward void PerlObj_dealloc(PerlObj_object *self);
36 staticforward PyObject * PerlObj_repr(PerlObj_object *self);
37 staticforward PyObject * PerlObj_str(PerlObj_object *self);
38 staticforward PyObject * PerlObj_call(PerlObj_object *self, PyObject *args, PyObject *kw);
39 staticforward PyObject * PerlObj_getattr(PerlObj_object *self, char *name);
40 staticforward PyObject * PerlObj_mp_subscript(PerlObj_object *self, PyObject *key);
41
42 PyObject * newPerlSub_object(PyObject *base,
43 PyObject *pkg,
44 SV *cv);
45 PyObject * newPerlMethod_object(PyObject *base,
46 PyObject *pkg,
47 SV *obj);
48 PyObject * newPerlCfun_object(PyObject* (*cfun)(PyObject *self, PyObject *args));
49 staticforward void PerlSub_dealloc(PerlSub_object *self);
50 staticforward PyObject * PerlSub_call(PerlSub_object *self, PyObject *args, PyObject *kw);
51 staticforward PyObject * PerlSub_repr(PerlSub_object *self, PyObject *args);
52 staticforward PyObject * PerlSub_getattr(PerlSub_object *self, char *name);
53 staticforward int PerlSub_setattr(PerlSub_object *self,
54 char *name,
55 PyObject *value);
56
57 /**************************************
58 * METHOD DEFINITIONS *
59 **************************************/
60
61 /* methods of _perl_pkg */
62 PyObject *
newPerlPkg_object(PyObject * base,PyObject * package)63 newPerlPkg_object(PyObject *base, PyObject *package) {
64 PerlPkg_object * const self = PyObject_NEW(PerlPkg_object, &PerlPkg_type);
65
66 #if PY_MAJOR_VERSION >= 3
67 char * const bs = PyBytes_AsString(base);
68 char * const pkg = PyBytes_AsString(package);
69 #else
70 char * const bs = PyString_AsString(base);
71 char * const pkg = PyString_AsString(package);
72 #endif
73 char * const str = (char*)malloc((strlen(bs) + strlen(pkg) + strlen("::") + 1)
74 * sizeof(char));
75
76 if(!self) {
77 free(str);
78 PyErr_Format(PyExc_MemoryError, "Couldn't create Perl Package object.\n");
79 return NULL;
80 }
81 sprintf(str, "%s%s::", bs, pkg);
82
83 Py_INCREF(base);
84 Py_INCREF(package);
85 self->base = base;
86 self->pkg = package;
87 #if PY_MAJOR_VERSION >= 3
88 self->full = PyBytes_FromString(str);
89 #else
90 self->full = PyString_FromString(str);
91 #endif
92
93 free(str);
94 return (PyObject*)self;
95 }
96
97 static void
PerlPkg_dealloc(PerlPkg_object * self)98 PerlPkg_dealloc(PerlPkg_object *self) {
99 Py_XDECREF(self->pkg);
100 Py_XDECREF(self->base);
101 Py_XDECREF(self->full);
102 PyObject_Del(self);
103 }
104
105 static PyObject *
PerlPkg_repr(PerlPkg_object * self,PyObject * args)106 PerlPkg_repr(PerlPkg_object *self, PyObject *args) {
107 PyObject *s;
108 char * const str = (char*)malloc((strlen("<perl package: ''>")
109 + PyObject_Length(self->full)
110 + 1) * sizeof(char));
111 #if PY_MAJOR_VERSION >= 3
112 sprintf(str, "<perl package: '%s'>", PyBytes_AsString(self->full));
113 s = PyUnicode_FromString(str);
114 #else
115 sprintf(str, "<perl package: '%s'>", PyString_AsString(self->full));
116 s = PyString_FromString(str);
117 #endif
118 free(str);
119 return s;
120 }
121
122 static PyObject *
PerlPkg_getattr(PerlPkg_object * self,char * name)123 PerlPkg_getattr(PerlPkg_object *self, char *name) {
124 /*** Python Methods ***/
125 if (strcmp(name,"__methods__") == 0) {
126 return get_perl_pkg_subs(self->full);
127 }
128 else if (strcmp(name,"__members__") == 0) {
129 PyObject *retval = PyList_New(0);
130 return retval ? retval : NULL;
131 }
132 else if (strcmp(name,"__dict__") == 0) {
133 PyObject *retval = PyDict_New();
134 return retval ? retval : NULL;
135 }
136
137 /*** Special Names (but only for 'main' package) ***/
138 else if (PKG_EQ(self, "main::") && strcmp(name,"eval")==0) {
139 /* return a PerlSub_object which just does: eval(@_) */
140 return newPerlCfun_object(&special_perl_eval);
141 }
142 else if (PKG_EQ(self, "main::") && strcmp(name,"use")==0) {
143 /* return a PerlSub_object which just does:
144 * eval("use $_[0]; $_[0]->import") */
145 return newPerlCfun_object(&special_perl_use);
146 }
147 else if (PKG_EQ(self, "main::") && strcmp(name,"require")==0) {
148 /* return a PerlSub_object which just does:
149 * eval("require $_[0];") */
150 return newPerlCfun_object(&special_perl_require);
151 }
152
153 /*** A Perl Package, Sub, or Method ***/
154 else {
155 #if PY_MAJOR_VERSION >= 3
156 PyObject * const tmp = PyBytes_FromString(name);
157 char * const full_c = PyBytes_AsString(self->full);
158 #else
159 PyObject * const tmp = PyString_FromString(name);
160 char * const full_c = PyString_AsString(self->full);
161 #endif
162
163 PyObject * const res = perl_pkg_exists(full_c, name)
164 ? newPerlPkg_object(self->full, tmp)
165 : newPerlSub_object(self->full, tmp, NULL);
166
167 Py_DECREF(tmp);
168
169 return res;
170 }
171 }
172
module_dir(PerlPkg_object * self,PyObject * args)173 static PyObject * module_dir(PerlPkg_object *self, PyObject *args) {
174 return get_perl_pkg_subs(self->full);
175 }
176
177 static struct PyMethodDef PerlPkg_methods[] = {
178 {"__dir__", (PyCFunction)module_dir, METH_NOARGS, NULL},
179 {NULL} /* sentinel */
180 };
181
182 /* doc string */
183 static char PerlPkg_type__doc__[] =
184 "_perl_pkg -- Wrap a Perl package in a Python class"
185 ;
186
187 /* type definition */
188 PyTypeObject PerlPkg_type = {
189 PyVarObject_HEAD_INIT(NULL, 0)
190 "_perl_pkg", /*tp_name*/
191 sizeof(PerlPkg_object), /*tp_basicsize*/
192 0, /*tp_itemsize*/
193 /* methods */
194 (destructor)PerlPkg_dealloc, /*tp_dealloc*/
195 (printfunc)0, /*tp_print*/
196 (getattrfunc)PerlPkg_getattr, /*tp_getattr*/
197 (setattrfunc)0, /*tp_setattr*/
198 #if PY_MAJOR_VERSION < 3
199 (cmpfunc)0, /*tp_compare*/
200 #else
201 0, /*reserved*/
202 #endif
203 (reprfunc)PerlPkg_repr, /*tp_repr*/
204 0, /*tp_as_number*/
205 0, /*tp_as_sequence*/
206 0, /*tp_as_mapping*/
207 (hashfunc)0, /*tp_hash*/
208 (ternaryfunc)0, /*tp_call*/
209 (reprfunc)PerlPkg_repr, /*tp_str*/
210 0, /* tp_getattro */
211 0, /* tp_setattro */
212 0, /* tp_as_buffer */
213 Py_TPFLAGS_DEFAULT, /* tp_flags */
214 PerlPkg_type__doc__, /* Documentation string */
215 (traverseproc)0, /* tp_traverse */
216 (inquiry)0, /* tp_clear */
217 0, /* tp_richcompare */
218 0, /* tp_weaklistoffset */
219 0, /* tp_iter */
220 0, /* tp_iternext */
221 PerlPkg_methods, /* tp_methods */
222 };
223
224 /* methods of _perl_obj */
225 PyObject *
newPerlObj_object(SV * obj,PyObject * package)226 newPerlObj_object(SV *obj, PyObject *package) {
227 PerlObj_object * const self = PyObject_NEW(PerlObj_object, &PerlObj_type);
228
229 if(!self) {
230 PyErr_Format(PyExc_MemoryError, "Couldn't create Perl Obj object.\n");
231 return NULL;
232 }
233
234 Py_INCREF(package);
235 SvREFCNT_inc(obj);
236 self->pkg = package;
237 self->obj = obj;
238
239 return (PyObject*)self;
240 }
241
242 static void
PerlObj_dealloc(PerlObj_object * self)243 PerlObj_dealloc(PerlObj_object *self) {
244 Py_XDECREF(self->pkg);
245
246 if (self->obj) sv_2mortal(self->obj); /* mortal instead of DECREF. Object might be return value */
247
248 PyObject_Del(self);
249 }
250
251 static PyObject *
PerlObj_repr(PerlObj_object * self)252 PerlObj_repr(PerlObj_object *self) {
253 PyObject *s;
254 char * const str = (char*)malloc((strlen("<perl object: ''>")
255 + PyObject_Length(self->pkg)
256 + 1) * sizeof(char));
257 #if PY_MAJOR_VERSION >= 3
258 sprintf(str, "<perl object: '%s'>", PyBytes_AsString(self->pkg));
259 s = PyUnicode_FromString(str);
260 #else
261 sprintf(str, "<perl object: '%s'>", PyString_AsString(self->pkg));
262 s = PyString_FromString(str);
263 #endif
264 free(str);
265 return s;
266 }
267
268 static PyObject *
PerlObj_str(PerlObj_object * self)269 PerlObj_str(PerlObj_object *self) {
270 STRLEN len;
271 SV* const sv = ((SvTHINKFIRST(self->obj) && !SvIsCOW(self->obj)) || isGV_with_GP(self->obj))
272 ? sv_mortalcopy(self->obj)
273 : self->obj;
274
275 char * const str = SvPVutf8(sv, len);
276 return PyUnicode_DecodeUTF8(str, len, "replace");
277 }
278
279 static PyObject *
PerlObj_getattr(PerlObj_object * self,char * name)280 PerlObj_getattr(PerlObj_object *self, char *name) {
281 PyObject *retval = NULL;
282 if (strcmp(name,"__methods__") == 0) {
283 return get_perl_pkg_subs(self->pkg);
284 }
285 else if (strcmp(name,"__members__") == 0) {
286 retval = PyList_New(0);
287 return retval ? retval : NULL;
288 }
289 else if (strcmp(name,"__dict__") == 0) {
290 retval = PyDict_New();
291 return retval ? retval : NULL;
292 }
293 else {
294 SV * const obj = (SV*)SvRV(self->obj);
295 HV * const pkg = SvSTASH(obj);
296 /* probably a request for a method */
297 GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
298 if (gv && isGV(gv)) {
299 #if PY_MAJOR_VERSION >= 3
300 PyObject * const py_name = PyBytes_FromString(name);
301 #else
302 PyObject * const py_name = PyString_FromString(name);
303 #endif
304 retval = newPerlMethod_object(self->pkg, py_name, self->obj);
305 Py_DECREF(py_name);
306 }
307 else {
308 /* search for an attribute */
309 /* check if the object supports the __getattr__ protocol */
310 GV* const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, "__getattr__", FALSE);
311 if (gv && isGV(gv)) { /* __getattr__ supported! Let's see if an attribute is found. */
312 dSP;
313
314 ENTER;
315 SAVETMPS;
316
317 SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
318
319 PUSHMARK(SP);
320 XPUSHs(self->obj);
321 XPUSHs(sv_2mortal(newSVpv(name, 0)));
322 PUTBACK;
323
324 /* array context needed, so it's possible to return nothing (not even undef)
325 if the attribute does not exist */
326 int const count = call_sv(rv, G_ARRAY);
327
328 SPAGAIN;
329
330 if (count > 1)
331 croak("__getattr__ may only return a single scalar or an empty list!\n");
332
333 if (count == 1) { /* attribute exists! Now give the value back to Python */
334 retval = Pl2Py(POPs);
335 }
336
337 PUTBACK;
338 FREETMPS;
339 LEAVE;
340 }
341 if (! retval) { /* give up and raise a AttributeError */
342 char attribute_error[strlen(name) + 21];
343 sprintf(attribute_error, "attribute %s not found", name);
344 PyErr_SetString(PyExc_AttributeError, attribute_error);
345 }
346 }
347 return retval;
348 }
349 }
350
351 static PyObject*
PerlObj_mp_subscript(PerlObj_object * self,PyObject * key)352 PerlObj_mp_subscript(PerlObj_object *self, PyObject *key) {
353 /* check if the object supports the __getitem__ protocol */
354 PyObject *item = NULL;
355 PyObject *key_str = PyObject_Str(key); /* new reference */
356 #if PY_MAJOR_VERSION >= 3
357 PyObject* string_as_bytes = PyUnicode_AsUTF8String(key_str);/* new reference */
358 char * const name = PyBytes_AsString(string_as_bytes);
359 #else
360 char * const name = PyString_AsString(key_str);
361 #endif
362 SV * const obj = (SV*)SvRV(self->obj);
363 HV * const pkg = SvSTASH(obj);
364 GV* const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, "__getitem__", FALSE);
365 if (gv && isGV(gv)) { /* __getitem__ supported! Let's see if the key is found. */
366 dSP;
367
368 ENTER;
369 SAVETMPS;
370
371 SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
372
373 PUSHMARK(SP);
374 XPUSHs(self->obj);
375 XPUSHs(sv_2mortal(newSVpv(name, 0)));
376 PUTBACK;
377
378 /* array context needed, so it's possible to return nothing (not even undef)
379 if the attribute does not exist */
380 int const count = call_sv(rv, G_ARRAY);
381
382 SPAGAIN;
383
384 if (count > 1)
385 croak("__getitem__ may only return a single scalar or an empty list!\n");
386
387 if (count == 1) { /* item exists! Now give the value back to Python */
388 item = Pl2Py(POPs);
389 }
390
391 PUTBACK;
392 FREETMPS;
393 LEAVE;
394
395 if (count == 0) {
396 char attribute_error[strlen(name) + 21];
397 sprintf(attribute_error, "attribute %s not found", name);
398 PyErr_SetString(PyExc_KeyError, attribute_error);
399 }
400 }
401 else {
402 PyErr_Format(PyExc_TypeError, "'%.200s' object is unsubscriptable", Py_TYPE(self)->tp_name);
403 }
404 #if PY_MAJOR_VERSION >= 3
405 Py_DECREF(string_as_bytes);
406 #endif
407 Py_DECREF(key_str);
408 return item;
409 }
410
411 static PyObject *
PerlObj_call(PerlObj_object * self,PyObject * args,PyObject * kw)412 PerlObj_call(PerlObj_object *self, PyObject *args, PyObject *kw) {
413 dSP;
414 int i;
415 int const len = PyObject_Length(args);
416 int count;
417 PyObject *retval;
418
419 ENTER;
420 SAVETMPS;
421
422 PUSHMARK(SP);
423
424 if (self->obj) XPUSHs(self->obj);
425
426 if (kw) { /* if keyword arguments are present, positional arguments get pushed as into an arrayref */
427 AV * const positional = newAV();
428 for (i=0; i<len; i++) {
429 SV * const arg = Py2Pl(PyTuple_GetItem(args, i));
430 av_push(positional, sv_isobject(arg) ? SvREFCNT_inc(arg) : arg);
431 }
432 XPUSHs((SV *) sv_2mortal((SV *) newRV_inc((SV *) positional)));
433
434 SV * const kw_hash = Py2Pl(kw);
435 XPUSHs(kw_hash);
436 sv_2mortal(kw_hash);
437 sv_2mortal((SV *)positional);
438 }
439 else {
440 for (i=0; i<len; i++) {
441 SV * const arg = Py2Pl(PyTuple_GetItem(args, i));
442 XPUSHs(arg);
443 if (! sv_isobject(arg))
444 sv_2mortal(arg);
445 }
446 }
447
448 PUTBACK;
449
450 /* call the function */
451 /* because the Perl sub *could* be arbitrary Python code,
452 * I probably should temporarily hold a reference here */
453 Py_INCREF(self);
454
455 count = perl_call_sv(self->obj, G_EVAL);
456 SPAGAIN;
457
458 Py_DECREF(self); /* release*/
459
460
461 if (SvTRUE(ERRSV)) {
462 PyObject *exc = Pl2Py(ERRSV);
463 PyErr_SetObject(PyExc_Perl, exc);
464 ERRSV = NULL;
465 return NULL;
466 }
467
468 /* what to return? */
469 if (count == 0) {
470 Py_INCREF(Py_None);
471 retval = Py_None;
472 }
473 else if (count == 1) {
474 retval = Pl2Py(POPs);
475 }
476 else {
477 AV * const lst = newAV();
478 av_extend(lst, count);
479 for (i = count - 1; i >= 0; i--) {
480 av_store(lst, i, SvREFCNT_inc(POPs));
481 }
482 SV * const rv_lst = newRV_inc((SV*)lst);
483 retval = Pl2Py(rv_lst);
484 SvREFCNT_dec(rv_lst);
485 sv_2mortal((SV*)lst); /* this will get killed shortly */
486 }
487
488 PUTBACK;
489 FREETMPS;
490 LEAVE;
491
492 return retval;
493 }
494
495 #if PY_MAJOR_VERSION >= 3 // Python 3 rich compare
496 static PyObject*
PerlObj_richcompare(PerlObj_object * o1,PerlObj_object * o2,int op)497 PerlObj_richcompare(PerlObj_object *o1, PerlObj_object *o2, int op) {
498 /* Unable to compare different a Perl object with something else */
499 if (!PerlObjObject_Check(o1) || !PerlObjObject_Check(o2)) {
500 Py_RETURN_FALSE;
501 }
502
503 /* check if the object supports the __cmp__ protocol */
504 SV * const obj = (SV*)SvRV(o1->obj);
505 HV * const pkg = SvSTASH(obj);
506
507 const char* method_name = NULL;
508 switch (op) {
509 case Py_LT: method_name = "__lt__"; break;
510 case Py_LE: method_name = "__le__"; break;
511 case Py_EQ: method_name = "__eq__"; break;
512 case Py_NE: method_name = "__ne__"; break;
513 case Py_GT: method_name = "__gt__"; break;
514 case Py_GE: method_name = "__ge__"; break;
515 }
516
517 GV* const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, method_name, FALSE);
518 if (gv && isGV(gv)) {
519 int retval;
520 dSP;
521
522 ENTER;
523 SAVETMPS;
524
525 SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
526
527 PUSHMARK(SP);
528 XPUSHs(o1->obj);
529 XPUSHs(o2->obj);
530 PUTBACK;
531
532 int const count = call_sv(rv, G_SCALAR);
533
534 SPAGAIN;
535
536 if (count > 1)
537 croak("%s may only return a single scalar!\n", method_name);
538
539 if (count == 1) { /* attribute exists! Now give the value back to Python */
540 SV * const result = POPs;
541 if(!SvIOK(result))
542 croak("%s must return an integer!\n", method_name);
543 retval = SvIV(result);
544 }
545
546 PUTBACK;
547 FREETMPS;
548 LEAVE;
549 if(retval == 0) {Py_RETURN_TRUE;}
550 Py_RETURN_FALSE;
551 }
552 if (SvRV(o1->obj) == SvRV(o2->obj)) {/* just compare the dereferenced object pointers */
553 if(op == Py_EQ) {Py_RETURN_TRUE;}
554 Py_RETURN_FALSE;
555 }
556 if (SvRV(o1->obj) != SvRV(o2->obj)) {
557 if(op == Py_NE) {Py_RETURN_TRUE;}
558 Py_RETURN_FALSE;
559 }
560 Py_RETURN_NOTIMPLEMENTED;
561 }
562 #else // Python 2 __cmp__ method
563 static int
PerlObj_compare(PerlObj_object * o1,PerlObj_object * o2)564 PerlObj_compare(PerlObj_object *o1, PerlObj_object *o2) {
565 /* check if the object supports the __cmp__ protocol */
566 SV * const obj = (SV*)SvRV(o1->obj);
567 HV * const pkg = SvSTASH(obj);
568 GV* const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, "__cmp__", FALSE);
569 if (gv && isGV(gv)) {
570 int retval;
571 dSP;
572
573 ENTER;
574 SAVETMPS;
575
576 SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
577
578 PUSHMARK(SP);
579 XPUSHs(o1->obj);
580 XPUSHs(o2->obj);
581 PUTBACK;
582
583 int const count = call_sv(rv, G_SCALAR);
584
585 SPAGAIN;
586
587 if (count > 1)
588 croak("__cmp__ may only return a single scalar!\n");
589
590 if (count == 1) { /* attribute exists! Now give the value back to Python */
591 SV * const result = POPs;
592 if(!SvIOK(result))
593 croak("__cmp__ must return an integer!\n");
594 retval = SvIV(result);
595 }
596
597 PUTBACK;
598 FREETMPS;
599 LEAVE;
600 return retval;
601 }
602 if (SvRV(o1->obj) == SvRV(o2->obj)) /* just compare the dereferenced object pointers */
603 return 0;
604 return 1;
605 }
606 #endif
607
object_dir(PerlObj_object * self,PyObject * args)608 static PyObject * object_dir(PerlObj_object *self, PyObject *args) {
609 return get_perl_pkg_subs(self->pkg);
610 }
611
612 static struct PyMethodDef PerlObj_methods[] = {
613 {"__dir__", (PyCFunction)object_dir, METH_NOARGS, NULL},
614 {NULL} /* sentinel */
615 };
616
617 /* doc string */
618 static char PerlObj_type__doc__[] =
619 "_perl_obj -- Wrap a Perl object in a Python class"
620 ;
621
622 PyMappingMethods mp_methods = {
623 (lenfunc) 0, /*mp_length*/
624 (binaryfunc) PerlObj_mp_subscript, /*mp_subscript*/
625 (objobjargproc) 0, /*mp_ass_subscript*/
626 };
627
628 /* type definition */
629 PyTypeObject PerlObj_type = {
630 PyVarObject_HEAD_INIT(NULL, 0)
631 "_perl_obj", /*tp_name*/
632 sizeof(PerlObj_object), /*tp_basicsize*/
633 0, /*tp_itemsize*/
634 /* methods */
635 (destructor)PerlObj_dealloc, /*tp_dealloc*/
636 (printfunc)0, /*tp_print*/
637 (getattrfunc)PerlObj_getattr, /*tp_getattr*/
638 (setattrfunc)0, /*tp_setattr*/
639 #if PY_MAJOR_VERSION < 3
640 (cmpfunc)PerlObj_compare, /*tp_compare*/
641 #else
642 0, /*reserved*/
643 #endif
644 (reprfunc)PerlObj_repr, /*tp_repr*/
645 0, /*tp_as_number*/
646 0, /*tp_as_sequence*/
647 &mp_methods, /*tp_as_mapping*/
648 (hashfunc)0, /*tp_hash*/
649 (ternaryfunc)PerlObj_call, /*tp_call*/
650 (reprfunc)PerlObj_str, /*tp_str*/
651
652 /* Space for future expansion */
653 0L,0L,0L,0L,
654 PerlObj_type__doc__, /* Documentation string */
655 (traverseproc)0, /* tp_traverse */
656 (inquiry)0, /* tp_clear */
657 #if PY_MAJOR_VERSION < 3
658 0, /* unused */
659 #else
660 (richcmpfunc)PerlObj_richcompare, /* tp_richcompare */
661 #endif
662 0, /* tp_weaklistoffset */
663 0, /* tp_iter */
664 0, /* tp_iternext */
665 PerlObj_methods, /* tp_methods */
666 };
667
668 /* methods of _perl_sub */
669 PyObject *
newPerlSub_object(PyObject * package,PyObject * sub,SV * cv)670 newPerlSub_object(PyObject *package, PyObject *sub, SV *cv) {
671 PerlSub_object * const self = PyObject_NEW(PerlSub_object, &PerlSub_type);
672 char *str = NULL;
673
674 if(!self) {
675 PyErr_Format(PyExc_MemoryError, "Couldn't create Perl Sub object.\n");
676 return NULL;
677 }
678
679 /* initialize the name of the sub or method */
680 if (package && sub) {
681 str = malloc((PyObject_Length(package) + PyObject_Length(sub) + 1)
682 *sizeof(char));
683
684 #if PY_MAJOR_VERSION >= 3
685 sprintf(str, "%s%s", PyBytes_AsString(package),
686 PyBytes_AsString(sub));
687 #else
688 sprintf(str, "%s%s", PyString_AsString(package),
689 PyString_AsString(sub));
690 #endif
691
692 Py_INCREF(sub);
693 Py_INCREF(package);
694 self->sub = sub;
695 self->pkg = package;
696 #if PY_MAJOR_VERSION >= 3
697 self->full = PyBytes_FromString(str);
698 #else
699 self->full = PyString_FromString(str);
700 #endif
701 }
702 else {
703 self->sub = NULL;
704 self->pkg = NULL;
705 self->full = NULL;
706 }
707
708 /* we don't have to check for errors because we shouldn't have been
709 * created unless perl_get_cv worked once.
710 */
711 if (cv) {
712 self->ref = cv;
713 self->conf = 1;
714 }
715 else if (str) {
716 self->ref = (SV*)perl_get_cv(str,0); /* can return NULL if not found */
717 self->conf = self->ref ? 1 : 0;
718 }
719 else {
720 croak("Can't call newPerlSub_object() with all NULL arguments!\n");
721 }
722
723 SvREFCNT_inc(self->ref); /* quite important -- otherwise we lose it */
724 self->obj = NULL;
725 self->flgs = G_ARRAY;
726 self->cfun = 0;
727
728 if (str) free(str);
729
730 return (PyObject*)self;
731 }
732
733 PyObject *
newPerlMethod_object(PyObject * package,PyObject * sub,SV * obj)734 newPerlMethod_object(PyObject *package, PyObject *sub, SV *obj) {
735 PerlSub_object * const self = (PerlSub_object*)newPerlSub_object(package,
736 sub, NULL);
737 self->obj = obj;
738 SvREFCNT_inc(obj);
739 return (PyObject*)self;
740 }
741
newPerlCfun_object(PyObject * (* cfun)(PyObject * self,PyObject * args))742 PyObject * newPerlCfun_object(PyObject* (*cfun)(PyObject *self,
743 PyObject *args))
744 {
745 PerlSub_object * const self = PyObject_NEW(PerlSub_object, &PerlSub_type);
746 self->pkg = NULL;
747 self->sub = NULL;
748 self->full = NULL;
749 self->ref = NULL;
750 self->obj = NULL;
751 self->flgs = 0;
752 self->cfun = cfun;
753 return (PyObject *)self;
754 }
755
756 static void
PerlSub_dealloc(PerlSub_object * self)757 PerlSub_dealloc(PerlSub_object *self) {
758 Py_XDECREF(self->sub);
759 Py_XDECREF(self->pkg);
760 Py_XDECREF(self->full);
761
762 if (self->obj) SvREFCNT_dec(self->obj);
763 if (self->ref) SvREFCNT_dec(self->ref);
764
765 PyObject_Del(self);
766 }
767
768 static PyObject *
PerlSub_call(PerlSub_object * self,PyObject * args,PyObject * kw)769 PerlSub_call(PerlSub_object *self, PyObject *args, PyObject *kw) {
770 dSP;
771 int i;
772 int const len = PyObject_Length(args);
773 int count;
774 PyObject *retval;
775
776 /* if this wraps a C function, execute that */
777 if (self->cfun) return self->cfun((PyObject*)self, args);
778
779 ENTER;
780 SAVETMPS;
781
782 PUSHMARK(SP);
783
784 if (self->obj) XPUSHs(self->obj);
785
786 if (kw) { /* if keyword arguments are present, positional arguments get pushed as into an arrayref */
787 AV * const positional = newAV();
788 for (i=0; i<len; i++) {
789 SV * const arg = Py2Pl(PyTuple_GetItem(args, i));
790 av_push(positional, sv_isobject(arg) ? SvREFCNT_inc(arg) : arg);
791 }
792 XPUSHs((SV *) sv_2mortal((SV *) newRV_inc((SV *) positional)));
793
794 SV * const kw_hash = Py2Pl(kw);
795 XPUSHs(kw_hash);
796 sv_2mortal(kw_hash);
797 sv_2mortal((SV *)positional);
798 }
799 else {
800 for (i=0; i<len; i++) {
801 SV * const arg = Py2Pl(PyTuple_GetItem(args, i));
802 XPUSHs(arg);
803 if (! sv_isobject(arg))
804 sv_2mortal(arg);
805 }
806 }
807
808 PUTBACK;
809
810 /* call the function */
811 /* because the Perl sub *could* be arbitrary Python code,
812 * I probably should temporarily hold a reference here */
813 Py_INCREF(self);
814
815 if (self->ref)
816 count = perl_call_sv(self->ref, self->flgs | G_EVAL);
817 else if (self->sub && self->obj)
818 #if PY_MAJOR_VERSION >= 3
819 count = perl_call_method(PyBytes_AsString(self->sub), self->flgs | G_EVAL);
820 #else
821 count = perl_call_method(PyString_AsString(self->sub), self->flgs | G_EVAL);
822 #endif
823 else {
824 croak("Error: PerlSub called, but no C function, sub, or name found!\n");
825 }
826 SPAGAIN;
827
828 Py_DECREF(self); /* release*/
829
830
831 if (SvTRUE(ERRSV)) {
832 PyObject *exc = Pl2Py(ERRSV);
833 PyErr_SetObject(PyExc_Perl, exc);
834 ERRSV = NULL;
835 return NULL;
836 }
837
838 /* what to return? */
839 if (count == 0) {
840 Py_INCREF(Py_None);
841 retval = Py_None;
842 }
843 else if (count == 1) {
844 retval = Pl2Py(POPs);
845 }
846 else {
847 AV * const lst = newAV();
848 av_extend(lst, count);
849 for (i = count - 1; i >= 0; i--) {
850 av_store(lst, i, SvREFCNT_inc(POPs));
851 }
852 SV * const rv_lst = newRV_inc((SV*)lst);
853 retval = Pl2Py(rv_lst);
854 SvREFCNT_dec(rv_lst);
855 sv_2mortal((SV*)lst); /* this will get killed shortly */
856 }
857
858 PUTBACK;
859 FREETMPS;
860 LEAVE;
861
862 return retval;
863 }
864
865 static PyObject *
PerlSub_repr(PerlSub_object * self,PyObject * args)866 PerlSub_repr(PerlSub_object *self, PyObject *args) {
867 PyObject *s;
868 char * const str = (char*)malloc((strlen("<perl sub: ''>")
869 + (self->full
870 ? PyObject_Length(self->full)
871 : strlen("anonymous"))
872 + 1) * sizeof(char));
873 #if PY_MAJOR_VERSION >= 3
874 sprintf(str, "<perl sub: '%s'>", (self->full
875 ? PyBytes_AsString(self->full)
876 : "anonymous"));
877 s = PyUnicode_FromString(str);
878 #else
879 sprintf(str, "<perl sub: '%s'>", (self->full
880 ? PyString_AsString(self->full)
881 : "anonymous"));
882 s = PyString_FromString(str);
883 #endif
884 free(str);
885 return s;
886 }
887
888 static PyObject *
PerlSub_getattr(PerlSub_object * self,char * name)889 PerlSub_getattr(PerlSub_object *self, char *name) {
890 PyObject *retval = NULL;
891 if (strcmp(name,"flags")==0) {
892 retval = PyInt_FromLong((long)self->flgs);
893 }
894 else if (strcmp(name,"G_VOID")==0) {
895 retval = PyInt_FromLong((long)G_VOID);
896 }
897 else if (strcmp(name,"G_SCALAR")==0) {
898 retval = PyInt_FromLong((long)G_SCALAR);
899 }
900 else if (strcmp(name,"G_ARRAY")==0) {
901 retval = PyInt_FromLong((long)G_ARRAY);
902 }
903 else if (strcmp(name,"G_DISCARD")==0) {
904 retval = PyInt_FromLong((long)G_DISCARD);
905 }
906 else if (strcmp(name,"G_NOARGS")==0) {
907 retval = PyInt_FromLong((long)G_NOARGS);
908 }
909 else if (strcmp(name,"G_EVAL")==0) {
910 retval = PyInt_FromLong((long)G_EVAL);
911 }
912 else if (strcmp(name,"G_KEEPERR")==0) {
913 retval = PyInt_FromLong((long)G_KEEPERR);
914 }
915 else {
916 PyErr_Format(PyExc_AttributeError,
917 "Attribute '%s' not found for Perl sub '%s'", name,
918 #if PY_MAJOR_VERSION < 3
919 (self->full
920 ? PyString_AsString(self->full)
921 : (self->pkg ? PyString_AsString(self->pkg) : ""))
922 #else
923 (self->full
924 ? PyBytes_AsString(self->full)
925 : (self->pkg ? PyBytes_AsString(self->pkg) : ""))
926 #endif
927 );
928 retval = NULL;
929 }
930 return retval;
931 }
932
933 static int
PerlSub_setattr(PerlSub_object * self,char * name,PyObject * v)934 PerlSub_setattr(PerlSub_object *self, char *name, PyObject *v) {
935 if (strcmp(name, "flags")==0 && PyInt_Check(v)) {
936 self->flgs = (int)PyInt_AsLong(v);
937 return 0; /* success */
938 }
939 else if (strcmp(name,"flags")==0) {
940 PyErr_Format(PyExc_TypeError,
941 "'flags' can only be set from an integer. '%s'",
942 #if PY_MAJOR_VERSION < 3
943 (self->pkg ? PyString_AsString(self->pkg) : ""));
944 #else
945 (self->pkg ? PyBytes_AsString(self->pkg) : ""));
946 #endif
947
948 return -1; /* failure */
949 }
950 else {
951 PyErr_Format(PyExc_AttributeError,
952 "Attribute '%s' not found for Perl sub '%s'", name,
953 #if PY_MAJOR_VERSION < 3
954 (self->full
955 ? PyString_AsString(self->full)
956 : (self->pkg ? PyString_AsString(self->pkg) : ""))
957 #else
958 (self->full
959 ? PyBytes_AsString(self->full)
960 : (self->pkg ? PyBytes_AsString(self->pkg) : ""))
961 #endif
962 );
963 return -1; /* failure */
964 }
965 }
966
967 static struct PyMethodDef PerlSub_methods[] = {
968 {NULL, NULL} /* sentinel */
969 };
970
971 /* doc string */
972 static char PerlSub_type__doc__[] =
973 "_perl_sub -- Wrap a Perl sub in a Python class"
974 ;
975
976 /* type definition */
977 PyTypeObject PerlSub_type = {
978 PyVarObject_HEAD_INIT(NULL, 0)
979 "_perl_sub", /*tp_name*/
980 sizeof(PerlSub_object), /*tp_basicsize*/
981 0, /*tp_itemsize*/
982 /* methods */
983 (destructor)PerlSub_dealloc, /*tp_dealloc*/
984 (printfunc)0, /*tp_print*/
985 (getattrfunc)PerlSub_getattr, /*tp_getattr*/
986 (setattrfunc)PerlSub_setattr, /*tp_setattr*/
987 #if PY_MAJOR_VERSION < 3
988 (cmpfunc)0, /*tp_compare*/
989 #else
990 0, /*reserved*/
991 #endif
992 (reprfunc)PerlSub_repr, /*tp_repr*/
993 0, /*tp_as_number*/
994 0, /*tp_as_sequence*/
995 0, /*tp_as_mapping*/
996 (hashfunc)0, /*tp_hash*/
997 (ternaryfunc)PerlSub_call, /*tp_call*/
998 (reprfunc)PerlSub_repr, /*tp_str*/
999
1000 /* Space for future expansion */
1001 0L,0L,0L,0L,
1002 PerlSub_type__doc__, /* Documentation string */
1003 };
1004
1005 /* no module-public functions */
1006 static PyMethodDef perl_functions[] = {
1007 {NULL, NULL} /* sentinel */
1008 };
1009
special_perl_eval(PyObject * ignored,PyObject * args)1010 static PyObject * special_perl_eval(PyObject *ignored, PyObject *args) {
1011 dSP;
1012 SV *code;
1013 int i;
1014 int count;
1015 PyObject *retval;
1016 PyObject * const s = PyTuple_GetItem(args, 0);
1017
1018 #if PY_MAJOR_VERSION >= 3
1019 int is_string = PyBytes_Check(s) || PyUnicode_Check(s);
1020 #else
1021 int is_string = PyString_Check(s);
1022 #endif
1023 if(!is_string) {
1024 return NULL;
1025 }
1026
1027 ENTER;
1028 SAVETMPS;
1029
1030 /* not necessary -- but why not? */
1031 PUSHMARK(SP);
1032 PUTBACK;
1033
1034 /* run the anonymous subroutine under G_EVAL mode */
1035 #if PY_MAJOR_VERSION >= 3
1036 PyObject* s_bytes = 0;
1037 char* s_c_bytes = 0;
1038 if(PyUnicode_Check(s)) {
1039 s_bytes = PyUnicode_AsUTF8String(s);
1040 s_c_bytes = PyBytes_AsString(s_bytes);
1041 }
1042 else s_c_bytes = PyBytes_AsString(s);
1043 #else
1044 char* s_c_bytes = PyString_AsString(s);
1045 #endif
1046
1047 code = newSVpv(s_c_bytes,0);
1048 count = perl_eval_sv(code, G_EVAL);
1049
1050 #if PY_MAJOR_VERSION >= 3
1051 Py_XDECREF(s_bytes);
1052 #endif
1053
1054 SPAGAIN;
1055
1056 if (SvTRUE(ERRSV)) {
1057 warn("%s\n", SvPV_nolen(ERRSV));
1058 }
1059
1060 if (count == 0) {
1061 retval = Py_None;
1062 Py_INCREF(retval);
1063 }
1064 else if (count == 1) {
1065 SV * const s = POPs;
1066 retval = Pl2Py(s);
1067 }
1068 else {
1069 AV * const lst = newAV();
1070 for (i=0; i<count; i++) {
1071 av_push(lst, POPs);
1072 }
1073 retval = Pl2Py((SV*)lst);
1074 sv_2mortal((SV*)lst);
1075 }
1076
1077 PUTBACK;
1078 FREETMPS;
1079 LEAVE;
1080
1081 return retval;
1082 }
1083
special_perl_use(PyObject * ignored,PyObject * args)1084 static PyObject * special_perl_use(PyObject *ignored, PyObject *args) {
1085 PyObject * s = PyTuple_GetItem(args, 0);
1086 char *str;
1087
1088 #if PY_MAJOR_VERSION >= 3
1089 int is_string = PyBytes_Check(s) || PyUnicode_Check(s);
1090 #else
1091 int is_string = PyString_Check(s);
1092 #endif
1093 if(!is_string) {
1094 return NULL;
1095 }
1096
1097 #if PY_MAJOR_VERSION >= 3
1098 PyObject* s_bytes = 0;
1099 char* s_c_bytes = 0;
1100 if(PyUnicode_Check(s)) {
1101 s_bytes = PyUnicode_AsUTF8String(s);
1102 s_c_bytes = PyBytes_AsString(s_bytes);
1103 }
1104 else s_c_bytes = PyBytes_AsString(s);
1105 #else
1106 char* s_c_bytes = PyString_AsString(s);
1107 #endif
1108
1109 Printf(("calling use...'%s'\n", s_c_bytes));
1110
1111 str = malloc((strlen("use ")
1112 + PyObject_Length(s) + 1) * sizeof(char));
1113 sprintf(str, "use %s", s_c_bytes);
1114
1115 Printf(("eval-ing now!\n"));
1116 perl_eval_pv(str, TRUE);
1117 Printf(("'twas called!\n"));
1118
1119 free(str);
1120
1121 #if PY_MAJOR_VERSION >= 3
1122 Py_XDECREF(s_bytes);
1123 #endif
1124
1125 Py_INCREF(Py_None);
1126 return Py_None;
1127 }
1128
special_perl_require(PyObject * ignored,PyObject * args)1129 static PyObject * special_perl_require(PyObject *ignored, PyObject *args) {
1130 PyObject * const s = PyTuple_GetItem(args, 0);
1131
1132 #if PY_MAJOR_VERSION >= 3
1133 int is_string = PyBytes_Check(s) || PyUnicode_Check(s);
1134 #else
1135 int is_string = PyString_Check(s);
1136 #endif
1137 if(!is_string) {
1138 return NULL;
1139 }
1140
1141 #if PY_MAJOR_VERSION >= 3
1142 PyObject* s_bytes = 0;
1143 char* s_c_bytes = 0;
1144 if(PyUnicode_Check(s)) {
1145 s_bytes = PyUnicode_AsUTF8String(s);
1146 s_c_bytes = PyBytes_AsString(s_bytes);
1147 }
1148 else s_c_bytes = PyBytes_AsString(s);
1149 #else
1150 char* s_c_bytes = PyString_AsString(s);
1151 #endif
1152
1153 perl_require_pv(s_c_bytes);
1154
1155 #if PY_MAJOR_VERSION >= 3
1156 Py_XDECREF(s_bytes);
1157 #endif
1158
1159 Py_INCREF(Py_None);
1160 return Py_None;
1161 }
1162
1163 #ifdef CREATE_PERL
1164 static void
create_perl()1165 create_perl()
1166 {
1167 int argc = 1;
1168 char * const argv[] = {
1169 "perl"
1170 };
1171
1172 /* When we create a Perl interpreter from Python, we don't get to
1173 * dynamically load Perl modules unless that Python is patched, since
1174 * Python doesn't expose the LDGLOBAL flag, which is required. This
1175 * problem doesn't exist the other way because Perl exposes this
1176 * interface.
1177 *
1178 * For this reason I haven't bothered provided an xs_init function.
1179 */
1180
1181 my_perl = perl_alloc();
1182 perl_construct(my_perl);
1183 perl_parse(my_perl, NULL, argc, argv, NULL);
1184 perl_run(my_perl);
1185 }
1186 #endif
1187
1188 PyObject *PyExc_Perl;
1189
1190 void
initperl(void)1191 initperl(void){
1192 PyObject *m, *d, *p;
1193 #if PY_MAJOR_VERSION >= 3
1194 PyObject *dummy1 = PyBytes_FromString(""),
1195 *dummy2 = PyBytes_FromString("main");
1196 #else
1197 PyObject *dummy1 = PyString_FromString(""),
1198 *dummy2 = PyString_FromString("main");
1199 #endif
1200
1201
1202 /* Initialize the type of the new type objects here; doing it here
1203 * is required for portability to Windows without requiring C++. */
1204 #if PY_MAJOR_VERSION >= 3
1205 PerlPkg_type.ob_base.ob_base.ob_type = &PyType_Type;
1206 PyType_Ready(&PerlPkg_type);
1207 PerlObj_type.ob_base.ob_base.ob_type = &PyType_Type;
1208 PyType_Ready(&PerlObj_type);
1209 PerlSub_type.ob_base.ob_base.ob_type = &PyType_Type;
1210 PyType_Ready(&PerlSub_type);
1211 #else
1212 PerlPkg_type.ob_type = &PyType_Type;
1213 PerlObj_type.ob_type = &PyType_Type;
1214 PerlSub_type.ob_type = &PyType_Type;
1215 #endif
1216
1217 /* Create the module and add the functions */
1218 #if PY_MAJOR_VERSION >= 3
1219 static struct PyModuleDef perl_module = {
1220 PyModuleDef_HEAD_INIT,
1221 "perl",
1222 "perl -- Access a Perl interpreter transparently",
1223 -1, /* m_size */
1224 perl_functions, /* m_methods */
1225 0, /* m_reload */
1226 0, /* m_traverse */
1227 0, /* m_clear */
1228 0 /* m_free */
1229 };
1230 m = PyModule_Create(&perl_module);
1231 #else
1232 m = Py_InitModule4("perl",
1233 perl_functions,
1234 "perl -- Access a Perl interpreter transparently",
1235 (PyObject*)NULL,
1236 PYTHON_API_VERSION);
1237 #endif
1238
1239 /* Now replace the package 'perl' with the 'perl' object */
1240 m = PyImport_AddModule("sys");
1241 d = PyModule_GetDict(m);
1242 d = PyDict_GetItemString(d, "modules");
1243 p = newPerlPkg_object(dummy1, dummy2);
1244 PyDict_SetItemString(d, "perl", p);
1245 Py_DECREF(p);
1246
1247 #ifdef CREATE_PERL
1248 create_perl();
1249 #endif
1250 PyExc_Perl = PyErr_NewException("perl.Exception", NULL, NULL);
1251
1252 Py_DECREF(dummy1);
1253 Py_DECREF(dummy2);
1254 }
1255