summaryrefslogtreecommitdiffstats
path: root/library/http/http.tcl
diff options
context:
space:
mode:
authorwelch <welch>2000-03-17 02:15:06 (GMT)
committerwelch <welch>2000-03-17 02:15:06 (GMT)
commitf257591d5397a0616c8aed901998abd5275a0c0b (patch)
treee80a7be3a46f698f8df89e47c888b6906037a48f /library/http/http.tcl
parentf935563d25800bd6e653a2588ef1f6cfad56bc63 (diff)
downloadtcl-f257591d5397a0616c8aed901998abd5275a0c0b.zip
tcl-f257591d5397a0616c8aed901998abd5275a0c0b.tar.gz
tcl-f257591d5397a0616c8aed901998abd5275a0c0b.tar.bz2
Added -queryprogress callback to
http::geturl and also changed it so that writing the post data is event driven if the queryprogress callback or a timeout is given. This allows a timeout to occur when writing lots of post data. The queryprogress callback is called after each block of query data is posted. It has the same signature as the -progress callback.
Diffstat (limited to 'library/http/http.tcl')
-rw-r--r--library/http/http.tcl94
1 files changed, 90 insertions, 4 deletions
diff --git a/library/http/http.tcl b/library/http/http.tcl
index dd5bcf0..1460c85 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -9,9 +9,9 @@
# 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.21 2000/02/01 11:48:31 hobbs Exp $
+# RCS: @(#) $Id: http.tcl,v 1.22 2000/03/17 02:15:06 welch Exp $
-package provide http 2.2 ;# This uses Tcl namespaces
+package provide http 2.3 ;# This uses Tcl namespaces
namespace eval http {
variable http
@@ -172,7 +172,9 @@ proc http::reset { token {why reset} } {
variable $token
upvar 0 $token state
set state(status) $why
+ set state(querydone) $why
catch {fileevent $state(sock) readable {}}
+ catch {fileevent $state(sock) writable {}}
Finish $token
if {[info exists state(error)]} {
set errorlist $state(error)
@@ -217,6 +219,7 @@ proc http::geturl { url args } {
-headers {}
-timeout 0
-type application/x-www-form-urlencoded
+ -queryprogress {}
state header
meta {}
currentsize 0
@@ -226,7 +229,7 @@ proc http::geturl { url args } {
status ""
}
set options {-blocksize -channel -command -handler -headers \
- -progress -query -validate -timeout -type}
+ -progress -query -queryprogress -validate -timeout -type}
set usage [join $options ", "]
regsub -all -- - $options {} options
set pat ^-([join $options |])$
@@ -341,7 +344,17 @@ proc http::geturl { url args } {
puts $s "Content-Type: $state(-type)"
puts $s ""
fconfigure $s -translation {auto binary}
- puts -nonewline $s $state(-query)
+
+ # If a timeout is specified or a queryprogress callback is specified
+ # we do the post in the background
+
+ if {$state(-timeout) > 0 || [string length $state(-queryprogress)]} {
+ fileevent $s writable \
+ [list http::Write $token $state(-query) $state(-queryprogress)]
+ WaitPost $token
+ } else {
+ puts -nonewline $s $state(-query)
+ }
} else {
puts $s ""
}
@@ -427,6 +440,54 @@ proc http::cleanup {token} {
}
}
+# http::Write
+#
+# Write POST query data to the socket
+#
+# Arguments
+# token The token for the connection
+# query The query data to write to the connection
+# queryprogress The callback, if any, to make after each block
+#
+# Side Effects
+# Write the socket and handle callbacks.
+
+proc http::Write {token query queryprogress} {
+ variable $token
+ upvar 0 $token state
+ set s $state(sock)
+ if {![info exist state(queryoffset)]} {
+ set state(queryoffset) 0
+ set state(querylength) [string length $query]
+ }
+ set chunksize 16384
+
+ # Output a block. Tcl will buffer this if the socket blocks
+
+ if {$state(querylength) < $chunksize} {
+ set chunksize $state(querylength)
+ }
+ if {[catch {
+
+ # Catch I/O errors on dead sockets
+
+ puts -nonewline $s [string range $query $state(queryoffset) \
+ [incr state(queryoffset) $chunksize]]
+
+ if {[string length $queryprogress]} {
+ eval $queryprogress [list $token $state(queryoffset) $state(querylength)]
+ }
+
+ if {$state(queryoffset) >= $state(querylength)} {
+ fileevent $s writable {}
+ set state(querydone) ok
+ }
+ } err]} {
+ set state(querydone) $err
+ fileevent $s writable {}
+ }
+}
+
# http::Event
#
# Handle input on the socket
@@ -581,6 +642,7 @@ proc http::cleanup {token} {
#
# Arguments:
# token Connection token.
+#
# Results:
# The status after the wait.
@@ -600,6 +662,30 @@ proc http::wait {token} {
return $state(status)
}
+# http::WaitPost --
+#
+# Wait for the post data to be written out
+#
+# Arguments:
+# token Connection token.
+#
+# Results:
+# The status after the wait.
+
+proc http::WaitPost {token} {
+ variable $token
+ upvar 0 $token state
+
+ # We must wait on the original variable name, not the upvar alias
+ vwait $token\(querydone)
+ if {[string compare $state(querydone) ok] != 0} {
+ # throw an error to unwind geturl
+ return -code error $state(querydone)
+ } else {
+ return $state(querydone)
+ }
+}
+
# http::formatQuery --
#
# See documentaion for details.