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