mingw/lib/tcl8.4/http1.0/http.tcl

   1 # http.tcl
   2 # Client-side HTTP for GET, POST, and HEAD commands.
   3 # These routines can be used in untrusted code that uses the Safesock
   4 # security policy.
   5 # These procedures use a callback interface to avoid using vwait,
   6 # which is not defined in the safe base.
   7 #
   8 # RCS: @(#) $Id: http.tcl,v 1.4 2000/02/01 11:48:30 hobbs Exp $
   9 #
  10 # See the http.n man page for documentation
  11
  12 package provide http 1.0
  13
  14 array set http {
  15     -accept */*
  16     -proxyhost {}
  17     -proxyport {}
  18     -useragent {Tcl http client package 1.0}
  19     -proxyfilter httpProxyRequired
  20 }
  21 proc http_config {args} {
  22     global http
  23     set options [lsort [array names http -*]]
  24     set usage [join $options ", "]
  25     if {[llength $args] == 0} {
  26         set result {}
  27         foreach name $options {
  28             lappend result $name $http($name)
  29         }
  30         return $result
  31     }
  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]} {
  37             return $http($flag)
  38         } else {
  39             return -code error "Unknown option $flag, must be: $usage"
  40         }
  41     } else {
  42         foreach {flag value} $args {
  43             if {[regexp -- $pat $flag]} {
  44                 set http($flag) $value
  45             } else {
  46                 return -code error "Unknown option $flag, must be: $usage"
  47             }
  48         }
  49     }
  50 }
  51
  52  proc httpFinish { token {errormsg ""} } {
  53     upvar #0 $token state
  54     global errorInfo errorCode
  55     if {[string length $errormsg] != 0} {
  56         set state(error) [list $errormsg $errorInfo $errorCode]
  57         set state(status) error
  58     }
  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
  66             }
  67         }
  68         unset state(-command)
  69     }
  70 }
  71 proc http_reset { token {why reset} } {
  72     upvar #0 $token state
  73     set state(status) $why
  74     catch {fileevent $state(sock) readable {}}
  75     httpFinish $token
  76     if {[info exists state(error)]} {
  77         set errorlist $state(error)
  78         unset state(error)
  79         eval error $errorlist
  80     }
  81 }
  82 proc http_get { url args } {
  83     global http
  84     if {![info exists http(uid)]} {
  85         set http(uid) 0
  86     }
  87     set token http#[incr http(uid)]
  88     upvar #0 $token state
  89     http_reset $token
  90     array set state {
  91         -blocksize      8192
  92         -validate       0
  93         -headers        {}
  94         -timeout        0
  95         state           header
  96         meta            {}
  97         currentsize     0
  98         totalsize       0
  99         type            text/html
 100         body            {}
 101         status          ""
 102     }
 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]} {
 110             # Validate numbers
 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"
 115             }
 116             set state($flag) $value
 117         } else {
 118             return -code error "Unknown option $flag, can be: $usage"
 119         }
 120     }
 121     if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
 122             x proto host y port srvurl]} {
 123         error "Unsupported URL: $url"
 124     }
 125     if {[string length $port] == 0} {
 126         set port 80
 127     }
 128     if {[string length $srvurl] == 0} {
 129         set srvurl /
 130     }
 131     if {[string length $proto] == 0} {
 132         set url http://$url
 133     }
 134     set state(url) $url
 135     if {![catch {$http(-proxyfilter) $host} proxy]} {
 136         set phost [lindex $proxy 0]
 137         set pport [lindex $proxy 1]
 138     }
 139     if {$state(-timeout) > 0} {
 140         set state(after) [after $state(-timeout) [list http_reset $token timeout]]
 141     }
 142     if {[info exists phost] && [string length $phost]} {
 143         set srvurl $url
 144         set s [socket $phost $pport]
 145     } else {
 146         set s [socket $host $port]
 147     }
 148     set state(sock) $s
 149
 150     # Send data in cr-lf format, but accept any line terminators
 151
 152     fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
 153
 154     # The following is disallowed in safe interpreters, but the socket
 155     # is already in non-blocking mode in that case.
 156
 157     catch {fconfigure $s -blocking off}
 158     set len 0
 159     set how GET
 160     if {[info exists state(-query)]} {
 161         set len [string length $state(-query)]
 162         if {$len > 0} {
 163             set how POST
 164         }
 165     } elseif {$state(-validate)} {
 166         set how HEAD
 167     }
 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"
 177         }
 178     }
 179     if {$len > 0} {
 180         puts $s "Content-Length: $len"
 181         puts $s "Content-Type: application/x-www-form-urlencoded"
 182         puts $s ""
 183         fconfigure $s -translation {auto binary}
 184         puts -nonewline $s $state(-query)
 185     } else {
 186         puts $s ""
 187     }
 188     flush $s
 189     fileevent $s readable [list httpEvent $token]
 190     if {! [info exists state(-command)]} {
 191         http_wait $token
 192     }
 193     return $token
 194 }
 195 proc http_data {token} {
 196     upvar #0 $token state
 197     return $state(body)
 198 }
 199 proc http_status {token} {
 200     upvar #0 $token state
 201     return $state(status)
 202 }
 203 proc http_code {token} {
 204     upvar #0 $token state
 205     return $state(http)
 206 }
 207 proc http_size {token} {
 208     upvar #0 $token state
 209     return $state(currentsize)
 210 }
 211
 212  proc httpEvent {token} {
 213     upvar #0 $token state
 214     set s $state(sock)
 215
 216      if {[eof $s]} {
 217         httpEof $token
 218         return
 219     }
 220     if {$state(state) == "header"} {
 221         set n [gets $s line]
 222         if {$n == 0} {
 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
 229                 }
 230             }
 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
 236             }
 237         } elseif {$n > 0} {
 238             if {[regexp -nocase {^content-type:(.+)$} $line x type]} {
 239                 set state(type) [string trim $type]
 240             }
 241             if {[regexp -nocase {^content-length:(.+)$} $line x length]} {
 242                 set state(totalsize) [string trim $length]
 243             }
 244             if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
 245                 lappend state(meta) $key $value
 246             } elseif {[regexp ^HTTP $line]} {
 247                 set state(http) $line
 248             }
 249         }
 250     } else {
 251         if {[catch {
 252             if {[info exists state(-handler)]} {
 253                 set n [eval $state(-handler) {$s $token}]
 254             } else {
 255                 set block [read $s $state(-blocksize)]
 256                 set n [string length $block]
 257                 if {$n >= 0} {
 258                     append state(body) $block
 259                 }
 260             }
 261             if {$n >= 0} {
 262                 incr state(currentsize) $n
 263             }
 264         } err]} {
 265             httpFinish $token $err
 266         } else {
 267             if {[info exists state(-progress)]} {
 268                 eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
 269             }
 270         }
 271     }
 272 }
 273  proc httpCopyStart {s token} {
 274     upvar #0 $token state
 275     if {[catch {
 276         fcopy $s $state(-channel) -size $state(-blocksize) -command \
 277             [list httpCopyDone $token]
 278     } err]} {
 279         httpFinish $token $err
 280     }
 281 }
 282  proc httpCopyDone {token count {error {}}} {
 283     upvar #0 $token state
 284     set s $state(sock)
 285     incr state(currentsize) $count
 286     if {[info exists state(-progress)]} {
 287         eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
 288     }
 289     if {([string length $error] != 0)} {
 290         httpFinish $token $error
 291     } elseif {[eof $s]} {
 292         httpEof $token
 293     } else {
 294         httpCopyStart $s $token
 295     }
 296 }
 297  proc httpEof {token} {
 298     upvar #0 $token state
 299     if {$state(state) == "header"} {
 300         # Premature eof
 301         set state(status) eof
 302     } else {
 303         set state(status) ok
 304     }
 305     set state(state) eof
 306     httpFinish $token
 307 }
 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)
 312     }
 313     if {[info exists state(error)]} {
 314         set errorlist $state(error)
 315         unset state(error)
 316         eval error $errorlist
 317     }
 318     return $state(status)
 319 }
 320
 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.
 323
 324 proc http_formatQuery {args} {
 325     set result ""
 326     set sep ""
 327     foreach i $args {
 328         append result  $sep [httpMapReply $i]
 329         if {$sep != "="} {
 330             set sep =
 331         } else {
 332             set sep &
 333         }
 334     }
 335     return $result
 336 }
 337
 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
 344
 345  proc httpMapReply {string} {
 346     global httpFormMap
 347     set alphanumeric    a-zA-Z0-9
 348     if {![info exists httpFormMap]} {
 349
 350         for {set i 1} {$i <= 256} {incr i} {
 351             set c [format %c $i]
 352             if {![string match \[$alphanumeric\] $c]} {
 353                 set httpFormMap($c) %[format %.2x $i]
 354             }
 355         }
 356         # These are handled specially
 357         array set httpFormMap {
 358             " " +   \n %0d%0a
 359         }
 360     }
 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]
 366 }
 367
 368 # Default proxy filter.
 369  proc httpProxyRequired {host} {
 370     global http
 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
 374         }
 375         return [list $http(-proxyhost) $http(-proxyport)]
 376     } else {
 377         return {}
 378     }
 379 }