From: rich <rich>
Date: Sun, 12 Oct 2003 17:33:14 +0000 (+0000)
Subject: Added wrappers around some common libraries.
X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=1c369c3ba6b71d4524dfacd0ba3554e8a524ed57;p=perl4caml.git

Added wrappers around some common libraries.
---

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. <EXTERN.h>.
@@ -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 <stdio.h>
@@ -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