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