From b3ce4df051b4343721e8a5cfe253fbcc95877165 Mon Sep 17 00:00:00 2001 From: rich Date: Sun, 12 Oct 2003 10:52:00 +0000 Subject: [PATCH] Support for calling SVs, eval, array context, void context, get_sv. --- Makefile | 4 +- perl.ml | 23 +++--- perl.mli | 50 ++++++++----- perl_c.c | 256 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--- test.ml | 31 +++++--- test.pl | 25 ++++++- 6 files changed, 337 insertions(+), 52 deletions(-) diff --git a/Makefile b/Makefile index b32f3e0..b42813b 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ # Interface to Perl from OCaml. # Copyright (C) 2003 Merjis Ltd. -# $Id: Makefile,v 1.1 2003-10-11 18:25:52 rich Exp $ +# $Id: Makefile,v 1.2 2003-10-12 10:52:00 rich Exp $ include Makefile.config @@ -26,7 +26,7 @@ perl.cmxa: perl.cmx perl_c.o $(OCAMLMKLIB) -o perl $^ -lperl test: test.ml - $(OCAMLC) $^ perl.cma -o $@ + $(OCAMLC) perl.cma $^ -o $@ %.cmi: %.mli $(OCAMLC) $(OCAMLCFLAGS) -c $< diff --git a/perl.ml b/perl.ml index b31466b..43f6c42 100644 --- a/perl.ml +++ b/perl.ml @@ -1,17 +1,18 @@ (* Interface to Perl from OCaml. * Copyright (C) 2003 Merjis Ltd. - * $Id: perl.ml,v 1.1 2003-10-11 18:25:52 rich Exp $ + * $Id: perl.ml,v 1.2 2003-10-12 10:52:00 rich Exp $ *) type t type sv -exception PerlFailure of string +exception Perl_failure of string -(* Perform some once-only initialization when the library is loaded. *) external init : unit -> unit = "perl4caml_init" -let () = init () +let () = + Callback.register_exception "perl4caml_perl_failure" (Perl_failure ""); + init () (* Initialise C code. *) external create : ?args:string array -> unit -> t = "perl4caml_create" @@ -29,16 +30,16 @@ 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 get_sv : ?create:bool -> string -> sv = "perl4caml_get_sv" -(* -external call_array : string -> sv list -> sv list +external call : ?sv:sv -> ?fn:string -> sv list -> sv + = "perl4caml_call" + +external call_array : ?sv:sv -> ?fn:string -> sv list -> sv list = "perl4caml_call_array" -external call : string -> sv list -> unit - = "perl4caml_call" +external call_void : ?sv:sv -> ?fn:string -> sv list -> unit + = "perl4caml_call_void" external eval : string -> sv = "perl4caml_eval" -*) diff --git a/perl.mli b/perl.mli index b589323..8c6db5a 100644 --- a/perl.mli +++ b/perl.mli @@ -2,7 +2,7 @@ * * Copyright (C) 2003 Merjis Ltd. * - * $Id: perl.mli,v 1.1 2003-10-11 18:25:52 rich Exp $ + * $Id: perl.mli,v 1.2 2003-10-12 10:52:00 rich Exp $ *) type t @@ -11,7 +11,7 @@ type t type sv (** Perl scalar value. *) -exception PerlFailure of string +exception Perl_failure of string (** [die] in Perl code is translated automatically into this exception. *) external create : ?args:string array -> unit -> t @@ -57,28 +57,45 @@ external string_of_sv : sv -> string = "perl4caml_string_of_sv" 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.). +external get_sv : ?create:bool -> string -> sv = "perl4caml_get_sv" +(** Return a scalar value by name. For example, if you have a symbol + * called [$a] in Perl, then [get_sv "a"] will return its value. * - * If the Perl code calls [die] then this will throw [PerlFailure]. + * If the symbol does not exist, this throws [Not_found]. + * + * If the optional [?create] argument is set to true and the symbol does + * not exist, then Perl will create the symbol (with value [undef]) and + * this function will return the [SV] for [undef]. *) -(* -external call_array : string -> sv list -> sv list +external call : ?sv:sv -> ?fn:string -> sv list -> sv + = "perl4caml_call" +(** Call a Perl function in a scalar context, either by name (using the [?fn] + * parameter) or by calling a string/CODEREF (using the [?sv] parameter). + * + * Returns the Perl [SV] containing the result value. (See {!int_of_sv} etc.). + * + * If the Perl code calls [die] then this will throw [Perl_failure]. + *) + +external call_array : ?sv:sv -> ?fn: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. +(** Call a Perl function in an array context, either by name (using the [?fn] + * parameter) or by calling a string/CODEREF (using the [?sv] parameter). + * + * Returns the list of results. * - * If the Perl code calls [die] then this will throw [PerlFailure]. + * If the Perl code calls [die] then this will throw [Perl_failure]. *) -external call : string -> sv list -> unit - = "perl4caml_call" -(** Call a named Perl function in a void context, discarding any results. +external call_void : ?sv:sv -> ?fn:string -> sv list -> unit + = "perl4caml_call_void" +(** Call a Perl function in a void context, either by name (using the [?fn] + * parameter) or by calling a string/CODEREF (using the [?sv] parameter). + * + * Any results are discarded. * - * If the Perl code calls [die] then this will throw [PerlFailure]. + * If the Perl code calls [die] then this will throw [Perl_failure]. *) external eval : string -> sv @@ -86,4 +103,3 @@ external eval : string -> sv (** 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 index 53365b3..7de608b 100644 --- a/perl_c.c +++ b/perl_c.c @@ -1,6 +1,6 @@ /* 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 $ + * $Id: perl_c.c,v 1.2 2003-10-12 10:52:00 rich Exp $ */ #include @@ -29,6 +29,9 @@ static PerlInterpreter *my_perl; /* Wrap up an arbitrary void pointer in an opaque OCaml object. */ static value Val_voidptr (void *ptr); +/* Get the concrete value from an optional field. */ +static value unoption (value option, value deflt); + /* Unwrap an arbitrary void pointer from an opaque OCaml object. */ #define Voidptr_val(type,rv) ((type *) Field ((rv), 0)) @@ -155,37 +158,77 @@ perl4caml_sv_of_string (value strv) } CAMLprim value -perl4caml_call_scalar (value fnname, value arglist) +perl4caml_get_sv (value optcreate, value name) +{ + CAMLparam2 (optcreate, name); + CAMLlocal1 (create); + SV *sv; + + create = unoption (optcreate, Val_false); + sv = get_sv (String_val (name), create == Val_true ? TRUE : FALSE); + if (sv == NULL) raise_not_found (); + + CAMLreturn (Val_sv (sv)); +} + +CAMLprim value +perl4caml_call (value optsv, value optfnname, value arglist) { - CAMLparam2 (fnname, arglist); + CAMLparam3 (optsv, optfnname, arglist); dSP; int count; SV *sv; - CAMLlocal2 (errv, svv); + CAMLlocal3 (errv, svv, fnname); ENTER; SAVETMPS; /* Push the parameter list. */ PUSHMARK (SP); - /* XXX NOT IMPLEMENTED YET. */ + + /* Iteration over the linked list. */ + for (; arglist != Val_int (0); arglist = Field (arglist, 1)) + { + svv = Field (arglist, 0); + sv = Sv_val (svv); + XPUSHs (sv_2mortal (newSVsv (sv))); + } + PUTBACK; - count = call_pv (String_val (fnname), G_EVAL|G_SCALAR); + if (optsv != Val_int (0)) + { + svv = unoption (optsv, Val_false); + sv = Sv_val (svv); + count = call_sv (sv, G_EVAL|G_SCALAR); + } + else if (optfnname != Val_int (0)) + { + fnname = unoption (optfnname, Val_false); + count = call_pv (String_val (fnname), G_EVAL|G_SCALAR); + } + else + { + fprintf (stderr, + "Perl.call: must supply either 'sv' or 'fn' parameters."); + abort (); + } 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. + /* Pop return value off the 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? */ + /* Died with an error? + * XXX Actually this doesn't work for some reason. + */ if (SvTRUE (ERRSV)) { STRLEN n_a; @@ -202,10 +245,203 @@ perl4caml_call_scalar (value fnname, value arglist) } } -value +CAMLprim value +perl4caml_call_array (value optsv, value optfnname, value arglist) +{ + CAMLparam3 (optsv, optfnname, arglist); + dSP; + int i, count; + SV *sv; + CAMLlocal5 (errv, svv, fnname, list, cons); + + ENTER; + SAVETMPS; + + /* Push the parameter list. */ + PUSHMARK (SP); + + /* Iteration over the linked list. */ + for (; arglist != Val_int (0); arglist = Field (arglist, 1)) + { + svv = Field (arglist, 0); + sv = Sv_val (svv); + XPUSHs (sv_2mortal (newSVsv (sv))); + } + + PUTBACK; + + if (optsv != Val_int (0)) + { + svv = unoption (optsv, Val_false); + sv = Sv_val (svv); + count = call_sv (sv, G_EVAL|G_ARRAY); + } + else if (optfnname != Val_int (0)) + { + fnname = unoption (optfnname, Val_false); + count = call_pv (String_val (fnname), G_EVAL|G_ARRAY); + } + else + { + fprintf (stderr, + "Perl.call_array: must supply either 'sv' or 'fn' parameters."); + abort (); + } + + SPAGAIN; + + /* Pop all the return values off the stack into a list. Values on the + * stack are mortal, so we must copy them. + */ + list = Val_int (0); + for (i = 0; i < count; ++i) { + cons = alloc (2, 0); + Field (cons, 1) = list; + list = cons; + Field (cons, 0) = Val_sv (newSVsv (POPs)); + } + + /* Restore the stack. */ + PUTBACK; + FREETMPS; + LEAVE; + + /* Died with an error? + * XXX Actually this doesn't work for some reason. + */ + 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 + CAMLreturn (list); +} + +CAMLprim value +perl4caml_call_void (value optsv, value optfnname, value arglist) +{ + CAMLparam3 (optsv, optfnname, arglist); + dSP; + int count; + SV *sv; + CAMLlocal3 (errv, svv, fnname); + + ENTER; + SAVETMPS; + + /* Push the parameter list. */ + PUSHMARK (SP); + + /* Iteration over the linked list. */ + for (; arglist != Val_int (0); arglist = Field (arglist, 1)) + { + svv = Field (arglist, 0); + sv = Sv_val (svv); + XPUSHs (sv_2mortal (newSVsv (sv))); + } + + PUTBACK; + + if (optsv != Val_int (0)) + { + svv = unoption (optsv, Val_false); + sv = Sv_val (svv); + count = call_sv (sv, G_EVAL|G_VOID); + } + else if (optfnname != Val_int (0)) + { + fnname = unoption (optfnname, Val_false); + count = call_pv (String_val (fnname), G_EVAL|G_VOID); + } + else + { + fprintf (stderr, + "Perl.call_void: must supply either 'sv' or 'fn' parameters."); + abort (); + } + + SPAGAIN; + + assert (count == 0); /* Pretty sure it should never be anything else. */ + + /* Restore the stack. */ + PUTBACK; + FREETMPS; + LEAVE; + + /* Died with an error? + * XXX Actually this doesn't work for some reason. + */ + 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 + CAMLreturn (Val_unit); +} + +CAMLprim value +perl4caml_eval (value expr) +{ + CAMLparam1 (expr); + dSP; + SV *sv; + CAMLlocal2 (errv, svv); + + ENTER; + SAVETMPS; + + PUSHMARK (SP); + eval_pv (String_val (expr), G_SCALAR); + + SPAGAIN; + sv = newSVsv (POPs); + PUTBACK; + FREETMPS; + LEAVE; + + /* Died with an error? + * XXX Actually this doesn't work for some reason. + */ + 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); + } +} + +static value Val_voidptr (void *ptr) { value rv = alloc (1, Abstract_tag); /* XXX Is this correct? */ Field(rv, 0) = (value) ptr; return rv; } + +static value +unoption (value option, value deflt) +{ + if (option == Val_int (0)) /* "None" */ + return deflt; + else /* "Some 'a" */ + return Field (option, 0); +} diff --git a/test.ml b/test.ml index 35754a4..2732de1 100644 --- a/test.ml +++ b/test.ml @@ -1,6 +1,6 @@ (* Simple test of the API. * Copyright (C) 2003 Merjis Ltd. - * $Id: test.ml,v 1.1 2003-10-11 18:25:52 rich Exp $ + * $Id: test.ml,v 1.2 2003-10-12 10:52:00 rich Exp $ *) open Printf @@ -13,19 +13,32 @@ let () = 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 ~fn:"return_one" [] in + printf "return_one returned %d\n" (Perl.int_of_sv sv); flush stdout; -(* - let sv = Perl.call_scalar "adder" [`Int 3; `Int 4] in - printf "adder (3, 4) = %d\n" (Perl.int_of_sv sv); -*) + let sv = Perl.call ~fn:"adder" [Perl.sv_of_int 3; Perl.sv_of_int 4] in + printf "adder (3, 4) = %d\n" (Perl.int_of_sv sv); flush stdout; + + let svlist = Perl.call_array ~fn:"return_array" [] in + print_string "array returned:"; + List.iter ( + fun sv -> + printf " %d" (Perl.int_of_sv sv); + ) svlist; + printf "\n"; flush stdout; + + let sv = Perl.sv_of_string "return_one" in + let sv = Perl.call ~sv [] in + printf "return_one returned %d\n" (Perl.int_of_sv sv); flush stdout; + + (* Call a Perl closure. *) + let sv = Perl.call ~fn:"return_closure" [] in + let sv = Perl.call ~sv [Perl.sv_of_int 3; Perl.sv_of_int 4] in + printf "closure returned %d\n" (Perl.int_of_sv sv); flush stdout; -(* (* 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 index 480be16..b2b736d 100644 --- a/test.pl +++ b/test.pl @@ -1,7 +1,26 @@ -sub return1 +print "this is loading the 'test.pl' script!\n"; + +sub return_one + { + print "this is the 'return_one' function!\n"; + 1 + } + +sub return_array + { + print "this is the 'return_array' function!\n"; + (1, 2, 3) + } + +sub return_closure + { + sub { $_[0] * $_[1] } + } + +sub dies { - print "this is the 'return1' function!\n"; - 1; + print "this is the 'dies' function! about to die now ...\n"; + die "this is the exception message from 'dies'"; } sub adder -- 1.8.3.1