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