wrappers/pl_LWP_UserAgent.ml

   1 (** Wrapper around Perl [LWP::UserAgent] class.
   2   *
   3   * Copyright (C) 2003 Merjis Ltd.
   4   *
   5   * $Id: pl_LWP_UserAgent.ml,v 1.5 2004-11-25 21:24:51 rich Exp $
   6   *)
   7
   8 open Perl
   9
  10 open Pl_HTTP_Request
  11 open Pl_HTTP_Response
  12 open Pl_HTTP_Cookies
  13
  14 let _ = eval "use LWP::UserAgent"
  15
  16 class lwp_useragent sv =
  17
  18 object (self)
  19
  20   method simple_request (request : http_request) =
  21     let sv = call_method sv "simple_request" [request#sv] in
  22     new http_response sv
  23   method request (request : http_request) =
  24     let sv = call_method sv "request" [request#sv] in
  25     new http_response sv
  26   method agent =
  27     string_of_sv (call_method sv "agent" [])
  28   method set_agent v =
  29     call_method_void sv "agent" [sv_of_string v]
  30   method from =
  31     string_of_sv (call_method sv "from" [])
  32   method set_from v =
  33     call_method_void sv "from" [sv_of_string v]
  34   method cookie_jar =
  35     let sv = call_method sv "cookie_jar" [] in
  36     new http_cookies sv
  37   method set_cookie_jar (v : http_cookies) =
  38     call_method_void sv "cookie_jar" [v#sv]
  39   method set_cookie_jar_file filename =
  40     let hv = hv_empty () in
  41     hv_set hv "file" (sv_of_string filename);
  42     call_method_void sv "cookie_jar" [hashref hv]
  43   method requests_redirectable =
  44     let sv = call_method sv "requests_redirectable" [] in
  45     let av = deref_array sv in
  46     List.map string_of_sv (list_of_av av)
  47   method set_requests_redirectable methods =
  48     let av = av_empty () in
  49     List.iter (av_push av) (List.map sv_of_string methods);
  50     call_method_void sv "requests_redirectable" [arrayref av]
  51   method add_requests_redirectable method_ =
  52     let sv = call_method sv "requests_redirectable" [] in
  53     let av = deref_array sv in
  54     av_push av (sv_of_string method_)
  55   method timeout =
  56     int_of_sv (call_method sv "timeout" [])
  57   method set_timeout v =
  58     call_method_void sv "timeout" [sv_of_int v]
  59   method parse_head =
  60     bool_of_sv (call_method sv "parse_head" [])
  61   method set_parse_head v =
  62     call_method_void sv "parse_head" [sv_of_bool v]
  63   method max_size =
  64     int_of_sv (call_method sv "max_size" [])
  65   method set_max_size v =
  66     call_method_void sv "max_size" [sv_of_int v]
  67   method env_proxy () =
  68     call_method_void sv "env_proxy" []
  69
  70 end
  71
  72 (* Note that "new" is a reserved word, so I've appended an _ character. *)
  73 let new_ ?agent ?from ?timeout ?use_eval ?parse_head ?max_size
  74     ?env_proxy ?keep_alive ?cookie_jar ?cookie_jar_file () =
  75   let args = ref [] in
  76   let may f = function None -> () | Some v -> f v in
  77   may (fun v ->
  78          args := sv_of_string "agent" :: sv_of_string v :: !args) agent;
  79   may (fun v ->
  80          args := sv_of_string "from" :: sv_of_string v :: !args) from;
  81   may (fun v ->
  82          args := sv_of_string "timeout" :: sv_of_int v :: !args) timeout;
  83   may (fun v ->
  84          args := sv_of_string "use_eval" :: sv_of_bool v :: !args) use_eval;
  85   may (fun v ->
  86          args := sv_of_string "parse_head" :: sv_of_bool v :: !args)parse_head;
  87   may (fun v ->
  88          args := sv_of_string "max_size" :: sv_of_int v :: !args) max_size;
  89   may (fun v ->
  90          args := sv_of_string "env_proxy" :: sv_of_bool v :: !args) env_proxy;
  91   may (fun v ->
  92          args := sv_of_string "keep_alive" :: sv_of_int v :: !args) keep_alive;
  93   may (fun (v : http_cookies) ->
  94          args := sv_of_string "cookie_jar" :: v#sv :: !args) cookie_jar;
  95   may (fun v ->
  96          let hv = hv_empty () in
  97          hv_set hv "file" (sv_of_string v);
  98          let sv = hashref hv in
  99          args := sv_of_string "cookie_jar" :: sv :: !args) cookie_jar_file;
 100   let sv = call_class_method "LWP::UserAgent" "new" !args in
 101   new lwp_useragent sv