summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--library/http3/http.tcl241
1 files changed, 184 insertions, 57 deletions
diff --git a/library/http3/http.tcl b/library/http3/http.tcl
index 0b234a3..a5c93e2 100644
--- a/library/http3/http.tcl
+++ b/library/http3/http.tcl
@@ -4,16 +4,11 @@ package provided http 3
namespace eval ::http {
if {[info command ::http::Log] eq {}} {proc ::http::Log {args} {}}
- variable ContextConfiguration {
- -accept accept
- -proxyfilter proxyfilter
- -proxyhost proxyhost
- -proxyport proxyport
- -urlencoding urlencoding
- -useragent useragent
- }
- variable ContextCfgType {
+ variable ContextConfig {
-accept {string {^[^\s/]+/+[^\s/+]$} "MIME type"}
+ -charset string
+ -connectionclass class
+ -keepalive boolean
-proxyfilter callback
-proxyhost string
-proxyport integer
@@ -21,28 +16,7 @@ namespace eval ::http {
-useragent string
}
- variable ConnectionConfiguration {
- -binary isBinary
- -blocksize blocksize
- -channel channel
- -command cmdCallback
- -handler handlerCallback
- -headers headers
- -keepalive keepalive
- -method method
- -myaddr myaddr
- -progress progressCallback
- -protocol protocol
- -query queryData
- -queryblocksize queryBlocksize
- -querychannel queryChannel
- -queryprogress queryCallback
- -strict strict
- -timeout timeout
- -type mimetype
- -validate validate
- }
- variable ConnectionCfgType {
+ variable ConnectionConfig {
-binary boolean
-blocksize integer
-channel channel
@@ -63,17 +37,34 @@ namespace eval ::http {
-type {string {^[^\s/]+/+[^\s/+]$} "MIME type"}
-validate boolean
}
+ variable ConnectionDefaults {
+ -binary false
+ -blocksize 8192
+ -queryblocksize 8192
+ -validate false
+ -headers {}
+ -timeout 0
+ -type application/x-www-form-urlencoded
+ -queryprogress {}
+ -protocol 1.1
+ }
oo::class create Context {
- variable accept proxyhost proxyport proxyfilter urlencoding strict
- variable useragent socketmap urltypes encodings charset keepalive
+ variable config
+ variable strict socketmap urltypes encodings charset keepalive
+ variable connectionclass counter
constructor {} {
- set accept */*
- set proxyhost {}
- set proxyport {}
- set proxyfilter [namespace code {my ProxyRequired}]
- set urlencoding utf-8
+ array set config {
+ -accept */*
+ -charset iso8859-1
+ -keepalive 0
+ -proxyhost {}
+ -proxyport {}
+ -urlencoding utf-8
+ }
+ set config(-proxyfilter) [namespace code {my ProxyRequired}]
+ set connectionclass ::http::Connection
# We need a useragent string of this style or various servers will
# refuse to send us compressed content even when we ask for it.
@@ -87,7 +78,7 @@ namespace eval ::http {
set platform "[string totitle $tcl_platform(platform)]; U;\
$tcl_platform(os) $tcl_platform(osVersion)"
}
- set useragent "Mozilla/5.0 ($platform)\
+ set config(-useragent) "Mozilla/5.0 ($platform)\
http/[package provide http] Tcl/[package provide Tcl]"
# Create a map for HTTP/1.1 open sockets
@@ -105,6 +96,7 @@ namespace eval ::http {
set charset "iso8859-1"
set keepalive 0
set strict 1
+ set counter 0
}
method register {proto port command} {
@@ -131,30 +123,25 @@ namespace eval ::http {
}
method configure {args} {
- variable ::http::ContextConfiguration
- variable ::http::ContextCfgType
+ variable ::http::ContextConfig
- set options [dict keys $ContextConfiguration]
- set usage [join $options ", "]
+ set options [dict keys $ContextConfig]
if {[llength $args] == 0} {
set result {}
- dict for {option var} $ContextConfiguration {
- upvar 0 [my varname $var] v
- lappend result $option $v
+ dict for {option typeinfo} $ContextConfig {
+ lappend result $option $config($option)
}
return $result
}
if {[llength $args] == 1} {
set opt [::tcl::prefix match $options [lindex $args 0]]
- upvar 0 [my varname [dict get $ContextConfiguration $opt]] v
- return $v
+ return $config($opt)
}
foreach {option value} $args {
set opt [::tcl::prefix match $options $option]
- upvar 0 [my varname [dict get $ContextConfiguration $opt]] v
- set typeinfo [lassign [dict get $ContextCfgType $opt] type]
+ set typeinfo [lassign [dict get $ContextConfig $opt] type]
::http::Validate($type) $opt $value {*}$typeinfo
- set v $value
+ set config($opt) $value
}
}
@@ -196,24 +183,63 @@ namespace eval ::http {
}
method geturl {url args} {
- variable ::http::ConnectionCfgType
+ variable ::http::ConnectionConfig
+ variable ::http::ConnectionDefaults
if {[llength $args] & 1} {
return -code error "missing configuration option"
}
- set names [dict keys $ConnectionCfgType]
+ set names [dict keys $ConnectionConfig]
set options [dict map {opt value} $args {
set opt [::tcl::prefix match $names $opt]
- set typeinfo [lassign [dict get $ConnectionCfgType $opt] type]
+ set typeinfo [lassign [dict get $ConnectionConfig $opt] type]
::http::Validate($type) $opt $value {*}$typeinfo
set value
}]
- ::http::Connection new [self] $url $options
+ $connectionclass create [incr counter] \
+ [self] $url $ConnectionDefaults $options
+ }
+
+ method ProxyRequred {host} {
+ if {[info exists proxyhost] && [string length $proxyhost]} {
+ if {![info exists proxyport] || ![string length $proxyport]} {
+ set proxyport 8080
+ }
+ return [list $proxyhost $proxyport]
+ }
}
}
oo::class create Connection {
- constructor {config url options} {
- variable ::http::ConnectionConfiguration
+ variable cfg http
+ variable binary state meta coding currentsize totalsize querylength
+ variable queryoffset type body status httpline connection charset
+ constructor {context url defaults options} {
+ interp alias {} [namespace current]::Context {} $context
+ my eval upvar 0 [info object namespace $context]::config http
+ foreach {opt value} $defaults {
+ set cfg($opt) $value
+ }
+ set cfg(-keepalive) $http(-keepalive)
+ foreach {opt value} $options {
+ set cfg($opt) $value
+ }
+
+ my reset
+
+ set binary 0
+ set state connecting
+ set meta {}
+ set coding {}
+ set currentsize 0
+ set totalsize 0
+ set querylength 0
+ set queryoffset 0
+ set type text/html
+ set body {}
+ set status ""
+ set httpline ""
+ set connection close
+ set charset $http(-charset)
}
destructor {
@@ -223,24 +249,73 @@ namespace eval ::http {
}
method wait {} {
+ if {![info exists status] || $status eq ""} {
+ # We must wait on the true variable name, not the local
+ # unqualified version.
+ vwait [my varname status]
+ }
+
+ return [my status]
}
method data {} {
+ return $body
}
method error {} {
+ if {[info exists error]} {
+ return $error
+ }
+ return ""
}
method status {} {
+ if {![info exists status]} {
+ return "error"
+ }
+ return $status
}
method code {} {
+ return $httpline
}
method ncode {} {
+ set thecode [my code]
+ if {[regexp {[0-9]{3}} $thecode numeric_code]} {
+ return $numeric_code
+ } else {
+ return $thecode
+ }
+ }
+
+ method size {} {
+ return $currentsize
}
method meta {} {
+ return $meta
+ }
+
+ # Return the list of content-encoding transformations we need to do in
+ # order.
+ method ContentEncoding {} {
+ set r {}
+ if {[info exists coding]} {
+ foreach c [split $coding ,] {
+ switch -exact -- $c {
+ deflate { lappend r inflate }
+ gzip - x-gzip { lappend r gunzip }
+ compress - x-compress { lappend r decompress }
+ identity {}
+ default {
+ return -code error \
+ "unsupported content-encoding \"$c\""
+ }
+ }
+ }
+ }
+ return $r
}
}
@@ -298,4 +373,56 @@ namespace eval ::http {
"bad value for $opt ($value), must be dict"
}
}
+
+ proc Validate(class) {option value} {
+ if {![info object isa class $value]} {
+ return -code error \
+ "bad value for $opt ($value), must be class"
+ }
+ }
+
+ # http::CharsetToEncoding --
+ #
+ # Tries to map a given IANA charset to a tcl encoding. If no encoding
+ # can be found, returns binary.
+ #
+
+ proc CharsetToEncoding {charset} {
+ variable encodings
+
+ set charset [string tolower $charset]
+ if {[regexp {iso-?8859-([0-9]+)} $charset -> num]} {
+ set encoding "iso8859-$num"
+ } elseif {[regexp {iso-?2022-(jp|kr)} $charset -> ext]} {
+ set encoding "iso2022-$ext"
+ } elseif {[regexp {shift[-_]?js} $charset]} {
+ set encoding "shiftjis"
+ } elseif {[regexp {(?:windows|cp)-?([0-9]+)} $charset -> num]} {
+ set encoding "cp$num"
+ } elseif {$charset eq "us-ascii"} {
+ set encoding "ascii"
+ } elseif {[regexp {(?:iso-?)?lat(?:in)?-?([0-9]+)} $charset -> num]} {
+ switch -- $num {
+ 5 {set encoding "iso8859-9"}
+ 1 - 2 - 3 {
+ set encoding "iso8859-$num"
+ }
+ }
+ } else {
+ # other charset, like euc-xx, utf-8,... may directly map to
+ # encoding
+ set encoding $charset
+ }
+ set idx [lsearch -exact $encodings $encoding]
+ if {$idx >= 0} {
+ return $encoding
+ } else {
+ return "binary"
+ }
+ }
}
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: t
+# End: