summaryrefslogtreecommitdiffstats
path: root/library/http/http.tcl
diff options
context:
space:
mode:
authorwelch <welch>1999-11-18 02:22:41 (GMT)
committerwelch <welch>1999-11-18 02:22:41 (GMT)
commitbf803ce3d2dabe06c5d64ca09d834c73df3d6d77 (patch)
tree1797f6b4fbc772c0431a673e655dd46ecafb3448 /library/http/http.tcl
parent61c5d130c81598ba4ed1cae3f30747b89f023e7a (diff)
downloadtcl-bf803ce3d2dabe06c5d64ca09d834c73df3d6d77.zip
tcl-bf803ce3d2dabe06c5d64ca09d834c73df3d6d77.tar.gz
tcl-bf803ce3d2dabe06c5d64ca09d834c73df3d6d77.tar.bz2
Improved error handling of http::geturl in the case the server is
not available. Also correctly fixed the bug between -timeout and a subsequent http::status call.
Diffstat (limited to 'library/http/http.tcl')
-rw-r--r--library/http/http.tcl168
1 files changed, 134 insertions, 34 deletions
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 72b5623..bb705e0 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -9,7 +9,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.14 1999/11/10 02:52:20 hobbs Exp $
+# RCS: @(#) $Id: http.tcl,v 1.15 1999/11/18 02:22:44 welch Exp $
package provide http 2.1 ;# This uses Tcl namespaces
@@ -82,6 +82,17 @@ proc http::config {args} {
}
}
+# http::Finish --
+#
+# Clean up the socket and eval close time callbacks
+#
+# Arguments:
+# token Connection token.
+# errormsg If set, forces status to error.
+#
+# Side Effects:
+# Closes the socket
+
proc http::Finish { token {errormsg ""} } {
variable $token
upvar 0 $token state
@@ -113,8 +124,9 @@ proc http::config {args} {
# Arguments:
# token Connection token.
# why Status info.
-# Results:
-# TODO
+#
+# Side Effects:
+# See Finish
proc http::reset { token {why reset} } {
variable $token
@@ -235,8 +247,8 @@ proc http::geturl { url args } {
if {$state(-timeout) > 0} {
fileevent $s writable [list http::Connect $token]
http::wait $token
- if {[string equal $state(status) "timeout"]} {
- return
+ if {![string equal $state(status) "connect"]} {
+ return $token
}
fileevent $s writable {}
set state(status) ""
@@ -260,28 +272,37 @@ proc http::geturl { url args } {
} elseif {$state(-validate)} {
set how HEAD
}
- puts $s "$how $srvurl HTTP/1.0"
- puts $s "Accept: $http(-accept)"
- puts $s "Host: $host"
- puts $s "User-Agent: $http(-useragent)"
- foreach {key value} $state(-headers) {
- regsub -all \[\n\r\] $value {} value
- set key [string trim $key]
- if {[string length $key]} {
- puts $s "$key: $value"
+ if {[catch {
+ puts $s "$how $srvurl HTTP/1.0"
+ puts $s "Accept: $http(-accept)"
+ puts $s "Host: $host"
+ puts $s "User-Agent: $http(-useragent)"
+ foreach {key value} $state(-headers) {
+ regsub -all \[\n\r\] $value {} value
+ set key [string trim $key]
+ if {[string length $key]} {
+ puts $s "$key: $value"
+ }
}
+ if {$len > 0} {
+ puts $s "Content-Length: $len"
+ puts $s "Content-Type: application/x-www-form-urlencoded"
+ puts $s ""
+ fconfigure $s -translation {auto binary}
+ puts $s $state(-query)
+ } else {
+ puts $s ""
+ }
+ flush $s
+ fileevent $s readable [list http::Event $token]
+ } err]} {
+ # The socket probably was never connected, or the connection
+ # dropped later.
+
+ reset $token ioerror
+ return $token
}
- if {$len > 0} {
- puts $s "Content-Length: $len"
- puts $s "Content-Type: application/x-www-form-urlencoded"
- puts $s ""
- fconfigure $s -translation {auto binary}
- puts $s $state(-query)
- } else {
- puts $s ""
- }
- flush $s
- fileevent $s readable [list http::Event $token]
+
if {! [info exists state(-command)]} {
wait $token
}
@@ -332,12 +353,38 @@ proc http::cleanup {token} {
unset state
}
}
+
+# http::Connect
+#
+# Wait for an asynchronous connection to complete
+#
+# Arguments
+# token The token returned from http::geturl
+#
+# Side Effects
+# Sets the status of the connection, which unblocks
+# the waiting geturl call
+
proc http::Connect {token} {
variable $token
upvar 0 $token state
- set state(status) connect
+ if {[eof $state(sock)]} {
+ set state(status) ioerror
+ } else {
+ set state(status) connect
+ }
}
+# http::Event
+#
+# Handle input on the socket
+#
+# Arguments
+# token The token returned from http::geturl
+#
+# Side Effects
+# Read the socket and handle callbacks.
+
proc http::Event {token} {
variable $token
upvar 0 $token state
@@ -402,6 +449,18 @@ proc http::cleanup {token} {
}
}
}
+
+# http::CopyStart
+#
+# Error handling wrapper around fcopy
+#
+# Arguments
+# s The socket to copy from
+# token The token returned from http::geturl
+#
+# Side Effects
+# This closes the connection upon error
+
proc http::CopyStart {s token} {
variable $token
upvar 0 $token state
@@ -412,6 +471,18 @@ proc http::cleanup {token} {
Finish $token $err
}
}
+
+# http::CopyDone
+#
+# fcopy completion callback
+#
+# Arguments
+# token The token returned from http::geturl
+# count The amount transfered
+#
+# Side Effects
+# Invokes callbacks
+
proc http::CopyDone {token count {error {}}} {
variable $token
upvar 0 $token state
@@ -429,6 +500,17 @@ proc http::cleanup {token} {
CopyStart $s $token
}
}
+
+# http::Eof
+#
+# Handle eof on the socket
+#
+# Arguments
+# token The token returned from http::geturl
+#
+# Side Effects
+# Clean up the socket
+
proc http::Eof {token} {
variable $token
upvar 0 $token state
@@ -493,15 +575,25 @@ proc http::formatQuery {args} {
return $result
}
-# do x-www-urlencoded character mapping
-# The spec says: "non-alphanumeric characters are replaced by '%HH'"
-# 1 leave alphanumerics characters alone
-# 2 Convert every other character to an array lookup
-# 3 Escape constructs that are "special" to the tcl parser
-# 4 "subst" the result, doing all the array substitutions
-
+# http::mapReply --
+#
+# Do x-www-urlencoded character mapping
+#
+# Arguments:
+# string The string the needs to be encoded
+#
+# Results:
+# The encoded string
+
proc http::mapReply {string} {
variable formMap
+
+ # The spec says: "non-alphanumeric characters are replaced by '%HH'"
+ # 1 leave alphanumerics characters alone
+ # 2 Convert every other character to an array lookup
+ # 3 Escape constructs that are "special" to the tcl parser
+ # 4 "subst" the result, doing all the array substitutions
+
set alphanumeric a-zA-Z0-9
regsub -all \[^$alphanumeric\] $string {$formMap(&)} string
regsub -all \n $string {\\n} string
@@ -510,7 +602,15 @@ proc http::formatQuery {args} {
return [subst $string]
}
-# Default proxy filter.
+# http::ProxyRequired --
+# Default proxy filter.
+#
+# Arguments:
+# host The destination host
+#
+# Results:
+# The current proxy settings
+
proc http::ProxyRequired {host} {
variable http
if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {