home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 November / CPNL0711.ISO / beeld / teken / scribus-1.3.3.9-win32-install.exe / tcl / tcl8.4 / http1.0 / http.tcl next >
Text File  |  2000-01-31  |  10KB  |  380 lines
  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. }
  380.