From 16900866ff592a4c28e84579b28dd20efedd8613 Mon Sep 17 00:00:00 2001 From: rich Date: Sat, 11 Oct 2003 18:25:52 +0000 Subject: [PATCH 1/1] Added initial caml4perl. --- .cvsignore | 6 ++ .depend | 4 ++ Makefile | 56 +++++++++++++++ Makefile.config | 7 ++ perl.ml | 44 ++++++++++++ perl.mli | 89 ++++++++++++++++++++++++ perl_c.c | 211 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ test.ml | 31 +++++++++ test.pl | 10 +++ 9 files changed, 458 insertions(+) create mode 100644 .cvsignore create mode 100644 .depend create mode 100644 Makefile create mode 100644 Makefile.config create mode 100644 perl.ml create mode 100644 perl.mli create mode 100644 perl_c.c create mode 100644 test.ml create mode 100644 test.pl diff --git a/.cvsignore b/.cvsignore new file mode 100644 index 0000000..42ab944 --- /dev/null +++ b/.cvsignore @@ -0,0 +1,6 @@ +*.cmi +*.cmo +*.cmx +*.cma +*.cmxa +test \ No newline at end of file diff --git a/.depend b/.depend new file mode 100644 index 0000000..70e2493 --- /dev/null +++ b/.depend @@ -0,0 +1,4 @@ +perl.cmo: perl.cmi +perl.cmx: perl.cmi +test.cmo: perl.cmi +test.cmx: perl.cmx diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..b32f3e0 --- /dev/null +++ b/Makefile @@ -0,0 +1,56 @@ +# Interface to Perl from OCaml. +# Copyright (C) 2003 Merjis Ltd. +# $Id: Makefile,v 1.1 2003-10-11 18:25:52 rich Exp $ + +include Makefile.config + +OCAMLC := ocamlc +OCAMLOPT := ocamlopt +OCAMLMKLIB := ocamlmklib +OCAMLDEP := ocamldep + +OCAMLCFLAGS := -w s -g +OCAMLOPTFLAGS := -w s + +CC := gcc +CFLAGS := -Wall -Wno-unused -I$(PERLINCDIR) + +all: perl.cma test + +opt: perl.cmxa + +perl.cma: perl.cmo perl_c.o + $(OCAMLMKLIB) -o perl $^ -lperl + +perl.cmxa: perl.cmx perl_c.o + $(OCAMLMKLIB) -o perl $^ -lperl + +test: test.ml + $(OCAMLC) $^ perl.cma -o $@ + +%.cmi: %.mli + $(OCAMLC) $(OCAMLCFLAGS) -c $< + +%.cmo: %.ml + $(OCAMLC) $(OCAMLCFLAGS) -c $< + +%.cmx: %.ml + $(OCAMLOPT) $(OCAMLOPTFLAGS) -c $< + +.SUFFIXES: .mli .ml .cmi .cmo .cmx + +# Clean. + +clean: + rm -f core *~ *.bak *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so test + +# Build dependencies. + +ifeq ($(wildcard .depend),.depend) +include .depend +endif + +depend: .depend + +.depend: $(wildcard *.ml) $(wildcard *.mli) + $(OCAMLDEP) *.mli *.ml > .depend diff --git a/Makefile.config b/Makefile.config new file mode 100644 index 0000000..acf9799 --- /dev/null +++ b/Makefile.config @@ -0,0 +1,7 @@ +# perl4caml configuration -*- Makefile -*- +# $Id: Makefile.config,v 1.1 2003-10-11 18:25:52 rich Exp $ + +# PERLINCDIR +# Directory containing the Perl include files, eg. . + +PERLINCDIR := $(shell perl -MConfig -e 'print "$$Config{archlib}/CORE"') diff --git a/perl.ml b/perl.ml new file mode 100644 index 0000000..b31466b --- /dev/null +++ b/perl.ml @@ -0,0 +1,44 @@ +(* Interface to Perl from OCaml. + * Copyright (C) 2003 Merjis Ltd. + * $Id: perl.ml,v 1.1 2003-10-11 18:25:52 rich Exp $ + *) + +type t + +type sv + +exception PerlFailure of string + +(* Perform some once-only initialization when the library is loaded. *) +external init : unit -> unit = "perl4caml_init" +let () = init () + +external create : ?args:string array -> unit -> t + = "perl4caml_create" + +external destroy : t -> unit + = "perl4caml_destroy" + +external set_context : t -> unit + = "perl4caml_set_context" + +external int_of_sv : sv -> int = "perl4caml_int_of_sv" +external sv_of_int : int -> sv = "perl4caml_sv_of_int" +external float_of_sv : sv -> int = "perl4caml_float_of_sv" +external sv_of_float : int -> sv = "perl4caml_sv_of_float" +external string_of_sv : sv -> string = "perl4caml_string_of_sv" +external sv_of_string : string -> sv = "perl4caml_sv_of_string" + +external call_scalar : string -> sv list -> sv + = "perl4caml_call_scalar" + +(* +external call_array : string -> sv list -> sv list + = "perl4caml_call_array" + +external call : string -> sv list -> unit + = "perl4caml_call" + +external eval : string -> sv + = "perl4caml_eval" +*) diff --git a/perl.mli b/perl.mli new file mode 100644 index 0000000..b589323 --- /dev/null +++ b/perl.mli @@ -0,0 +1,89 @@ +(** Interface to Perl from OCaml. + * + * Copyright (C) 2003 Merjis Ltd. + * + * $Id: perl.mli,v 1.1 2003-10-11 18:25:52 rich Exp $ + *) + +type t +(** Perl interpreter (abstract type). *) + +type sv +(** Perl scalar value. *) + +exception PerlFailure of string +(** [die] in Perl code is translated automatically into this exception. *) + +external create : ?args:string array -> unit -> t + = "perl4caml_create" +(** Create a Perl interpreter. + * + * The optional [?args] parameter is the command line passed to the + * interpreter, and controls things like whether warnings are enabled + * ([-w]) and which file(s) are parsed. The first element in the + * array is the executable name (you can just set this to [""]). + * + * Perl won't allow you to create multiple interpreters at the same time + * unless Perl itself was compiled with [-Dusemultiplicity]. However you + * can create, then destroy, then create another and so on. + *) + +external destroy : t -> unit + = "perl4caml_destroy" +(** Destroy a Perl interpreter, performing any necessary cleanup. *) + +external set_context : t -> unit + = "perl4caml_set_context" +(** IF Perl was compiled with [-Dusemultiplicity] and IF you are using + * multiple interpreters at the same time, then you must call this to + * set the implied "current" interpreter. + * + * Most users will never need to call this function. + *) + +external int_of_sv : sv -> int = "perl4caml_int_of_sv" +(** Convert a Perl [SV] into an integer. Note that OCaml [int]s aren't + * large enough to store the full 32 (or 64) bits from a Perl integer, + * so you may get a silent overflow. + *) +external sv_of_int : int -> sv = "perl4caml_sv_of_int" +(** Convert an [int] into a Perl [SV]. *) +external float_of_sv : sv -> int = "perl4caml_float_of_sv" +(** Convert a Perl [SV] into a float. *) +external sv_of_float : int -> sv = "perl4caml_sv_of_float" +(** Convert a [float] into a Perl [SV]. *) +external string_of_sv : sv -> string = "perl4caml_string_of_sv" +(** Convert a Perl [SV] into a string. *) +external sv_of_string : string -> sv = "perl4caml_sv_of_string" +(** Convert a [string] into a Perl [SV]. *) + +external call_scalar : string -> sv list -> sv + = "perl4caml_call_scalar" +(** Call a named Perl function in a scalar context. Returns the Perl [SV] + * containing the result value. (See {!int_of_sv} etc.). + * + * If the Perl code calls [die] then this will throw [PerlFailure]. + *) + +(* +external call_array : string -> sv list -> sv list + = "perl4caml_call_array" +(** Call a named Perl function in an array context. Returns the array as + * a list of Perl [SV]s. + * + * If the Perl code calls [die] then this will throw [PerlFailure]. + *) + +external call : string -> sv list -> unit + = "perl4caml_call" +(** Call a named Perl function in a void context, discarding any results. + * + * If the Perl code calls [die] then this will throw [PerlFailure]. + *) + +external eval : string -> sv + = "perl4caml_eval" +(** This is exactly like the Perl [eval] command. It evaluates a piece of + * Perl code (in scalar context) and returns the result (a Perl [SV]). + *) +*) diff --git a/perl_c.c b/perl_c.c new file mode 100644 index 0000000..53365b3 --- /dev/null +++ b/perl_c.c @@ -0,0 +1,211 @@ +/* Interface to Perl from OCaml. + * Copyright (C) 2003 Merjis Ltd. + * $Id: perl_c.c,v 1.1 2003-10-11 18:25:52 rich Exp $ + */ + +#include +#include +#include +#include +#include + +#include +#include +#include +#include +#include + +/* XXX This was required to avoid an error on my machine when loading the Perl + * headers. Not clear why this is missing. + */ +#define off64_t __off64_t + +#include +#include + +/* Perl requires the interpreter to be called literally 'my_perl'! */ +static PerlInterpreter *my_perl; + +/* Wrap up an arbitrary void pointer in an opaque OCaml object. */ +static value Val_voidptr (void *ptr); + +/* Unwrap an arbitrary void pointer from an opaque OCaml object. */ +#define Voidptr_val(type,rv) ((type *) Field ((rv), 0)) + +/* Hide Perl types in opaque OCaml objects. */ +#define Val_perl(pl) (Val_voidptr ((pl))) +#define Perl_val(plv) (Voidptr_val (PerlInterpreter, (plv))) +#define Val_sv(sv) (Val_voidptr ((sv))) +#define Sv_val(svv) (Voidptr_val (SV, (svv))) + +CAMLprim value +perl4caml_init (value unit) +{ + PERL_SYS_INIT3 (NULL, NULL, NULL); + return Val_unit; +} + +CAMLprim value +perl4caml_create (value optargs, value unit) +{ + CAMLparam2 (optargs, unit); + CAMLlocal1 (args); + int argc, i; + char **argv; + static char *no_args[] = { "", "-e", "0" }; + + /* Arguments given? */ + if (optargs == Val_int (0)) /* "None" */ + { + argc = 3; + argv = no_args; + } + else /* "Some args" where args is a string array. */ + { + args = Field (optargs, 0); + argc = Wosize_val (args); + argv = alloca (argc * sizeof (char *)); + for (i = 0; i < argc; ++i) argv[i] = String_val (Field (args, i)); + } + + my_perl = perl_alloc (); + perl_construct (my_perl); + PL_exit_flags |= PERL_EXIT_DESTRUCT_END; + perl_parse (my_perl, NULL, argc, argv, NULL); + perl_run (my_perl); + + CAMLreturn (Val_perl (my_perl)); +} + +CAMLprim value +perl4caml_destroy (value plv) +{ + CAMLparam1 (plv); + PerlInterpreter *pl = Perl_val (plv); + + perl_destruct (pl); + perl_free (pl); + + CAMLreturn (Val_unit); +} + +CAMLprim value +perl4caml_set_context (value plv) +{ + CAMLparam1 (plv); + PerlInterpreter *pl = Perl_val (plv); + + PERL_SET_CONTEXT (pl); + my_perl = pl; + + CAMLreturn (Val_unit); +} + +CAMLprim value +perl4caml_int_of_sv (value svv) +{ + CAMLparam1 (svv); + SV *sv = Sv_val (svv); + CAMLreturn (Val_int (SvIV (sv))); +} + +CAMLprim value +perl4caml_sv_of_int (value iv) +{ + CAMLparam1 (iv); + CAMLreturn (Val_sv (newSViv (Int_val (iv)))); +} + +CAMLprim value +perl4caml_float_of_sv (value svv) +{ + CAMLparam1 (svv); + SV *sv = Sv_val (svv); + CAMLlocal1 (f); + f = copy_double (SvNV (sv)); + CAMLreturn (f); +} + +CAMLprim value +perl4caml_sv_of_float (value fv) +{ + CAMLparam1 (fv); + CAMLreturn (Val_sv (newSViv (Double_val (fv)))); +} + +CAMLprim value +perl4caml_string_of_sv (value svv) +{ + CAMLparam1 (svv); + SV *sv = Sv_val (svv); + char *str; + STRLEN len; + CAMLlocal1 (strv); + str = SvPV (sv, len); + /* XXX This won't work if the string contains NUL. */ + strv = copy_string (str); + CAMLreturn (strv); +} + +CAMLprim value +perl4caml_sv_of_string (value strv) +{ + CAMLparam1 (strv); + CAMLreturn (Val_sv (newSVpv (String_val (strv), string_length (strv)))); +} + +CAMLprim value +perl4caml_call_scalar (value fnname, value arglist) +{ + CAMLparam2 (fnname, arglist); + dSP; + int count; + SV *sv; + CAMLlocal2 (errv, svv); + + ENTER; + SAVETMPS; + + /* Push the parameter list. */ + PUSHMARK (SP); + /* XXX NOT IMPLEMENTED YET. */ + PUTBACK; + + count = call_pv (String_val (fnname), G_EVAL|G_SCALAR); + + SPAGAIN; + + assert (count == 1); /* Pretty sure it should never be anything else. */ + + /* Pop return value off the stack and restore Perl stack. Note that the + * return value on the stack is mortal, so we need to take a copy. + */ + sv = newSVsv (POPs); + PUTBACK; + FREETMPS; + LEAVE; + + /* Died with an error? */ + if (SvTRUE (ERRSV)) + { + STRLEN n_a; + const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */ + + errv = copy_string (err); + + raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); + } + else + { + svv = Val_sv (sv); + CAMLreturn (svv); + } +} + +value +Val_voidptr (void *ptr) +{ + value rv = alloc (1, Abstract_tag); /* XXX Is this correct? */ + Field(rv, 0) = (value) ptr; + return rv; +} diff --git a/test.ml b/test.ml new file mode 100644 index 0000000..35754a4 --- /dev/null +++ b/test.ml @@ -0,0 +1,31 @@ +(* Simple test of the API. + * Copyright (C) 2003 Merjis Ltd. + * $Id: test.ml,v 1.1 2003-10-11 18:25:52 rich Exp $ + *) + +open Printf + +let () = + (* Arguments passed to the Perl "command line". Loads [test.pl] *) + let args = [| ""; "-wT"; "test.pl" |] in + + (* Create the Perl interpreter. *) + let pl = Perl.create ~args () in + + (* Call some subroutines in [test.pl]. *) + let sv = Perl.call_scalar "return1" [] in + printf "return1 = %d\n" (Perl.int_of_sv sv); + +(* + let sv = Perl.call_scalar "adder" [`Int 3; `Int 4] in + printf "adder (3, 4) = %d\n" (Perl.int_of_sv sv); +*) + +(* + (* Evaluate a simple expression. *) + Perl.eval "$a = 3"; + printf "$a contains %d\n" (Perl.int_of_sv (Perl.get_sv "a")); +*) + + (* Destroy the interpreter. *) + Perl.destroy pl diff --git a/test.pl b/test.pl new file mode 100644 index 0000000..480be16 --- /dev/null +++ b/test.pl @@ -0,0 +1,10 @@ +sub return1 + { + print "this is the 'return1' function!\n"; + 1; + } + +sub adder + { + $_[0] + $_[1] + } -- 1.8.3.1