From 92ee36459463e0a040d32f5eac0ec38bb28be8f4 Mon Sep 17 00:00:00 2001
From: rich <rich>
Date: Thu, 25 Nov 2004 21:24:51 +0000
Subject: [PATCH] Wrapper around WWW::Mechanize. Additional methods for
 LWP::UserAgent.

---
 .depend                      |   4 +
 Makefile                     |   5 +-
 wrappers/pl_LWP_UserAgent.ml |  16 +++-
 wrappers/pl_WWW_Mechanize.ml | 184 +++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 205 insertions(+), 4 deletions(-)
 create mode 100644 wrappers/pl_WWW_Mechanize.ml

diff --git a/.depend b/.depend
index 5dd4204..7cb0eba 100644
--- a/.depend
+++ b/.depend
@@ -64,3 +64,7 @@ wrappers/pl_Template.cmo: perl.cmi
 wrappers/pl_Template.cmx: perl.cmx 
 wrappers/pl_URI.cmo: perl.cmi 
 wrappers/pl_URI.cmx: perl.cmx 
+wrappers/pl_WWW_Mechanize.cmo: perl.cmi wrappers/pl_HTTP_Response.cmo \
+    wrappers/pl_LWP_UserAgent.cmo 
+wrappers/pl_WWW_Mechanize.cmx: perl.cmx wrappers/pl_HTTP_Response.cmx \
+    wrappers/pl_LWP_UserAgent.cmx 
diff --git a/Makefile b/Makefile
index 61c0174..6f42213 100644
--- a/Makefile
+++ b/Makefile
@@ -1,6 +1,6 @@
 # Interface to Perl from OCaml.
 # Copyright (C) 2003 Merjis Ltd.
-# $Id: Makefile,v 1.22 2004-11-22 17:08:36 rich Exp $
+# $Id: Makefile,v 1.23 2004-11-25 21:24:51 rich Exp $
 
 include Makefile.config
 
@@ -50,7 +50,8 @@ WRAPPERS := \
 	wrappers/pl_HTTP_Request_Common.cmo \
 	wrappers/pl_HTTP_Response.cmo \
 	wrappers/pl_LWP_UserAgent.cmo \
-	wrappers/pl_Template.cmo
+	wrappers/pl_Template.cmo \
+	wrappers/pl_WWW_Mechanize.cmo
 
 all:	perl4caml.cma perl4caml.cmxa META all-examples html
 
diff --git a/wrappers/pl_LWP_UserAgent.ml b/wrappers/pl_LWP_UserAgent.ml
index 941ba36..a293839 100644
--- a/wrappers/pl_LWP_UserAgent.ml
+++ b/wrappers/pl_LWP_UserAgent.ml
@@ -2,7 +2,7 @@
   *
   * Copyright (C) 2003 Merjis Ltd.
   *
-  * $Id: pl_LWP_UserAgent.ml,v 1.4 2004-11-22 17:08:36 rich Exp $
+  * $Id: pl_LWP_UserAgent.ml,v 1.5 2004-11-25 21:24:51 rich Exp $
   *)
 
 open Perl
@@ -40,6 +40,18 @@ object (self)
     let hv = hv_empty () in
     hv_set hv "file" (sv_of_string filename);
     call_method_void sv "cookie_jar" [hashref hv]
+  method requests_redirectable =
+    let sv = call_method sv "requests_redirectable" [] in
+    let av = deref_array sv in
+    List.map string_of_sv (list_of_av av)
+  method set_requests_redirectable methods =
+    let av = av_empty () in
+    List.iter (av_push av) (List.map sv_of_string methods);
+    call_method_void sv "requests_redirectable" [arrayref av]
+  method add_requests_redirectable method_ =
+    let sv = call_method sv "requests_redirectable" [] in
+    let av = deref_array sv in
+    av_push av (sv_of_string method_)
   method timeout =
     int_of_sv (call_method sv "timeout" [])
   method set_timeout v =
@@ -52,7 +64,7 @@ object (self)
     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 =
+  method env_proxy () =
     call_method_void sv "env_proxy" []
 
 end
