summaryrefslogtreecommitdiffstats
path: root/library/http/http.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/http/http.tcl')
-rw-r--r--library/http/http.tcl598
1 files changed, 477 insertions, 121 deletions
diff --git a/library/http/http.tcl b/library/http/http.tcl
index d508ba0..98b1a64 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -8,23 +8,12 @@
# 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.65 2008/03/12 05:57:44 hobbs Exp $
-
-# Rough version history:
-# 1.0 Old http_get interface.
-# 2.0 http:: namespace and http::geturl.
-# 2.1 Added callbacks to handle arriving data, and timeouts.
-# 2.2 Added ability to fetch into a channel.
-# 2.3 Added SSL support, and ability to post from a channel. This version
-# also cleans up error cases and eliminates the "ioerror" status in
-# favor of raising an error
-# 2.4 Added -binary option to http::geturl and charset element to the state
-# array.
+# RCS: @(#) $Id: http.tcl,v 1.66 2008/03/12 09:51:38 hobbs Exp $
package require Tcl 8.4
# Keep this in sync with pkgIndex.tcl and with the install directories
# in Makefiles
-package provide http 2.5.5
+package provide http 2.7
namespace eval http {
# Allow resourcing to not clobber existing data
@@ -56,6 +45,16 @@ namespace eval http {
# These are handled specially
set map(\n) %0d%0a
variable formMap [array get map]
+
+ # Create a map for HTTP/1.1 open sockets
+ variable socketmap
+ if {[info exists socketmap]} {
+ # Close but don't remove open sockets on re-init
+ foreach {url sock} [array get socketmap] {
+ catch {close $sock}
+ }
+ }
+ array set socketmap {}
}
init
@@ -66,15 +65,37 @@ namespace eval http {
variable encodings [string tolower [encoding names]]
# This can be changed, but iso8859-1 is the RFC standard.
- variable defaultCharset "iso8859-1"
+ variable defaultCharset
+ if {![info exists defaultCharset]} {
+ set defaultCharset "iso8859-1"
+ }
# Force RFC 3986 strictness in geturl url verification?
- variable strict 1
+ variable strict
+ if {![info exists strict]} {
+ set strict 1
+ }
+
+ # Let user control default keepalive for compatibility
+ variable defaultKeepalive
+ if {![info exists defaultKeepalive]} {
+ set defaultKeepalive 1
+ }
namespace export geturl config reset wait formatQuery register unregister
# Useful, but not exported: data size status code
}
+# http::Log --
+#
+# Debugging output -- define this to observe HTTP/1.1 socket usage.
+# Should echo any args received.
+#
+# Arguments:
+# msg Message to output
+#
+proc http::Log {args} {}
+
# http::register --
#
# See documentation for details.
@@ -173,7 +194,11 @@ proc http::Finish { token {errormsg ""} {skipCB 0}} {
set state(error) [list $errormsg $errorInfo $errorCode]
set state(status) "error"
}
- catch {close $state(sock)}
+ if {($state(status) eq "timeout") || ($state(status) eq "error")
+ || ([info exists state(connection)] && ($state(connection) eq "close"))
+ } {
+ CloseSocket $state(sock) $token
+ }
if {[info exists state(after)]} { after cancel $state(after) }
if {[info exists state(-command)] && !$skipCB} {
if {[catch {eval $state(-command) {$token}} err]} {
@@ -187,6 +212,45 @@ proc http::Finish { token {errormsg ""} {skipCB 0}} {
}
}
+# http::CloseSocket -
+#
+# Close a socket and remove it from the persistent sockets table.
+# If possible an http token is included here but when we are called
+# from a fileevent on remote closure we need to find the correct
+# entry - hence the second section.
+
+proc ::http::CloseSocket {s {token {}}} {
+ variable socketmap
+ catch {fileevent $s readable {}}
+ set conn_id {}
+ if {$token ne ""} {
+ variable $token
+ upvar 0 $token state
+ if {[info exists state(socketinfo)]} {
+ set conn_id $state(socketinfo)
+ }
+ } else {
+ set map [array get socketmap]
+ set ndx [lsearch -exact $map $s]
+ if {$ndx != -1} {
+ incr ndx -1
+ set conn_id [lindex $map $ndx]
+ }
+ }
+ if {$conn_id eq {} || ![info exists socketmap($conn_id)]} {
+ Log "Closing socket $s (no connection info)"
+ if {[catch {close $s} err]} { Log "Error: $err" }
+ } else {
+ if {[info exists socketmap($conn_id)]} {
+ Log "Closing connection $conn_id (sock $socketmap($conn_id))"
+ if {[catch {close $socketmap($conn_id)} err]} { Log "Error: $err" }
+ unset socketmap($conn_id)
+ } else {
+ Log "Cannot close connection $conn_id - no socket in socket map"
+ }
+ }
+}
+
# http::reset --
#
# See documentation for details.
@@ -228,6 +292,7 @@ proc http::geturl { url args } {
variable http
variable urlTypes
variable defaultCharset
+ variable defaultKeepalive
variable strict
# Initialize the state variable, an array. We'll return the name of this
@@ -252,6 +317,8 @@ proc http::geturl { url args } {
-timeout 0
-type application/x-www-form-urlencoded
-queryprogress {}
+ -protocol 1.1
+ binary 0
state header
meta {}
coding {}
@@ -263,29 +330,33 @@ proc http::geturl { url args } {
body {}
status ""
http ""
+ connection close
}
+ set state(-keepalive) $defaultKeepalive
+ set state(-strict) $strict
# These flags have their types verified [Bug 811170]
array set type {
-binary boolean
-blocksize integer
-queryblocksize integer
- -validate boolean
+ -strict boolean
-timeout integer
+ -validate boolean
}
set state(charset) $defaultCharset
set options {
- -binary -blocksize -channel -command -handler -headers
- -method -progress -query -queryblocksize
- -querychannel -queryprogress -validate -timeout -type
+ -binary -blocksize -channel -command -handler -headers -keepalive
+ -method -myaddr -progress -protocol -query -queryblocksize
+ -querychannel -queryprogress -strict -timeout -type -validate
}
- set usage [join $options ", "]
+ set usage [join [lsort $options] ", "]
set options [string map {- ""} $options]
set pat ^-([join $options |])$
foreach {flag value} $args {
- if {[regexp $pat $flag]} {
+ if {[regexp -- $pat $flag]} {
# Validate numbers
- if {[info exists type($flag)] && \
- ![string is $type($flag) -strict $value]} {
+ if {[info exists type($flag)] &&
+ ![string is $type($flag) -strict $value]} {
unset $token
return -code error "Bad value for $flag ($value), must be $type($flag)"
}
@@ -338,7 +409,8 @@ proc http::geturl { url args } {
#
# From a validation perspective, we need to ensure that the parts of the
# URL that are going to the server are correctly encoded.
- # This is only done if $::http::strict is true (default 0 for compat).
+ # This is only done if $state(-strict) is true (inherited from
+ # $::http::strict).
set URLmatcher {(?x) # this is _expanded_ syntax
^
@@ -384,7 +456,7 @@ proc http::geturl { url args } {
(?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+
$
}
- if {$strict && ![regexp -- $validityRE $user]} {
+ if {$state(-strict) && ![regexp -- $validityRE $user]} {
unset $token
# Provide a better error message in this error case
if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} {
@@ -404,7 +476,7 @@ proc http::geturl { url args } {
(?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )?
$
}
- if {$strict && ![regexp -- $validityRE $srvurl]} {
+ if {$state(-strict) && ![regexp -- $validityRE $srvurl]} {
unset $token
# Provide a better error message in this error case
if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} {
@@ -416,7 +488,7 @@ proc http::geturl { url args } {
} else {
set srvurl /
}
- if {[string length $proto] == 0} {
+ if {$proto eq ""} {
set proto http
}
if {![info exists urlTypes($proto)]} {
@@ -426,7 +498,7 @@ proc http::geturl { url args } {
set defport [lindex $urlTypes($proto) 0]
set defcmd [lindex $urlTypes($proto) 1]
- if {[string length $port] == 0} {
+ if {$port eq ""} {
set port $defport
}
if {![catch {$http(-proxyfilter) $host} proxy]} {
@@ -451,39 +523,69 @@ proc http::geturl { url args } {
# If a timeout is specified we set up the after event and arrange for an
# asynchronous socket connection.
+ set sockopts [list]
if {$state(-timeout) > 0} {
set state(after) [after $state(-timeout) \
[list http::reset $token timeout]]
- set async -async
- } else {
- set async ""
+ lappend sockopts -async
}
# If we are using the proxy, we must pass in the full URL that includes
# the server name.
- if {[info exists phost] && [string length $phost]} {
+ if {[info exists phost] && ($phost ne "")} {
set srvurl $url
- set conStat [catch {eval $defcmd $async {$phost $pport}} s]
+ set targetAddr [list $phost $pport]
} else {
- set conStat [catch {eval $defcmd $async {$host $port}} s]
+ set targetAddr [list $host $port]
}
-
- if {$conStat} {
- # Something went wrong while trying to establish the connection. Clean
- # up after events and such, but DON'T call the command callback (if
- # available) because we're going to throw an exception from here
- # instead.
- Finish $token "" 1
- cleanup $token
- return -code error $s
+ # Proxy connections aren't shared among different hosts.
+ set state(socketinfo) $host:$port
+
+ # See if we are supposed to use a previously opened channel.
+ if {$state(-keepalive)} {
+ variable socketmap
+ if {[info exists socketmap($state(socketinfo))]} {
+ if {[catch {fconfigure $socketmap($state(socketinfo))}]} {
+ Log "WARNING: socket for $state(socketinfo) was closed"
+ unset socketmap($state(socketinfo))
+ } else {
+ set sock $socketmap($state(socketinfo))
+ Log "reusing socket $sock for $state(socketinfo)"
+ catch {fileevent $sock writable {}}
+ catch {fileevent $sock readable {}}
+ }
+ }
+ # don't automatically close this connection socket
+ set state(connection) {}
+ }
+ if {![info exists sock]} {
+ # Pass -myaddr directly to the socket command
+ if {[info exists state(-myaddr)]} {
+ lappend sockopts -myaddr $state(-myaddr)
+ }
+ if {[catch {eval $defcmd $sockopts $targetAddr} sock]} {
+ # something went wrong while trying to establish the
+ # connection. Clean up after events and such, but DON'T call the
+ # command callback (if available) because we're going to throw an
+ # exception from here instead.
+
+ Finish $token "" 1
+ cleanup $token
+ return -code error $sock
+ }
+ }
+ set state(sock) $sock
+ Log "Using $sock for $state(socketinfo)" \
+ [expr {$state(-keepalive)?"keepalive":""}]
+ if {$state(-keepalive)} {
+ set socketmap($state(socketinfo)) $sock
}
- set state(sock) $s
# Wait for the connection to complete.
if {$state(-timeout) > 0} {
- fileevent $s writable [list http::Connect $token]
+ fileevent $sock writable [list http::Connect $token]
http::wait $token
if {![info exists state]} {
@@ -508,12 +610,12 @@ proc http::geturl { url args } {
# Send data in cr-lf format, but accept any line terminators
- fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
+ fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize)
# The following is disallowed in safe interpreters, but the socket is
# already in non-blocking mode in that case.
- catch {fconfigure $s -blocking off}
+ catch {fconfigure $sock -blocking off}
set how GET
if {$isQuery} {
set state(querylength) [string length $state(-query)]
@@ -539,27 +641,52 @@ proc http::geturl { url args } {
}
if {[catch {
- puts $s "$how $srvurl HTTP/1.0"
- puts $s "Accept: $http(-accept)"
- if {$port == $defport} {
- # Don't add port in this case, to handle broken servers. [Bug
- # 504508]
- puts $s "Host: $host"
+ puts $sock "$how $srvurl HTTP/$state(-protocol)"
+ puts $sock "Accept: $http(-accept)"
+ array set hdrs $state(-headers)
+ if {[info exists hdrs(Host)]} {
+ # Allow Host spoofing [Bug 928154]
+ puts $sock "Host: $hdrs(Host)"
+ } elseif {$port == $defport} {
+ # Don't add port in this case, to handle broken servers.
+ # [Bug #504508]
+ puts $sock "Host: $host"
} else {
- puts $s "Host: $host:$port"
+ puts $sock "Host: $host:$port"
}
- puts $s "User-Agent: $http(-useragent)"
+ unset hdrs
+ puts $sock "User-Agent: $http(-useragent)"
+ if {$state(-protocol) == 1.0 && $state(-keepalive)} {
+ puts $sock "Connection: keep-alive"
+ }
+ if {$state(-protocol) > 1.0 && !$state(-keepalive)} {
+ puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1
+ }
+ if {[info exists phost] && ($phost ne "") && $state(-keepalive)} {
+ puts $sock "Proxy-Connection: Keep-Alive"
+ }
+ set accept_encoding_seen 0
foreach {key value} $state(-headers) {
+ if {[string equal -nocase $key "host"]} { continue }
+ if {[string equal -nocase $key "accept-encoding"]} {
+ set accept_encoding_seen 1
+ }
set value [string map [list \n "" \r ""] $value]
set key [string trim $key]
- if {$key eq "Content-Length"} {
+ if {[string equal -nocase $key "content-length"]} {
set contDone 1
set state(querylength) $value
}
if {[string length $key]} {
- puts $s "$key: $value"
+ puts $sock "$key: $value"
}
}
+ # Soft zlib dependency check - no package require
+ if {!$accept_encoding_seen && [llength [package provide zlib]]
+ && !([info exists state(-channel)] || [info exists state(-handler)])
+ } {
+ puts $sock "Accept-Encoding: gzip, identity, *;q=0.1"
+ }
if {$isQueryChannel && $state(querylength) == 0} {
# Try to determine size of data in channel. If we cannot seek, the
# surrounding catch will trap us
@@ -588,17 +715,17 @@ proc http::geturl { url args } {
# their POST data if they expect the client to read their response.
if {$isQuery || $isQueryChannel} {
- puts $s "Content-Type: $state(-type)"
+ puts $sock "Content-Type: $state(-type)"
if {!$contDone} {
- puts $s "Content-Length: $state(querylength)"
+ puts $sock "Content-Length: $state(querylength)"
}
- puts $s ""
- fconfigure $s -translation {auto binary}
- fileevent $s writable [list http::Write $token]
+ puts $sock ""
+ fconfigure $sock -translation {auto binary}
+ fileevent $sock writable [list http::Write $token]
} else {
- puts $s ""
- flush $s
- fileevent $s readable [list http::Event $token]
+ puts $sock ""
+ flush $sock
+ fileevent $sock readable [list http::Event $sock $token]
}
if {! [info exists state(-command)]} {
@@ -738,7 +865,7 @@ proc http::Connect {token} {
proc http::Write {token} {
variable $token
upvar 0 $token state
- set s $state(sock)
+ set sock $state(sock)
# Output a block. Tcl will buffer this if the socket blocks
set done 0
@@ -749,19 +876,20 @@ proc http::Write {token} {
# Chop up large query strings so queryprogress callback can give
# smooth feedback.
- puts -nonewline $s \
+ puts -nonewline $sock \
[string range $state(-query) $state(queryoffset) \
[expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
incr state(queryoffset) $state(-queryblocksize)
if {$state(queryoffset) >= $state(querylength)} {
set state(queryoffset) $state(querylength)
+ puts $sock ""
set done 1
}
} else {
# Copy blocks from the query channel
set outStr [read $state(-querychannel) $state(-queryblocksize)]
- puts -nonewline $s $outStr
+ puts -nonewline $sock $outStr
incr state(queryoffset) [string length $outStr]
if {[eof $state(-querychannel)]} {
set done 1
@@ -775,9 +903,9 @@ proc http::Write {token} {
set done 1
}
if {$done} {
- catch {flush $s}
- fileevent $s writable {}
- fileevent $s readable [list http::Event $token]
+ catch {flush $sock}
+ fileevent $sock writable {}
+ fileevent $sock readable [list http::Event $sock $token]
}
# Callback to the client after we've completely handled everything.
@@ -793,79 +921,164 @@ proc http::Write {token} {
# Handle input on the socket
#
# Arguments
+# sock The socket receiving input.
# token The token returned from http::geturl
#
# Side Effects
# Read the socket and handle callbacks.
-proc http::Event {token} {
+proc http::Event {sock token} {
variable $token
upvar 0 $token state
- set s $state(sock)
+ if {![info exists state]} {
+ Log "Event $sock with invalid token '$token' - remote close?"
+ if {! [eof $sock]} {
+ if {[string length [set d [read $sock]]] != 0} {
+ Log "WARNING: additional data left on closed socket"
+ }
+ }
+ CloseSocket $sock
+ return
+ }
if {$state(state) eq "header"} {
- if {[catch {gets $s line} n]} {
+ if {[catch {gets $sock line} n]} {
return [Finish $token $n]
} elseif {$n == 0} {
- variable encodings
+ # We have now read all headers
+ # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
+ if {$state(http) == "" || [lindex $state(http) 1] == 100} { return }
+
set state(state) body
- if {$state(-binary) || ![string match -nocase text* $state(type)]
- || [string match *gzip* $state(coding)]
- || [string match *compress* $state(coding)]} {
+
+ # If doing a HEAD, then we won't get any body
+ if {$state(-validate)} {
+ Eof $token
+ return
+ }
+
+ # For non-chunked transfer we may have no body -- in this case we
+ # may get no further file event if the connection doesn't close and
+ # no more data is sent. We can tell and must finish up now - not
+ # later.
+ if {!(([info exists state(connection)]
+ && ($state(connection) eq "close"))
+ || [info exists state(transfer)])
+ && $state(totalsize) == 0
+ } then {
+ Log "body size is 0 and no events likely - complete."
+ Eof $token
+ return
+ }
+
+ # We have to use binary translation to count bytes properly.
+ fconfigure $sock -translation binary
+
+ if {$state(-binary) || ![string match -nocase text* $state(type)]} {
# Turn off conversions for non-text data
- fconfigure $s -translation binary
+ set state(binary) 1
+ }
+ if {$state(binary) || [string match *gzip* $state(coding)]
+ || [string match *compress* $state(coding)]} {
if {[info exists state(-channel)]} {
fconfigure $state(-channel) -translation binary
}
- } else {
- # If we are getting text, set the incoming channel's encoding
- # correctly. iso8859-1 is the RFC default, but this could be
- # any IANA charset. However, we only know how to convert what
- # we have encodings for.
- set idx [lsearch -exact $encodings \
- [string tolower $state(charset)]]
- if {$idx >= 0} {
- fconfigure $s -encoding [lindex $encodings $idx]
- }
}
- if {[info exists state(-channel)] && \
- ![info exists state(-handler)]} {
+ if {[info exists state(-channel)] &&
+ ![info exists state(-handler)]} {
# Initiate a sequence of background fcopies
- fileevent $s readable {}
- CopyStart $s $token
+ fileevent $sock readable {}
+ CopyStart $sock $token
return
}
} elseif {$n > 0} {
- if {[regexp -nocase {^content-type:(.+)$} $line x type]} {
- set state(type) [string trim $type]
- # grab the optional charset information
- regexp -nocase {charset\s*=\s*(\S+)} $type x state(charset)
- }
- if {[regexp -nocase {^content-length:(.+)$} $line x length]} {
- set state(totalsize) [string trim $length]
- }
- if {[regexp -nocase {^content-encoding:(.+)$} $line x coding]} {
- set state(coding) [string trim $coding]
- }
+ # Process header lines
if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
+ switch -- [string tolower $key] {
+ content-type {
+ set state(type) [string trim [string tolower $value]]
+ # grab the optional charset information
+ regexp -nocase {charset\s*=\s*(\S+?);?} \
+ $state(type) -> state(charset)
+ }
+ content-length {
+ set state(totalsize) [string trim $value]
+ }
+ content-encoding {
+ set state(coding) [string trim $value]
+ }
+ transfer-encoding {
+ set state(transfer) \
+ [string trim [string tolower $value]]
+ }
+ proxy-connection -
+ connection {
+ set state(connection) \
+ [string trim [string tolower $value]]
+ }
+ }
lappend state(meta) $key [string trim $value]
} elseif {[string match HTTP* $line]} {
set state(http) $line
}
}
} else {
+ # Now reading body
if {[catch {
if {[info exists state(-handler)]} {
- set n [eval $state(-handler) {$s $token}]
+ set n [eval $state(-handler) [list $sock $token]]
+ } elseif {[info exists state(transfer_final)]} {
+ set line [getTextLine $sock]
+ set n [string length $line]
+ if {$n > 0} {
+ Log "found $n bytes following final chunk"
+ append state(transfer_final) $line
+ } else {
+ Log "final chunk part"
+ Eof $token
+ }
+ } elseif {[info exists state(transfer)]
+ && $state(transfer) eq "chunked"} {
+ set size 0
+ set chunk [getTextLine $sock]
+ set n [string length $chunk]
+ if {[string trim $chunk] ne ""} {
+ scan $chunk %x size
+ if {$size != 0} {
+ set bl [fconfigure $sock -blocking]
+ fconfigure $sock -blocking 1
+ set chunk [read $sock $size]
+ fconfigure $sock -blocking $bl
+ set n [string length $chunk]
+ if {$n >= 0} {
+ append state(body) $chunk
+ }
+ if {$size != [string length $chunk]} {
+ Log "WARNING: mis-sized chunk:\
+ was [string length $chunk], should be $size"
+ }
+ getTextLine $sock
+ } else {
+ set state(transfer_final) {}
+ }
+ }
} else {
- set block [read $s $state(-blocksize)]
+ #Log "read non-chunk $state(currentsize) of $state(totalsize)"
+ set block [read $sock $state(-blocksize)]
set n [string length $block]
if {$n >= 0} {
append state(body) $block
}
}
- if {$n >= 0} {
- incr state(currentsize) $n
+ if {[info exists state]} {
+ if {$n >= 0} {
+ incr state(currentsize) $n
+ }
+ # If Content-Length - check for end of data.
+ if {($state(totalsize) > 0)
+ && ($state(currentsize) >= $state(totalsize))} {
+ Eof $token
+ }
}
} err]} {
return [Finish $token $err]
@@ -877,28 +1090,54 @@ proc http::Event {token} {
}
}
- if {[eof $s]} {
- Eof $token
+ # catch as an Eof above may have closed the socket already
+ if {![catch {eof $sock} eof] && $eof} {
+ if {[info exists $token]} {
+ set state(connection) close
+ Eof $token
+ } else {
+ # open connection closed on a token that has been cleaned up.
+ CloseSocket $sock
+ }
return
}
}
+# http::getTextLine --
+#
+# Get one line with the stream in blocking crlf mode
+#
+# Arguments
+# sock The socket receiving input.
+#
+# Results:
+# The line of text, without trailing newline
+
+proc http::getTextLine {sock} {
+ set tr [fconfigure $sock -translation]
+ set bl [fconfigure $sock -blocking]
+ fconfigure $sock -translation crlf -blocking 1
+ set r [gets $sock]
+ fconfigure $sock -translation $tr -blocking $bl
+ return $r
+}
+
# http::CopyStart
#
# Error handling wrapper around fcopy
#
# Arguments
-# s The socket to copy from
+# sock 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} {
+proc http::CopyStart {sock token} {
variable $token
upvar 0 $token state
if {[catch {
- fcopy $s $state(-channel) -size $state(-blocksize) -command \
+ fcopy $sock $state(-channel) -size $state(-blocksize) -command \
[list http::CopyDone $token]
} err]} {
Finish $token $err
@@ -919,7 +1158,7 @@ proc http::CopyStart {s token} {
proc http::CopyDone {token count {error {}}} {
variable $token
upvar 0 $token state
- set s $state(sock)
+ set sock $state(sock)
incr state(currentsize) $count
if {[info exists state(-progress)]} {
eval $state(-progress) \
@@ -928,10 +1167,10 @@ proc http::CopyDone {token count {error {}}} {
# At this point the token may have been reset
if {[string length $error]} {
Finish $token $error
- } elseif {[catch {eof $s} iseof] || $iseof} {
+ } elseif {[catch {eof $sock} iseof] || $iseof} {
Eof $token
} else {
- CopyStart $s $token
+ CopyStart $sock $token
}
}
@@ -945,7 +1184,7 @@ proc http::CopyDone {token count {error {}}} {
# Side Effects
# Clean up the socket
-proc http::Eof {token} {
+proc http::Eof {token {force 0}} {
variable $token
upvar 0 $token state
if {$state(state) eq "header"} {
@@ -954,7 +1193,31 @@ proc http::Eof {token} {
} else {
set state(status) ok
}
- set state(state) eof
+
+ if {($state(coding) eq "gzip") && [string length $state(body)] > 0} {
+ if {[catch {
+ set state(body) [Gunzip $state(body)]
+ } err]} {
+ return [Finish $token $err]
+ }
+ }
+
+ if {!$state(binary)} {
+
+ # If we are getting text, set the incoming channel's
+ # encoding correctly. iso8859-1 is the RFC default, but
+ # this could be any IANA charset. However, we only know
+ # how to convert what we have encodings for.
+
+ set enc [CharsetToEncoding $state(charset)]
+ if {$enc ne "binary"} {
+ set state(body) [encoding convertfrom $enc $state(body)]
+ }
+
+ # Translate text line endings.
+ set state(body) [string map {\r\n \n \r \n} $state(body)]
+ }
+
Finish $token
}
@@ -972,7 +1235,7 @@ proc http::wait {token} {
variable $token
upvar 0 $token state
- if {![info exists state(status)] || [string length $state(status)] == 0} {
+ if {![info exists state(status)] || $state(status) eq ""} {
# We must wait on the original variable name, not the upvar alias
vwait ${token}(status)
}
@@ -982,7 +1245,7 @@ proc http::wait {token} {
# http::formatQuery --
#
-# See documentation for details. Call http::formatQuery with an even
+# See documentation for details. Call http::formatQuery with an even
# number of arguments, where the first is a name, the second is a value,
# the third is another name, and so on.
#
@@ -1058,6 +1321,99 @@ proc http::ProxyRequired {host} {
}
}
+# http::CharsetToEncoding --
+#
+# Tries to map a given IANA charset to a tcl encoding.
+# If no encoding can be found, returns binary.
+#
+
+proc http::CharsetToEncoding {charset} {
+ variable encodings
+
+ set charset [string tolower $charset]
+ if {[regexp {iso-?8859-([0-9]+)} $charset - num]} {
+ set encoding "iso8859-$num"
+ } elseif {[regexp {iso-?2022-(jp|kr)} $charset - ext]} {
+ set encoding "iso2022-$ext"
+ } elseif {[regexp {shift[-_]?js} $charset -]} {
+ set encoding "shiftjis"
+ } elseif {[regexp {(windows|cp)-?([0-9]+)} $charset - - num]} {
+ set encoding "cp$num"
+ } elseif {$charset eq "us-ascii"} {
+ set encoding "ascii"
+ } elseif {[regexp {(iso-?)?lat(in)?-?([0-9]+)} $charset - - - num]} {
+ switch -- $num {
+ 5 {set encoding "iso8859-9"}
+ 1 -
+ 2 -
+ 3 {set encoding "iso8859-$num"}
+ }
+ } else {
+ # other charset, like euc-xx, utf-8,... may directly maps to encoding
+ set encoding $charset
+ }
+ set idx [lsearch -exact $encodings $encoding]
+ if {$idx >= 0} {
+ return $encoding
+ } else {
+ return "binary"
+ }
+}
+
+# http::Gunzip --
+#
+# Decompress data transmitted using the gzip transfer coding.
+#
+
+# FIX ME: redo using zlib sinflate
+proc http::Gunzip {data} {
+ binary scan $data Scb5icc magic method flags time xfl os
+ set pos 10
+ if {$magic != 0x1f8b} {
+ return -code error "invalid data: supplied data is not in gzip format"
+ }
+ if {$method != 8} {
+ return -code error "invalid compression method"
+ }
+
+ foreach {f_text f_crc f_extra f_name f_comment} [split $flags ""] break
+ set extra ""
+ if { $f_extra } {
+ binary scan $data @${pos}S xlen
+ incr pos 2
+ set extra [string range $data $pos $xlen]
+ set pos [incr xlen]
+ }
+
+ set name ""
+ if { $f_name } {
+ set ndx [string first \0 $data $pos]
+ set name [string range $data $pos $ndx]
+ set pos [incr ndx]
+ }
+
+ set comment ""
+ if { $f_comment } {
+ set ndx [string first \0 $data $pos]
+ set comment [string range $data $pos $ndx]
+ set pos [incr ndx]
+ }
+
+ set fcrc ""
+ if { $f_crc } {
+ set fcrc [string range $data $pos [incr pos]]
+ incr pos
+ }
+
+ binary scan [string range $data end-7 end] ii crc size
+ set inflated [zlib inflate [string range $data $pos end-8]]
+
+ if { $crc != [set chk [zlib crc32 $inflated]] } {
+ return -code error "invalid data: checksum mismatch $crc != $chk"
+ }
+ return $inflated
+}
+
# Local variables:
# indent-tabs-mode: t
# End: