2 # Client-side HTTP for GET, POST, and HEAD commands.
3 # These routines can be used in untrusted code that uses the Safesock
5 # These procedures use a callback interface to avoid using vwait,
6 # which is not defined in the safe base.
8 # RCS: @(#) $Id: http.tcl,v 1.4 2000/02/01 11:48:30 hobbs Exp $
10 # See the http.n man page for documentation
12 package provide http 1.0
18 -useragent {Tcl http client package 1.0}
19 -proxyfilter httpProxyRequired
21 proc http_config {args} {
23 set options [lsort [array names http -*]]
24 set usage [join $options ", "]
25 if {[llength $args] == 0} {
27 foreach name $options {
28 lappend result $name $http($name)
32 regsub -all -- - $options {} options
33 set pat ^-([join $options |])$
34 if {[llength $args] == 1} {
35 set flag [lindex $args 0]
36 if {[regexp -- $pat $flag]} {
39 return -code error "Unknown option $flag, must be: $usage"
42 foreach {flag value} $args {
43 if {[regexp -- $pat $flag]} {
44 set http($flag) $value
46 return -code error "Unknown option $flag, must be: $usage"
52 proc httpFinish { token {errormsg ""} } {
54 global errorInfo errorCode
55 if {[string length $errormsg] != 0} {
56 set state(error) [list $errormsg $errorInfo $errorCode]
57 set state(status) error
59 catch {close $state(sock)}
60 catch {after cancel $state(after)}
61 if {[info exists state(-command)]} {
62 if {[catch {eval $state(-command) {$token}} err]} {
63 if {[string length $errormsg] == 0} {
64 set state(error) [list $err $errorInfo $errorCode]
65 set state(status) error
71 proc http_reset { token {why reset} } {
73 set state(status) $why
74 catch {fileevent $state(sock) readable {}}
76 if {[info exists state(error)]} {
77 set errorlist $state(error)
82 proc http_get { url args } {
84 if {![info exists http(uid)]} {
87 set token http#[incr http(uid)]
103 set options {-blocksize -channel -command -handler -headers \
104 -progress -query -validate -timeout}
105 set usage [join $options ", "]
106 regsub -all -- - $options {} options
107 set pat ^-([join $options |])$
108 foreach {flag value} $args {
109 if {[regexp $pat $flag]} {
111 if {[info exists state($flag)] && \
112 [regexp {^[0-9]+$} $state($flag)] && \
113 ![regexp {^[0-9]+$} $value]} {
114 return -code error "Bad value for $flag ($value), must be integer"
116 set state($flag) $value
118 return -code error "Unknown option $flag, can be: $usage"
121 if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
122 x proto host y port srvurl]} {
123 error "Unsupported URL: $url"
125 if {[string length $port] == 0} {
128 if {[string length $srvurl] == 0} {
131 if {[string length $proto] == 0} {
135 if {![catch {$http(-proxyfilter) $host} proxy]} {
136 set phost [lindex $proxy 0]
137 set pport [lindex $proxy 1]
139 if {$state(-timeout) > 0} {
140 set state(after) [after $state(-timeout) [list http_reset $token timeout]]
142 if {[info exists phost] && [string length $phost]} {
144 set s [socket $phost $pport]
146 set s [socket $host $port]
150 # Send data in cr-lf format, but accept any line terminators
152 fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
154 # The following is disallowed in safe interpreters, but the socket
155 # is already in non-blocking mode in that case.
157 catch {fconfigure $s -blocking off}
160 if {[info exists state(-query)]} {
161 set len [string length $state(-query)]
165 } elseif {$state(-validate)} {
168 puts $s "$how $srvurl HTTP/1.0"
169 puts $s "Accept: $http(-accept)"
170 puts $s "Host: $host"
171 puts $s "User-Agent: $http(-useragent)"
172 foreach {key value} $state(-headers) {
173 regsub -all \[\n\r\] $value {} value
174 set key [string trim $key]
175 if {[string length $key]} {
176 puts $s "$key: $value"
180 puts $s "Content-Length: $len"
181 puts $s "Content-Type: application/x-www-form-urlencoded"
183 fconfigure $s -translation {auto binary}
184 puts -nonewline $s $state(-query)
189 fileevent $s readable [list httpEvent $token]
190 if {! [info exists state(-command)]} {
195 proc http_data {token} {
196 upvar #0 $token state
199 proc http_status {token} {
200 upvar #0 $token state
201 return $state(status)
203 proc http_code {token} {
204 upvar #0 $token state
207 proc http_size {token} {
208 upvar #0 $token state
209 return $state(currentsize)
212 proc httpEvent {token} {
213 upvar #0 $token state
220 if {$state(state) == "header"} {
223 set state(state) body
224 if {![regexp -nocase ^text $state(type)]} {
225 # Turn off conversions for non-text data
226 fconfigure $s -translation binary
227 if {[info exists state(-channel)]} {
228 fconfigure $state(-channel) -translation binary
231 if {[info exists state(-channel)] &&
232 ![info exists state(-handler)]} {
233 # Initiate a sequence of background fcopies
234 fileevent $s readable {}
235 httpCopyStart $s $token
238 if {[regexp -nocase {^content-type:(.+)$} $line x type]} {
239 set state(type) [string trim $type]
241 if {[regexp -nocase {^content-length:(.+)$} $line x length]} {
242 set state(totalsize) [string trim $length]
244 if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
245 lappend state(meta) $key $value
246 } elseif {[regexp ^HTTP $line]} {
247 set state(http) $line
252 if {[info exists state(-handler)]} {
253 set n [eval $state(-handler) {$s $token}]
255 set block [read $s $state(-blocksize)]
256 set n [string length $block]
258 append state(body) $block
262 incr state(currentsize) $n
265 httpFinish $token $err
267 if {[info exists state(-progress)]} {
268 eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
273 proc httpCopyStart {s token} {
274 upvar #0 $token state
276 fcopy $s $state(-channel) -size $state(-blocksize) -command \
277 [list httpCopyDone $token]
279 httpFinish $token $err
282 proc httpCopyDone {token count {error {}}} {
283 upvar #0 $token state
285 incr state(currentsize) $count
286 if {[info exists state(-progress)]} {
287 eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
289 if {([string length $error] != 0)} {
290 httpFinish $token $error
291 } elseif {[eof $s]} {
294 httpCopyStart $s $token
297 proc httpEof {token} {
298 upvar #0 $token state
299 if {$state(state) == "header"} {
301 set state(status) eof
308 proc http_wait {token} {
309 upvar #0 $token state
310 if {![info exists state(status)] || [string length $state(status)] == 0} {
311 vwait $token\(status)
313 if {[info exists state(error)]} {
314 set errorlist $state(error)
316 eval error $errorlist
318 return $state(status)
321 # Call http_formatQuery with an even number of arguments, where the first is
322 # a name, the second is a value, the third is another name, and so on.
324 proc http_formatQuery {args} {
328 append result $sep [httpMapReply $i]
338 # do x-www-urlencoded character mapping
339 # The spec says: "non-alphanumeric characters are replaced by '%HH'"
340 # 1 leave alphanumerics characters alone
341 # 2 Convert every other character to an array lookup
342 # 3 Escape constructs that are "special" to the tcl parser
343 # 4 "subst" the result, doing all the array substitutions
345 proc httpMapReply {string} {
347 set alphanumeric a-zA-Z0-9
348 if {![info exists httpFormMap]} {
350 for {set i 1} {$i <= 256} {incr i} {
352 if {![string match \[$alphanumeric\] $c]} {
353 set httpFormMap($c) %[format %.2x $i]
356 # These are handled specially
357 array set httpFormMap {
361 regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string
362 regsub -all \n $string {\\n} string
363 regsub -all \t $string {\\t} string
364 regsub -all {[][{})\\]\)} $string {\\&} string
365 return [subst $string]
368 # Default proxy filter.
369 proc httpProxyRequired {host} {
371 if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
372 if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} {
373 set http(-proxyport) 8080
375 return [list $http(-proxyhost) $http(-proxyport)]