(* Interface to Perl from OCaml.
* Copyright (C) 2003 Merjis Ltd.
- * $Id: perl.ml,v 1.2 2003-10-12 10:52:00 rich Exp $
+ * $Id: perl.ml,v 1.3 2003-10-12 11:56:26 rich Exp $
*)
type t
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 sv_is_true : sv -> bool = "perl4caml_sv_is_true"
+external sv_is_undef : sv -> bool = "perl4caml_sv_is_undef"
+external sv_get_undef : unit -> sv = "perl4caml_sv_get_undef"
+external sv_get_yes : unit -> sv = "perl4caml_sv_get_yes"
+external sv_get_no : unit -> sv = "perl4caml_sv_get_no"
+
+let sv_undef = sv_get_undef ()
+let sv_true = sv_get_yes ()
+let sv_false = sv_get_no ()
external get_sv : ?create:bool -> string -> sv = "perl4caml_get_sv"
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_void : ?sv:sv -> ?fn:string -> sv list -> unit
= "perl4caml_call_void"
external eval : string -> sv
= "perl4caml_eval"
+
+external call_method : sv -> string -> sv list -> sv
+ = "perl4caml_call_method"
+external call_method_array : sv -> string -> sv list -> sv list
+ = "perl4caml_call_method_array"
+external call_method_void : sv -> string -> sv list -> unit
+ = "perl4caml_call_method_void"
+external call_class_method : string -> string -> sv list -> sv
+ = "perl4caml_call_class_method"
+external call_class_method_array : string -> string -> sv list -> sv list
+ = "perl4caml_call_class_method_array"
+external call_class_method_void : string -> string -> sv list -> unit
+ = "perl4caml_call_class_method_void"
*
* Copyright (C) 2003 Merjis Ltd.
*
- * $Id: perl.mli,v 1.2 2003-10-12 10:52:00 rich Exp $
+ * $Id: perl.mli,v 1.3 2003-10-12 11:56:26 rich Exp $
*)
type t
(** 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 sv_is_true : sv -> bool = "perl4caml_sv_is_true"
+(** Return [true] if the [SV] is "true" (in the Perl sense of truth). *)
+external sv_is_undef : sv -> bool = "perl4caml_sv_is_undef"
+(** Return [true] if the [SV] is undefined (is [undef]). *)
+val sv_undef : sv
+(** Returns [undef]. *)
+val sv_true : sv
+(** Returns an [SV] which is true. *)
+val sv_false : sv
+(** Returns an [SV] which is false. *)
external get_sv : ?create:bool -> string -> sv = "perl4caml_get_sv"
(** Return a scalar value by name. For example, if you have a symbol
(** 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]).
*)
+
+external call_method : sv -> string -> sv list -> sv
+ = "perl4caml_call_method"
+(** [call_method obj name [parameters]] calls the method [name] on the Perl
+ * object [obj] with the given parameters, in a scalar context. Thus this
+ * is equivalent to [$obj->name (parameters)].
+ *
+ * Returns the Perl [SV] containing the result value.
+ *
+ * If the method calls [die] then this will throw [Perl_failure].
+ *)
+
+external call_method_array : sv -> string -> sv list -> sv list
+ = "perl4caml_call_method_array"
+(** Like [call_method], but the method is called in an array context. *)
+
+external call_method_void : sv -> string -> sv list -> unit
+ = "perl4caml_call_method_void"
+(** Like [call_method], but the method is called in a void context (results
+ * are discarded). *)
+
+external call_class_method : string -> string -> sv list -> sv
+ = "perl4caml_call_class_method"
+(** [call_class_method classname name [parameters]] calls the static method
+ * [name] in the Perl class [classname] with the given parameters, in a
+ * scalar context. Thus this is equivalent to [$classname->name (parameters)].
+ *
+ * Returns the Perl [SV] containing the result value.
+ *
+ * If the static method calls [die] then this will throw [Perl_failure].
+ *)
+
+external call_class_method_array : string -> string -> sv list -> sv list
+ = "perl4caml_call_class_method_array"
+(** Like [call_class_method], but the method is called in an array context. *)
+
+external call_class_method_void : string -> string -> sv list -> unit
+ = "perl4caml_call_class_method_void"
+(** Like [call_class_method], but the method is called in a void context. *)
/* Interface to Perl from OCaml.
* Copyright (C) 2003 Merjis Ltd.
- * $Id: perl_c.c,v 1.2 2003-10-12 10:52:00 rich Exp $
+ * $Id: perl_c.c,v 1.3 2003-10-12 11:56:26 rich Exp $
*/
#include <stdio.h>
}
CAMLprim value
+perl4caml_sv_is_true (value svv)
+{
+ CAMLparam1 (svv);
+ SV *sv = Sv_val (svv);
+ CAMLreturn (SvTRUE (sv) ? Val_true : Val_false);
+}
+
+CAMLprim value
+perl4caml_sv_is_undef (value svv)
+{
+ CAMLparam1 (svv);
+ SV *sv = Sv_val (svv);
+ CAMLreturn (sv == &PL_sv_undef ? Val_true : Val_false);
+}
+
+CAMLprim value
+perl4caml_sv_get_undef (value unit)
+{
+ CAMLparam1 (unit);
+ CAMLreturn (Val_sv (&PL_sv_undef));
+}
+
+CAMLprim value
+perl4caml_sv_get_yes (value unit)
+{
+ CAMLparam1 (unit);
+ CAMLreturn (Val_sv (&PL_sv_yes));
+}
+
+CAMLprim value
+perl4caml_sv_get_no (value unit)
+{
+ CAMLparam1 (unit);
+ CAMLreturn (Val_sv (&PL_sv_no));
+}
+
+CAMLprim value
perl4caml_get_sv (value optcreate, value name)
{
CAMLparam2 (optcreate, name);
}
}
+CAMLprim value
+perl4caml_call_method (value ref, value name, value arglist)
+{
+ CAMLparam3 (ref, name, arglist);
+ dSP;
+ int count;
+ SV *sv;
+ CAMLlocal2 (errv, svv);
+
+ ENTER;
+ SAVETMPS;
+
+ /* Push the parameter list. */
+ PUSHMARK (SP);
+
+ sv = Sv_val (ref);
+ XPUSHs (sv_2mortal (newSVsv (sv)));
+
+ /* 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_method (String_val (name), G_EVAL|G_SCALAR);
+
+ SPAGAIN;
+
+ assert (count == 1); /* Pretty sure it should never be anything else. */
+
+ /* 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?
+ * 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);
+ }
+}
+
+CAMLprim value
+perl4caml_call_method_array (value ref, value name, value arglist)
+{
+ CAMLparam3 (ref, name, arglist);
+ dSP;
+ int count, i;
+ SV *sv;
+ CAMLlocal4 (errv, svv, list, cons);
+
+ ENTER;
+ SAVETMPS;
+
+ /* Push the parameter list. */
+ PUSHMARK (SP);
+
+ sv = Sv_val (ref);
+ XPUSHs (sv_2mortal (newSVsv (sv)));
+
+ /* 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_method (String_val (name), G_EVAL|G_ARRAY);
+
+ SPAGAIN;
+
+ /* Pop all return values off the stack. Note that the return values on the
+ * stack are mortal, so we need to take a copy.
+ */
+ 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_method_void (value ref, value name, value arglist)
+{
+ CAMLparam3 (ref, name, arglist);
+ dSP;
+ int count;
+ SV *sv;
+ CAMLlocal2 (errv, svv);
+
+ ENTER;
+ SAVETMPS;
+
+ /* Push the parameter list. */
+ PUSHMARK (SP);
+
+ sv = Sv_val (ref);
+ XPUSHs (sv_2mortal (newSVsv (sv)));
+
+ /* 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_method (String_val (name), G_EVAL|G_VOID);
+
+ 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_call_class_method (value classname, value name, value arglist)
+{
+ CAMLparam3 (classname, name, arglist);
+ dSP;
+ int count;
+ SV *sv;
+ CAMLlocal2 (errv, svv);
+
+ ENTER;
+ SAVETMPS;
+
+ /* Push the parameter list. */
+ PUSHMARK (SP);
+
+ XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
+
+ /* 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_method (String_val (name), G_EVAL|G_SCALAR);
+
+ SPAGAIN;
+
+ assert (count == 1); /* Pretty sure it should never be anything else. */
+
+ /* 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?
+ * 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);
+ }
+}
+
+CAMLprim value
+perl4caml_call_class_method_array (value classname, value name, value arglist)
+{
+ CAMLparam3 (classname, name, arglist);
+ dSP;
+ int count, i;
+ SV *sv;
+ CAMLlocal4 (errv, svv, list, cons);
+
+ ENTER;
+ SAVETMPS;
+
+ /* Push the parameter list. */
+ PUSHMARK (SP);
+
+ XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
+
+ /* 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_method (String_val (name), G_EVAL|G_ARRAY);
+
+ SPAGAIN;
+
+ /* Pop all return values off the stack. Note that the return values on the
+ * stack are mortal, so we need to take a copy.
+ */
+ 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_class_method_void (value classname, value name, value arglist)
+{
+ CAMLparam3 (classname, name, arglist);
+ dSP;
+ int count;
+ SV *sv;
+ CAMLlocal2 (errv, svv);
+
+ ENTER;
+ SAVETMPS;
+
+ /* Push the parameter list. */
+ PUSHMARK (SP);
+
+ XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
+
+ /* 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_method (String_val (name), G_EVAL|G_VOID);
+
+ 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);
+}
+
static value
Val_voidptr (void *ptr)
{
git.annexia.org / perl4caml.git / commitdiff