From: rich <rich>
Date: Mon, 22 Nov 2004 17:08:36 +0000 (+0000)
Subject: More complete LWP wrappers.
X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=f71f13bd5e85b5cca4e9c2e63bf9d9c3283d66cf;p=perl4caml.git

More complete LWP wrappers.
---

diff --git a/.depend b/.depend
index 1b82a0d..5dd4204 100644
--- a/.depend
+++ b/.depend
@@ -28,18 +28,24 @@ 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_Cookies.cmo: perl.cmi 
+wrappers/pl_HTTP_Cookies.cmx: perl.cmx 
+wrappers/pl_HTTP_Headers.cmo: perl.cmi 
+wrappers/pl_HTTP_Headers.cmx: perl.cmx 
+wrappers/pl_HTTP_Message.cmo: perl.cmi wrappers/pl_HTTP_Headers.cmo 
+wrappers/pl_HTTP_Message.cmx: perl.cmx wrappers/pl_HTTP_Headers.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_Request_Common.cmo: perl.cmi wrappers/pl_HTTP_Request.cmo 
+wrappers/pl_HTTP_Request_Common.cmx: perl.cmx wrappers/pl_HTTP_Request.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_LWP_UserAgent.cmo: perl.cmi wrappers/pl_HTTP_Cookies.cmo \
+    wrappers/pl_HTTP_Request.cmo wrappers/pl_HTTP_Response.cmo 
+wrappers/pl_LWP_UserAgent.cmx: perl.cmx wrappers/pl_HTTP_Cookies.cmx \
+    wrappers/pl_HTTP_Request.cmx wrappers/pl_HTTP_Response.cmx 
 wrappers/pl_Net_Google.cmo: perl.cmi wrappers/pl_Net_Google_Cache.cmo \
     wrappers/pl_Net_Google_Search.cmo wrappers/pl_Net_Google_Spelling.cmo 
 wrappers/pl_Net_Google.cmx: perl.cmx wrappers/pl_Net_Google_Cache.cmx \
diff --git a/MANIFEST b/MANIFEST
index 777844a..400535a 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -25,8 +25,11 @@ wrappers/pl_Date_Parse.ml
 wrappers/pl_HTML_Element.ml
 wrappers/pl_HTML_Parser.ml
 wrappers/pl_HTML_TreeBuilder.ml
+wrappers/pl_HTTP_Cookies.ml
+wrappers/pl_HTTP_Headers.ml
 wrappers/pl_HTTP_Message.ml
 wrappers/pl_HTTP_Request.ml
+wrappers/pl_HTTP_Request_Common.ml
 wrappers/pl_HTTP_Response.ml
 wrappers/pl_LWP_UserAgent.ml
 wrappers/pl_Net_Google.ml
diff --git a/Makefile b/Makefile
index 1560e4e..61c0174 100644
--- a/Makefile
+++ b/Makefile
@@ -1,6 +1,6 @@
 # Interface to Perl from OCaml.
 # Copyright (C) 2003 Merjis Ltd.
-# $Id: Makefile,v 1.21 2004-11-03 14:15:16 rich Exp $
+# $Id: Makefile,v 1.22 2004-11-22 17:08:36 rich Exp $
 
 include Makefile.config
 
@@ -43,8 +43,11 @@ WRAPPERS := \
 	wrappers/pl_HTML_Parser.cmo \
 	wrappers/pl_HTML_TreeBuilder.cmo \
 	wrappers/pl_URI.cmo \
+	wrappers/pl_HTTP_Cookies.cmo \
+	wrappers/pl_HTTP_Headers.cmo \
 	wrappers/pl_HTTP_Message.cmo \
 	wrappers/pl_HTTP_Request.cmo \
+	wrappers/pl_HTTP_Request_Common.cmo \
 	wrappers/pl_HTTP_Response.cmo \
 	wrappers/pl_LWP_UserAgent.cmo \
 	wrappers/pl_Template.cmo
@@ -150,15 +153,16 @@ dist:
 	ls -l $(PACKAGE)-$(VERSION).tar.gz
 
 check-manifest:
