URL
https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k
Compare Revisions
- This comparison shows the changes necessary to convert path
/or1k/trunk/insight/tcl/library/http1.0
- from Rev 578 to Rev 1765
- ↔ Reverse comparison
Rev 578 → Rev 1765
/http.tcl
0,0 → 1,379
# http.tcl |
# Client-side HTTP for GET, POST, and HEAD commands. |
# These routines can be used in untrusted code that uses the Safesock |
# security policy. |
# These procedures use a callback interface to avoid using vwait, |
# which is not defined in the safe base. |
# |
# RCS: @(#) $Id: http.tcl,v 1.1.1.1 2002-01-16 10:25:30 markom Exp $ |
# |
# See the http.n man page for documentation |
|
package provide http 1.0 |
|
array set http { |
-accept */* |
-proxyhost {} |
-proxyport {} |
-useragent {Tcl http client package 1.0} |
-proxyfilter httpProxyRequired |
} |
proc http_config {args} { |
global http |
set options [lsort [array names http -*]] |
set usage [join $options ", "] |
if {[llength $args] == 0} { |
set result {} |
foreach name $options { |
lappend result $name $http($name) |
} |
return $result |
} |
regsub -all -- - $options {} options |
set pat ^-([join $options |])$ |
if {[llength $args] == 1} { |
set flag [lindex $args 0] |
if {[regexp -- $pat $flag]} { |
return $http($flag) |
} else { |
return -code error "Unknown option $flag, must be: $usage" |
} |
} else { |
foreach {flag value} $args { |
if {[regexp -- $pat $flag]} { |
set http($flag) $value |
} else { |
return -code error "Unknown option $flag, must be: $usage" |
} |
} |
} |
} |
|
proc httpFinish { token {errormsg ""} } { |
upvar #0 $token state |
global errorInfo errorCode |
if {[string length $errormsg] != 0} { |
set state(error) [list $errormsg $errorInfo $errorCode] |
set state(status) error |
} |
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] |
set state(status) error |
} |
} |
unset state(-command) |
} |
} |
proc http_reset { token {why reset} } { |
upvar #0 $token state |
set state(status) $why |
catch {fileevent $state(sock) readable {}} |
httpFinish $token |
if {[info exists state(error)]} { |
set errorlist $state(error) |
unset state(error) |
eval error $errorlist |
} |
} |
proc http_get { url args } { |
global http |
if {![info exists http(uid)]} { |
set http(uid) 0 |
} |
set token http#[incr http(uid)] |
upvar #0 $token state |
http_reset $token |
array set state { |
-blocksize 8192 |
-validate 0 |
-headers {} |
-timeout 0 |
state header |
meta {} |
currentsize 0 |
totalsize 0 |
type text/html |
body {} |
status "" |
} |
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]} { |
# Validate numbers |
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" |
} |
set state($flag) $value |
} else { |
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} { |
set port 80 |
} |
if {[string length $srvurl] == 0} { |
set srvurl / |
} |
if {[string length $proto] == 0} { |
set url http://$url |
} |
set state(url) $url |
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 srvurl $url |
set s [socket $phost $pport] |
} else { |
set s [socket $host $port] |
} |
set state(sock) $s |
|
# 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} |
set len 0 |
set how GET |
if {[info exists state(-query)]} { |
set len [string length $state(-query)] |
if {$len > 0} { |
set how POST |
} |
} elseif {$state(-validate)} { |
set how HEAD |
} |
puts $s "$how $srvurl HTTP/1.0" |
puts $s "Accept: $http(-accept)" |
puts $s "Host: $host" |
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 "$key: $value" |
} |
} |
if {$len > 0} { |
puts $s "Content-Length: $len" |
puts $s "Content-Type: application/x-www-form-urlencoded" |
puts $s "" |
fconfigure $s -translation {auto binary} |
puts $s $state(-query) |
} else { |
puts $s "" |
} |
flush $s |
fileevent $s readable [list httpEvent $token] |
if {! [info exists state(-command)]} { |
http_wait $token |
} |
return $token |
} |
proc http_data {token} { |
upvar #0 $token state |
return $state(body) |
} |
proc http_status {token} { |
upvar #0 $token state |
return $state(status) |
} |
proc http_code {token} { |
upvar #0 $token state |
return $state(http) |
} |
proc http_size {token} { |
upvar #0 $token state |
return $state(currentsize) |
} |
|
proc httpEvent {token} { |
upvar #0 $token state |
set s $state(sock) |
|
if {[eof $s]} { |
httpEof $token |
return |
} |
if {$state(state) == "header"} { |
set n [gets $s line] |
if {$n == 0} { |
set state(state) body |
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 |
fileevent $s readable {} |
httpCopyStart $s $token |
} |
} elseif {$n > 0} { |
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]} { |
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]} { |
httpFinish $token $err |
} else { |
if {[info exists state(-progress)]} { |
eval $state(-progress) {$token $state(totalsize) $state(currentsize)} |
} |
} |
} |
} |
proc httpCopyStart {s token} { |
upvar #0 $token state |
if {[catch { |
fcopy $s $state(-channel) -size $state(-blocksize) -command \ |
[list httpCopyDone $token] |
} err]} { |
httpFinish $token $err |
} |
} |
proc httpCopyDone {token count {error {}}} { |
upvar #0 $token state |
set s $state(sock) |
incr state(currentsize) $count |
if {[info exists state(-progress)]} { |
eval $state(-progress) {$token $state(totalsize) $state(currentsize)} |
} |
if {([string length $error] != 0)} { |
httpFinish $token $error |
} elseif {[eof $s]} { |
httpEof $token |
} else { |
httpCopyStart $s $token |
} |
} |
proc httpEof {token} { |
upvar #0 $token state |
if {$state(state) == "header"} { |
# Premature eof |
set state(status) eof |
} else { |
set state(status) ok |
} |
set state(state) eof |
httpFinish $token |
} |
proc http_wait {token} { |
upvar #0 $token state |
if {![info exists state(status)] || [string length $state(status)] == 0} { |
vwait $token\(status) |
} |
if {[info exists state(error)]} { |
set errorlist $state(error) |
unset state(error) |
eval error $errorlist |
} |
return $state(status) |
} |
|
# 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} { |
set result "" |
set sep "" |
foreach i $args { |
append result $sep [httpMapReply $i] |
if {$sep != "="} { |
set sep = |
} else { |
set sep & |
} |
} |
return $result |
} |
|
# 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} { |
global httpFormMap |
set alphanumeric a-zA-Z0-9 |
if {![info exists httpFormMap]} { |
|
for {set i 1} {$i <= 256} {incr i} { |
set c [format %c $i] |
if {![string match \[$alphanumeric\] $c]} { |
set httpFormMap($c) %[format %.2x $i] |
} |
} |
# These are handled specially |
array set httpFormMap { |
" " + \n %0d%0a |
} |
} |
regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string |
regsub -all \n $string {\\n} string |
regsub -all \t $string {\\t} string |
regsub -all {[][{})\\]\)} $string {\\&} string |
return [subst $string] |
} |
|
# Default proxy filter. |
proc httpProxyRequired {host} { |
global http |
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)] |
} else { |
return {} |
} |
} |
http.tcl
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: pkgIndex.tcl
===================================================================
--- pkgIndex.tcl (nonexistent)
+++ pkgIndex.tcl (revision 1765)
@@ -0,0 +1,11 @@
+# Tcl package index file, version 1.0
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded http 1.0 [list tclPkgSetup $dir http 1.0 {{http.tcl source {httpCopyDone httpCopyStart httpEof httpEvent httpFinish httpMapReply httpProxyRequired http_code http_config http_data http_formatQuery http_get http_reset http_size http_status http_wait}}}]
pkgIndex.tcl
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property