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