ce5366722ee07171212957e3e9accb4e28abdebe
[perl4caml.git] / perl_c.c
1 /* Interface to Perl from OCaml.
2    Copyright (C) 2003 Merjis Ltd.
3
4    This library is free software; you can redistribute it and/or
5    modify it under the terms of the GNU Library General Public
6    License as published by the Free Software Foundation; either
7    version 2 of the License, or (at your option) any later version.
8
9    This library is distributed in the hope that it will be useful,
10    but WITHOUT ANY WARRANTY; without even the implied warranty of
11    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12    Library General Public License for more details.
13
14    You should have received a copy of the GNU General Public License
15    along with this library; see the file COPYING.  If not, write to
16    the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
17    Boston, MA 02111-1307, USA.
18
19    $Id: perl_c.c,v 1.25 2008-03-01 13:02:21 rich Exp $
20  */
21
22 #include <stdio.h>
23 #include <stdlib.h>
24 #include <assert.h>
25 #include <unistd.h>
26 #include <alloca.h>
27
28 #define CAML_NAME_SPACE 1
29
30 #include <caml/alloc.h>
31 #include <caml/callback.h>
32 #include <caml/custom.h>
33 #include <caml/fail.h>
34 #include <caml/memory.h>
35 #include <caml/mlvalues.h>
36
37 #include <EXTERN.h>
38 #include <perl.h>
39
40 /* Perl requires the interpreter to be called literally 'my_perl'! */
41 static PerlInterpreter *my_perl;
42
43 /* Get the concrete value from an optional field. */
44 static value unoption (value option, value deflt);
45
46 /* Wrap up an arbitrary void pointer in an opaque OCaml object. */
47 static value Val_voidptr (void *ptr);
48
49 /* Unwrap an arbitrary void pointer from an opaque OCaml object. */
50 #define Voidptr_val(type,rv) ((type *) Field ((rv), 0))
51
52 #if PERL4CAML_REFCOUNTING_EXPERIMENTAL
53
54 /* Unwrap a custom block. */
55 #define Xv_val(rv) (*((void **)Data_custom_val(rv)))
56
57 /* Wrap up an SV, AV or HV in a custom OCaml object which will decrement
58  * the reference count on finalization.
59  */
60 static value Val_xv (SV *sv);
61
62 #else
63
64 #define Xv_val(rv) Voidptr_val (SV, (rv))
65 #define Val_xv(sv) Val_voidptr ((sv))
66
67 #endif
68
69 /* Hide Perl types in opaque OCaml objects. */
70 #define Val_perl(pl) (Val_voidptr ((pl)))
71 #define Perl_val(plv) (Voidptr_val (PerlInterpreter, (plv)))
72 #define Val_sv(sv) (Val_xv ((sv)))
73 #define Sv_val(svv) ((SV *) Xv_val (svv))
74 #define Val_av(av) (Val_xv ((SV *)(av)))
75 #define Av_val(avv) ((AV *) Xv_val (avv))
76 #define Val_hv(hv) (Val_xv ((SV *)(hv)))
77 #define Hv_val(hvv) ((HV *) Xv_val (hvv))
78 #define Val_he(he) (Val_voidptr ((he)))
79 #define He_val(hev) (Voidptr_val (HE, (hev)))
80
81 static void
82 xs_init (pTHX)
83 {
84   char *file = __FILE__;
85   EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
86
87   newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
88 }
89
90 CAMLprim value
91 perl4caml_init (value unit)
92 {
93   CAMLparam1 (unit);
94   int argc = 4;
95   static char *argv[] = { "", "-w", "-e", "0", NULL };
96
97   PERL_SYS_INIT (&argc, &argv);
98   my_perl = perl_alloc ();
99   perl_construct (my_perl);
100   PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
101   perl_parse (my_perl, xs_init, argc, argv, (char **) NULL);
102   /*perl_run (my_perl);*/
103
104   CAMLreturn (Val_unit);
105 }
106
107 CAMLprim value
108 perl4caml_int_of_sv (value svv)
109 {
110   CAMLparam1 (svv);
111   SV *sv = Sv_val (svv);
112   CAMLreturn (Val_int (SvIV (sv)));
113 }
114
115 CAMLprim value
116 perl4caml_sv_of_int (value iv)
117 {
118   CAMLparam1 (iv);
119   CAMLreturn (Val_sv (newSViv (Int_val (iv))));
120 }
121
122 CAMLprim value
123 perl4caml_float_of_sv (value svv)
124 {
125   CAMLparam1 (svv);
126   SV *sv = Sv_val (svv);
127   CAMLlocal1 (f);
128   f = caml_copy_double (SvNV (sv));
129   CAMLreturn (f);
130 }
131
132 CAMLprim value
133 perl4caml_sv_of_float (value fv)
134 {
135   CAMLparam1 (fv);
136   CAMLreturn (Val_sv (newSVnv (Double_val (fv))));
137 }
138
139 CAMLprim value
140 perl4caml_string_of_sv (value svv)
141 {
142   CAMLparam1 (svv);
143   SV *sv = Sv_val (svv);
144   char *str;
145   STRLEN len;
146   CAMLlocal1 (strv);
147   str = SvPV (sv, len);
148   strv = caml_alloc_string (len);
149   memcpy (String_val (strv), str, len);
150   CAMLreturn (strv);
151 }
152
153 CAMLprim value
154 perl4caml_sv_of_string (value strv)
155 {
156   CAMLparam1 (strv);
157   CAMLreturn (Val_sv (newSVpv (String_val (strv), caml_string_length (strv))));
158 }
159
160 CAMLprim value
161 perl4caml_sv_is_true (value svv)
162 {
163   CAMLparam1 (svv);
164   SV *sv = Sv_val (svv);
165   CAMLreturn (SvTRUE (sv) ? Val_true : Val_false);
166 }
167
168 CAMLprim value
169 perl4caml_sv_undef (value unit)
170 {
171   CAMLparam1 (unit);
172   /*CAMLreturn (Val_sv (newSV (0)));*/
173   CAMLreturn (Val_sv (&PL_sv_undef));
174 }
175
176 CAMLprim value
177 perl4caml_sv_is_undef (value svv)
178 {
179   CAMLparam1 (svv);
180   SV *sv = Sv_val (svv);
181   CAMLreturn (!SvPOK (sv) && !SvIOK (sv) && SvTYPE (sv) == SVt_NULL
182               ? Val_true : Val_false);
183 }
184
185 CAMLprim value
186 perl4caml_sv_yes (value unit)
187 {
188   CAMLparam1 (unit);
189   CAMLreturn (Val_sv (&PL_sv_yes));
190 }
191
192 CAMLprim value
193 perl4caml_sv_no (value unit)
194 {
195   CAMLparam1 (unit);
196   CAMLreturn (Val_sv (&PL_sv_no));
197 }
198
199 static int
200 sv_type (SV *sv)
201 {
202 #if PERL_VERSION >= 11
203   if (SvROK(sv)) return 4;
204 #endif
205   switch (SvTYPE (sv))
206     {
207     case SVt_IV: return 1;
208     case SVt_NV: return 2;
209     case SVt_PV: return 3;
210 #if PERL_VERSION < 11
211     case SVt_RV: return 4;
212 #endif
213     case SVt_PVAV: return 5;
214     case SVt_PVHV: return 6;
215     case SVt_PVCV: return 7;
216     case SVt_PVGV: return 8;
217     case SVt_PVMG: return 9;
218     default: return 0;
219     }
220 }
221
222 CAMLprim value
223 perl4caml_sv_type (value svv)
224 {
225   CAMLparam1 (svv);
226   SV *sv = Sv_val (svv);
227
228   CAMLreturn (Val_int (sv_type (sv)));
229 }
230
231 CAMLprim value
232 perl4caml_address_of_sv (value svv)
233 {
234   CAMLparam1 (svv);
235   SV *sv = Sv_val (svv);
236   CAMLreturn (caml_copy_nativeint ((long) sv));
237 }
238
239 CAMLprim value
240 perl4caml_address_of_av (value avv)
241 {
242   CAMLparam1 (avv);
243   AV *av = Av_val (avv);
244   CAMLreturn (caml_copy_nativeint ((long) av));
245 }
246
247 CAMLprim value
248 perl4caml_address_of_hv (value hvv)
249 {
250   CAMLparam1 (hvv);
251   HV *hv = Hv_val (hvv);
252   CAMLreturn (caml_copy_nativeint ((long) hv));
253 }
254
255 CAMLprim value
256 perl4caml_scalarref (value svv)
257 {
258   CAMLparam1 (svv);
259   CAMLlocal1 (rsvv);
260   SV *sv = Sv_val (svv);
261   rsvv = Val_sv (newRV_inc (sv));
262   CAMLreturn (rsvv);
263 }
264
265 CAMLprim value
266 perl4caml_arrayref (value avv)
267 {
268   CAMLparam1 (avv);
269   CAMLlocal1 (rsvv);
270   AV *av = Av_val (avv);
271   rsvv = Val_sv (newRV_inc ((SV *) av));
272   CAMLreturn (rsvv);
273 }
274
275 CAMLprim value
276 perl4caml_hashref (value hvv)
277 {
278   CAMLparam1 (hvv);
279   CAMLlocal1 (rsvv);
280   HV *hv = Hv_val (hvv);
281   rsvv = Val_sv (newRV_inc ((SV *) hv));
282   CAMLreturn (rsvv);
283 }
284
285 CAMLprim value
286 perl4caml_reftype (value svv)
287 {
288   CAMLparam1 (svv);
289   SV *sv = Sv_val (svv);
290
291   if (!SvROK (sv))
292     caml_invalid_argument ("reftype: SV is not a reference");
293
294   CAMLreturn (Val_int (sv_type (SvRV (sv))));
295 }
296
297 CAMLprim value
298 perl4caml_deref (value svv)
299 {
300   CAMLparam1 (svv);
301   CAMLlocal1 (rsvv);
302   SV *sv = Sv_val (svv);
303
304   if (!SvROK (sv))
305     caml_invalid_argument ("deref: SV is not a reference");
306   switch (SvTYPE (SvRV (sv))) {
307   case SVt_IV:
308   case SVt_NV:
309   case SVt_PV:
310 #if PERL_VERSION < 11
311   case SVt_RV:
312 #endif
313   case SVt_PVMG:
314     break;
315   default:
316     caml_invalid_argument ("deref: SV is not a reference to a scalar");
317   }
318   sv = SvRV (sv);
319   /* Increment the reference count because we're creating another
320    * value pointing at the referenced SV.
321    */
322   sv = SvREFCNT_inc (sv);
323   rsvv = Val_sv (sv);
324   CAMLreturn (rsvv);
325 }
326
327 CAMLprim value
328 perl4caml_deref_array (value svv)
329 {
330   CAMLparam1 (svv);
331   CAMLlocal1 (ravv);
332   SV *sv = Sv_val (svv);
333
334   if (!SvROK (sv))
335     caml_invalid_argument ("deref_array: SV is not a reference");
336   switch (SvTYPE (SvRV (sv))) {
337   case SVt_PVAV:
338     break;
339   default:
340     caml_invalid_argument ("deref_array: SV is not a reference to an array");
341   }
342   sv = SvRV (sv);
343   /* Increment the reference count because we're creating another
344    * value pointing at the referenced AV.
345    */
346   sv = SvREFCNT_inc (sv);
347   ravv = Val_av ((AV *) sv);
348   CAMLreturn (ravv);
349 }
350
351 CAMLprim value
352 perl4caml_deref_hash (value svv)
353 {
354   CAMLparam1 (svv);
355   CAMLlocal1 (rhvv);
356   SV *sv = Sv_val (svv);
357
358   if (!SvROK (sv))
359     caml_invalid_argument ("deref_hash: SV is not a reference");
360   switch (SvTYPE (SvRV (sv))) {
361   case SVt_PVHV:
362     break;
363   default:
364     caml_invalid_argument ("deref_hash: SV is not a reference to a hash");
365   }
366   sv = SvRV (sv);
367   /* Increment the reference count because we're creating another
368    * value pointing at the referenced HV.
369    */
370   sv = SvREFCNT_inc (sv);
371   rhvv = Val_hv ((HV *) sv);
372   CAMLreturn (rhvv);
373 }
374
375 CAMLprim value
376 perl4caml_av_empty (value unit)
377 {
378   CAMLparam1 (unit);
379   AV *av = newAV ();
380   CAMLreturn (Val_av (av));
381 }
382
383 /* We don't know in advance how long the list will be, which makes this
384  * a little harder.
385  */
386 CAMLprim value
387 perl4caml_av_of_sv_list (value svlistv)
388 {
389   CAMLparam1 (svlistv);
390   CAMLlocal1 (svv);
391   SV *sv, **svlist = 0;
392   int alloc = 0, size = 0;
393   AV *av;
394
395   for (; svlistv != Val_int (0); svlistv = Field (svlistv, 1))
396     {
397       svv = Field (svlistv, 0);
398       sv = Sv_val (svv);
399       if (size >= alloc) {
400         alloc = alloc == 0 ? 1 : alloc * 2;
401         svlist = realloc (svlist, alloc * sizeof (SV *));
402       }
403       svlist[size++] = sv;
404     }
405
406   av = av_make (size, svlist);
407
408   if (alloc > 0) free (svlist); /* Free memory allocated to SV list. */
409
410   CAMLreturn (Val_av (av));
411 }
412
413 /* XXX av_map would be faster if we also had sv_list_of_av. */
414
415 CAMLprim value
416 perl4caml_av_push (value avv, value svv)
417 {
418   CAMLparam2 (avv, svv);
419   AV *av = Av_val (avv);
420   SV *sv = Sv_val (svv);
421   av_push (av, sv);
422   CAMLreturn (Val_unit);
423 }
424
425 CAMLprim value
426 perl4caml_av_pop (value avv)
427 {
428   CAMLparam1 (avv);
429   AV *av = Av_val (avv);
430   SV *sv = av_pop (av);
431   /* Increment the reference count because we're creating another
432    * value pointing at the referenced AV.
433    */
434   sv = SvREFCNT_inc (sv);
435   CAMLreturn (Val_sv (sv));
436 }
437
438 CAMLprim value
439 perl4caml_av_unshift (value avv, value svv)
440 {
441   CAMLparam2 (avv, svv);
442   AV *av = Av_val (avv);
443   SV *sv = Sv_val (svv);
444   av_unshift (av, 1);
445   SvREFCNT_inc (sv);
446   if (av_store (av, 0, sv) == 0)
447     SvREFCNT_dec (sv);
448   CAMLreturn (Val_unit);
449 }
450
451 CAMLprim value
452 perl4caml_av_shift (value avv)
453 {
454   CAMLparam1 (avv);
455   AV *av = Av_val (avv);
456   SV *sv = av_shift (av);
457   /* Increment the reference count because we're creating another
458    * value pointing at the referenced AV.
459    */
460   sv = SvREFCNT_inc (sv);
461   CAMLreturn (Val_sv (sv));
462 }
463
464 CAMLprim value
465 perl4caml_av_length (value avv)
466 {
467   CAMLparam1 (avv);
468   AV *av = Av_val (avv);
469   CAMLreturn (Val_int (av_len (av) + 1));
470 }
471
472 CAMLprim value
473 perl4caml_av_set (value avv, value i, value svv)
474 {
475   CAMLparam3 (avv, i, svv);
476   AV *av = Av_val (avv);
477   SV *sv = Sv_val (svv);
478   SvREFCNT_inc (sv);
479   if (av_store (av, Int_val (i), sv) == 0)
480     SvREFCNT_dec (sv);
481   CAMLreturn (Val_unit);
482 }
483
484 CAMLprim value
485 perl4caml_av_get (value avv, value i)
486 {
487   CAMLparam2 (avv, i);
488   AV *av = Av_val (avv);
489   SV **svp = av_fetch (av, Int_val (i), 0);
490   if (svp == 0) caml_invalid_argument ("av_get: index out of bounds");
491   /* Increment the reference count because we're creating another
492    * value pointing at the referenced AV.
493    */
494   *svp = SvREFCNT_inc (*svp);
495   CAMLreturn (Val_sv (*svp));
496 }
497
498 CAMLprim value
499 perl4caml_av_clear (value avv)
500 {
501   CAMLparam1 (avv);
502   AV *av = Av_val (avv);
503   av_clear (av);
504   CAMLreturn (Val_unit);
505 }
506
507 CAMLprim value
508 perl4caml_av_undef (value avv)
509 {
510   CAMLparam1 (avv);
511   AV *av = Av_val (avv);
512   av_undef (av);
513   CAMLreturn (Val_unit);
514 }
515
516 CAMLprim value
517 perl4caml_av_extend (value avv, value i)
518 {
519   CAMLparam2 (avv, i);
520   AV *av = Av_val (avv);
521   av_extend (av, Int_val (i));
522   CAMLreturn (Val_unit);
523 }
524
525 CAMLprim value
526 perl4caml_hv_empty (value unit)
527 {
528   CAMLparam1 (unit);
529   HV *hv = newHV ();
530   CAMLreturn (Val_hv (hv));
531 }
532
533 CAMLprim value
534 perl4caml_hv_set (value hvv, value key, value svv)
535 {
536   CAMLparam3 (hvv, key, svv);
537   HV *hv = Hv_val (hvv);
538   SV *sv = Sv_val (svv);
539   SvREFCNT_inc (sv);
540   if (hv_store (hv, String_val (key), caml_string_length (key), sv, 0) == 0)
541     SvREFCNT_dec (sv);
542   CAMLreturn (Val_unit);
543 }
544
545 CAMLprim value
546 perl4caml_hv_get (value hvv, value key)
547 {
548   CAMLparam2 (hvv, key);
549   HV *hv = Hv_val (hvv);
550   SV **svp = hv_fetch (hv, String_val (key), caml_string_length (key), 0);
551   if (svp == 0) caml_raise_not_found ();
552   /* Increment the reference count because we're creating another
553    * value pointing at the referenced SV.
554    */
555   SvREFCNT_inc (*svp);
556   CAMLreturn (Val_sv (*svp));
557 }
558
559 CAMLprim value
560 perl4caml_hv_exists (value hvv, value key)
561 {
562   CAMLparam2 (hvv, key);
563   HV *hv = Hv_val (hvv);
564   bool r = hv_exists (hv, String_val (key), caml_string_length (key));
565   CAMLreturn (r ? Val_true : Val_false);
566 }
567
568 CAMLprim value
569 perl4caml_hv_delete (value hvv, value key)
570 {
571   CAMLparam2 (hvv, key);
572   HV *hv = Hv_val (hvv);
573   hv_delete (hv, String_val (key), caml_string_length (key), G_DISCARD);
574   CAMLreturn (Val_unit);
575 }
576
577 CAMLprim value
578 perl4caml_hv_clear (value hvv)
579 {
580   CAMLparam1 (hvv);
581   HV *hv = Hv_val (hvv);
582   hv_clear (hv);
583   CAMLreturn (Val_unit);
584 }
585
586 CAMLprim value
587 perl4caml_hv_undef (value hvv)
588 {
589   CAMLparam1 (hvv);
590   HV *hv = Hv_val (hvv);
591   hv_undef (hv);
592   CAMLreturn (Val_unit);
593 }
594
595 CAMLprim value
596 perl4caml_hv_iterinit (value hvv)
597 {
598   CAMLparam1 (hvv);
599   HV *hv = Hv_val (hvv);
600   int i = hv_iterinit (hv);
601   CAMLreturn (caml_copy_int32 (i));
602 }
603
604 CAMLprim value
605 perl4caml_hv_iternext (value hvv)
606 {
607   CAMLparam1 (hvv);
608   CAMLlocal1 (hev);
609   HV *hv = Hv_val (hvv);
610   HE *he = hv_iternext (hv);
611   if (he == NULL) caml_raise_not_found ();
612   hev = Val_he (he);
613   CAMLreturn (hev);
614 }
615
616 CAMLprim value
617 perl4caml_hv_iterkey (value hev)
618 {
619   CAMLparam1 (hev);
620   CAMLlocal1 (strv);
621   HE *he = He_val (hev);
622   I32 len;
623   char *str = hv_iterkey (he, &len);
624   strv = caml_alloc_string (len);
625   memcpy (String_val (strv), str, len);
626   CAMLreturn (strv);
627 }
628
629 CAMLprim value
630 perl4caml_hv_iterval (value hvv, value hev)
631 {
632   CAMLparam2 (hvv, hev);
633   CAMLlocal1 (svv);
634   HV *hv = Hv_val (hvv);
635   HE *he = He_val (hev);
636   SV *sv = hv_iterval (hv, he);
637   SvREFCNT_inc (sv);
638   svv = Val_sv (sv);
639   CAMLreturn (svv);
640 }
641
642 CAMLprim value
643 perl4caml_hv_iternextsv (value hvv)
644 {
645   CAMLparam1 (hvv);
646   CAMLlocal3 (strv, svv, rv);
647   HV *hv = Hv_val (hvv);
648   char *str; I32 len;
649   SV *sv = hv_iternextsv (hv, &str, &len);
650   if (sv == NULL) caml_raise_not_found ();
651   SvREFCNT_inc (sv);
652   svv = Val_sv (sv);
653   strv = caml_alloc_string (len);
654   memcpy (String_val (strv), str, len);
655   /* Construct a tuple (strv, svv). */
656   rv = caml_alloc_tuple (2);
657   Field (rv, 0) = strv;
658   Field (rv, 1) = svv;
659   CAMLreturn (rv);
660 }
661
662 CAMLprim value
663 perl4caml_get_sv (value optcreate, value name)
664 {
665   CAMLparam2 (optcreate, name);
666   CAMLlocal1 (create);
667   SV *sv;
668
669   create = unoption (optcreate, Val_false);
670   sv = get_sv (String_val (name), create == Val_true ? TRUE : FALSE);
671   if (sv == NULL) caml_raise_not_found ();
672
673   /* Increment the reference count because we're creating another
674    * value pointing at the referenced SV.
675    */
676   SvREFCNT_inc (sv);
677
678   CAMLreturn (Val_sv (sv));
679 }
680
681 CAMLprim value
682 perl4caml_get_av (value optcreate, value name)
683 {
684   CAMLparam2 (optcreate, name);
685   CAMLlocal1 (create);
686   AV *av;
687
688   create = unoption (optcreate, Val_false);
689   av = get_av (String_val (name), create == Val_true ? TRUE : FALSE);
690   if (av == NULL) caml_raise_not_found ();
691
692   /* Increment the reference count because we're creating another
693    * value pointing at the AV.
694    */
695   SvREFCNT_inc (av);
696
697   CAMLreturn (Val_av (av));
698 }
699
700 CAMLprim value
701 perl4caml_get_hv (value optcreate, value name)
702 {
703   CAMLparam2 (optcreate, name);
704   CAMLlocal1 (create);
705   HV *hv;
706
707   create = unoption (optcreate, Val_false);
708   hv = get_hv (String_val (name), create == Val_true ? TRUE : FALSE);
709   if (hv == NULL) caml_raise_not_found ();
710
711   /* Increment the reference count because we're creating another
712    * value pointing at the HV.
713    */
714   SvREFCNT_inc (hv);
715
716   CAMLreturn (Val_hv (hv));
717 }
718
719 static inline void
720 check_perl_failure ()
721 {
722   CAMLparam0 ();
723   CAMLlocal1 (errv);
724
725   SV *errsv = get_sv ("@", TRUE);
726
727   if (SvTRUE (errsv))           /* Equivalent of $@ in Perl. */
728     {
729       STRLEN n_a;
730       const char *err = SvPV (errsv, n_a);
731
732       errv = caml_copy_string (err);
733
734       caml_raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
735     }
736
737   CAMLreturn0;
738 }
739
740 CAMLprim value
741 perl4caml_call (value optsv, value optfnname, value arglist)
742 {
743   CAMLparam3 (optsv, optfnname, arglist);
744   dSP;
745   int count;
746   SV *sv;
747   CAMLlocal3 (errv, svv, fnname);
748
749   ENTER;
750   SAVETMPS;
751
752   /* Push the parameter list. */
753   PUSHMARK (SP);
754
755   /* Iteration over the linked list. */
756   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
757     {
758       svv = Field (arglist, 0);
759       sv = Sv_val (svv);
760       XPUSHs (sv_2mortal (newSVsv (sv)));
761     }
762
763   PUTBACK;
764
765   if (optsv != Val_int (0))
766     {
767       svv = unoption (optsv, Val_false);
768       sv = Sv_val (svv);
769       count = call_sv (sv, G_EVAL|G_SCALAR);
770     }
771   else if (optfnname != Val_int (0))
772     {
773       fnname = unoption (optfnname, Val_false);
774       count = call_pv (String_val (fnname), G_EVAL|G_SCALAR);
775     }
776   else
777     {
778       fprintf (stderr,
779                "Perl.call: must supply either 'sv' or 'fn' parameters.");
780       abort ();
781     }
782
783   SPAGAIN;
784
785   assert (count == 1); /* Pretty sure it should never be anything else. */
786
787   /* Pop return value off the stack. Note that the return value on the
788    * stack is mortal, so we need to take a copy.
789    */
790   sv = newSVsv (POPs);
791   PUTBACK;
792   FREETMPS;
793   LEAVE;
794
795   check_perl_failure ();
796
797   svv = Val_sv (sv);
798   CAMLreturn (svv);
799 }
800
801 CAMLprim value
802 perl4caml_call_array (value optsv, value optfnname, value arglist)
803 {
804   CAMLparam3 (optsv, optfnname, arglist);
805   dSP;
806   int i, count;
807   SV *sv;
808   CAMLlocal5 (errv, svv, fnname, list, cons);
809
810   ENTER;
811   SAVETMPS;
812
813   /* Push the parameter list. */
814   PUSHMARK (SP);
815
816   /* Iteration over the linked list. */
817   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
818     {
819       svv = Field (arglist, 0);
820       sv = Sv_val (svv);
821       XPUSHs (sv_2mortal (newSVsv (sv)));
822     }
823
824   PUTBACK;
825
826   if (optsv != Val_int (0))
827     {
828       svv = unoption (optsv, Val_false);
829       sv = Sv_val (svv);
830       count = call_sv (sv, G_EVAL|G_ARRAY);
831     }
832   else if (optfnname != Val_int (0))
833     {
834       fnname = unoption (optfnname, Val_false);
835       count = call_pv (String_val (fnname), G_EVAL|G_ARRAY);
836     }
837   else
838     {
839       fprintf (stderr,
840                "Perl.call_array: must supply either 'sv' or 'fn' parameters.");
841       abort ();
842     }
843
844   SPAGAIN;
845
846   /* Pop all the return values off the stack into a list. Values on the
847    * stack are mortal, so we must copy them.
848    */
849   list = Val_int (0);
850   for (i = 0; i < count; ++i) {
851     SV *sv;
852
853     cons = caml_alloc (2, 0);
854     Field (cons, 1) = list;
855     list = cons;
856     sv = newSVsv (POPs);
857     Field (cons, 0) = Val_sv (sv);
858   }
859
860   /* Restore the stack. */
861   PUTBACK;
862   FREETMPS;
863   LEAVE;
864
865   check_perl_failure ();
866
867   CAMLreturn (list);
868 }
869
870 CAMLprim value
871 perl4caml_call_void (value optsv, value optfnname, value arglist)
872 {
873   CAMLparam3 (optsv, optfnname, arglist);
874   dSP;
875   int count;
876   SV *sv;
877   CAMLlocal3 (errv, svv, fnname);
878
879   ENTER;
880   SAVETMPS;
881
882   /* Push the parameter list. */
883   PUSHMARK (SP);
884
885   /* Iteration over the linked list. */
886   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
887     {
888       svv = Field (arglist, 0);
889       sv = Sv_val (svv);
890       XPUSHs (sv_2mortal (newSVsv (sv)));
891     }
892
893   PUTBACK;
894
895   if (optsv != Val_int (0))
896     {
897       svv = unoption (optsv, Val_false);
898       sv = Sv_val (svv);
899       count = call_sv (sv, G_EVAL|G_VOID);
900     }
901   else if (optfnname != Val_int (0))
902     {
903       fnname = unoption (optfnname, Val_false);
904       count = call_pv (String_val (fnname), G_EVAL|G_VOID|G_DISCARD);
905     }
906   else
907     {
908       fprintf (stderr,
909                "Perl.call_void: must supply either 'sv' or 'fn' parameters.");
910       abort ();
911     }
912
913   SPAGAIN;
914
915   assert (count == 0);
916
917   /* Restore the stack. */
918   PUTBACK;
919   FREETMPS;
920   LEAVE;
921
922   check_perl_failure ();
923
924   CAMLreturn (Val_unit);
925 }
926
927 CAMLprim value
928 perl4caml_eval (value expr)
929 {
930   CAMLparam1 (expr);
931   dSP;
932   SV *sv;
933   CAMLlocal2 (errv, svv);
934
935   sv = eval_pv (String_val (expr), G_SCALAR);
936
937   check_perl_failure ();
938
939   svv = Val_sv (sv);
940   CAMLreturn (svv);
941 }
942
943 CAMLprim value
944 perl4caml_call_method (value ref, value name, value arglist)
945 {
946   CAMLparam3 (ref, name, arglist);
947   dSP;
948   int count;
949   SV *sv;
950   CAMLlocal2 (errv, svv);
951
952   ENTER;
953   SAVETMPS;
954
955   /* Push the parameter list. */
956   PUSHMARK (SP);
957
958   sv = Sv_val (ref);
959   XPUSHs (sv_2mortal (newSVsv (sv)));
960
961   /* Iteration over the linked list. */
962   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
963     {
964       svv = Field (arglist, 0);
965       sv = Sv_val (svv);
966       XPUSHs (sv_2mortal (newSVsv (sv)));
967     }
968
969   PUTBACK;
970
971   count = call_method (String_val (name), G_EVAL|G_SCALAR);
972
973   SPAGAIN;
974
975   assert (count == 1); /* Pretty sure it should never be anything else. */
976
977   /* Pop return value off the stack. Note that the return value on the
978    * stack is mortal, so we need to take a copy.
979    */
980   sv = newSVsv (POPs);
981   PUTBACK;
982   FREETMPS;
983   LEAVE;
984
985   check_perl_failure ();
986
987   svv = Val_sv (sv);
988   CAMLreturn (svv);
989 }
990
991 CAMLprim value
992 perl4caml_call_method_array (value ref, value name, value arglist)
993 {
994   CAMLparam3 (ref, name, arglist);
995   dSP;
996   int count, i;
997   SV *sv;
998   CAMLlocal4 (errv, svv, list, cons);
999
1000   ENTER;
1001   SAVETMPS;
1002
1003   /* Push the parameter list. */
1004   PUSHMARK (SP);
1005
1006   sv = Sv_val (ref);
1007   XPUSHs (sv_2mortal (newSVsv (sv)));
1008
1009   /* Iteration over the linked list. */
1010   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
1011     {
1012       svv = Field (arglist, 0);
1013       sv = Sv_val (svv);
1014       XPUSHs (sv_2mortal (newSVsv (sv)));
1015     }
1016
1017   PUTBACK;
1018
1019   count = call_method (String_val (name), G_EVAL|G_ARRAY);
1020
1021   SPAGAIN;
1022
1023   /* Pop all return values off the stack. Note that the return values on the
1024    * stack are mortal, so we need to take a copy.
1025    */
1026   list = Val_int (0);
1027   for (i = 0; i < count; ++i) {
1028     SV *sv;
1029
1030     cons = caml_alloc (2, 0);
1031     Field (cons, 1) = list;
1032     list = cons;
1033     sv = newSVsv (POPs);
1034     Field (cons, 0) = Val_sv (sv);
1035   }
1036
1037   /* Restore the stack. */
1038   PUTBACK;
1039   FREETMPS;
1040   LEAVE;
1041
1042   check_perl_failure ();
1043
1044   CAMLreturn (list);
1045 }
1046
1047 CAMLprim value
1048 perl4caml_call_method_void (value ref, value name, value arglist)
1049 {
1050   CAMLparam3 (ref, name, arglist);
1051   dSP;
1052   int count;
1053   SV *sv;
1054   CAMLlocal2 (errv, svv);
1055
1056   ENTER;
1057   SAVETMPS;
1058
1059   /* Push the parameter list. */
1060   PUSHMARK (SP);
1061
1062   sv = Sv_val (ref);
1063   XPUSHs (sv_2mortal (newSVsv (sv)));
1064
1065   /* Iteration over the linked list. */
1066   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
1067     {
1068       svv = Field (arglist, 0);
1069       sv = Sv_val (svv);
1070       XPUSHs (sv_2mortal (newSVsv (sv)));
1071     }
1072
1073   PUTBACK;
1074
1075   count = call_method (String_val (name), G_EVAL|G_VOID|G_DISCARD);
1076
1077   SPAGAIN;
1078
1079   assert (count == 0);
1080
1081   /* Restore the stack. */
1082   PUTBACK;
1083   FREETMPS;
1084   LEAVE;
1085
1086   check_perl_failure ();
1087
1088   CAMLreturn (Val_unit);
1089 }
1090
1091 CAMLprim value
1092 perl4caml_call_class_method (value classname, value name, value arglist)
1093 {
1094   CAMLparam3 (classname, name, arglist);
1095   dSP;
1096   int count;
1097   SV *sv;
1098   CAMLlocal2 (errv, svv);
1099
1100   ENTER;
1101   SAVETMPS;
1102
1103   /* Push the parameter list. */
1104   PUSHMARK (SP);
1105
1106   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
1107
1108   /* Iteration over the linked list. */
1109   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
1110     {
1111       svv = Field (arglist, 0);
1112       sv = Sv_val (svv);
1113       XPUSHs (sv_2mortal (newSVsv (sv)));
1114     }
1115
1116   PUTBACK;
1117
1118   count = call_method (String_val (name), G_EVAL|G_SCALAR);
1119
1120   SPAGAIN;
1121
1122   assert (count == 1); /* Pretty sure it should never be anything else. */
1123
1124   /* Pop return value off the stack. Note that the return value on the
1125    * stack is mortal, so we need to take a copy.
1126    */
1127   sv = newSVsv (POPs);
1128   PUTBACK;
1129   FREETMPS;
1130   LEAVE;
1131
1132   check_perl_failure ();
1133
1134   svv = Val_sv (sv);
1135   CAMLreturn (svv);
1136 }
1137
1138 CAMLprim value
1139 perl4caml_call_class_method_array (value classname, value name, value arglist)
1140 {
1141   CAMLparam3 (classname, name, arglist);
1142   dSP;
1143   int count, i;
1144   SV *sv;
1145   CAMLlocal4 (errv, svv, list, cons);
1146
1147   ENTER;
1148   SAVETMPS;
1149
1150   /* Push the parameter list. */
1151   PUSHMARK (SP);
1152
1153   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
1154
1155   /* Iteration over the linked list. */
1156   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
1157     {
1158       svv = Field (arglist, 0);
1159       sv = Sv_val (svv);
1160       XPUSHs (sv_2mortal (newSVsv (sv)));
1161     }
1162
1163   PUTBACK;
1164
1165   count = call_method (String_val (name), G_EVAL|G_ARRAY);
1166
1167   SPAGAIN;
1168
1169   /* Pop all return values off the stack. Note that the return values on the
1170    * stack are mortal, so we need to take a copy.
1171    */
1172   list = Val_int (0);
1173   for (i = 0; i < count; ++i) {
1174     cons = caml_alloc (2, 0);
1175     Field (cons, 1) = list;
1176     list = cons;
1177     Field (cons, 0) = Val_sv (newSVsv (POPs));
1178   }
1179
1180   /* Restore the stack. */
1181   PUTBACK;
1182   FREETMPS;
1183   LEAVE;
1184
1185   check_perl_failure ();
1186
1187   CAMLreturn (list);
1188 }
1189
1190 CAMLprim value
1191 perl4caml_call_class_method_void (value classname, value name, value arglist)
1192 {
1193   CAMLparam3 (classname, name, arglist);
1194   dSP;
1195   int count;
1196   SV *sv;
1197   CAMLlocal2 (errv, svv);
1198
1199   ENTER;
1200   SAVETMPS;
1201
1202   /* Push the parameter list. */
1203   PUSHMARK (SP);
1204
1205   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
1206
1207   /* Iteration over the linked list. */
1208   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
1209     {
1210       svv = Field (arglist, 0);
1211       sv = Sv_val (svv);
1212       XPUSHs (sv_2mortal (newSVsv (sv)));
1213     }
1214
1215   PUTBACK;
1216
1217   count = call_method (String_val (name), G_EVAL|G_VOID|G_DISCARD);
1218
1219   SPAGAIN;
1220
1221   assert (count == 0);
1222
1223   /* Restore the stack. */
1224   PUTBACK;
1225   FREETMPS;
1226   LEAVE;
1227
1228   check_perl_failure ();
1229
1230   CAMLreturn (Val_unit);
1231 }
1232
1233 static value
1234 Val_voidptr (void *ptr)
1235 {
1236   CAMLparam0 ();
1237   CAMLlocal1 (rv);
1238   rv = caml_alloc (1, Abstract_tag);
1239   Field(rv, 0) = (value) ptr;
1240   CAMLreturn (rv);
1241 }
1242
1243 #if PERL4CAML_REFCOUNTING_EXPERIMENTAL
1244
1245 static void
1246 xv_finalize (value v)
1247 {
1248   /*fprintf (stderr, "about to decrement %p\n", Xv_val (v));*/
1249   SvREFCNT_dec ((SV *) Xv_val (v));
1250 }
1251
1252 static struct custom_operations xv_custom_operations = {
1253   "xv_custom_operations",
1254   xv_finalize,
1255   custom_compare_default,
1256   custom_hash_default,
1257   custom_serialize_default,
1258   custom_deserialize_default
1259 };
1260
1261 static value
1262 Val_xv (SV *sv)
1263 {
1264   CAMLparam0 ();
1265   CAMLlocal1 (rv);
1266   rv = caml_alloc_custom (&xv_custom_operations, sizeof (void *), 0, 1);
1267   Xv_val (rv) = sv;
1268   CAMLreturn (rv);
1269 }
1270
1271 #endif /* PERL4CAML_REFCOUNTING_EXPERIMENTAL */
1272
1273 static value
1274 unoption (value option, value deflt)
1275 {
1276   if (option == Val_int (0))    /* "None" */
1277     return deflt;
1278   else                          /* "Some 'a" */
1279     return Field (option, 0);
1280 }