From 1c369c3ba6b71d4524dfacd0ba3554e8a524ed57 Mon Sep 17 00:00:00 2001 From: rich Date: Sun, 12 Oct 2003 17:33:14 +0000 Subject: [PATCH] Added wrappers around some common libraries. --- .depend | 30 +++++ MANIFEST | 13 +- Makefile | 51 ++++++-- Makefile.config | 4 +- examples/.cvsignore | 1 + examples/loadpage.ml | 64 ++++++++++ examples/test.ml | 11 +- perl.ml | 43 +++++-- perl.mli | 77 +++++++++-- perl_c.c | 274 ++++++++++++++++------------------------ perl_init.ml | 6 + wrappers/.cvsignore | 5 + wrappers/pl_HTML_Element.ml | 74 +++++++++++ wrappers/pl_HTML_Parser.ml | 21 +++ wrappers/pl_HTML_TreeBuilder.ml | 34 +++++ wrappers/pl_HTTP_Message.ml | 17 +++ wrappers/pl_HTTP_Request.ml | 40 ++++++ wrappers/pl_HTTP_Response.ml | 42 ++++++ wrappers/pl_LWP_UserAgent.ml | 68 ++++++++++ wrappers/pl_URI.ml | 48 +++++++ 20 files changed, 716 insertions(+), 207 deletions(-) create mode 100644 examples/loadpage.ml create mode 100644 perl_init.ml create mode 100644 wrappers/.cvsignore create mode 100644 wrappers/pl_HTML_Element.ml create mode 100644 wrappers/pl_HTML_Parser.ml create mode 100644 wrappers/pl_HTML_TreeBuilder.ml create mode 100644 wrappers/pl_HTTP_Message.ml create mode 100644 wrappers/pl_HTTP_Request.ml create mode 100644 wrappers/pl_HTTP_Response.ml create mode 100644 wrappers/pl_LWP_UserAgent.ml create mode 100644 wrappers/pl_URI.ml diff --git a/.depend b/.depend index 719dda0..e160297 100644 --- a/.depend +++ b/.depend @@ -1,4 +1,34 @@ perl.cmo: perl.cmi perl.cmx: perl.cmi +perl_init.cmo: perl.cmi +perl_init.cmx: perl.cmx +examples/loadpage.cmo: perl.cmi wrappers/pl_HTML_Element.cmo \ + wrappers/pl_HTML_TreeBuilder.cmo wrappers/pl_HTTP_Request.cmo \ + wrappers/pl_LWP_UserAgent.cmo +examples/loadpage.cmx: perl.cmx wrappers/pl_HTML_Element.cmx \ + wrappers/pl_HTML_TreeBuilder.cmx wrappers/pl_HTTP_Request.cmx \ + wrappers/pl_LWP_UserAgent.cmx examples/test.cmo: perl.cmi examples/test.cmx: perl.cmx +wrappers/pl_HTML_Element.cmo: perl.cmi +wrappers/pl_HTML_Element.cmx: perl.cmx +wrappers/pl_HTML_Parser.cmo: perl.cmi +wrappers/pl_HTML_Parser.cmx: perl.cmx +wrappers/pl_HTML_TreeBuilder.cmo: perl.cmi wrappers/pl_HTML_Element.cmo \ + wrappers/pl_HTML_Parser.cmo +wrappers/pl_HTML_TreeBuilder.cmx: perl.cmx wrappers/pl_HTML_Element.cmx \ + wrappers/pl_HTML_Parser.cmx +wrappers/pl_HTTP_Message.cmo: perl.cmi +wrappers/pl_HTTP_Message.cmx: perl.cmx +wrappers/pl_HTTP_Request.cmo: perl.cmi wrappers/pl_HTTP_Message.cmo \ + wrappers/pl_URI.cmo +wrappers/pl_HTTP_Request.cmx: perl.cmx wrappers/pl_HTTP_Message.cmx \ + wrappers/pl_URI.cmx +wrappers/pl_HTTP_Response.cmo: perl.cmi wrappers/pl_HTTP_Message.cmo +wrappers/pl_HTTP_Response.cmx: perl.cmx wrappers/pl_HTTP_Message.cmx +wrappers/pl_LWP_UserAgent.cmo: perl.cmi wrappers/pl_HTTP_Request.cmo \ + wrappers/pl_HTTP_Response.cmo +wrappers/pl_LWP_UserAgent.cmx: perl.cmx wrappers/pl_HTTP_Request.cmx \ + wrappers/pl_HTTP_Response.cmx +wrappers/pl_URI.cmo: perl.cmi +wrappers/pl_URI.cmx: perl.cmx diff --git a/MANIFEST b/MANIFEST index 7631190..45a7965 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4,9 +4,20 @@ Makefile Makefile.config MANIFEST examples/.cvsignore +examples/loadpage.ml examples/TestClass.pm examples/test.ml examples/test.pl perl.ml perl.mli -perl_c.c \ No newline at end of file +perl_c.c +perl_init.ml +wrappers/.cvsignore +wrappers/pl_HTML_Element.ml +wrappers/pl_HTML_Parser.ml +wrappers/pl_HTML_TreeBuilder.ml +wrappers/pl_HTTP_Message.ml +wrappers/pl_HTTP_Request.ml +wrappers/pl_HTTP_Response.ml +wrappers/pl_LWP_UserAgent.ml +wrappers/pl_URI.ml \ No newline at end of file diff --git a/Makefile b/Makefile index b02d272..c365c0a 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ # Interface to Perl from OCaml. # Copyright (C) 2003 Merjis Ltd. -# $Id: Makefile,v 1.5 2003-10-12 12:14:06 rich Exp $ +# $Id: Makefile,v 1.6 2003-10-12 17:33:14 rich Exp $ include Makefile.config @@ -9,22 +9,46 @@ OCAMLOPT := ocamlopt OCAMLMKLIB := ocamlmklib OCAMLDEP := ocamldep -OCAMLCFLAGS := -w s -g -OCAMLOPTFLAGS := -w s +OCAMLCINCS := -I wrappers +OCAMLOPTINCS := $(OCAMLCINCS) + +OCAMLCFLAGS := -w s -g $(OCAMLCINCS) +OCAMLOPTFLAGS := -w s $(OCAMLOPTINCS) CC := gcc CFLAGS := -Wall -Wno-unused -I$(PERLINCDIR) -all: perl.cma perl.cmxa examples/test +WRAPPERS := \ + wrappers/pl_HTML_Element.cmo \ + wrappers/pl_HTML_Parser.cmo \ + wrappers/pl_HTML_TreeBuilder.cmo \ + wrappers/pl_URI.cmo \ + wrappers/pl_HTTP_Message.cmo \ + wrappers/pl_HTTP_Request.cmo \ + wrappers/pl_HTTP_Response.cmo \ + wrappers/pl_LWP_UserAgent.cmo + +all: perl.cma perl.cmxa perl_init.cmo perl_init.cmx all-examples -perl.cma: perl.cmo perl_c.o +perl.cma: perl.cmo perl_c.o $(WRAPPERS) $(OCAMLMKLIB) -o perl $^ -lperl -perl.cmxa: perl.cmx perl_c.o +perl.cmxa: perl.cmx perl_c.o $(WRAPPERS:.cmo=.cmx) $(OCAMLMKLIB) -o perl $^ -lperl -examples/test: examples/test.ml - $(OCAMLC) $(OCAMLCFLAGS) perl.cma $^ -o $@ +all-examples: examples/test examples/loadpage + +examples/test: examples/test.cmo + $(OCAMLC) $(OCAMLCFLAGS) perl.cma perl_init.cmo $^ -o $@ + +#examples/test.opt: examples/test.cmx +# $(OCAMLOPT) $(OCAMLOPTFLAGS) perl.cmxa perl_init.cmx $^ -o $@ + +examples/loadpage: examples/loadpage.cmo + $(OCAMLC) $(OCAMLCFLAGS) perl.cma perl_init.cmo $^ -o $@ + +#examples/loadpage.opt: examples/loadpage.cmx +# $(OCAMLOPT) $(OCAMLOPTFLAGS) perl.cmxa perl_init.cmx $^ -o $@ %.cmi: %.mli $(OCAMLC) $(OCAMLCFLAGS) -c $< @@ -42,8 +66,8 @@ examples/test: examples/test.ml JUNKFILES = core *~ *.bak *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so clean: - rm -f examples/test - for d in . examples; do (cd $$d; rm -f $(JUNKFILES)); done + rm -f examples/test examples/loadpage + for d in . examples wrappers; do (cd $$d; rm -f $(JUNKFILES)); done # Build dependencies. @@ -53,8 +77,10 @@ endif depend: .depend -.depend: $(wildcard *.ml) $(wildcard *.mli) - $(OCAMLDEP) *.mli *.ml examples/*.ml > .depend +.depend: $(wildcard *.ml) $(wildcard *.mli) $(wildcard examples/*.ml) \ + $(wildcard wrappers/*.ml) + $(OCAMLDEP) $(OCAMLCINCS) *.mli *.ml examples/*.ml wrappers/*.ml \ + > .depend # Install. @@ -62,6 +88,7 @@ install: install -c -m 0755 -d $(OCAMLLIBDIR) install -c -m 0755 -d $(OCAMLLIBDIR)/stublibs install -c -m 0644 perl.cmi perl.mli perl.cma perl.cmxa $(OCAMLLIBDIR) + install -c -m 0644 perl_init.cmo perl_init.cmx $(OCAMLLIBDIR) install -c -m 0644 perl.a libperl.a $(OCAMLLIBDIR) install -c -m 0644 dllperl.so $(OCAMLLIBDIR)/stublibs diff --git a/Makefile.config b/Makefile.config index e3a1039..3cdafe3 100644 --- a/Makefile.config +++ b/Makefile.config @@ -1,5 +1,5 @@ # perl4caml configuration -*- Makefile -*- -# $Id: Makefile.config,v 1.2 2003-10-12 12:14:06 rich Exp $ +# $Id: Makefile.config,v 1.3 2003-10-12 17:33:14 rich Exp $ # PERLINCDIR # Directory containing the Perl include files, eg. . @@ -14,4 +14,4 @@ OCAMLLIBDIR := $(shell ocamlc -where) # PACKAGE and VERSION PACKAGE := perl4caml -VERSION := 0.2.0 +VERSION := 0.2.1 diff --git a/examples/.cvsignore b/examples/.cvsignore index 6882876..4114948 100644 --- a/examples/.cvsignore +++ b/examples/.cvsignore @@ -4,3 +4,4 @@ *.cma *.cmxa test +loadpage \ No newline at end of file diff --git a/examples/loadpage.ml b/examples/loadpage.ml new file mode 100644 index 0000000..d73bf9c --- /dev/null +++ b/examples/loadpage.ml @@ -0,0 +1,64 @@ +(* Example program which uses LWP::UserAgent and HTML::TreeBuilder to + * download an HTTP page and parse it. + * Copyright (C) 2003 Merjis Ltd. + * $Id: loadpage.ml,v 1.1 2003-10-12 17:33:14 rich Exp $ + *) + +open Printf + +open Pl_LWP_UserAgent +open Pl_HTTP_Request +open Pl_HTML_TreeBuilder +open Pl_HTML_Element + +let () = + (* This is a hack which shouldn't be needed in future. *) + Perl.eval "use LWP::UserAgent"; + Perl.eval "use Net::HTTP"; + + let site = + if Array.length Sys.argv >= 2 then + Sys.argv.(1) + else + "http://www.merjis.com/" in + + (* Create the UserAgent object. *) + let ua = Pl_LWP_UserAgent.new_ ~env_proxy:true () in + + (* Fetch the page. *) + let req = Pl_HTTP_Request.new_ "GET" ~uri:site () in + let res = ua#request req in + + if not res#is_success then + failwith ("Error while fetching " ^ site ^ ": " ^ res#status_line); + + (* Extract the content of the page. *) + let content = res#content in + + (* Parse it using HTML::TreeBuilder. *) + let tree = Pl_HTML_TreeBuilder.new_from_content content in + + (* Turn the tree into an HTML::Element. *) + let tree = tree#elementify in + + (* Print out the resulting tree. *) + let rec print root = + let tag = root#tag in + let attrs = root#all_external_attr in + let subnodes = root#content_list in + + printf "Start tag: %s\n" tag; + List.iter (fun (name, value) -> + printf "\tAttr: %s=\"%s\"\n" name value) attrs; + + List.iter (fun node -> + match node with + Element node -> print node + | String str -> + printf "String: %s\n" str) subnodes; + printf "End tag: %s\n" tag + in + print tree; + + (* Destroy the Perl interpreter. *) + Perl.destroy () diff --git a/examples/test.ml b/examples/test.ml index 56d2bfa..8ec8c74 100644 --- a/examples/test.ml +++ b/examples/test.ml @@ -1,16 +1,13 @@ (* Simple test of the API. * Copyright (C) 2003 Merjis Ltd. - * $Id: test.ml,v 1.1 2003-10-12 11:56:27 rich Exp $ + * $Id: test.ml,v 1.2 2003-10-12 17:33:14 rich Exp $ *) open Printf let () = - (* Arguments passed to the Perl "command line". Loads [test.pl] *) - let args = [| ""; "-wT"; "examples/test.pl" |] in - - (* Create the Perl interpreter. *) - let pl = Perl.create ~args () in + (* Load "test.pl". *) + Perl.eval "require 'examples/test.pl'"; (* Call some subroutines in [test.pl]. *) let sv = Perl.call ~fn:"return_one" [] in @@ -49,4 +46,4 @@ let () = printf "TestClass.foo is %d\n" (Perl.int_of_sv sv); flush stdout; (* Destroy the interpreter. *) - Perl.destroy pl + Perl.destroy () diff --git a/perl.ml b/perl.ml index b8c1012..7069d35 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.3 2003-10-12 11:56:26 rich Exp $ + * $Id: perl.ml,v 1.4 2003-10-12 17:33:14 rich Exp $ *) type t @@ -9,17 +9,17 @@ type sv exception Perl_failure of string -external init : unit -> unit = "perl4caml_init" -let () = +external c_init : unit -> unit = "perl4caml_init" +let init () = Callback.register_exception "perl4caml_perl_failure" (Perl_failure ""); - init () (* Initialise C code. *) + c_init () (* Initialise C code. *) + +external destroy : unit -> unit + = "perl4caml_destroy" external create : ?args:string array -> unit -> t = "perl4caml_create" -external destroy : t -> unit - = "perl4caml_destroy" - external set_context : t -> unit = "perl4caml_set_context" @@ -31,13 +31,30 @@ 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" +external sv_undef : unit -> sv = "perl4caml_sv_undef" +external sv_yes : unit -> sv = "perl4caml_sv_yes" +external sv_no : unit -> sv = "perl4caml_sv_no" + +let sv_true () = sv_of_int 1 +let sv_false () = sv_of_int 0 + +let bool_of_sv = sv_is_true +let sv_of_bool b = if b then sv_true () else sv_false () + +type sv_t = SVt_NULL + | SVt_IV + | SVt_NV + | SVt_PV + | SVt_RV + | SVt_PVAV + | SVt_PVHV + | SVt_PVCV + | SVt_PVGV + | SVt_PVMG + +external sv_type : sv -> sv_t = "perl4caml_sv_type" -let sv_undef = sv_get_undef () -let sv_true = sv_get_yes () -let sv_false = sv_get_no () +external deref : sv -> sv = "perl4caml_deref" external get_sv : ?create:bool -> string -> sv = "perl4caml_get_sv" diff --git a/perl.mli b/perl.mli index 7473d29..2c60907 100644 --- a/perl.mli +++ b/perl.mli @@ -2,7 +2,7 @@ * * Copyright (C) 2003 Merjis Ltd. * - * $Id: perl.mli,v 1.3 2003-10-12 11:56:26 rich Exp $ + * $Id: perl.mli,v 1.4 2003-10-12 17:33:14 rich Exp $ *) type t @@ -14,9 +14,25 @@ type sv exception Perl_failure of string (** [die] in Perl code is translated automatically into this exception. *) +val init : unit -> unit +(** Don't call this. Instead link your program with [perl_init.cmo] or + * [perl_init.cmx] which calls this for you. + *) + +external destroy : unit -> unit + = "perl4caml_destroy" +(** Destroy the current Perl interpreter, performing any necessary cleanup. + * You should call this at the end of your program, otherwise Perl won't + * properly clean up. + * + * Note that a Perl interpreter is created for you by default when you + * use perl4caml. + *) + external create : ?args:string array -> unit -> t = "perl4caml_create" -(** Create a Perl interpreter. +(** Create a new Perl interpreter. (Note that a Perl interpreter is created + * for you by default so you don't need to call this). * * The optional [?args] parameter is the command line passed to the * interpreter, and controls things like whether warnings are enabled @@ -26,12 +42,10 @@ external create : ?args:string array -> unit -> t * 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. + * + * The newly created interpreter is set as the "current interpreter". *) -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 @@ -56,16 +70,61 @@ 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]. *) +val bool_of_sv : sv -> bool +(** Convert an [SV] into a boolean. *) +val sv_of_bool : bool -> sv +(** Convert a boolean into an [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 +external sv_undef : unit -> sv = "perl4caml_sv_undef" (** Returns [undef]. *) -val sv_true : sv +val sv_true : unit -> sv (** Returns an [SV] which is true. *) -val sv_false : sv +val sv_false : unit -> sv (** Returns an [SV] which is false. *) +external sv_yes : unit -> sv = "perl4caml_sv_yes" +(** Returns Perl's internal [PL_sv_yes]. (There are some unresolved issues + * with using this, so use {!sv_true} instead). *) +external sv_no : unit -> sv = "perl4caml_sv_no" +(** Returns Perl's internal [PL_sv_no]. (There are some unresolved issues + * with using this, so use {!sv_false} instead). *) + +(* Actually there are many more types defined than this ... *) +type sv_t = SVt_NULL + | SVt_IV (** Integer scalar. *) + | SVt_NV (** Floating point scalar. *) + | SVt_PV (** String scalar. *) + | SVt_RV (** Reference. *) + | SVt_PVAV (** Array ref. *) + | SVt_PVHV (** Hash ref. *) + | SVt_PVCV (** Code ref. *) + | SVt_PVGV (** Glob. *) + | SVt_PVMG (** Blessed or magical scalar. *) +external sv_type : sv -> sv_t = "perl4caml_sv_type" +(** Return the type of data contained in an [SV]. Somewhat equivalent to + * calling Perl's [ref] function. + *) + +external deref : sv -> sv = "perl4caml_deref" +(** The input is a reference to a scalar. This returns the underlying + * scalar [SV]. If the input is not a reference to a scalar, throws + * [Invalid_arg]. + *) +(* +external deref_array : sv -> av = "perl4caml_deref_array" +(** The input is a reference to an array. This returns the underlying + * array [AV]. If the input is not a reference to an array, throws + * [Invalid_arg]. + *) +external deref_hash : sv -> hv = "perl4caml_deref_hash" +(** The input is a reference to a hash. This returns the underlying + * hash [HV]. If the input is not a reference to a hash, throws + * [Invalid_arg]. + *) +*) external get_sv : ?create:bool -> string -> sv = "perl4caml_get_sv" (** Return a scalar value by name. For example, if you have a symbol diff --git a/perl_c.c b/perl_c.c index 690b145..2a9e71d 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.3 2003-10-12 11:56:26 rich Exp $ + * $Id: perl_c.c,v 1.4 2003-10-12 17:33:14 rich Exp $ */ #include @@ -44,7 +44,18 @@ static value unoption (value option, value deflt); CAMLprim value perl4caml_init (value unit) { + static char *argv[] = { "", "-w", "-e", "0" }; + int argc = sizeof argv / sizeof argv[0]; + PERL_SYS_INIT3 (NULL, NULL, NULL); + + /* Create a default interpreter. */ + 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);*/ + return Val_unit; } @@ -75,19 +86,23 @@ perl4caml_create (value optargs, value unit) perl_construct (my_perl); PL_exit_flags |= PERL_EXIT_DESTRUCT_END; perl_parse (my_perl, NULL, argc, argv, NULL); - perl_run (my_perl); + /*perl_run (my_perl);*/ CAMLreturn (Val_perl (my_perl)); } CAMLprim value -perl4caml_destroy (value plv) +perl4caml_destroy (value unit) { - CAMLparam1 (plv); - PerlInterpreter *pl = Perl_val (plv); + CAMLparam1 (unit); + + perl_destruct (my_perl); + perl_free (my_perl); - perl_destruct (pl); - perl_free (pl); + /* Force a segfault if someone tries to use a Perl function without + * creating another interpreter first. + */ + my_perl = 0; CAMLreturn (Val_unit); } @@ -174,27 +189,71 @@ perl4caml_sv_is_undef (value svv) } CAMLprim value -perl4caml_sv_get_undef (value unit) +perl4caml_sv_undef (value unit) { CAMLparam1 (unit); CAMLreturn (Val_sv (&PL_sv_undef)); } CAMLprim value -perl4caml_sv_get_yes (value unit) +perl4caml_sv_yes (value unit) { CAMLparam1 (unit); CAMLreturn (Val_sv (&PL_sv_yes)); } CAMLprim value -perl4caml_sv_get_no (value unit) +perl4caml_sv_no (value unit) { CAMLparam1 (unit); CAMLreturn (Val_sv (&PL_sv_no)); } CAMLprim value +perl4caml_sv_type (value svv) +{ + CAMLparam1 (svv); + SV *sv = Sv_val (svv); + + switch (SvTYPE (sv)) + { + case SVt_IV: CAMLreturn (Val_int (1)); + case SVt_NV: CAMLreturn (Val_int (2)); + case SVt_PV: CAMLreturn (Val_int (3)); + case SVt_RV: CAMLreturn (Val_int (4)); + case SVt_PVAV: CAMLreturn (Val_int (5)); + case SVt_PVHV: CAMLreturn (Val_int (6)); + case SVt_PVCV: CAMLreturn (Val_int (7)); + case SVt_PVGV: CAMLreturn (Val_int (8)); + case SVt_PVMG: CAMLreturn (Val_int (9)); + default: CAMLreturn (Val_int (0)); + } +} + +CAMLprim value +perl4caml_deref (value svv) +{ + CAMLparam1 (svv); + CAMLlocal1 (rsvv); + SV *sv = Sv_val (svv); + + if (SvTYPE (sv) != SVt_RV) + invalid_argument ("deref: SV is not a reference"); + switch (SvTYPE (SvRV (sv))) { + case SVt_IV: + case SVt_NV: + case SVt_PV: + case SVt_RV: + case SVt_PVMG: + break; + default: + invalid_argument ("deref: SV is not a reference to a scalar"); + } + rsvv = Val_sv (SvRV (sv)); + CAMLreturn (rsvv); +} + +CAMLprim value perl4caml_get_sv (value optcreate, value name) { CAMLparam2 (optcreate, name); @@ -208,6 +267,23 @@ perl4caml_get_sv (value optcreate, value name) CAMLreturn (Val_sv (sv)); } +static inline void +check_perl_failure () +{ + SV *errsv = get_sv ("@", TRUE); + + if (SvTRUE (errsv)) /* Equivalent of $@ in Perl. */ + { + CAMLlocal1 (errv); + STRLEN n_a; + const char *err = SvPV (errsv, n_a); + + errv = copy_string (err); + + raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); + } +} + CAMLprim value perl4caml_call (value optsv, value optfnname, value arglist) { @@ -263,23 +339,10 @@ perl4caml_call (value optsv, value optfnname, value arglist) 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); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - { - svv = Val_sv (sv); - CAMLreturn (svv); - } + svv = Val_sv (sv); + CAMLreturn (svv); } CAMLprim value @@ -343,20 +406,9 @@ perl4caml_call_array (value optsv, value optfnname, value arglist) 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. */ + check_perl_failure (); - errv = copy_string (err); - - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - CAMLreturn (list); + CAMLreturn (list); } CAMLprim value @@ -411,20 +463,9 @@ perl4caml_call_void (value optsv, value optfnname, value arglist) 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); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - CAMLreturn (Val_unit); + CAMLreturn (Val_unit); } CAMLprim value @@ -435,35 +476,12 @@ perl4caml_eval (value expr) SV *sv; CAMLlocal2 (errv, svv); - ENTER; - SAVETMPS; + sv = eval_pv (String_val (expr), G_SCALAR); - PUSHMARK (SP); - eval_pv (String_val (expr), G_SCALAR); + check_perl_failure (); - 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); - } + svv = Val_sv (sv); + CAMLreturn (svv); } CAMLprim value @@ -508,23 +526,10 @@ perl4caml_call_method (value ref, value name, value arglist) 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); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - { - svv = Val_sv (sv); - CAMLreturn (svv); - } + svv = Val_sv (sv); + CAMLreturn (svv); } CAMLprim value @@ -575,20 +580,9 @@ perl4caml_call_method_array (value ref, value name, value arglist) 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); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - CAMLreturn (list); + CAMLreturn (list); } CAMLprim value @@ -630,20 +624,9 @@ perl4caml_call_method_void (value ref, value name, value arglist) 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); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - CAMLreturn (Val_unit); + CAMLreturn (Val_unit); } CAMLprim value @@ -687,23 +670,10 @@ perl4caml_call_class_method (value classname, value name, value arglist) 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); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - { - svv = Val_sv (sv); - CAMLreturn (svv); - } + svv = Val_sv (sv); + CAMLreturn (svv); } CAMLprim value @@ -753,20 +723,9 @@ perl4caml_call_class_method_array (value classname, value name, value arglist) 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); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - CAMLreturn (list); + CAMLreturn (list); } CAMLprim value @@ -807,20 +766,9 @@ perl4caml_call_class_method_void (value classname, value name, value arglist) 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); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - CAMLreturn (Val_unit); + CAMLreturn (Val_unit); } static value diff --git a/perl_init.ml b/perl_init.ml new file mode 100644 index 0000000..4f81139 --- /dev/null +++ b/perl_init.ml @@ -0,0 +1,6 @@ +(* Every program must link with perl_init.cmo (or perl_init.cmx). + * Copyright (C) 2003 Merjis Ltd. + * $Id: perl_init.ml,v 1.1 2003-10-12 17:33:14 rich Exp $ + *) + +Perl.init () diff --git a/wrappers/.cvsignore b/wrappers/.cvsignore new file mode 100644 index 0000000..c0404dd --- /dev/null +++ b/wrappers/.cvsignore @@ -0,0 +1,5 @@ +*.cmi +*.cmo +*.cmx +*.cma +*.cmxa diff --git a/wrappers/pl_HTML_Element.ml b/wrappers/pl_HTML_Element.ml new file mode 100644 index 0000000..6430985 --- /dev/null +++ b/wrappers/pl_HTML_Element.ml @@ -0,0 +1,74 @@ +(* Wrapper around Perl HTML::Element class. + * Copyright (C) 2003 Merjis Ltd. + * $Id: pl_HTML_Element.ml,v 1.1 2003-10-12 17:33:15 rich Exp $ + *) + +open Perl + +type 'a content_t = Element of 'a | String of string + +class html_element sv = + + let rec assocs_of_svlist = function + [] -> [] + | [x] -> failwith "HTML::Element all_attr returned odd-length list!" + | svname :: svvalue :: xs -> + (string_of_sv svname, string_of_sv svvalue) :: assocs_of_svlist xs + in + + let rec list_of_svlist = function + [] -> [] + | sv :: xs -> + string_of_sv sv :: list_of_svlist xs + in + +object (self) + + method sv = sv + + method attr name = + string_of_sv (call_method sv "attr" [sv_of_string name]) + method set_attr name value = + call_method_void sv "attr" [sv_of_string name; sv_of_string value] + method tag = + string_of_sv (call_method sv "tag" []) + method set_tag tag = + call_method_void sv "tag" [sv_of_string tag] + method parent = + let sv = call_method sv "parent" [] in + new html_element sv + method set_parent (parent : html_element) = + call_method_void sv "parent" [parent#sv] + method content_list = + let svlist = call_method_array sv "content_list" [] in + List.map + (fun c -> + match sv_type c with + SVt_PV -> String (string_of_sv c) + | SVt_RV -> Element (new html_element (deref c)) + | _ -> failwith "HTML::Element content_type: unknown type" + ) svlist + method all_attr = + let svlist = call_method_array sv "all_attr" [] in + assocs_of_svlist svlist + method all_attr_names = + let svlist = call_method_array sv "all_attr_names" [] in + list_of_svlist svlist + method all_external_attr = + let svlist = call_method_array sv "all_external_attr" [] in + assocs_of_svlist svlist + method all_external_attr_names = + let svlist = call_method_array sv "all_external_attr_names" [] in + list_of_svlist svlist + +end + +(* Note that "new" is a reserved word, so I've appended an _ character. *) +let new_ tag attrs = + let rec loop = function + [] -> [] + | (name, value) :: xs -> sv_of_string name :: sv_of_string value :: loop xs + in + let sv = call_class_method "HTML::Element" "new" + (sv_of_string tag :: loop attrs) in + new html_element sv diff --git a/wrappers/pl_HTML_Parser.ml b/wrappers/pl_HTML_Parser.ml new file mode 100644 index 0000000..150547a --- /dev/null +++ b/wrappers/pl_HTML_Parser.ml @@ -0,0 +1,21 @@ +(* Wrapper around Perl HTML::Parser class. + * Copyright (C) 2003 Merjis Ltd. + * $Id: pl_HTML_Parser.ml,v 1.1 2003-10-12 17:33:15 rich Exp $ + *) + +open Perl + +class html_parser sv = + +object (self) + + method parse_file filename = + call_method_void sv "parse_file" [sv_of_string filename] + method parse content = + call_method_void sv "parse" [sv_of_string content] + method eof = + call_method_void sv "eof" [] + method delete = + call_method_void sv "delete" [] + +end diff --git a/wrappers/pl_HTML_TreeBuilder.ml b/wrappers/pl_HTML_TreeBuilder.ml new file mode 100644 index 0000000..f3a6032 --- /dev/null +++ b/wrappers/pl_HTML_TreeBuilder.ml @@ -0,0 +1,34 @@ +(* Wrapper around Perl HTML::TreeBuilder class. + * Copyright (C) 2003 Merjis Ltd. + * $Id: pl_HTML_TreeBuilder.ml,v 1.1 2003-10-12 17:33:15 rich Exp $ + *) + +open Perl + +open Pl_HTML_Parser +open Pl_HTML_Element + +class html_treebuilder sv = + +object (self) + inherit html_parser sv + + method elementify = + let sv = call_method sv "elementify" [] in + new html_element sv +end + +(* Note that "new" is a reserved word, so I've appended an _ character. *) +let new_ () = + let sv = call_class_method "HTML::TreeBuilder" "new" [] in + new html_treebuilder sv + +let new_from_file filename = + let sv = call_class_method "HTML::TreeBuilder" "new_from_file" + [sv_of_string filename] in + new html_treebuilder sv + +let new_from_content content = + let sv = call_class_method "HTML::TreeBuilder" "new_from_content" + [sv_of_string content] in + new html_treebuilder sv diff --git a/wrappers/pl_HTTP_Message.ml b/wrappers/pl_HTTP_Message.ml new file mode 100644 index 0000000..53d69de --- /dev/null +++ b/wrappers/pl_HTTP_Message.ml @@ -0,0 +1,17 @@ +(* Wrapper around Perl HTTP::Message class. + * Copyright (C) 2003 Merjis Ltd. + * $Id: pl_HTTP_Message.ml,v 1.1 2003-10-12 17:33:15 rich Exp $ + *) + +open Perl + +class http_message sv = + +object (self) + + method content = + string_of_sv (call_method sv "content" []) + method set_content content = + call_method_void sv "set_content" [sv_of_string content] + +end diff --git a/wrappers/pl_HTTP_Request.ml b/wrappers/pl_HTTP_Request.ml new file mode 100644 index 0000000..be17e17 --- /dev/null +++ b/wrappers/pl_HTTP_Request.ml @@ -0,0 +1,40 @@ +(* Wrapper around Perl HTTP::Request class. + * Copyright (C) 2003 Merjis Ltd. + * $Id: pl_HTTP_Request.ml,v 1.1 2003-10-12 17:33:15 rich Exp $ + *) + +open Perl + +open Pl_HTTP_Message +open Pl_URI + +class http_request sv = + +object (self) + inherit http_message sv + + method sv = sv + + method method_ = + string_of_sv (call_method sv "method" []) + method set_method meth = + call_method_void sv "method" [sv_of_string meth] + method as_string = + string_of_sv (call_method sv "as_string" []) + +end + +let new_ meth ?uri_obj ?uri (* ?header ?content *) () = + let sv = + match uri_obj, uri with + None, None -> + failwith ("Pl_HTTP_Request.new_ must be called with either a "^ + "~uri_obj (URI object) or ~uri (string) parameter.") + | Some (uri_obj : uri), None -> + call_class_method "HTTP::Request" "new" [sv_of_string meth; + uri_obj#sv] + | _, Some uri -> + call_class_method "HTTP::Request" "new" [sv_of_string meth; + sv_of_string uri] + in + new http_request sv diff --git a/wrappers/pl_HTTP_Response.ml b/wrappers/pl_HTTP_Response.ml new file mode 100644 index 0000000..2bb479e --- /dev/null +++ b/wrappers/pl_HTTP_Response.ml @@ -0,0 +1,42 @@ +(* Wrapper around Perl HTTP::Response class. + * Copyright (C) 2003 Merjis Ltd. + * $Id: pl_HTTP_Response.ml,v 1.1 2003-10-12 17:33:15 rich Exp $ + *) + +open Perl + +open Pl_HTTP_Message + +class http_response sv = + +object (self) + inherit http_message sv + + method code = + string_of_sv (call_method sv "code" []) + method set_code code = + call_method_void sv "code" [sv_of_string code] + method message = + string_of_sv (call_method sv "message" []) + method set_message message = + call_method_void sv "message" [sv_of_string message] + method status_line = + string_of_sv (call_method sv "status_line" []) + method base = + string_of_sv (call_method sv "base" []) + method as_string = + string_of_sv (call_method sv "as_string" []) + method is_info = + bool_of_sv (call_method sv "is_info" []) + method is_success = + bool_of_sv (call_method sv "is_success" []) + method is_redirect = + bool_of_sv (call_method sv "is_redirect" []) + method is_error = + bool_of_sv (call_method sv "is_error" []) + method error_as_HTML = + string_of_sv (call_method sv "error_as_HTML" []) + +end + +(* let new_ ... *) diff --git a/wrappers/pl_LWP_UserAgent.ml b/wrappers/pl_LWP_UserAgent.ml new file mode 100644 index 0000000..2a68f4a --- /dev/null +++ b/wrappers/pl_LWP_UserAgent.ml @@ -0,0 +1,68 @@ +(* Wrapper around Perl LWP::UserAgent class. + * Copyright (C) 2003 Merjis Ltd. + * $Id: pl_LWP_UserAgent.ml,v 1.1 2003-10-12 17:33:15 rich Exp $ + *) + +open Perl + +open Pl_HTTP_Request +open Pl_HTTP_Response + +class lwp_useragent sv = + +object (self) + + method simple_request (request : http_request) = + let sv = call_method sv "simple_request" [request#sv] in + new http_response sv + method request (request : http_request) = + let sv = call_method sv "simple_request" [request#sv] in + new http_response sv + method agent = + string_of_sv (call_method sv "agent" []) + method set_agent v = + call_method_void sv "agent" [sv_of_string v] + method from = + string_of_sv (call_method sv "from" []) + method set_from v = + call_method_void sv "from" [sv_of_string v] + method timeout = + int_of_sv (call_method sv "timeout" []) + method set_timeout v = + call_method_void sv "timeout" [sv_of_int v] + method parse_head = + bool_of_sv (call_method sv "parse_head" []) + method set_parse_head v = + call_method_void sv "parse_head" [sv_of_bool v] + method max_size = + int_of_sv (call_method sv "max_size" []) + method set_max_size v = + call_method_void sv "max_size" [sv_of_int v] + method env_proxy = + call_method_void sv "env_proxy" [] + +end + +(* Note that "new" is a reserved word, so I've appended an _ character. *) +let new_ ?agent ?from ?timeout ?use_eval ?parse_head ?max_size + ?env_proxy ?keep_alive () = + let args = ref [] in + let may f = function None -> () | Some v -> f v in + may (fun v -> + args := sv_of_string "agent" :: sv_of_string v :: !args) agent; + may (fun v -> + args := sv_of_string "from" :: sv_of_string v :: !args) from; + may (fun v -> + args := sv_of_string "timeout" :: sv_of_int v :: !args) timeout; + may (fun v -> + args := sv_of_string "use_eval" :: sv_of_bool v :: !args) use_eval; + may (fun v -> + args := sv_of_string "parse_head" :: sv_of_bool v :: !args)parse_head; + may (fun v -> + args := sv_of_string "max_size" :: sv_of_int v :: !args) max_size; + may (fun v -> + args := sv_of_string "env_proxy" :: sv_of_bool v :: !args) env_proxy; + may (fun v -> + args := sv_of_string "keep_alive" :: sv_of_int v :: !args) keep_alive; + let sv = call_class_method "LWP::UserAgent" "new" !args in + new lwp_useragent sv diff --git a/wrappers/pl_URI.ml b/wrappers/pl_URI.ml new file mode 100644 index 0000000..b590b24 --- /dev/null +++ b/wrappers/pl_URI.ml @@ -0,0 +1,48 @@ +(* Wrapper around Perl URI class. + * Copyright (C) 2003 Merjis Ltd. + * $Id: pl_URI.ml,v 1.1 2003-10-12 17:33:15 rich Exp $ + *) + +open Perl + +class uri sv = + +object (self) + + method sv = sv + + method scheme = + string_of_sv (call_method sv "scheme" []) + method set_scheme scheme = + call_method_void sv "scheme" [sv_of_string scheme] + method opaque = + string_of_sv (call_method sv "opaque" []) + method set_opaque opaque = + call_method_void sv "opaque" [sv_of_string opaque] + method path = + string_of_sv (call_method sv "path" []) + method set_path path = + call_method_void sv "path" [sv_of_string path] + method fragment = + string_of_sv (call_method sv "fragment" []) + method set_fragment fragment = + call_method_void sv "fragment" [sv_of_string fragment] + method as_string = + string_of_sv (call_method sv "as_string" []) + method canonical = + string_of_sv (call_method sv "canonical" []) + method abs base = + string_of_sv (call_method sv "abs" [sv_of_string base]) + method rel base = + string_of_sv (call_method sv "rel" [sv_of_string base]) + +end + +let new_ ?scheme str = + let args = + [sv_of_string str] @ + match scheme with + None -> [] + | Some scheme -> [sv_of_string scheme] in + let sv = call_class_method "URI" "new" args in + new uri sv -- 1.8.3.1