--- /dev/null
+*.cmi
+*.cmo
+*.cmx
+*.cma
+*.cmxa
+test
\ No newline at end of file
--- /dev/null
+perl.cmo: perl.cmi
+perl.cmx: perl.cmi
+test.cmo: perl.cmi
+test.cmx: perl.cmx
--- /dev/null
+# 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
--- /dev/null
+# 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. <EXTERN.h>.
+
+PERLINCDIR := $(shell perl -MConfig -e 'print "$$Config{archlib}/CORE"')
--- /dev/null
+(* 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"
+*)
--- /dev/null
+(** 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]).
+ *)
+*)
--- /dev/null
+/* 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 <stdio.h>
+#include <stdlib.h>
+#include <assert.h>
+#include <unistd.h>
+#include <alloca.h>
+
+#include <caml/alloc.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+
+/* 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 <EXTERN.h>
+#include <perl.h>
+
+/* 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;
+}
--- /dev/null
+(* 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
--- /dev/null
+sub return1
+ {
+ print "this is the 'return1' function!\n";
+ 1;
+ }
+
+sub adder
+ {
+ $_[0] + $_[1]
+ }
git.annexia.org / perl4caml.git / commitdiff