-	@for d in `find -type d -name CVS`; \
+	@for d in `find -type d -name CVS | grep -v '^\./debian/'`; \
 	do \
 	b=`dirname $$d`/; \
 	awk -F/ '$$1 != "D" {print $$2}' $$d/Entries | \
 	sed -e "s|^|$$b|" -e "s|^\./||"; \
 	done | sort > .check-manifest; \
 	sort MANIFEST > .orig-manifest; \
-	diff -u .orig-manifest .check-manifest; \
-	rm -f .orig-manifest .check-manifest
+	diff -u .orig-manifest .check-manifest; rv=$$?; \
+	rm -f .orig-manifest .check-manifest; \
+	exit $$rv
 
 # Debian packages.
 
diff --git a/wrappers/pl_HTTP_Cookies.ml b/wrappers/pl_HTTP_Cookies.ml
new file mode 100644
index 0000000..592ff86
--- /dev/null
+++ b/wrappers/pl_HTTP_Cookies.ml
@@ -0,0 +1,54 @@
+(** Wrapper around Perl [HTTP::Cookies] class.
+  *
+  * Copyright (C) 2003 Merjis Ltd.
+  *
+  * $Id: pl_HTTP_Cookies.ml,v 1.1 2004-11-22 17:08:36 rich Exp $
+  *)
+
+open Perl
+
+let _ = eval "use HTTP::Cookies"
+
+class http_cookies sv =
+
+object (self)
+  method sv = sv
+
+  method save ?filename () =
+    let args = match filename with
+	None -> []
+      | Some filename -> [sv_of_string filename] in
+    call_method_void sv "save" args
+
+  method load ?filename () =
+    let args = match filename with
+	None -> []
+      | Some filename -> [sv_of_string filename] in
+    call_method_void sv "load" args
+
+  method revert () =
+    call_method_void sv "revert" []
+
+  method as_string ?skip_discardables () =
+    let args = match skip_discardables with
+	None -> []
+      | Some b -> [sv_of_bool b] in
+    string_of_sv (call_method sv "as_string" args)
+
+end
+
+let new_ ?file ?autosave ?ignore_discard ?hide_cookie2 () =
+  let args = ref [] in
+  let may f = function None -> () | Some v -> f v in
+  may (fun v ->
+	 args := sv_of_string "file" :: sv_of_string v :: !args) file;
+  may (fun v ->
+	 args := sv_of_string "autosave" :: sv_of_bool v :: !args) autosave;
+  may (fun v ->
+	 args := sv_of_string "ignore_discard" :: sv_of_bool v :: !args)
+    ignore_discard;
+  may (fun v ->
+	 args := sv_of_string "hide_cookie2" :: sv_of_bool v :: !args)
+    hide_cookie2;
+  let sv = call_class_method "HTTP::Cookies" "new" !args in
+  new http_cookies sv
diff --git a/wrappers/pl_HTTP_Headers.ml b/wrappers/pl_HTTP_Headers.ml
new file mode 100644
index 0000000..7f7b2c9
--- /dev/null
+++ b/wrappers/pl_HTTP_Headers.ml
@@ -0,0 +1,24 @@
+(** Wrapper around Perl [HTTP::Message] class.
+  *
+  * Copyright (C) 2003 Merjis Ltd.
+  *
+  * $Id: pl_HTTP_Headers.ml,v 1.1 2004-11-22 17:08:36 rich Exp $
+  *)
+
+open Perl
+
+let _ = eval "use HTTP::Headers"
+
+class http_headers sv =
+
+object (self)
+
+  method header key =
+    string_of_sv (call_method sv "header" [sv_of_string key])
+  method set_header key value =
+    call_method_void sv "header" [sv_of_string key; sv_of_string value]
+
+  method as_string =
+    string_of_sv (call_method sv "as_string" [])
+
+end
diff --git a/wrappers/pl_HTTP_Message.ml b/wrappers/pl_HTTP_Message.ml
index 0a51105..29140b2 100644
--- a/wrappers/pl_HTTP_Message.ml
+++ b/wrappers/pl_HTTP_Message.ml
@@ -2,16 +2,19 @@
   *
   * Copyright (C) 2003 Merjis Ltd.
   *
-  * $Id: pl_HTTP_Message.ml,v 1.3 2003-10-16 13:41:07 rich Exp $
+  * $Id: pl_HTTP_Message.ml,v 1.4 2004-11-22 17:08:36 rich Exp $
   *)
 
 open Perl
 
