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