1 /* Interface to Perl from OCaml.
2 * Copyright (C) 2003 Merjis Ltd.
3 * $Id: perl_c.c,v 1.3 2003-10-12 11:56:26 rich Exp $
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>
18 /* XXX This was required to avoid an error on my machine when loading the Perl
19 * headers. Not clear why this is missing.
21 #define off64_t __off64_t
26 /* Perl requires the interpreter to be called literally 'my_perl'! */
27 static PerlInterpreter *my_perl;
29 /* Wrap up an arbitrary void pointer in an opaque OCaml object. */
30 static value Val_voidptr (void *ptr);
32 /* Get the concrete value from an optional field. */
33 static value unoption (value option, value deflt);
35 /* Unwrap an arbitrary void pointer from an opaque OCaml object. */
36 #define Voidptr_val(type,rv) ((type *) Field ((rv), 0))
38 /* Hide Perl types in opaque OCaml objects. */
39 #define Val_perl(pl) (Val_voidptr ((pl)))
40 #define Perl_val(plv) (Voidptr_val (PerlInterpreter, (plv)))
41 #define Val_sv(sv) (Val_voidptr ((sv)))
42 #define Sv_val(svv) (Voidptr_val (SV, (svv)))
45 perl4caml_init (value unit)
47 PERL_SYS_INIT3 (NULL, NULL, NULL);
52 perl4caml_create (value optargs, value unit)
54 CAMLparam2 (optargs, unit);
58 static char *no_args[] = { "", "-e", "0" };
60 /* Arguments given? */
61 if (optargs == Val_int (0)) /* "None" */
66 else /* "Some args" where args is a string array. */
68 args = Field (optargs, 0);
69 argc = Wosize_val (args);
70 argv = alloca (argc * sizeof (char *));
71 for (i = 0; i < argc; ++i) argv[i] = String_val (Field (args, i));
74 my_perl = perl_alloc ();
75 perl_construct (my_perl);
76 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
77 perl_parse (my_perl, NULL, argc, argv, NULL);
80 CAMLreturn (Val_perl (my_perl));
84 perl4caml_destroy (value plv)
87 PerlInterpreter *pl = Perl_val (plv);
92 CAMLreturn (Val_unit);
96 perl4caml_set_context (value plv)
99 PerlInterpreter *pl = Perl_val (plv);
101 PERL_SET_CONTEXT (pl);
104 CAMLreturn (Val_unit);
108 perl4caml_int_of_sv (value svv)
111 SV *sv = Sv_val (svv);
112 CAMLreturn (Val_int (SvIV (sv)));
116 perl4caml_sv_of_int (value iv)
119 CAMLreturn (Val_sv (newSViv (Int_val (iv))));
123 perl4caml_float_of_sv (value svv)
126 SV *sv = Sv_val (svv);
128 f = copy_double (SvNV (sv));
133 perl4caml_sv_of_float (value fv)
136 CAMLreturn (Val_sv (newSViv (Double_val (fv))));
140 perl4caml_string_of_sv (value svv)
143 SV *sv = Sv_val (svv);
147 str = SvPV (sv, len);
148 /* XXX This won't work if the string contains NUL. */
149 strv = copy_string (str);
154 perl4caml_sv_of_string (value strv)
157 CAMLreturn (Val_sv (newSVpv (String_val (strv), string_length (strv))));
161 perl4caml_sv_is_true (value svv)
164 SV *sv = Sv_val (svv);
165 CAMLreturn (SvTRUE (sv) ? Val_true : Val_false);
169 perl4caml_sv_is_undef (value svv)
172 SV *sv = Sv_val (svv);
173 CAMLreturn (sv == &PL_sv_undef ? Val_true : Val_false);
177 perl4caml_sv_get_undef (value unit)
180 CAMLreturn (Val_sv (&PL_sv_undef));
184 perl4caml_sv_get_yes (value unit)
187 CAMLreturn (Val_sv (&PL_sv_yes));
191 perl4caml_sv_get_no (value unit)
194 CAMLreturn (Val_sv (&PL_sv_no));
198 perl4caml_get_sv (value optcreate, value name)
200 CAMLparam2 (optcreate, name);
204 create = unoption (optcreate, Val_false);
205 sv = get_sv (String_val (name), create == Val_true ? TRUE : FALSE);
206 if (sv == NULL) raise_not_found ();
208 CAMLreturn (Val_sv (sv));
212 perl4caml_call (value optsv, value optfnname, value arglist)
214 CAMLparam3 (optsv, optfnname, arglist);
218 CAMLlocal3 (errv, svv, fnname);
223 /* Push the parameter list. */
226 /* Iteration over the linked list. */
227 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
229 svv = Field (arglist, 0);
231 XPUSHs (sv_2mortal (newSVsv (sv)));
236 if (optsv != Val_int (0))
238 svv = unoption (optsv, Val_false);
240 count = call_sv (sv, G_EVAL|G_SCALAR);
242 else if (optfnname != Val_int (0))
244 fnname = unoption (optfnname, Val_false);
245 count = call_pv (String_val (fnname), G_EVAL|G_SCALAR);
250 "Perl.call: must supply either 'sv' or 'fn' parameters.");
256 assert (count == 1); /* Pretty sure it should never be anything else. */
258 /* Pop return value off the stack. Note that the return value on the
259 * stack is mortal, so we need to take a copy.
266 /* Died with an error?
267 * XXX Actually this doesn't work for some reason.
272 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
274 errv = copy_string (err);
276 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
286 perl4caml_call_array (value optsv, value optfnname, value arglist)
288 CAMLparam3 (optsv, optfnname, arglist);
292 CAMLlocal5 (errv, svv, fnname, list, cons);
297 /* Push the parameter list. */
300 /* Iteration over the linked list. */
301 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
303 svv = Field (arglist, 0);
305 XPUSHs (sv_2mortal (newSVsv (sv)));
310 if (optsv != Val_int (0))
312 svv = unoption (optsv, Val_false);
314 count = call_sv (sv, G_EVAL|G_ARRAY);
316 else if (optfnname != Val_int (0))
318 fnname = unoption (optfnname, Val_false);
319 count = call_pv (String_val (fnname), G_EVAL|G_ARRAY);
324 "Perl.call_array: must supply either 'sv' or 'fn' parameters.");
330 /* Pop all the return values off the stack into a list. Values on the
331 * stack are mortal, so we must copy them.
334 for (i = 0; i < count; ++i) {
336 Field (cons, 1) = list;
338 Field (cons, 0) = Val_sv (newSVsv (POPs));
341 /* Restore the stack. */
346 /* Died with an error?
347 * XXX Actually this doesn't work for some reason.
352 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
354 errv = copy_string (err);
356 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
363 perl4caml_call_void (value optsv, value optfnname, value arglist)
365 CAMLparam3 (optsv, optfnname, arglist);
369 CAMLlocal3 (errv, svv, fnname);
374 /* Push the parameter list. */
377 /* Iteration over the linked list. */
378 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
380 svv = Field (arglist, 0);
382 XPUSHs (sv_2mortal (newSVsv (sv)));
387 if (optsv != Val_int (0))
389 svv = unoption (optsv, Val_false);
391 count = call_sv (sv, G_EVAL|G_VOID);
393 else if (optfnname != Val_int (0))
395 fnname = unoption (optfnname, Val_false);
396 count = call_pv (String_val (fnname), G_EVAL|G_VOID);
401 "Perl.call_void: must supply either 'sv' or 'fn' parameters.");
407 assert (count == 0); /* Pretty sure it should never be anything else. */
409 /* Restore the stack. */
414 /* Died with an error?
415 * XXX Actually this doesn't work for some reason.
420 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
422 errv = copy_string (err);
424 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
427 CAMLreturn (Val_unit);
431 perl4caml_eval (value expr)
436 CAMLlocal2 (errv, svv);
442 eval_pv (String_val (expr), G_SCALAR);
450 /* Died with an error?
451 * XXX Actually this doesn't work for some reason.
456 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
458 errv = copy_string (err);
460 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
470 perl4caml_call_method (value ref, value name, value arglist)
472 CAMLparam3 (ref, name, arglist);
476 CAMLlocal2 (errv, svv);
481 /* Push the parameter list. */
485 XPUSHs (sv_2mortal (newSVsv (sv)));
487 /* Iteration over the linked list. */
488 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
490 svv = Field (arglist, 0);
492 XPUSHs (sv_2mortal (newSVsv (sv)));
497 count = call_method (String_val (name), G_EVAL|G_SCALAR);
501 assert (count == 1); /* Pretty sure it should never be anything else. */
503 /* Pop return value off the stack. Note that the return value on the
504 * stack is mortal, so we need to take a copy.
511 /* Died with an error?
512 * XXX Actually this doesn't work for some reason.
517 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
519 errv = copy_string (err);
521 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
531 perl4caml_call_method_array (value ref, value name, value arglist)
533 CAMLparam3 (ref, name, arglist);
537 CAMLlocal4 (errv, svv, list, cons);
542 /* Push the parameter list. */
546 XPUSHs (sv_2mortal (newSVsv (sv)));
548 /* Iteration over the linked list. */
549 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
551 svv = Field (arglist, 0);
553 XPUSHs (sv_2mortal (newSVsv (sv)));
558 count = call_method (String_val (name), G_EVAL|G_ARRAY);
562 /* Pop all return values off the stack. Note that the return values on the
563 * stack are mortal, so we need to take a copy.
566 for (i = 0; i < count; ++i) {
568 Field (cons, 1) = list;
570 Field (cons, 0) = Val_sv (newSVsv (POPs));
573 /* Restore the stack. */
578 /* Died with an error?
579 * XXX Actually this doesn't work for some reason.
584 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
586 errv = copy_string (err);
588 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
595 perl4caml_call_method_void (value ref, value name, value arglist)
597 CAMLparam3 (ref, name, arglist);
601 CAMLlocal2 (errv, svv);
606 /* Push the parameter list. */
610 XPUSHs (sv_2mortal (newSVsv (sv)));
612 /* Iteration over the linked list. */
613 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
615 svv = Field (arglist, 0);
617 XPUSHs (sv_2mortal (newSVsv (sv)));
622 count = call_method (String_val (name), G_EVAL|G_VOID);
626 assert (count == 0); /* Pretty sure it should never be anything else. */
628 /* Restore the stack. */
633 /* Died with an error?
634 * XXX Actually this doesn't work for some reason.
639 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
641 errv = copy_string (err);
643 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
646 CAMLreturn (Val_unit);
650 perl4caml_call_class_method (value classname, value name, value arglist)
652 CAMLparam3 (classname, name, arglist);
656 CAMLlocal2 (errv, svv);
661 /* Push the parameter list. */
664 XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
666 /* Iteration over the linked list. */
667 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
669 svv = Field (arglist, 0);
671 XPUSHs (sv_2mortal (newSVsv (sv)));
676 count = call_method (String_val (name), G_EVAL|G_SCALAR);
680 assert (count == 1); /* Pretty sure it should never be anything else. */
682 /* Pop return value off the stack. Note that the return value on the
683 * stack is mortal, so we need to take a copy.
690 /* Died with an error?
691 * XXX Actually this doesn't work for some reason.
696 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
698 errv = copy_string (err);
700 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
710 perl4caml_call_class_method_array (value classname, value name, value arglist)
712 CAMLparam3 (classname, name, arglist);
716 CAMLlocal4 (errv, svv, list, cons);
721 /* Push the parameter list. */
724 XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
726 /* Iteration over the linked list. */
727 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
729 svv = Field (arglist, 0);
731 XPUSHs (sv_2mortal (newSVsv (sv)));
736 count = call_method (String_val (name), G_EVAL|G_ARRAY);
740 /* Pop all return values off the stack. Note that the return values on the
741 * stack are mortal, so we need to take a copy.
744 for (i = 0; i < count; ++i) {
746 Field (cons, 1) = list;
748 Field (cons, 0) = Val_sv (newSVsv (POPs));
751 /* Restore the stack. */
756 /* Died with an error?
757 * XXX Actually this doesn't work for some reason.
762 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
764 errv = copy_string (err);
766 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
773 perl4caml_call_class_method_void (value classname, value name, value arglist)
775 CAMLparam3 (classname, name, arglist);
779 CAMLlocal2 (errv, svv);
784 /* Push the parameter list. */
787 XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
789 /* Iteration over the linked list. */
790 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
792 svv = Field (arglist, 0);
794 XPUSHs (sv_2mortal (newSVsv (sv)));
799 count = call_method (String_val (name), G_EVAL|G_VOID);
803 assert (count == 0); /* Pretty sure it should never be anything else. */
805 /* Restore the stack. */
810 /* Died with an error?
811 * XXX Actually this doesn't work for some reason.
816 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
818 errv = copy_string (err);
820 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
823 CAMLreturn (Val_unit);
827 Val_voidptr (void *ptr)
829 value rv = alloc (1, Abstract_tag); /* XXX Is this correct? */
830 Field(rv, 0) = (value) ptr;
835 unoption (value option, value deflt)
837 if (option == Val_int (0)) /* "None" */
840 return Field (option, 0);