diff --git a/wrappers/pl_WWW_Mechanize.ml b/wrappers/pl_WWW_Mechanize.ml
new file mode 100644
index 0000000..a29a5a9
--- /dev/null
+++ b/wrappers/pl_WWW_Mechanize.ml
@@ -0,0 +1,184 @@
+(** Wrapper around Perl [WWW::Mechanize] class.
+  *
+  * Copyright (C) 2004 Merjis Ltd.
+  *
+  * $Id: pl_WWW_Mechanize.ml,v 1.1 2004-11-25 21:24:51 rich Exp $
+  *)
+
+open Perl
+
+open Pl_LWP_UserAgent
+
+let _ = eval "use WWW::Mechanize"
+
+class www_mechanize sv =
+
+object (self)
+  inherit lwp_useragent sv
+
+  method agent_alias alias =
+    call_method_void sv "agent_alias" [sv_of_string alias]
+  method known_agent_aliases =
+    let svlist = call_method_array sv "known_agent_aliases" [] in
+    List.map string_of_sv svlist
+
+  method get url =
+    call_method_void sv "get" [sv_of_string url]
+  method reload () =
+    call_method_void sv "reload" []
+  method back () =
+    call_method_void sv "back" []
+
+  method follow_link ?text ?text_regex ?url ?url_regex ?url_abs ?url_abs_regex
+    ?name ?name_regex ?tag ?tag_regex ?n () =
+    let args = ref [] in
+    let add name f = function
+      | None -> ()
+      | Some p -> args := sv_of_string name :: f p :: !args
+    in
+    add "text" sv_of_string text;
+    add "text_regex" sv_of_string text_regex;
+    add "url" sv_of_string url;
+    add "url_regex" sv_of_string url_regex;
+    add "url_abs" sv_of_string url_abs;
+    add "url_abs_regex" sv_of_string url_abs_regex;
+    add "name" sv_of_string name;
+    add "name_regex" sv_of_string name_regex;
+    add "tag" sv_of_string tag;
+    add "tag_regex" sv_of_string tag_regex;
+    add "n" sv_of_int n;
+    call_method_void sv "follow_link" !args
+
+  (* XXX What do these next two functions return? *)
+  method form_number n =
+    call_method_void sv "form_number" [sv_of_int n]
+  method form_name name =
+    call_method_void sv "form_name" [sv_of_string name]
+
+  (* XXX There is an arrayref variant of this method, but what
+   * it does is apparently undocumented.
+   *)
+  method field name value n =
+    call_method_void sv "field" [sv_of_string name; sv_of_string value;
+				 sv_of_int n]
+  method set_fields fields =
+    let args = ref [] in
+    List.iter (fun (k, v) ->
+		 (* Note: reversed k, v because we'll reverse the whole list.*)
+		 args := sv_of_string v :: sv_of_string k :: !args) fields;
+    let args = List.rev !args in
+    call_method_void sv "set_fields" args
+
+  method value name n =
+    let sv = call_method sv "value" [sv_of_string name; sv_of_int n] in
+    string_of_sv sv
+
+  (* XXX Doesn't support setting criteria. *)
+  method set_visible names =
+    let names = List.map sv_of_string names in
+    call_method_void sv "set_visible" names
+
+  method tick ?set name value =
+    let args = match set with
+	None -> [ sv_of_string name; sv_of_string value ]
+      | Some b -> [ sv_of_string name; sv_of_string value; sv_of_bool b ] in
+    call_method_void sv "tick" args
+
+  method untick name value =
+    call_method_void sv "untick" [ sv_of_string name; sv_of_string value ]
+
+  method click ?xy button =
+    let args = match xy with
+	None -> [ sv_of_string button ]
+      | Some (x, y) -> [ sv_of_string button; sv_of_int x; sv_of_int y ] in
+    call_method_void sv "click" args
+  method click1 () =
+    call_method_void sv "click" []
+  method click_button ?name ?number ?value ?xy () =
+    let args = ref [] in
+    let add name f = function
+      | None -> ()
+      | Some p -> args := sv_of_string name :: f p :: !args
+    in
+    add "name" sv_of_string name;
+    add "number" sv_of_int number;
+    add "value" sv_of_string value;
+    (match xy with
+	 None -> ()
+       | Some (x, y) ->
+	   args := sv_of_string "x" :: sv_of_int x ::
+	     sv_of_string "y" :: sv_of_int y :: !args);
+    call_method_void sv "click" !args
+
+  method select name value =
+    call_method_void sv "select" [ sv_of_string name; sv_of_string value ]
+  method select_multiple name values =
+    let av = av_empty () in
+    List.iter (av_push av) (List.map sv_of_string values);
+    call_method_void sv "select" [ sv_of_string name; arrayref av ]
+
+  method submit () =
+    call_method_void sv "submit" []
+
+  (*method submit_form ?form_number ?form_name ?fields ?button ?xy () *)
+
+  method success =
+    let sv = call_method sv "success" [] in
+    bool_of_sv sv
+  method uri =
+    let sv = call_method sv "uri" [] in
+    string_of_sv sv
+  method response =
+    let sv = call_method sv "response" [] in
+    new Pl_HTTP_Response.http_response sv
+  method res =
+    let sv = call_method sv "res" [] in
+    new Pl_HTTP_Response.http_response sv
+  method status =
+    let sv = call_method sv "status" [] in
+    int_of_sv sv
+  method ct =
+    let sv = call_method sv "ct" [] in
+    string_of_sv sv
+  method base =
+    let sv = call_method sv "base" [] in
+    string_of_sv sv
+  method content =
+    let sv = call_method sv "content" [] in
+    string_of_sv sv
+  (* method forms = *)
+  (* method current_forms = *)
+  (* method links = *)
+  method is_html =
+    let sv = call_method sv "is_html" [] in
+    bool_of_sv sv
+  method title =
+    let sv = call_method sv "title" [] in
+    string_of_sv sv
+
+  (* method find_link .... = *)
+  (* method find_all_links .... = *)
+
+  (* method add_header .... = *)
+  (* method delete_header .... = *)
+
+  method quiet =
+    let sv = call_method sv "quiet" [] in
+    bool_of_sv sv
+  method set_quiet b =
+    call_method_void sv "quiet" [sv_of_bool b]
+  (* method stack_depth ... = *)
+  method redirect_ok =
+    let sv = call_method sv "redirect_ok" [] in
+    bool_of_sv sv
+
+  (* method request ... = *)
+  (* method update_html ... = *)
+
+end
+
+(* XXX Should be able to pass args to constructor of LWP::UserAgent. *)
+(* XXX WWW::Mechanize has additional parameters. *)
+let new_ () =
+  let sv = call_class_method "WWW::Mechanize" "new" [] in
+  new www_mechanize sv
-- 
1.8.3.1