From 2a8fbfca012f397ebc7a5978ce851691cc48ba7b Mon Sep 17 00:00:00 2001
From: hobbs <hobbs>
Date: Wed, 12 Mar 2008 05:57:43 +0000
Subject: 	* library/http/http.tcl (http::geturl): add -method option to
 support 	* tests/http.test (http-3.1):		http PUT and DELETE
 requests. 	* doc/http.n:				[Bug 1599901, 862554]

---
 ChangeLog             |  4 ++++
 doc/http.n            |  7 ++++++-
 library/http/http.tcl | 13 +++++++++----
 tests/http.test       |  4 ++--
 4 files changed, 21 insertions(+), 7 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 127ec44..dabeb47 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2008-03-11  Jeff Hobbs  <jeffh@ActiveState.com>
 
+	* library/http/http.tcl (http::geturl): add -method option to support
+	* tests/http.test (http-3.1):		http PUT and DELETE requests.
+	* doc/http.n:				[Bug 1599901, 862554]
+
 	* library/http/http.tcl: whitespace changes, code cleanup.  Allow
 	http to be re-sourced without overwriting http state.
 
diff --git a/doc/http.n b/doc/http.n
index d5c8cca..69538f4 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -6,7 +6,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: http.n,v 1.33 2008/03/10 18:49:09 dgp Exp $
+'\" RCS: @(#) $Id: http.n,v 1.34 2008/03/12 05:57:44 hobbs Exp $
 '\" 
 .so man.macros
 .TH "http" n 2.5.5 http "Tcl Bundled Packages"
@@ -206,6 +206,11 @@ HTTP request:
 Pragma: no-cache
 .CE
 .TP
+\fB\-method\fR \fItype\fR
+Force the HTTP request method to \fItype\fR. \fB::http::geturl\fR will
+auto-select GET, POST or HEAD based on other optiosn, but this option
+enables choices like PUT and DELETE for webdav support.
+.TP
 \fB\-progress\fR \fIcallback\fR
 The \fIcallback\fR is made after each transfer of data from the URL.
 The callback gets three additional arguments: the \fItoken\fR from
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 91f2dc9..d508ba0 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -8,7 +8,7 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: http.tcl,v 1.64 2008/03/12 05:39:58 hobbs Exp $
+# RCS: @(#) $Id: http.tcl,v 1.65 2008/03/12 05:57:44 hobbs Exp $
 
 # Rough version history:
 # 1.0	Old http_get interface.
@@ -273,9 +273,11 @@ proc http::geturl { url args } {
 	-timeout	integer
     }
     set state(charset)	$defaultCharset
-    set options {-binary -blocksize -channel -command -handler -headers \
-	    -progress -query -queryblocksize -querychannel -queryprogress\
-	    -validate -timeout -type}
+    set options {
+	-binary -blocksize -channel -command -handler -headers
+	-method -progress -query -queryblocksize
+	-querychannel -queryprogress -validate -timeout -type
+    }
     set usage [join $options ", "]
     set options [string map {- ""} $options]
     set pat ^-([join $options |])$
@@ -532,6 +534,9 @@ proc http::geturl { url args } {
 	fconfigure $state(-querychannel) -blocking 1 -translation binary
 	set contDone 0
     }
+    if {[info exists state(-method)] && $state(-method) ne ""} {
+	set how $state(-method)
+    }
 
     if {[catch {
 	puts $s "$how $srvurl HTTP/1.0"
diff --git a/tests/http.test b/tests/http.test
index c8f82a2..235252e 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -12,7 +12,7 @@
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
 #
-# RCS: @(#) $Id: http.test,v 1.46 2007/12/13 15:26:06 dgp Exp $
+# RCS: @(#) $Id: http.test,v 1.47 2008/03/12 05:57:44 hobbs Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -117,7 +117,7 @@ test http-2.1 {http::reset} {
 
 test http-3.1 {http::geturl} {
     list [catch {http::geturl -bogus flag} msg] $msg
-} {1 {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -progress, -query, -queryblocksize, -querychannel, -queryprogress, -validate, -timeout, -type}}
+} {1 {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -method, -progress, -query, -queryblocksize, -querychannel, -queryprogress, -validate, -timeout, -type}}
 test http-3.2 {http::geturl} {
     catch {http::geturl http:junk} err
     set err
-- 
cgit v0.12