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