wrappers/pl_WWW_Mechanize.ml

   1 (** Wrapper around Perl [WWW::Mechanize] class. *)
   2 (*  Copyright (C) 2003 Merjis Ltd.
   3
   4     This library is free software; you can redistribute it and/or
   5     modify it under the terms of the GNU Library General Public
   6     License as published by the Free Software Foundation; either
   7     version 2 of the License, or (at your option) any later version.
   8
   9     This library is distributed in the hope that it will be useful,
  10     but WITHOUT ANY WARRANTY; without even the implied warranty of
  11     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12     Library General Public License for more details.
  13
  14     You should have received a copy of the GNU General Public License
  15     along with this library; see the file COPYING.  If not, write to
  16     the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  17     Boston, MA 02111-1307, USA.
  18
  19     $Id: pl_WWW_Mechanize.ml,v 1.8 2008-03-01 13:02:21 rich Exp $
  20   *)
  21
  22 open Perl
  23
  24 open Pl_LWP_UserAgent
  25
  26 let _ = eval "use WWW::Mechanize"
  27
  28 class www_mechanize sv =
  29
  30 object (self)
  31   inherit lwp_useragent sv
  32
  33   method agent_alias alias =
  34     call_method_void sv "agent_alias" [sv_of_string alias]
  35   method known_agent_aliases =
  36     let svlist = call_method_array sv "known_agent_aliases" [] in
  37     List.map string_of_sv svlist
  38
  39   method get url =
  40     call_method_void sv "get" [sv_of_string url]
  41   method reload () =
  42     call_method_void sv "reload" []
  43   method back () =
  44     call_method_void sv "back" []
  45
  46   method follow_link ?text ?text_regex ?url ?url_regex ?url_abs ?url_abs_regex
  47     ?name ?name_regex ?tag ?tag_regex ?n () =
  48     let args = ref [] in
  49     let add name f = function
  50       | None -> ()
  51       | Some p -> args := sv_of_string name :: f p :: !args
  52     in
  53     add "text" sv_of_string text;
  54     add "text_regex" sv_of_string text_regex;
  55     add "url" sv_of_string url;
  56     add "url_regex" sv_of_string url_regex;
  57     add "url_abs" sv_of_string url_abs;
  58     add "url_abs_regex" sv_of_string url_abs_regex;
  59     add "name" sv_of_string name;
  60     add "name_regex" sv_of_string name_regex;
  61     add "tag" sv_of_string tag;
  62     add "tag_regex" sv_of_string tag_regex;
  63     add "n" sv_of_int n;
  64     call_method_void sv "follow_link" !args
  65
  66   method forms =
  67     let svlist = call_method_array sv "forms" [] in
  68     List.map (new Pl_HTML_Form.html_form) svlist
  69   method form_number n =
  70     let sv = call_method sv "form_number" [sv_of_int n] in
  71     new Pl_HTML_Form.html_form sv
  72   method form_name name =
  73     let sv = call_method sv "form_name" [sv_of_string name] in
  74     new Pl_HTML_Form.html_form sv
  75
  76   (* XXX There is an arrayref variant of this method, but what
  77    * it does is apparently undocumented.
  78    *)
  79   method field ?n name value =
  80     let args = match n with
  81         None -> [sv_of_string name; sv_of_string value]
  82       | Some n -> [sv_of_string name; sv_of_string value; sv_of_int n] in
  83     call_method_void sv "field" args
  84   method set_fields fields =
  85     let args = ref [] in
  86     List.iter (fun (k, v) ->
  87                  (* Note: reversed k, v because we'll reverse the whole list.*)
  88                  args := sv_of_string v :: sv_of_string k :: !args) fields;
  89     let args = List.rev !args in
  90     call_method_void sv "set_fields" args
  91
  92   method value ?n name =
  93     let args = match n with
  94         None -> [sv_of_string name]
  95       | Some n -> [sv_of_string name; sv_of_int n] in
  96     let sv = call_method sv "value" args in
  97     string_of_sv sv
  98
  99   (* XXX Doesn't support setting criteria. *)
 100   method set_visible names =
 101     let names = List.map sv_of_string names in
 102     call_method_void sv "set_visible" names
 103
 104   method tick ?set name value =
 105     let args = match set with
 106         None -> [ sv_of_string name; sv_of_string value ]
 107       | Some b -> [ sv_of_string name; sv_of_string value; sv_of_bool b ] in
 108     call_method_void sv "tick" args
 109
 110   method untick name value =
 111     call_method_void sv "untick" [ sv_of_string name; sv_of_string value ]
 112
 113   method click ?xy button =
 114     let args = match xy with
 115         None -> [ sv_of_string button ]
 116       | Some (x, y) -> [ sv_of_string button; sv_of_int x; sv_of_int y ] in
 117     call_method_void sv "click" args
 118   method click1 () =
 119     call_method_void sv "click" []
 120   method click_button ?name ?number ?value ?xy () =
 121     let args = ref [] in
 122     let add name f = function
 123       | None -> ()
 124       | Some p -> args := sv_of_string name :: f p :: !args
 125     in
 126     add "name" sv_of_string name;
 127     add "number" sv_of_int number;
 128     add "value" sv_of_string value;
 129     (match xy with
 130          None -> ()
 131        | Some (x, y) ->
 132            args := sv_of_string "x" :: sv_of_int x ::
 133              sv_of_string "y" :: sv_of_int y :: !args);
 134     call_method_void sv "click" !args
 135
 136   method select name value =
 137     call_method_void sv "select" [ sv_of_string name; sv_of_string value ]
 138   method select_multiple name values =
 139     let av = av_empty () in
 140     List.iter (av_push av) (List.map sv_of_string values);
 141     call_method_void sv "select" [ sv_of_string name; arrayref av ]
 142
 143   method submit () =
 144     call_method_void sv "submit" []
 145
 146   method submit_form ?form_number ?form_name ?fields ?button ?xy () =
 147     let args = ref [] in
 148     let add name f = function
 149       | None -> ()
 150       | Some p -> args := sv_of_string name :: f p :: !args
 151     in
 152     add "form_number" sv_of_int form_number;
 153     add "form_name" sv_of_string form_name;
 154     (match fields with
 155      | None -> ()
 156      | Some fields ->
 157          let hv = hv_empty () in
 158          List.iter (
 159            fun (name, value) ->
 160              hv_set hv name (sv_of_string value)
 161          ) fields;
 162          let sv = hashref hv in
 163          args := sv_of_string "fields" :: sv :: !args
 164     );
 165     add "button" sv_of_string button;
 166     (match xy with
 167      | None -> ()
 168      | Some (x, y) ->
 169          args := sv_of_string "x" :: sv_of_int x ::
 170            sv_of_string "y" :: sv_of_int y :: !args);
 171     let sv = call_method sv "submit_form" !args in
 172     new Pl_HTTP_Response.http_response sv
 173
 174   method success =
 175     let sv = call_method sv "success" [] in
 176     bool_of_sv sv
 177   method uri =
 178     let sv = call_method sv "uri" [] in
 179     string_of_sv sv
 180   method response =
 181     let sv = call_method sv "response" [] in
 182     new Pl_HTTP_Response.http_response sv
 183   method res =
 184     let sv = call_method sv "res" [] in
 185     new Pl_HTTP_Response.http_response sv
 186   method status =
 187     let sv = call_method sv "status" [] in
 188     int_of_sv sv
 189   method ct =
 190     let sv = call_method sv "ct" [] in
 191     string_of_sv sv
 192   method base =
 193     let sv = call_method sv "base" [] in
 194     string_of_sv sv
 195   method content =
 196     let sv = call_method sv "content" [] in
 197     string_of_sv sv
 198   (* method current_forms = *)
 199   method links =
 200     let svs = call_method_array sv "links" [] in
 201     List.map (new www_mechanize_link) svs
 202   method is_html =
 203     let sv = call_method sv "is_html" [] in
 204     bool_of_sv sv
 205   method title =
 206     let sv = call_method sv "title" [] in
 207     string_of_sv sv
 208
 209   (* method find_link .... = *)
 210   (* method find_all_links .... = *)
 211
 212   (* method add_header .... = *)
 213   (* method delete_header .... = *)
 214
 215   method quiet =
 216     let sv = call_method sv "quiet" [] in
 217     bool_of_sv sv
 218   method set_quiet b =
 219     call_method_void sv "quiet" [sv_of_bool b]
 220   (* method stack_depth ... = *)
 221   method redirect_ok =
 222     let sv = call_method sv "redirect_ok" [] in
 223     bool_of_sv sv
 224
 225   (* method request ... = *)
 226   (* method update_html ... = *)
 227
 228 end
 229
 230 and www_mechanize_link sv =
 231
 232 object (self)
 233
 234   method sv = sv
 235
 236   method url =
 237     let sv = call_method sv "url" [] in
 238     string_of_sv sv
 239
 240   method text =
 241     let sv = call_method sv "text" [] in
 242     string_of_sv sv
 243
 244   method name =
 245     let sv = call_method sv "name" [] in
 246     string_of_sv sv
 247
 248   method tag =
 249     let sv = call_method sv "tag" [] in
 250     string_of_sv sv
 251
 252   method base =
 253     let sv = call_method sv "base" [] in
 254     string_of_sv sv
 255
 256   method url_abs =
 257     let sv = call_method sv "url_abs" [] in
 258     string_of_sv sv
 259
 260 end
 261
 262 (* XXX Should be able to pass args to constructor of LWP::UserAgent. *)
 263 (* XXX WWW::Mechanize has additional parameters. *)
 264 let new_ ?autocheck () =
 265   let args = ref [] in
 266   let may f = function None -> () | Some v -> f v in
 267   may (fun v ->
 268          args := sv_of_string "autocheck" :: sv_of_bool v :: !args) autocheck;
 269   let sv = call_class_method "WWW::Mechanize" "new" !args in
 270   new www_mechanize sv