Attachment "diff.dat" to
ticket [1063703fff]
added by
hobbs
2004-11-12 04:00:34.
--- ./http.tcl.disabled 2004-10-02 02:57:49.000000000 +0200
+++ ./http.tcl.new 2004-11-11 09:51:54.017173956 +0100
@@ -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.43.2.4 2004/05/25 22:50:47 hobbs Exp $
+# RCS: @(#) $Id: http.tcl,v 1.43 2002/10/03 13:34:32 dkf Exp $
# Rough version history:
# 1.0 Old http_get interface
@@ -19,13 +19,14 @@
# 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.
+# 3.0 Added HTTP/1.1 extensions: HTTP 100 (continue) and Chunked Transfer-Encoding
+# 3.1 Added -binary option to http::geturl and charset element
+# to the state array.
package require Tcl 8.2
# keep this in sync with pkgIndex.tcl
# and with the install directories in Makefiles
-package provide http 2.5.0
+package provide http 3.1
namespace eval http {
variable http
@@ -56,11 +57,11 @@
array set urlTypes {
http {80 ::socket}
}
-
+
variable encodings [string tolower [encoding names]]
# This can be changed, but iso8859-1 is the RFC standard.
variable defaultCharset "iso8859-1"
-
+
namespace export geturl config reset wait formatQuery register unregister
# Useful, but not exported: data size status code
}
@@ -120,7 +121,7 @@
}
return $result
}
- set options [string map {- ""} $options]
+ regsub -all -- - $options {} options
set pat ^-([join $options |])$
if {[llength $args] == 1} {
set flag [lindex $args 0]
@@ -165,6 +166,7 @@
}
catch {close $state(sock)}
catch {after cancel $state(after)}
+
if {[info exists state(-command)] && !$skipCB} {
if {[catch {eval $state(-command) {$token}} err]} {
if {[string length $errormsg] == 0} {
@@ -246,9 +248,9 @@
-queryprogress {}
state header
meta {}
- coding {}
currentsize 0
totalsize 0
+ coding {}
querylength 0
queryoffset 0
type text/html
@@ -256,28 +258,21 @@
status ""
http ""
}
- # These flags have their types verified [Bug 811170]
- array set type {
- -binary boolean
- -blocksize integer
- -queryblocksize integer
- -validate boolean
- -timeout integer
- }
set state(charset) $defaultCharset
set options {-binary -blocksize -channel -command -handler -headers \
-progress -query -queryblocksize -querychannel -queryprogress\
-validate -timeout -type}
set usage [join $options ", "]
- set options [string map {- ""} $options]
+ regsub -all -- - $options {} options
set pat ^-([join $options |])$
foreach {flag value} $args {
if {[regexp $pat $flag]} {
# Validate numbers
- if {[info exists type($flag)] && \
- ![string is $type($flag) -strict $value]} {
+ if {[info exists state($flag)] && \
+ [string is integer -strict $state($flag)] && \
+ ![string is integer -strict $value]} {
unset $token
- return -code error "Bad value for $flag ($value), must be $type($flag)"
+ return -code error "Bad value for $flag ($value), must be integer"
}
set state($flag) $value
} else {
@@ -296,11 +291,9 @@
}
# Validate URL, determine the server host and port, and check proxy case
- # Recognize user:pass@host URLs also, although we do not do anything
- # with that info yet.
- set exp {^(([^:]*)://)?([^@]+@)?([^/:]+)(:([0-9]+))?(/.*)?$}
- if {![regexp -nocase $exp $url x prefix proto user host y port srvurl]} {
+ if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
+ x prefix proto host y port srvurl]} {
unset $token
return -code error "Unsupported URL: $url"
}
@@ -413,7 +406,7 @@
}
if {[catch {
- puts $s "$how $srvurl HTTP/1.0"
+ puts $s "$how $srvurl HTTP/1.1"
puts $s "Accept: $http(-accept)"
if {$port == $defport} {
# Don't add port in this case, to handle broken servers.
@@ -423,15 +416,16 @@
puts $s "Host: $host:$port"
}
puts $s "User-Agent: $http(-useragent)"
+ puts $s "Connection: close"
foreach {key value} $state(-headers) {
- set value [string map [list \n "" \r ""] $value]
+ regsub -all \[\n\r\] $value {} value
set key [string trim $key]
if {[string equal $key "Content-Length"]} {
- set contDone 1
- set state(querylength) $value
+ set contDone 1
+ set state(querylength) $value
}
if {[string length $key]} {
- puts $s "$key: $value"
+ puts $s "$key: $value"
}
}
if {$isQueryChannel && $state(querylength) == 0} {
@@ -461,7 +455,7 @@
# (among Solaris, Linux, and NT) behave the same, and none
# behave all that well in any case. Servers should always read thier
# POST data if they expect the client to read their response.
-
+
if {$isQuery || $isQueryChannel} {
puts $s "Content-Type: $state(-type)"
if {!$contDone} {
@@ -486,8 +480,9 @@
# Something went wrong, so throw the exception, and the
# enclosing catch will do cleanup.
return -code error [lindex $state(error) 0]
- }
+ }
}
+
} err]} {
# The socket probably was never connected,
# or the connection dropped later.
@@ -543,6 +538,26 @@
upvar 0 $token state
return $state(currentsize)
}
+proc http::charset {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(charset)
+}
+
+proc http::meta {token} {
+ variable $token
+ upvar #0 $token state
+ set max 0
+ foreach {name value} $state(meta) {
+ if {[string length $name] > $max} {
+ set max [string length $name]
+ }
+ }
+ incr max
+ foreach {name value} $state(meta) {
+ puts [format "%-*s %s" $max $name: $value]
+ }
+}
proc http::error {token} {
variable $token
@@ -595,7 +610,6 @@
}
return
}
-
# http::Write
#
# Write POST query data to the socket
@@ -610,13 +624,16 @@
variable $token
upvar 0 $token state
set s $state(sock)
-
+
# Output a block. Tcl will buffer this if the socket blocks
+
set done 0
if {[catch {
+
# Catch I/O errors on dead sockets
if {[info exists state(-query)]} {
+
# Chop up large query strings so queryprogress callback
# can give smooth feedback
@@ -629,6 +646,7 @@
set done 1
}
} else {
+
# Copy blocks from the query channel
set outStr [read $state(-querychannel) $state(-queryblocksize)]
@@ -674,7 +692,7 @@
upvar 0 $token state
set s $state(sock)
- if {[eof $s]} {
+ if {[eof $s]} {
Eof $token
return
}
@@ -682,33 +700,33 @@
if {[catch {gets $s line} n]} {
Finish $token $n
} elseif {$n == 0} {
- variable encodings
- set state(state) body
- if {$state(-binary) || ![string match -nocase text* $state(type)]
- || [string match *gzip* $state(coding)]
- || [string match *compress* $state(coding)]} {
- # Turn off conversions for non-text data
- fconfigure $s -translation binary
- if {[info exists state(-channel)]} {
- fconfigure $state(-channel) -translation binary
+ # empty line marks end of response headers
+ # http 1.1 allows status 100 (continue)
+ if {[ncode $token] != "100"} {
+ variable encodings
+ set state(state) body
+ if {$state(-binary) || ![regexp -nocase ^text $state(type)] || [regexp chunked|gzip|compress $state(coding)]} {
+ # Turn off conversions for non-text data or chunked transfers
+ fconfigure $s -translation binary
+ 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]
+ }
}
- } 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)]} {
+ # Initiate a sequence of background fcopies
+ fileevent $s readable {}
+ CopyStart $s $token
}
- }
- if {[info exists state(-channel)] && \
- ![info exists state(-handler)]} {
- # Initiate a sequence of background fcopies
- fileevent $s readable {}
- CopyStart $s $token
- }
+ }
} elseif {$n > 0} {
if {[regexp -nocase {^content-type:(.+)$} $line x type]} {
set state(type) [string trim $type]
@@ -718,37 +736,78 @@
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]
+ if {[regexp -nocase {^transfer-encoding:(.+)$} $line x coding]} {
+ set state(coding) [string trim [string tolower $coding]]
+ set state(-chunksize) 0
}
if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
lappend state(meta) $key [string trim $value]
- } elseif {[string match HTTP* $line]} {
+ } elseif {[regexp ^HTTP $line]} {
set state(http) $line
}
}
} else {
- if {[catch {
- if {[info exists state(-handler)]} {
- set n [eval $state(-handler) {$s $token}]
- } else {
- set block [read $s $state(-blocksize)]
- set n [string length $block]
- if {$n >= 0} {
- append state(body) $block
- }
- }
- if {$n >= 0} {
- incr state(currentsize) $n
- }
- } err]} {
- Finish $token $err
- } else {
- if {[info exists state(-progress)]} {
- eval $state(-progress) \
- {$token $state(totalsize) $state(currentsize)}
- }
- }
+ if {[catch {
+ if {[info exists state(-handler)]} {
+ set n [eval $state(-handler) {$s $token}]
+ } else {
+
+ # Sonderbehandlung von chunked Transfer-Encoding -> chunk data einlesen
+ if {($state(coding) == "chunked") && ($state(-chunksize) > 0)} {
+ set block [read $s $state(-chunksize)]
+ set n [string length $block]
+ if {$n >= 0} {
+ append state(body) $block
+ set state(-chunksize) [expr $state(-chunksize) - $n]
+ }
+ # Chunk-Ende? -> dann \r\n entfernen
+ if {$state(-chunksize) == 0} {
+ gets $s
+ }
+ # -> chunk size einlesen
+ } elseif {($state(coding) == "chunked") && ($state(-chunksize) == 0)} {
+ set state(-chunksize) [gets $s]
+ # keine Ahnung warum sich das einmal nicht ausgegangen ist, wurde um ein zeichnen zu wenig eingelesen...
+ if {($state(-chunksize) != "") && ([string trim $state(-chunksize)] == "")} {
+ set state(-chunksize) [gets $s]
+ }
+ if {($state(-chunksize) != "") && ($state(-chunksize) != 0)} {
+ set state(-chunksize) [expr "0x$state(-chunksize)"]
+ # Rest des Blocks einlesen
+ set block [read $s $state(-chunksize)]
+ set n [string length $block]
+ if {$n >= 0} {
+ append state(body) $block
+ set state(-chunksize) [expr $state(-chunksize) - $n]
+ }
+ # Chunk-Ende? -> dann \r\n entfernen
+ if {$state(-chunksize) == 0} {
+ gets $s
+ }
+ # letzter Transfer
+ } else {
+ gets $s
+ set n 0
+ }
+ # kein chunk
+ } else {
+ set block [read $s $state(-blocksize)]
+ set n [string length $block]
+ if {$n >= 0} {
+ append state(body) $block
+ }
+ }
+ }
+ if {$n >= 0} {
+ incr state(currentsize) $n
+ }
+ } err]} {
+ Finish $token $err
+ } else {
+ if {[info exists state(-progress)]} {
+ eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
+ }
+ }
}
}
@@ -767,10 +826,27 @@
variable $token
upvar 0 $token state
if {[catch {
- fcopy $s $state(-channel) -size $state(-blocksize) -command \
- [list http::CopyDone $token]
+ # Sonderbehandlung von chunked Transfer-Encoding -> chunk data einlesen
+ if {($state(coding) == "chunked") && ($state(-chunksize) > 0)} {
+ fcopy $s $state(-channel) -size $state(-chunksize) -command [list http::CopyDone $token]
+ # -> chunk size einlesen
+ } elseif {($state(coding) == "chunked") && ($state(-chunksize) == 0)} {
+ set state(-chunksize) [gets $s]
+ if {($state(-chunksize) != "") && ($state(-chunksize) != 0)} {
+ set state(-chunksize) [expr "0x$state(-chunksize)"]
+ # Rest des Blocks einlesen
+ fcopy $s $state(-channel) -size $state(-chunksize) -command [list http::CopyDone $token]
+ # letzter Transfer
+ } else {
+ gets $s
+ CopyDone $token 0
+ }
+ # kein chunk
+ } else {
+ fcopy $s $state(-channel) -size $state(-blocksize) -command [list http::CopyDone $token]
+ }
} err]} {
- Finish $token $err
+ Finish $token $err
}
}
@@ -790,16 +866,26 @@
upvar 0 $token state
set s $state(sock)
incr state(currentsize) $count
+ if {$state(coding) == "chunked"} {
+ if {$count >= 0} {
+ set state(-chunksize) [expr $state(-chunksize) - $count]
+ }
+ # Chunk-Ende? -> dann \r\n entfernen
+ if {$state(-chunksize) == 0} {
+ gets $s
+ }
+ }
+
if {[info exists state(-progress)]} {
- eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
+ eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
}
# At this point the token may have been reset
if {[string length $error]} {
- Finish $token $error
+ Finish $token $error
} elseif {[catch {eof $s} iseof] || $iseof} {
- Eof $token
+ Eof $token
} else {
- CopyStart $s $token
+ CopyStart $s $token
}
}
@@ -866,10 +952,10 @@
set sep ""
foreach i $args {
append result $sep [mapReply $i]
- if {[string equal $sep "="]} {
- set sep &
- } else {
+ if {[string compare $sep "="]} {
set sep =
+ } else {
+ set sep &
}
}
return $result
@@ -886,19 +972,15 @@
# The encoded string
proc http::mapReply {string} {
- variable http
variable formMap
variable alphanumeric
-
+
# 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
- if {$http(-urlencoding) ne ""} {
- set string [encoding convertto $http(-urlencoding) $string]
- }
regsub -all \[^$alphanumeric\] $string {$formMap(&)} string
regsub -all {[][{})\\]\)} $string {\\&} string
return [subst -nocommand $string]
@@ -916,10 +998,11 @@
proc http::ProxyRequired {host} {
variable http
if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
- if {![info exists http(-proxyport)] || \
- ![string length $http(-proxyport)]} {
+ if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} {
set http(-proxyport) 8080
}
return [list $http(-proxyhost) $http(-proxyport)]
+ } else {
+ return {}
}
}
