1 /* Interface to Perl from OCaml.
2 * Copyright (C) 2003 Merjis Ltd.
3 * $Id: perl_c.c,v 1.2 2003-10-12 10:52:00 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_get_sv (value optcreate, value name)
163 CAMLparam2 (optcreate, name);
167 create = unoption (optcreate, Val_false);
168 sv = get_sv (String_val (name), create == Val_true ? TRUE : FALSE);
169 if (sv == NULL) raise_not_found ();
171 CAMLreturn (Val_sv (sv));
175 perl4caml_call (value optsv, value optfnname, value arglist)
177 CAMLparam3 (optsv, optfnname, arglist);
181 CAMLlocal3 (errv, svv, fnname);
186 /* Push the parameter list. */
189 /* Iteration over the linked list. */
190 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
192 svv = Field (arglist, 0);
194 XPUSHs (sv_2mortal (newSVsv (sv)));
199 if (optsv != Val_int (0))
201 svv = unoption (optsv, Val_false);
203 count = call_sv (sv, G_EVAL|G_SCALAR);
205 else if (optfnname != Val_int (0))
207 fnname = unoption (optfnname, Val_false);
208 count = call_pv (String_val (fnname), G_EVAL|G_SCALAR);
213 "Perl.call: must supply either 'sv' or 'fn' parameters.");
219 assert (count == 1); /* Pretty sure it should never be anything else. */
221 /* Pop return value off the stack. Note that the return value on the
222 * stack is mortal, so we need to take a copy.
229 /* Died with an error?
230 * XXX Actually this doesn't work for some reason.
235 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
237 errv = copy_string (err);
239 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
249 perl4caml_call_array (value optsv, value optfnname, value arglist)
251 CAMLparam3 (optsv, optfnname, arglist);
255 CAMLlocal5 (errv, svv, fnname, list, cons);
260 /* Push the parameter list. */
263 /* Iteration over the linked list. */
264 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
266 svv = Field (arglist, 0);
268 XPUSHs (sv_2mortal (newSVsv (sv)));
273 if (optsv != Val_int (0))
275 svv = unoption (optsv, Val_false);
277 count = call_sv (sv, G_EVAL|G_ARRAY);
279 else if (optfnname != Val_int (0))
281 fnname = unoption (optfnname, Val_false);
282 count = call_pv (String_val (fnname), G_EVAL|G_ARRAY);
287 "Perl.call_array: must supply either 'sv' or 'fn' parameters.");
293 /* Pop all the return values off the stack into a list. Values on the
294 * stack are mortal, so we must copy them.
297 for (i = 0; i < count; ++i) {
299 Field (cons, 1) = list;
301 Field (cons, 0) = Val_sv (newSVsv (POPs));
304 /* Restore the stack. */
309 /* Died with an error?
310 * XXX Actually this doesn't work for some reason.
315 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
317 errv = copy_string (err);
319 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
326 perl4caml_call_void (value optsv, value optfnname, value arglist)
328 CAMLparam3 (optsv, optfnname, arglist);
332 CAMLlocal3 (errv, svv, fnname);
337 /* Push the parameter list. */
340 /* Iteration over the linked list. */
341 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
343 svv = Field (arglist, 0);
345 XPUSHs (sv_2mortal (newSVsv (sv)));
350 if (optsv != Val_int (0))
352 svv = unoption (optsv, Val_false);
354 count = call_sv (sv, G_EVAL|G_VOID);
356 else if (optfnname != Val_int (0))
358 fnname = unoption (optfnname, Val_false);
359 count = call_pv (String_val (fnname), G_EVAL|G_VOID);
364 "Perl.call_void: must supply either 'sv' or 'fn' parameters.");
370 assert (count == 0); /* Pretty sure it should never be anything else. */
372 /* Restore the stack. */
377 /* Died with an error?
378 * XXX Actually this doesn't work for some reason.
383 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
385 errv = copy_string (err);
387 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
390 CAMLreturn (Val_unit);
394 perl4caml_eval (value expr)
399 CAMLlocal2 (errv, svv);
405 eval_pv (String_val (expr), G_SCALAR);
413 /* Died with an error?
414 * XXX Actually this doesn't work for some reason.
419 const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
421 errv = copy_string (err);
423 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
433 Val_voidptr (void *ptr)
435 value rv = alloc (1, Abstract_tag); /* XXX Is this correct? */
436 Field(rv, 0) = (value) ptr;
441 unoption (value option, value deflt)
443 if (option == Val_int (0)) /* "None" */
446 return Field (option, 0);