1 /* Interface to Perl from OCaml.
2 * Copyright (C) 2003 Merjis Ltd.
3 * $Id: perl_c.c,v 1.5 2003-10-14 16:05:21 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)))
43 #define Val_av(av) (Val_voidptr ((av)))
44 #define Av_val(avv) (Voidptr_val (AV, (avv)))
49 char *file = __FILE__;
50 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
52 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
56 perl4caml_init (value unit)
58 static char *argv[] = { "", "-w", "-e", "0" };
59 int argc = sizeof argv / sizeof argv[0];
61 PERL_SYS_INIT3 (NULL, NULL, NULL);
63 /* Create a default interpreter. */
64 my_perl = perl_alloc ();
65 perl_construct (my_perl);
66 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
67 perl_parse (my_perl, xs_init, argc, argv, NULL);
68 /*perl_run (my_perl);*/
74 perl4caml_create (value optargs, value unit)
76 CAMLparam2 (optargs, unit);
80 static char *no_args[] = { "", "-e", "0" };
82 /* Arguments given? */
83 if (optargs == Val_int (0)) /* "None" */
88 else /* "Some args" where args is a string array. */
90 args = Field (optargs, 0);
91 argc = Wosize_val (args);
92 argv = alloca (argc * sizeof (char *));
93 for (i = 0; i < argc; ++i) argv[i] = String_val (Field (args, i));
96 my_perl = perl_alloc ();
97 perl_construct (my_perl);
98 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
99 perl_parse (my_perl, xs_init, argc, argv, NULL);
100 /*perl_run (my_perl);*/
102 CAMLreturn (Val_perl (my_perl));
106 perl4caml_destroy (value unit)
110 perl_destruct (my_perl);
113 /* Force a segfault if someone tries to use a Perl function without
114 * creating another interpreter first.
118 CAMLreturn (Val_unit);
122 perl4caml_set_context (value plv)
125 PerlInterpreter *pl = Perl_val (plv);
127 PERL_SET_CONTEXT (pl);
130 CAMLreturn (Val_unit);
134 perl4caml_int_of_sv (value svv)
137 SV *sv = Sv_val (svv);
138 CAMLreturn (Val_int (SvIV (sv)));
142 perl4caml_sv_of_int (value iv)
145 CAMLreturn (Val_sv (newSViv (Int_val (iv))));
149 perl4caml_float_of_sv (value svv)
152 SV *sv = Sv_val (svv);
154 f = copy_double (SvNV (sv));
159 perl4caml_sv_of_float (value fv)
162 CAMLreturn (Val_sv (newSViv (Double_val (fv))));
166 perl4caml_string_of_sv (value svv)
169 SV *sv = Sv_val (svv);
173 str = SvPV (sv, len);
174 /* XXX This won't work if the string contains NUL. */
175 strv = copy_string (str);
180 perl4caml_sv_of_string (value strv)
183 CAMLreturn (Val_sv (newSVpv (String_val (strv), string_length (strv))));
187 perl4caml_sv_is_true (value svv)
190 SV *sv = Sv_val (svv);
191 CAMLreturn (SvTRUE (sv) ? Val_true : Val_false);
195 perl4caml_sv_is_undef (value svv)
198 SV *sv = Sv_val (svv);
199 CAMLreturn (sv == &PL_sv_undef ? Val_true : Val_false);
203 perl4caml_sv_undef (value unit)
206 CAMLreturn (Val_sv (&PL_sv_undef));
210 perl4caml_sv_yes (value unit)
213 CAMLreturn (Val_sv (&PL_sv_yes));
217 perl4caml_sv_no (value unit)
220 CAMLreturn (Val_sv (&PL_sv_no));
224 perl4caml_sv_type (value svv)
227 SV *sv = Sv_val (svv);
231 case SVt_IV: CAMLreturn (Val_int (1));
232 case SVt_NV: CAMLreturn (Val_int (2));
233 case SVt_PV: CAMLreturn (Val_int (3));
234 case SVt_RV: CAMLreturn (Val_int (4));
235 case SVt_PVAV: CAMLreturn (Val_int (5));
236 case SVt_PVHV: CAMLreturn (Val_int (6));
237 case SVt_PVCV: CAMLreturn (Val_int (7));
238 case SVt_PVGV: CAMLreturn (Val_int (8));
239 case SVt_PVMG: CAMLreturn (Val_int (9));
240 default: CAMLreturn (Val_int (0));
245 perl4caml_deref (value svv)
249 SV *sv = Sv_val (svv);
251 if (SvTYPE (sv) != SVt_RV)
252 invalid_argument ("deref: SV is not a reference");
253 switch (SvTYPE (SvRV (sv))) {
261 invalid_argument ("deref: SV is not a reference to a scalar");
263 rsvv = Val_sv (SvRV (sv));
268 perl4caml_deref_array (value svv)
272 SV *sv = Sv_val (svv);
274 if (SvTYPE (sv) != SVt_RV)
275 invalid_argument ("deref_array: SV is not a reference");
276 switch (SvTYPE (SvRV (sv))) {
280 invalid_argument ("deref_array: SV is not a reference to an array");
282 ravv = Val_av ((AV *) SvRV (sv));
287 perl4caml_av_empty (value unit)
291 CAMLreturn (Val_av (av));
294 /* We don't know in advance how long the list will be, which makes this
298 perl4caml_av_of_sv_list (value svlistv)
300 CAMLparam1 (svlistv);
302 SV *sv, **svlist = 0;
303 int alloc = 0, size = 0;
306 for (; svlistv != Val_int (0); svlistv = Field (svlistv, 1))
308 svv = Field (svlistv, 0);
311 alloc = alloc == 0 ? 1 : alloc * 2;
312 svlist = realloc (svlist, alloc * sizeof (SV *));
317 av = av_make (size, svlist);
319 if (alloc > 0) free (svlist); /* Free memory allocated to SV list. */
321 CAMLreturn (Val_av (av));
324 /* XXX av_map would be faster if we also had sv_list_of_av. */
327 perl4caml_av_push (value avv, value svv)
329 CAMLparam2 (avv, svv);
330 AV *av = Av_val (avv);
331 SV *sv = Sv_val (svv);
333 CAMLreturn (Val_unit);
337 perl4caml_av_pop (value avv)
340 AV *av = Av_val (avv);
341 SV *sv = av_pop (av);
342 CAMLreturn (Val_sv (sv));
346 perl4caml_av_unshift (value avv, value svv)
348 CAMLparam2 (avv, svv);
349 AV *av = Av_val (avv);
350 SV *sv = Sv_val (svv);
353 if (av_store (av, 0, sv) == 0)
355 CAMLreturn (Val_unit);
359 perl4caml_av_shift (value avv)
362 AV *av = Av_val (avv);
363 SV *sv = av_shift (av);
364 CAMLreturn (Val_sv (sv));
368 perl4caml_av_length (value avv)
371 AV *av = Av_val (avv);
372 CAMLreturn (Val_int (av_len (av) + 1));
376 perl4caml_av_set (value avv, value i, value svv)
378 CAMLparam3 (avv, i, svv);
379 AV *av = Av_val (avv);
380 SV *sv = Sv_val (svv);
382 if (av_store (av, Int_val (i), sv) == 0)
384 CAMLreturn (Val_unit);
388 perl4caml_av_get (value avv, value i)
391 AV *av = Av_val (avv);
392 SV **svp = av_fetch (av, Int_val (i), 0);
393 if (svp == 0) invalid_argument ("av_get: index out of bounds");
394 CAMLreturn (Val_sv (*svp));
398 perl4caml_av_clear (value avv)
401 AV *av = Av_val (avv);
403 CAMLreturn (Val_unit);
407 perl4caml_av_undef (value avv)
410 AV *av = Av_val (avv);
412 CAMLreturn (Val_unit);
416 perl4caml_av_extend (value avv, value i)
419 AV *av = Av_val (avv);
420 av_extend (av, Int_val (i));
421 CAMLreturn (Val_unit);
425 perl4caml_get_sv (value optcreate, value name)
427 CAMLparam2 (optcreate, name);
431 create = unoption (optcreate, Val_false);
432 sv = get_sv (String_val (name), create == Val_true ? TRUE : FALSE);
433 if (sv == NULL) raise_not_found ();
435 CAMLreturn (Val_sv (sv));
439 perl4caml_get_av (value optcreate, value name)
441 CAMLparam2 (optcreate, name);
445 create = unoption (optcreate, Val_false);
446 av = get_av (String_val (name), create == Val_true ? TRUE : FALSE);
447 if (av == NULL) raise_not_found ();
449 CAMLreturn (Val_av (av));
453 check_perl_failure ()
455 SV *errsv = get_sv ("@", TRUE);
457 if (SvTRUE (errsv)) /* Equivalent of $@ in Perl. */
461 const char *err = SvPV (errsv, n_a);
463 errv = copy_string (err);
465 raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
470 perl4caml_call (value optsv, value optfnname, value arglist)
472 CAMLparam3 (optsv, optfnname, arglist);
476 CAMLlocal3 (errv, svv, fnname);
481 /* Push the parameter list. */
484 /* Iteration over the linked list. */
485 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
487 svv = Field (arglist, 0);
489 XPUSHs (sv_2mortal (newSVsv (sv)));
494 if (optsv != Val_int (0))
496 svv = unoption (optsv, Val_false);
498 count = call_sv (sv, G_EVAL|G_SCALAR);
500 else if (optfnname != Val_int (0))
502 fnname = unoption (optfnname, Val_false);
503 count = call_pv (String_val (fnname), G_EVAL|G_SCALAR);
508 "Perl.call: must supply either 'sv' or 'fn' parameters.");
514 assert (count == 1); /* Pretty sure it should never be anything else. */
516 /* Pop return value off the stack. Note that the return value on the
517 * stack is mortal, so we need to take a copy.
524 check_perl_failure ();
531 perl4caml_call_array (value optsv, value optfnname, value arglist)
533 CAMLparam3 (optsv, optfnname, arglist);
537 CAMLlocal5 (errv, svv, fnname, list, cons);
542 /* Push the parameter list. */
545 /* Iteration over the linked list. */
546 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
548 svv = Field (arglist, 0);
550 XPUSHs (sv_2mortal (newSVsv (sv)));
555 if (optsv != Val_int (0))
557 svv = unoption (optsv, Val_false);
559 count = call_sv (sv, G_EVAL|G_ARRAY);
561 else if (optfnname != Val_int (0))
563 fnname = unoption (optfnname, Val_false);
564 count = call_pv (String_val (fnname), G_EVAL|G_ARRAY);
569 "Perl.call_array: must supply either 'sv' or 'fn' parameters.");
575 /* Pop all the return values off the stack into a list. Values on the
576 * stack are mortal, so we must copy them.
579 for (i = 0; i < count; ++i) {
581 Field (cons, 1) = list;
583 Field (cons, 0) = Val_sv (newSVsv (POPs));
586 /* Restore the stack. */
591 check_perl_failure ();
597 perl4caml_call_void (value optsv, value optfnname, value arglist)
599 CAMLparam3 (optsv, optfnname, arglist);
603 CAMLlocal3 (errv, svv, fnname);
608 /* Push the parameter list. */
611 /* Iteration over the linked list. */
612 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
614 svv = Field (arglist, 0);
616 XPUSHs (sv_2mortal (newSVsv (sv)));
621 if (optsv != Val_int (0))
623 svv = unoption (optsv, Val_false);
625 count = call_sv (sv, G_EVAL|G_VOID);
627 else if (optfnname != Val_int (0))
629 fnname = unoption (optfnname, Val_false);
630 count = call_pv (String_val (fnname), G_EVAL|G_VOID);
635 "Perl.call_void: must supply either 'sv' or 'fn' parameters.");
641 assert (count == 0); /* Pretty sure it should never be anything else. */
643 /* Restore the stack. */
648 check_perl_failure ();
650 CAMLreturn (Val_unit);
654 perl4caml_eval (value expr)
659 CAMLlocal2 (errv, svv);
661 sv = eval_pv (String_val (expr), G_SCALAR);
663 check_perl_failure ();
670 perl4caml_call_method (value ref, value name, value arglist)
672 CAMLparam3 (ref, name, arglist);
676 CAMLlocal2 (errv, svv);
681 /* Push the parameter list. */
685 XPUSHs (sv_2mortal (newSVsv (sv)));
687 /* Iteration over the linked list. */
688 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
690 svv = Field (arglist, 0);
692 XPUSHs (sv_2mortal (newSVsv (sv)));
697 count = call_method (String_val (name), G_EVAL|G_SCALAR);
701 assert (count == 1); /* Pretty sure it should never be anything else. */
703 /* Pop return value off the stack. Note that the return value on the
704 * stack is mortal, so we need to take a copy.
711 check_perl_failure ();
718 perl4caml_call_method_array (value ref, value name, value arglist)
720 CAMLparam3 (ref, name, arglist);
724 CAMLlocal4 (errv, svv, list, cons);
729 /* Push the parameter list. */
733 XPUSHs (sv_2mortal (newSVsv (sv)));
735 /* Iteration over the linked list. */
736 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
738 svv = Field (arglist, 0);
740 XPUSHs (sv_2mortal (newSVsv (sv)));
745 count = call_method (String_val (name), G_EVAL|G_ARRAY);
749 /* Pop all return values off the stack. Note that the return values on the
750 * stack are mortal, so we need to take a copy.
753 for (i = 0; i < count; ++i) {
755 Field (cons, 1) = list;
757 Field (cons, 0) = Val_sv (newSVsv (POPs));
760 /* Restore the stack. */
765 check_perl_failure ();
771 perl4caml_call_method_void (value ref, value name, value arglist)
773 CAMLparam3 (ref, name, arglist);
777 CAMLlocal2 (errv, svv);
782 /* Push the parameter list. */
786 XPUSHs (sv_2mortal (newSVsv (sv)));
788 /* Iteration over the linked list. */
789 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
791 svv = Field (arglist, 0);
793 XPUSHs (sv_2mortal (newSVsv (sv)));
798 count = call_method (String_val (name), G_EVAL|G_VOID);
802 assert (count == 0); /* Pretty sure it should never be anything else. */
804 /* Restore the stack. */
809 check_perl_failure ();
811 CAMLreturn (Val_unit);
815 perl4caml_call_class_method (value classname, value name, value arglist)
817 CAMLparam3 (classname, name, arglist);
821 CAMLlocal2 (errv, svv);
826 /* Push the parameter list. */
829 XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
831 /* Iteration over the linked list. */
832 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
834 svv = Field (arglist, 0);
836 XPUSHs (sv_2mortal (newSVsv (sv)));
841 count = call_method (String_val (name), G_EVAL|G_SCALAR);
845 assert (count == 1); /* Pretty sure it should never be anything else. */
847 /* Pop return value off the stack. Note that the return value on the
848 * stack is mortal, so we need to take a copy.
855 check_perl_failure ();
862 perl4caml_call_class_method_array (value classname, value name, value arglist)
864 CAMLparam3 (classname, name, arglist);
868 CAMLlocal4 (errv, svv, list, cons);
873 /* Push the parameter list. */
876 XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
878 /* Iteration over the linked list. */
879 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
881 svv = Field (arglist, 0);
883 XPUSHs (sv_2mortal (newSVsv (sv)));
888 count = call_method (String_val (name), G_EVAL|G_ARRAY);
892 /* Pop all return values off the stack. Note that the return values on the
893 * stack are mortal, so we need to take a copy.
896 for (i = 0; i < count; ++i) {
898 Field (cons, 1) = list;
900 Field (cons, 0) = Val_sv (newSVsv (POPs));
903 /* Restore the stack. */
908 check_perl_failure ();
914 perl4caml_call_class_method_void (value classname, value name, value arglist)
916 CAMLparam3 (classname, name, arglist);
920 CAMLlocal2 (errv, svv);
925 /* Push the parameter list. */
928 XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
930 /* Iteration over the linked list. */
931 for (; arglist != Val_int (0); arglist = Field (arglist, 1))
933 svv = Field (arglist, 0);
935 XPUSHs (sv_2mortal (newSVsv (sv)));
940 count = call_method (String_val (name), G_EVAL|G_VOID);
944 assert (count == 0); /* Pretty sure it should never be anything else. */
946 /* Restore the stack. */
951 check_perl_failure ();
953 CAMLreturn (Val_unit);
957 Val_voidptr (void *ptr)
959 value rv = alloc (1, Abstract_tag); /* XXX Is this correct? */
960 Field(rv, 0) = (value) ptr;
965 unoption (value option, value deflt)
967 if (option == Val_int (0)) /* "None" */
970 return Field (option, 0);