+open Pl_HTTP_Headers
+
 let _ = eval "use HTTP::Message"
 
 class http_message sv =
 
 object (self)
+  inherit http_headers sv
 
   method content =
     string_of_sv (call_method sv "content" [])
diff --git a/wrappers/pl_HTTP_Request_Common.ml b/wrappers/pl_HTTP_Request_Common.ml
new file mode 100644
index 0000000..f027b58
--- /dev/null
+++ b/wrappers/pl_HTTP_Request_Common.ml
@@ -0,0 +1,38 @@
+(** Wrapper around Perl [HTTP::Request::Common] class.
+  *
+  * Copyright (C) 2003 Merjis Ltd.
+  *
+  * $Id: pl_HTTP_Request_Common.ml,v 1.1 2004-11-22 17:08:36 rich Exp $
+  *)
+
+open Perl
+
+open Pl_HTTP_Request
+
+let _ = eval "use HTTP::Request::Common"
+
+let get, head, put =
+  let dofn fn url headers =
+    let args =
+      sv_of_string url ::
+	List.fold_right (fun (k, v) rest ->
+			   sv_of_string k :: sv_of_string v :: rest)
+	headers [] in
+    new http_request (call ~fn args)
+  in
+  let get = dofn "GET" in
+  let head = dofn "HEAD" in
+  let put = dofn "PUT" in
+  get, head, put
+
+let post url ?form headers =
+  let hv = hv_empty () in
+  (match form with
+     | None -> ()
+     | Some xs -> List.iter (fun (k, v) -> hv_set hv k (sv_of_string v)) xs);
+  let args =
+    sv_of_string url :: hashref hv ::
+      List.fold_right (fun (k, v) rest ->
+			 sv_of_string k :: sv_of_string v :: rest)
+      headers [] in
+  new http_request (call ~fn:"POST" args)
diff --git a/wrappers/pl_LWP_UserAgent.ml b/wrappers/pl_LWP_UserAgent.ml
index c6a5b98..941ba36 100644
--- a/wrappers/pl_LWP_UserAgent.ml
+++ b/wrappers/pl_LWP_UserAgent.ml
@@ -2,13 +2,14 @@
   *
   * Copyright (C) 2003 Merjis Ltd.
   *
-  * $Id: pl_LWP_UserAgent.ml,v 1.3 2003-10-16 13:41:07 rich Exp $
+  * $Id: pl_LWP_UserAgent.ml,v 1.4 2004-11-22 17:08:36 rich Exp $
   *)
 
 open Perl
 
 open Pl_HTTP_Request
 open Pl_HTTP_Response
+open Pl_HTTP_Cookies
 
 let _ = eval "use LWP::UserAgent"
 
@@ -30,6 +31,15 @@ object (self)
     string_of_sv (call_method sv "from" [])
   method set_from v =
     call_method_void sv "from" [sv_of_string v]
+  method cookie_jar =
+    let sv = call_method sv "cookie_jar" [] in
+    new http_cookies sv
+  method set_cookie_jar (v : http_cookies) =
+    call_method_void sv "cookie_jar" [v#sv]
+  method set_cookie_jar_file filename =
+    let hv = hv_empty () in
+    hv_set hv "file" (sv_of_string filename);
+    call_method_void sv "cookie_jar" [hashref hv]
   method timeout =
     int_of_sv (call_method sv "timeout" [])
   method set_timeout v =
@@ -49,7 +59,7 @@ 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 () =
+    ?env_proxy ?keep_alive ?cookie_jar ?cookie_jar_file () =
   let args = ref [] in
   let may f = function None -> () | Some v -> f v in
   may (fun v ->
@@ -68,5 +78,12 @@ let new_ ?agent ?from ?timeout ?use_eval ?parse_head ?max_size
 	 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;
+  may (fun (v : http_cookies) ->
+	 args := sv_of_string "cookie_jar" :: v#sv :: !args) cookie_jar;
+  may (fun v ->
+	 let hv = hv_empty () in
+	 hv_set hv "file" (sv_of_string v);
+	 let sv = hashref hv in
+	 args := sv_of_string "cookie_jar" :: sv :: !args) cookie_jar_file;
   let sv = call_class_method "LWP::UserAgent" "new" !args in
   new lwp_useragent sv