*
* 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
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
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
(** 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]).
*)
-*)
/* 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 <stdio.h>
/* 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))
}
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;
}
}
-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);
+}
(* 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
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
git.annexia.org / perl4caml.git / commitdiff