# Client-side HTTP for GET, POST, and HEAD commands.
# These routines can be used in untrusted code that uses the Safesock
# These procedures use a callback interface to avoid using vwait,
# which is not defined in the safe base.
# RCS: @(#) $Id: http.tcl,v 1.4 2000/02/01 11:48:30 hobbs Exp $
# See the http.n man page for documentation
-useragent {Tcl http client
package 1.0}
-proxyfilter httpProxyRequired
proc http_config
{args
} {
set options [lsort [array names
http -*]]
set usage
[join $options ", "]
if {[llength $args] == 0} {
lappend result
$name $http($name)
regsub -all -- - $options {} options
set pat ^
-([join $options |
])$
if {[llength $args] == 1} {
set flag
[lindex $args 0]
if {[regexp -- $pat $flag]} {
return -code error "Unknown option $flag, must be: $usage"
foreach {flag value
} $args {
if {[regexp -- $pat $flag]} {
return -code error "Unknown option $flag, must be: $usage"
proc httpFinish
{ token
{errormsg
""} } {
global errorInfo errorCode
if {[string length
$errormsg] != 0} {
set state
(error) [list $errormsg $errorInfo $errorCode]
catch {close $state(sock
)}
catch {after cancel
$state(after)}
if {[info exists state
(-command)]} {
if {[catch {eval $state(-command) {$token}} err
]} {
if {[string length
$errormsg] == 0} {
set state
(error) [list $err $errorInfo $errorCode]
proc http_reset
{ token
{why reset
} } {
catch {fileevent $state(sock
) readable
{}}
if {[info exists state
(error)]} {
set errorlist
$state(error)
proc http_get
{ url args
} {
if {![info exists
http(uid
)]} {
set token
http#[incr http(uid)]
set options {-blocksize -channel -command -handler -headers \
-progress -query -validate -timeout}
set usage
[join $options ", "]
regsub -all -- - $options {} options
set pat ^
-([join $options |
])$
foreach {flag value
} $args {
if {[regexp $pat $flag]} {
if {[info exists state
($flag)] && \
[regexp {^
[0-9]+$} $state($flag)] && \
![regexp {^
[0-9]+$} $value]} {
return -code error "Bad value for $flag ($value), must be integer"
return -code error "Unknown option $flag, can be: $usage"
if {! [regexp -nocase {^
(http://)?
([^
/:]+)(:([0-9]+))?
(/.
*)?
$} $url \
x proto host y port srvurl
]} {
error "Unsupported URL: $url"
if {[string length
$port] == 0} {
if {[string length
$srvurl] == 0} {
if {[string length
$proto] == 0} {
if {![catch {$http(-proxyfilter) $host} proxy
]} {
set phost
[lindex $proxy 0]
set pport
[lindex $proxy 1]
if {$state(-timeout) > 0} {
set state
(after) [after $state(-timeout) [list http_reset
$token timeout
]]
if {[info exists phost
] && [string length
$phost]} {
set s
[socket $phost $pport]
set s
[socket $host $port]
# Send data in cr-lf format, but accept any line terminators
fconfigure $s -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
}
if {[info exists state
(-query)]} {
set len
[string length
$state(-query)]
} elseif
{$state(-validate)} {
puts $s "$how $srvurl HTTP/1.0"
puts $s "Accept: $http(-accept)"
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 "Content-Length: $len"
puts $s "Content-Type: application/x-www-form-urlencoded"
fconfigure $s -translation {auto
binary}
puts -nonewline $s $state(-query)
fileevent $s readable
[list httpEvent
$token]
if {! [info exists state
(-command)]} {
proc http_status
{token
} {
return $state(currentsize
)
if {$state(state
) == "header"} {
if {![regexp -nocase ^
text $state(type
)]} {
# Turn off conversions for non-text data
fconfigure $s -translation binary
if {[info exists state
(-channel)]} {
fconfigure $state(-channel) -translation binary
if {[info exists state
(-channel)] &&
![info exists state
(-handler)]} {
# Initiate a sequence of background fcopies
if {[regexp -nocase {^content-type
:(.
+)$} $line x type
]} {
set state
(type
) [string trim
$type]
if {[regexp -nocase {^content-length
:(.
+)$} $line x length
]} {
set state
(totalsize
) [string trim
$length]
if {[regexp -nocase {^
([^
:]+):(.
+)$} $line x key value
]} {
lappend state
(meta
) $key $value
} elseif
{[regexp ^HTTP
$line]} {
if {[info exists state
(-handler)]} {
set n
[eval $state(-handler) {$s $token}]
set block
[read $s $state(-blocksize)]
set n
[string length
$block]
append state
(body
) $block
incr state
(currentsize
) $n
if {[info exists state
(-progress)]} {
eval $state(-progress) {$token $state(totalsize
) $state(currentsize
)}
proc httpCopyStart
{s token
} {
fcopy $s $state(-channel) -size $state(-blocksize) -command \
[list httpCopyDone
$token]
proc httpCopyDone
{token count
{error {}}} {
incr state
(currentsize
) $count
if {[info exists state
(-progress)]} {
eval $state(-progress) {$token $state(totalsize
) $state(currentsize
)}
if {([string length
$error] != 0)} {
if {$state(state
) == "header"} {
if {![info exists state
(status
)] ||
[string length
$state(status
)] == 0} {
if {[info exists state
(error)]} {
set errorlist
$state(error)
# 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.
proc http_formatQuery
{args
} {
append result
$sep [httpMapReply
$i]
# 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
proc httpMapReply
{string} {
set alphanumeric a-zA-Z0-9
if {![info exists httpFormMap
]} {
for {set i
1} {$i <= 256} {incr i
} {
if {![string match
\[$alphanumeric\] $c]} {
set httpFormMap
($c) %[format %.2x
$i]
# These are handled specially
regsub -all \[^
$alphanumeric\] $string {$httpFormMap(&)} string
regsub -all \n $string {\\n
} string
regsub -all \t $string {\\t
} string
regsub -all {[][{})\\]\)} $string {\\&} string
proc httpProxyRequired
{host
} {
if {[info exists
http(-proxyhost)] && [string length
$http(-proxyhost)]} {
if {![info exists
http(-proxyport)] ||
![string length
$http(-proxyport)]} {
set http(-proxyport) 8080
return [list $http(-proxyhost) $http(-proxyport)]