From dafc0bde0b51d76c41b2d646af3699730e31dfbb Mon Sep 17 00:00:00 2001 From: rich Date: Sun, 12 Oct 2003 11:56:26 +0000 Subject: [PATCH] Undef, true, false SVs. Class methods. Moved examples into a subdirectory. --- .cvsignore | 1 - Makefile | 13 +- examples/.cvsignore | 6 + examples/TestClass.pm | 23 +++ test.ml => examples/test.ml | 14 +- test.pl => examples/test.pl | 3 + perl.ml | 26 ++- perl.mli | 51 +++++- perl_c.c | 396 +++++++++++++++++++++++++++++++++++++++++++- 9 files changed, 519 insertions(+), 14 deletions(-) create mode 100644 examples/.cvsignore create mode 100644 examples/TestClass.pm rename test.ml => examples/test.ml (67%) rename test.pl => examples/test.pl (92%) diff --git a/.cvsignore b/.cvsignore index 42ab944..c0404dd 100644 --- a/.cvsignore +++ b/.cvsignore @@ -3,4 +3,3 @@ *.cmx *.cma *.cmxa -test \ No newline at end of file diff --git a/Makefile b/Makefile index b42813b..9a18d46 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ # Interface to Perl from OCaml. # Copyright (C) 2003 Merjis Ltd. -# $Id: Makefile,v 1.2 2003-10-12 10:52:00 rich Exp $ +# $Id: Makefile,v 1.3 2003-10-12 11:56:26 rich Exp $ include Makefile.config @@ -15,7 +15,7 @@ OCAMLOPTFLAGS := -w s CC := gcc CFLAGS := -Wall -Wno-unused -I$(PERLINCDIR) -all: perl.cma test +all: perl.cma examples/test opt: perl.cmxa @@ -25,8 +25,8 @@ perl.cma: perl.cmo perl_c.o perl.cmxa: perl.cmx perl_c.o $(OCAMLMKLIB) -o perl $^ -lperl -test: test.ml - $(OCAMLC) perl.cma $^ -o $@ +examples/test: examples/test.ml + $(OCAMLC) $(OCAMLCFLAGS) perl.cma $^ -o $@ %.cmi: %.mli $(OCAMLC) $(OCAMLCFLAGS) -c $< @@ -41,8 +41,11 @@ test: test.ml # Clean. +JUNKFILES = core *~ *.bak *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so + clean: - rm -f core *~ *.bak *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so test + rm -f examples/test + for d in . examples; do (cd $$d; rm -f $(JUNKFILES)); done # Build dependencies. diff --git a/examples/.cvsignore b/examples/.cvsignore new file mode 100644 index 0000000..6882876 --- /dev/null +++ b/examples/.cvsignore @@ -0,0 +1,6 @@ +*.cmi +*.cmo +*.cmx +*.cma +*.cmxa +test diff --git a/examples/TestClass.pm b/examples/TestClass.pm new file mode 100644 index 0000000..a083788 --- /dev/null +++ b/examples/TestClass.pm @@ -0,0 +1,23 @@ +package TestClass; + +sub new + { + my $class = shift; + my $self = { foo => 1 }; + bless $self, $class; + } + +sub get_foo + { + my $self = shift; + $self->{foo} + } + +sub set_foo + { + my $self = shift; + my $value = shift; + $self->{foo} = $value + } + +1; diff --git a/test.ml b/examples/test.ml similarity index 67% rename from test.ml rename to examples/test.ml index 2732de1..56d2bfa 100644 --- a/test.ml +++ b/examples/test.ml @@ -1,13 +1,13 @@ (* Simple test of the API. * Copyright (C) 2003 Merjis Ltd. - * $Id: test.ml,v 1.2 2003-10-12 10:52:00 rich Exp $ + * $Id: test.ml,v 1.1 2003-10-12 11:56:27 rich Exp $ *) open Printf let () = (* Arguments passed to the Perl "command line". Loads [test.pl] *) - let args = [| ""; "-wT"; "test.pl" |] in + let args = [| ""; "-wT"; "examples/test.pl" |] in (* Create the Perl interpreter. *) let pl = Perl.create ~args () in @@ -38,7 +38,15 @@ let () = (* Evaluate a simple expression. *) Perl.eval "$a = 3"; - printf "$a contains %d\n" (Perl.int_of_sv (Perl.get_sv "a")); + printf "$a contains %d\n" (Perl.int_of_sv (Perl.get_sv "a")); flush stdout; + + (* Test calling methods in the "TestClass" class. *) + let obj = Perl.call_class_method "TestClass" "new" [] in + let sv = Perl.call_method obj "get_foo" [] in + printf "TestClass.foo is %d\n" (Perl.int_of_sv sv); flush stdout; + Perl.call_method obj "set_foo" [Perl.sv_of_int 2]; + let sv = Perl.call_method obj "get_foo" [] in + printf "TestClass.foo is %d\n" (Perl.int_of_sv sv); flush stdout; (* Destroy the interpreter. *) Perl.destroy pl diff --git a/test.pl b/examples/test.pl similarity index 92% rename from test.pl rename to examples/test.pl index b2b736d..02ed68b 100644 --- a/test.pl +++ b/examples/test.pl @@ -1,3 +1,6 @@ +use lib "examples"; +use TestClass; + print "this is loading the 'test.pl' script!\n"; sub return_one diff --git a/perl.ml b/perl.ml index 43f6c42..b8c1012 100644 --- a/perl.ml +++ b/perl.ml @@ -1,6 +1,6 @@ (* 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 @@ -29,17 +29,37 @@ 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 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" diff --git a/perl.mli b/perl.mli index 8c6db5a..7473d29 100644 --- a/perl.mli +++ b/perl.mli @@ -2,7 +2,7 @@ * * 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 @@ -56,6 +56,16 @@ 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 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 @@ -103,3 +113,42 @@ 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]). *) + +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. *) diff --git a/perl_c.c b/perl_c.c index 7de608b..690b145 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.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 @@ -158,6 +158,43 @@ perl4caml_sv_of_string (value strv) } 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); @@ -429,6 +466,363 @@ perl4caml_eval (value expr) } } +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) { -- 1.8.3.1