From: rich <rich>
Date: Sat, 11 Oct 2003 18:25:52 +0000 (+0000)
Subject: Added initial caml4perl.
X-Git-Url: http://git.annexia.org/?p=perl4caml.git;a=commitdiff_plain;h=16900866ff592a4c28e84579b28dd20efedd8613

Added initial caml4perl.
---

16900866ff592a4c28e84579b28dd20efedd8613
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. <EXTERN.h>.
+
+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 <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;
+}
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]
+  }