Added META (package information) for perl4caml.
[perl4caml.git] / perl_c.c
1 /* Interface to Perl from OCaml.
2  * Copyright (C) 2003 Merjis Ltd.
3  * $Id: perl_c.c,v 1.8 2003-10-18 12:36: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 #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_deref (value svv)
245 {
246   CAMLparam1 (svv);
247   CAMLlocal1 (rsvv);
248   SV *sv = Sv_val (svv);
249
250   if (SvTYPE (sv) != SVt_RV)
251     invalid_argument ("deref: SV is not a reference");
252   switch (SvTYPE (SvRV (sv))) {
253   case SVt_IV:
254   case SVt_NV:
255   case SVt_PV:
256   case SVt_RV:
257   case SVt_PVMG:
258     break;
259   default:
260     invalid_argument ("deref: SV is not a reference to a scalar");
261   }
262   rsvv = Val_sv (SvRV (sv));
263   CAMLreturn (rsvv);
264 }
265
266 CAMLprim value
267 perl4caml_deref_array (value svv)
268 {
269   CAMLparam1 (svv);
270   CAMLlocal1 (ravv);
271   SV *sv = Sv_val (svv);
272
273   if (SvTYPE (sv) != SVt_RV)
274     invalid_argument ("deref_array: SV is not a reference");
275   switch (SvTYPE (SvRV (sv))) {
276   case SVt_PVAV:
277     break;
278   default:
279     invalid_argument ("deref_array: SV is not a reference to an array");
280   }
281   ravv = Val_av ((AV *) SvRV (sv));
282   CAMLreturn (ravv);
283 }
284
285 CAMLprim value
286 perl4caml_deref_hash (value svv)
287 {
288   CAMLparam1 (svv);
289   CAMLlocal1 (rhvv);
290   SV *sv = Sv_val (svv);
291
292   if (SvTYPE (sv) != SVt_RV)
293     invalid_argument ("deref_array: SV is not a reference");
294   switch (SvTYPE (SvRV (sv))) {
295   case SVt_PVHV:
296     break;
297   default:
298     invalid_argument ("deref_array: SV is not a reference to a hash");
299   }
300   rhvv = Val_hv ((HV *) SvRV (sv));
301   CAMLreturn (rhvv);
302 }
303
304 CAMLprim value
305 perl4caml_av_empty (value unit)
306 {
307   CAMLparam1 (unit);
308   AV *av = newAV ();
309   CAMLreturn (Val_av (av));
310 }
311
312 /* We don't know in advance how long the list will be, which makes this
313  * a little harder.
314  */
315 CAMLprim value
316 perl4caml_av_of_sv_list (value svlistv)
317 {
318   CAMLparam1 (svlistv);
319   CAMLlocal1 (svv);
320   SV *sv, **svlist = 0;
321   int alloc = 0, size = 0;
322   AV *av;
323
324   for (; svlistv != Val_int (0); svlistv = Field (svlistv, 1))
325     {
326       svv = Field (svlistv, 0);
327       sv = Sv_val (svv);
328       if (size >= alloc) {
329         alloc = alloc == 0 ? 1 : alloc * 2;
330         svlist = realloc (svlist, alloc * sizeof (SV *));
331       }
332       svlist[size++] = sv;
333     }
334
335   av = av_make (size, svlist);
336
337   if (alloc > 0) free (svlist); /* Free memory allocated to SV list. */
338
339   CAMLreturn (Val_av (av));
340 }
341
342 /* XXX av_map would be faster if we also had sv_list_of_av. */
343
344 CAMLprim value
345 perl4caml_av_push (value avv, value svv)
346 {
347   CAMLparam2 (avv, svv);
348   AV *av = Av_val (avv);
349   SV *sv = Sv_val (svv);
350   av_push (av, sv);
351   CAMLreturn (Val_unit);
352 }
353
354 CAMLprim value
355 perl4caml_av_pop (value avv)
356 {
357   CAMLparam1 (avv);
358   AV *av = Av_val (avv);
359   SV *sv = av_pop (av);
360   CAMLreturn (Val_sv (sv));
361 }
362
363 CAMLprim value
364 perl4caml_av_unshift (value avv, value svv)
365 {
366   CAMLparam2 (avv, svv);
367   AV *av = Av_val (avv);
368   SV *sv = Sv_val (svv);
369   av_unshift (av, 1);
370   SvREFCNT_inc (sv);
371   if (av_store (av, 0, sv) == 0)
372     SvREFCNT_dec (sv);
373   CAMLreturn (Val_unit);
374 }
375
376 CAMLprim value
377 perl4caml_av_shift (value avv)
378 {
379   CAMLparam1 (avv);
380   AV *av = Av_val (avv);
381   SV *sv = av_shift (av);
382   CAMLreturn (Val_sv (sv));
383 }
384
385 CAMLprim value
386 perl4caml_av_length (value avv)
387 {
388   CAMLparam1 (avv);
389   AV *av = Av_val (avv);
390   CAMLreturn (Val_int (av_len (av) + 1));
391 }
392
393 CAMLprim value
394 perl4caml_av_set (value avv, value i, value svv)
395 {
396   CAMLparam3 (avv, i, svv);
397   AV *av = Av_val (avv);
398   SV *sv = Sv_val (svv);
399   SvREFCNT_inc (sv);
400   if (av_store (av, Int_val (i), sv) == 0)
401     SvREFCNT_dec (sv);
402   CAMLreturn (Val_unit);
403 }
404
405 CAMLprim value
406 perl4caml_av_get (value avv, value i)
407 {
408   CAMLparam2 (avv, i);
409   AV *av = Av_val (avv);
410   SV **svp = av_fetch (av, Int_val (i), 0);
411   if (svp == 0) invalid_argument ("av_get: index out of bounds");
412   CAMLreturn (Val_sv (*svp));
413 }
414
415 CAMLprim value
416 perl4caml_av_clear (value avv)
417 {
418   CAMLparam1 (avv);
419   AV *av = Av_val (avv);
420   av_clear (av);
421   CAMLreturn (Val_unit);
422 }
423
424 CAMLprim value
425 perl4caml_av_undef (value avv)
426 {
427   CAMLparam1 (avv);
428   AV *av = Av_val (avv);
429   av_undef (av);
430   CAMLreturn (Val_unit);
431 }
432
433 CAMLprim value
434 perl4caml_av_extend (value avv, value i)
435 {
436   CAMLparam2 (avv, i);
437   AV *av = Av_val (avv);
438   av_extend (av, Int_val (i));
439   CAMLreturn (Val_unit);
440 }
441
442 CAMLprim value
443 perl4caml_hv_empty (value unit)
444 {
445   CAMLparam1 (unit);
446   HV *hv = newHV ();
447   CAMLreturn (Val_hv (hv));
448 }
449
450 CAMLprim value
451 perl4caml_hv_set (value hvv, value key, value svv)
452 {
453   CAMLparam3 (hvv, key, svv);
454   HV *hv = Hv_val (hvv);
455   SV *sv = Sv_val (svv);
456   SvREFCNT_inc (sv);
457   if (hv_store (hv, String_val (key), string_length (key), sv, 0) == 0)
458     SvREFCNT_dec (sv);
459   CAMLreturn (Val_unit);
460 }
461
462 CAMLprim value
463 perl4caml_hv_get (value hvv, value key)
464 {
465   CAMLparam2 (hvv, key);
466   HV *hv = Hv_val (hvv);
467   SV **svp = hv_fetch (hv, String_val (key), string_length (key), 0);
468   if (svp == 0) raise_not_found ();
469   CAMLreturn (Val_sv (*svp));
470 }
471
472 CAMLprim value
473 perl4caml_hv_exists (value hvv, value key)
474 {
475   CAMLparam2 (hvv, key);
476   HV *hv = Hv_val (hvv);
477   bool r = hv_exists (hv, String_val (key), string_length (key));
478   CAMLreturn (r ? Val_true : Val_false);
479 }
480
481 CAMLprim value
482 perl4caml_hv_delete (value hvv, value key)
483 {
484   CAMLparam2 (hvv, key);
485   HV *hv = Hv_val (hvv);
486   hv_delete (hv, String_val (key), string_length (key), G_DISCARD);
487   CAMLreturn (Val_unit);
488 }
489
490 CAMLprim value
491 perl4caml_hv_clear (value hvv)
492 {
493   CAMLparam1 (hvv);
494   HV *hv = Hv_val (hvv);
495   hv_clear (hv);
496   CAMLreturn (Val_unit);
497 }
498
499 CAMLprim value
500 perl4caml_hv_undef (value hvv)
501 {
502   CAMLparam1 (hvv);
503   HV *hv = Hv_val (hvv);
504   hv_undef (hv);
505   CAMLreturn (Val_unit);
506 }
507
508 CAMLprim value
509 perl4caml_get_sv (value optcreate, value name)
510 {
511   CAMLparam2 (optcreate, name);
512   CAMLlocal1 (create);
513   SV *sv;
514
515   create = unoption (optcreate, Val_false);
516   sv = get_sv (String_val (name), create == Val_true ? TRUE : FALSE);
517   if (sv == NULL) raise_not_found ();
518
519   CAMLreturn (Val_sv (sv));
520 }
521
522 CAMLprim value
523 perl4caml_get_av (value optcreate, value name)
524 {
525   CAMLparam2 (optcreate, name);
526   CAMLlocal1 (create);
527   AV *av;
528
529   create = unoption (optcreate, Val_false);
530   av = get_av (String_val (name), create == Val_true ? TRUE : FALSE);
531   if (av == NULL) raise_not_found ();
532
533   CAMLreturn (Val_av (av));
534 }
535
536 CAMLprim value
537 perl4caml_get_hv (value optcreate, value name)
538 {
539   CAMLparam2 (optcreate, name);
540   CAMLlocal1 (create);
541   HV *hv;
542
543   create = unoption (optcreate, Val_false);
544   hv = get_hv (String_val (name), create == Val_true ? TRUE : FALSE);
545   if (hv == NULL) raise_not_found ();
546
547   CAMLreturn (Val_hv (hv));
548 }
549
550 static inline void
551 check_perl_failure ()
552 {
553   SV *errsv = get_sv ("@", TRUE);
554
555   if (SvTRUE (errsv))           /* Equivalent of $@ in Perl. */
556     {
557       CAMLlocal1 (errv);
558       STRLEN n_a;
559       const char *err = SvPV (errsv, n_a);
560
561       errv = copy_string (err);
562
563       raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
564     }
565 }
566
567 CAMLprim value
568 perl4caml_call (value optsv, value optfnname, value arglist)
569 {
570   CAMLparam3 (optsv, optfnname, arglist);
571   dSP;
572   int count;
573   SV *sv;
574   CAMLlocal3 (errv, svv, fnname);
575
576   ENTER;
577   SAVETMPS;
578
579   /* Push the parameter list. */
580   PUSHMARK (SP);
581
582   /* Iteration over the linked list. */
583   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
584     {
585       svv = Field (arglist, 0);
586       sv = Sv_val (svv);
587       XPUSHs (sv_2mortal (newSVsv (sv)));
588     }
589
590   PUTBACK;
591
592   if (optsv != Val_int (0))
593     {
594       svv = unoption (optsv, Val_false);
595       sv = Sv_val (svv);
596       count = call_sv (sv, G_EVAL|G_SCALAR);
597     }
598   else if (optfnname != Val_int (0))
599     {
600       fnname = unoption (optfnname, Val_false);
601       count = call_pv (String_val (fnname), G_EVAL|G_SCALAR);
602     }
603   else
604     {
605       fprintf (stderr,
606                "Perl.call: must supply either 'sv' or 'fn' parameters.");
607       abort ();
608     }
609
610   SPAGAIN;
611
612   assert (count == 1); /* Pretty sure it should never be anything else. */
613
614   /* Pop return value off the stack. Note that the return value on the
615    * stack is mortal, so we need to take a copy.
616    */
617   sv = newSVsv (POPs);
618   PUTBACK;
619   FREETMPS;
620   LEAVE;
621
622   check_perl_failure ();
623
624   svv = Val_sv (sv);
625   CAMLreturn (svv);
626 }
627
628 CAMLprim value
629 perl4caml_call_array (value optsv, value optfnname, value arglist)
630 {
631   CAMLparam3 (optsv, optfnname, arglist);
632   dSP;
633   int i, count;
634   SV *sv;
635   CAMLlocal5 (errv, svv, fnname, list, cons);
636
637   ENTER;
638   SAVETMPS;
639
640   /* Push the parameter list. */
641   PUSHMARK (SP);
642
643   /* Iteration over the linked list. */
644   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
645     {
646       svv = Field (arglist, 0);
647       sv = Sv_val (svv);
648       XPUSHs (sv_2mortal (newSVsv (sv)));
649     }
650
651   PUTBACK;
652
653   if (optsv != Val_int (0))
654     {
655       svv = unoption (optsv, Val_false);
656       sv = Sv_val (svv);
657       count = call_sv (sv, G_EVAL|G_ARRAY);
658     }
659   else if (optfnname != Val_int (0))
660     {
661       fnname = unoption (optfnname, Val_false);
662       count = call_pv (String_val (fnname), G_EVAL|G_ARRAY);
663     }
664   else
665     {
666       fprintf (stderr,
667                "Perl.call_array: must supply either 'sv' or 'fn' parameters.");
668       abort ();
669     }
670
671   SPAGAIN;
672
673   /* Pop all the return values off the stack into a list. Values on the
674    * stack are mortal, so we must copy them.
675    */
676   list = Val_int (0);
677   for (i = 0; i < count; ++i) {
678     cons = alloc (2, 0);
679     Field (cons, 1) = list;
680     list = cons;
681     Field (cons, 0) = Val_sv (newSVsv (POPs));
682   }
683
684   /* Restore the stack. */
685   PUTBACK;
686   FREETMPS;
687   LEAVE;
688
689   check_perl_failure ();
690
691   CAMLreturn (list);
692 }
693
694 CAMLprim value
695 perl4caml_call_void (value optsv, value optfnname, value arglist)
696 {
697   CAMLparam3 (optsv, optfnname, arglist);
698   dSP;
699   int count;
700   SV *sv;
701   CAMLlocal3 (errv, svv, fnname);
702
703   ENTER;
704   SAVETMPS;
705
706   /* Push the parameter list. */
707   PUSHMARK (SP);
708
709   /* Iteration over the linked list. */
710   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
711     {
712       svv = Field (arglist, 0);
713       sv = Sv_val (svv);
714       XPUSHs (sv_2mortal (newSVsv (sv)));
715     }
716
717   PUTBACK;
718
719   if (optsv != Val_int (0))
720     {
721       svv = unoption (optsv, Val_false);
722       sv = Sv_val (svv);
723       count = call_sv (sv, G_EVAL|G_VOID);
724     }
725   else if (optfnname != Val_int (0))
726     {
727       fnname = unoption (optfnname, Val_false);
728       count = call_pv (String_val (fnname), G_EVAL|G_VOID);
729     }
730   else
731     {
732       fprintf (stderr,
733                "Perl.call_void: must supply either 'sv' or 'fn' parameters.");
734       abort ();
735     }
736
737   SPAGAIN;
738
739   assert (count == 0); /* Pretty sure it should never be anything else. */
740
741   /* Restore the stack. */
742   PUTBACK;
743   FREETMPS;
744   LEAVE;
745
746   check_perl_failure ();
747
748   CAMLreturn (Val_unit);
749 }
750
751 CAMLprim value
752 perl4caml_eval (value expr)
753 {
754   CAMLparam1 (expr);
755   dSP;
756   SV *sv;
757   CAMLlocal2 (errv, svv);
758
759   sv = eval_pv (String_val (expr), G_SCALAR);
760
761   check_perl_failure ();
762
763   svv = Val_sv (sv);
764   CAMLreturn (svv);
765 }
766
767 CAMLprim value
768 perl4caml_call_method (value ref, value name, value arglist)
769 {
770   CAMLparam3 (ref, name, arglist);
771   dSP;
772   int count;
773   SV *sv;
774   CAMLlocal2 (errv, svv);
775
776   ENTER;
777   SAVETMPS;
778
779   /* Push the parameter list. */
780   PUSHMARK (SP);
781
782   sv = Sv_val (ref);
783   XPUSHs (sv_2mortal (newSVsv (sv)));
784
785   /* Iteration over the linked list. */
786   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
787     {
788       svv = Field (arglist, 0);
789       sv = Sv_val (svv);
790       XPUSHs (sv_2mortal (newSVsv (sv)));
791     }
792
793   PUTBACK;
794
795   count = call_method (String_val (name), G_EVAL|G_SCALAR);
796
797   SPAGAIN;
798
799   assert (count == 1); /* Pretty sure it should never be anything else. */
800
801   /* Pop return value off the stack. Note that the return value on the
802    * stack is mortal, so we need to take a copy.
803    */
804   sv = newSVsv (POPs);
805   PUTBACK;
806   FREETMPS;
807   LEAVE;
808
809   check_perl_failure ();
810
811   svv = Val_sv (sv);
812   CAMLreturn (svv);
813 }
814
815 CAMLprim value
816 perl4caml_call_method_array (value ref, value name, value arglist)
817 {
818   CAMLparam3 (ref, name, arglist);
819   dSP;
820   int count, i;
821   SV *sv;
822   CAMLlocal4 (errv, svv, list, cons);
823
824   ENTER;
825   SAVETMPS;
826
827   /* Push the parameter list. */
828   PUSHMARK (SP);
829
830   sv = Sv_val (ref);
831   XPUSHs (sv_2mortal (newSVsv (sv)));
832
833   /* Iteration over the linked list. */
834   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
835     {
836       svv = Field (arglist, 0);
837       sv = Sv_val (svv);
838       XPUSHs (sv_2mortal (newSVsv (sv)));
839     }
840
841   PUTBACK;
842
843   count = call_method (String_val (name), G_EVAL|G_ARRAY);
844
845   SPAGAIN;
846
847   /* Pop all return values off the stack. Note that the return values on the
848    * stack are mortal, so we need to take a copy.
849    */
850   list = Val_int (0);
851   for (i = 0; i < count; ++i) {
852     cons = alloc (2, 0);
853     Field (cons, 1) = list;
854     list = cons;
855     Field (cons, 0) = Val_sv (newSVsv (POPs));
856   }
857
858   /* Restore the stack. */
859   PUTBACK;
860   FREETMPS;
861   LEAVE;
862
863   check_perl_failure ();
864
865   CAMLreturn (list);
866 }
867
868 CAMLprim value
869 perl4caml_call_method_void (value ref, value name, value arglist)
870 {
871   CAMLparam3 (ref, name, arglist);
872   dSP;
873   int count;
874   SV *sv;
875   CAMLlocal2 (errv, svv);
876
877   ENTER;
878   SAVETMPS;
879
880   /* Push the parameter list. */
881   PUSHMARK (SP);
882
883   sv = Sv_val (ref);
884   XPUSHs (sv_2mortal (newSVsv (sv)));
885
886   /* Iteration over the linked list. */
887   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
888     {
889       svv = Field (arglist, 0);
890       sv = Sv_val (svv);
891       XPUSHs (sv_2mortal (newSVsv (sv)));
892     }
893
894   PUTBACK;
895
896   count = call_method (String_val (name), G_EVAL|G_VOID);
897
898   SPAGAIN;
899
900   assert (count == 0); /* Pretty sure it should never be anything else. */
901
902   /* Restore the stack. */
903   PUTBACK;
904   FREETMPS;
905   LEAVE;
906
907   check_perl_failure ();
908
909   CAMLreturn (Val_unit);
910 }
911
912 CAMLprim value
913 perl4caml_call_class_method (value classname, value name, value arglist)
914 {
915   CAMLparam3 (classname, name, arglist);
916   dSP;
917   int count;
918   SV *sv;
919   CAMLlocal2 (errv, svv);
920
921   ENTER;
922   SAVETMPS;
923
924   /* Push the parameter list. */
925   PUSHMARK (SP);
926
927   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
928
929   /* Iteration over the linked list. */
930   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
931     {
932       svv = Field (arglist, 0);
933       sv = Sv_val (svv);
934       XPUSHs (sv_2mortal (newSVsv (sv)));
935     }
936
937   PUTBACK;
938
939   count = call_method (String_val (name), G_EVAL|G_SCALAR);
940
941   SPAGAIN;
942
943   assert (count == 1); /* Pretty sure it should never be anything else. */
944
945   /* Pop return value off the stack. Note that the return value on the
946    * stack is mortal, so we need to take a copy.
947    */
948   sv = newSVsv (POPs);
949   PUTBACK;
950   FREETMPS;
951   LEAVE;
952
953   check_perl_failure ();
954
955   svv = Val_sv (sv);
956   CAMLreturn (svv);
957 }
958
959 CAMLprim value
960 perl4caml_call_class_method_array (value classname, value name, value arglist)
961 {
962   CAMLparam3 (classname, name, arglist);
963   dSP;
964   int count, i;
965   SV *sv;
966   CAMLlocal4 (errv, svv, list, cons);
967
968   ENTER;
969   SAVETMPS;
970
971   /* Push the parameter list. */
972   PUSHMARK (SP);
973
974   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
975
976   /* Iteration over the linked list. */
977   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
978     {
979       svv = Field (arglist, 0);
980       sv = Sv_val (svv);
981       XPUSHs (sv_2mortal (newSVsv (sv)));
982     }
983
984   PUTBACK;
985
986   count = call_method (String_val (name), G_EVAL|G_ARRAY);
987
988   SPAGAIN;
989
990   /* Pop all return values off the stack. Note that the return values on the
991    * stack are mortal, so we need to take a copy.
992    */
993   list = Val_int (0);
994   for (i = 0; i < count; ++i) {
995     cons = alloc (2, 0);
996     Field (cons, 1) = list;
997     list = cons;
998     Field (cons, 0) = Val_sv (newSVsv (POPs));
999   }
1000
1001   /* Restore the stack. */
1002   PUTBACK;
1003   FREETMPS;
1004   LEAVE;
1005
1006   check_perl_failure ();
1007
1008   CAMLreturn (list);
1009 }
1010
1011 CAMLprim value
1012 perl4caml_call_class_method_void (value classname, value name, value arglist)
1013 {
1014   CAMLparam3 (classname, name, arglist);
1015   dSP;
1016   int count;
1017   SV *sv;
1018   CAMLlocal2 (errv, svv);
1019
1020   ENTER;
1021   SAVETMPS;
1022
1023   /* Push the parameter list. */
1024   PUSHMARK (SP);
1025
1026   XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
1027
1028   /* Iteration over the linked list. */
1029   for (; arglist != Val_int (0); arglist = Field (arglist, 1))
1030     {
1031       svv = Field (arglist, 0);
1032       sv = Sv_val (svv);
1033       XPUSHs (sv_2mortal (newSVsv (sv)));
1034     }
1035
1036   PUTBACK;
1037
1038   count = call_method (String_val (name), G_EVAL|G_VOID);
1039
1040   SPAGAIN;
1041
1042   assert (count == 0); /* Pretty sure it should never be anything else. */
1043
1044   /* Restore the stack. */
1045   PUTBACK;
1046   FREETMPS;
1047   LEAVE;
1048
1049   check_perl_failure ();
1050
1051   CAMLreturn (Val_unit);
1052 }
1053
1054 static value
1055 Val_voidptr (void *ptr)
1056 {
1057   value rv = alloc (1, Abstract_tag); /* XXX Is this correct? */
1058   Field(rv, 0) = (value) ptr;
1059   return rv;
1060 }
1061
1062 static value
1063 unoption (value option, value deflt)
1064 {
1065   if (option == Val_int (0))    /* "None" */
1066     return deflt;
1067   else                          /* "Some 'a" */
1068     return Field (option, 0);
1069 }