diff options
| -rw-r--r-- | library/http/http.tcl | 16 | ||||
| -rw-r--r-- | tests/http.test | 22 |
2 files changed, 19 insertions, 19 deletions
diff --git a/library/http/http.tcl b/library/http/http.tcl index c8dbe9b..f43dd1b 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: http.tcl,v 1.54 2005/11/18 13:57:53 dkf Exp $ +# RCS: @(#) $Id: http.tcl,v 1.55 2005/11/18 14:51:02 dkf Exp $ # Rough version history: # 1.0 Old http_get interface. @@ -333,7 +333,7 @@ proc http::geturl { url args } { set URLmatcher {(?x) # this is _expanded_ syntax ^ - (?: (\w+) : ) # <protocol scheme> + (?: (\w+) : ) ? # <protocol scheme> (?: // (?: ( @@ -343,7 +343,7 @@ proc http::geturl { url args } { ( [^/:\#?]+ ) # <host part of authority> (?: : (\d+) )? # <port part of authority> )? - ( / [^\#?]* (?: \? [^\#?]* ) )? # <path> (including query) + ( / [^\#?]* (?: \? [^\#?]* )?)? # <path> (including query) (?: \# (.*) )? # <fragment> $ } @@ -372,13 +372,13 @@ proc http::geturl { url args } { # Check for validity according to RFC 3986, Appendix A set validityRE {(?xi) ^ - (?: [\w-.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+ + (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+ $ } if {![regexp -- $validityRE $user]} { unset $token # Provide a better error message in this error case - if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $path bad]} { + if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} { return -code error \ "Illegal encoding character usage \"$bad\" in URL user" } @@ -390,15 +390,15 @@ proc http::geturl { url args } { set validityRE {(?xi) ^ # Path part (already must start with / character) - (?: [\w-.~!$&'()*+,;=:@/] | %[0-9a-f][0-9a-f] )* + (?: [-\w.~!$&'()*+,;=:@/] | %[0-9a-f][0-9a-f] )* # Query part (optional, permits ? characters) - (?: ? (?: [\w-.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )? + (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )? $ } if {![regexp -- $validityRE $srvurl]} { unset $token # Provide a better error message in this error case - if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $path bad]} { + if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} { return -code error \ "Illegal encoding character usage \"$bad\" in URL path" } diff --git a/tests/http.test b/tests/http.test index fda00b9..b7d618c 100644 --- a/tests/http.test +++ b/tests/http.test @@ -12,7 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # -# RCS: @(#) $Id: http.test,v 1.40 2005/11/18 13:57:53 dkf Exp $ +# RCS: @(#) $Id: http.test,v 1.41 2005/11/18 14:51:02 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -122,8 +122,8 @@ test http-3.2 {http::geturl} { catch {http::geturl http:junk} err set err } {Unsupported URL: http:junk} -set url [info hostname]:$port -set badurl [info hostname]:6666 +set url //[info hostname]:$port +set badurl //[info hostname]:6666 test http-3.3 {http::geturl} { set token [http::geturl $url] http::data $token @@ -132,11 +132,11 @@ test http-3.3 {http::geturl} { <h2>GET /</h2> </body></html>" set tail /a/b/c -set url [info hostname]:$port/a/b/c +set url //[info hostname]:$port/a/b/c set fullurl http://user:pass@[info hostname]:$port/a/b/c -set binurl [info hostname]:$port/binary -set posturl [info hostname]:$port/post -set badposturl [info hostname]:$port/droppost +set binurl //[info hostname]:$port/binary +set posturl //[info hostname]:$port/post +set badposturl //[info hostname]:$port/droppost test http-3.4 {http::geturl} { set token [http::geturl $url] http::data $token @@ -155,7 +155,7 @@ test http-3.5 {http::geturl} { http::data $token } "<html><head><title>HTTP/1.0 TEST</title></head><body> <h1>Hello, World!</h1> -<h2>GET http://$url</h2> +<h2>GET http:$url</h2> </body></html>" test http-3.6 {http::geturl} { http::config -proxyfilter bogus @@ -381,7 +381,7 @@ test http-4.6 {http::Event} { close $in removeFile $testfile set x -} "$bindata$binurl" +} "$bindata[string trimleft $binurl /]" proc myProgress {token total current} { global progress httpLog if {[info exists httpLog] && $httpLog} { @@ -453,7 +453,7 @@ test http-4.15 {http::Event} { # This test may fail if you use a proxy server. That is to be # expected and is not a problem with Tcl. set code [catch { - set token [http::geturl not_a_host.tcl.tk -timeout 1000 -command {#}] + set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command {#}] http::wait $token http::status $token } err] @@ -488,7 +488,7 @@ test http-6.1 {http::ProxyRequired} { set data(body) } "<html><head><title>HTTP/1.0 TEST</title></head><body> <h1>Hello, World!</h1> -<h2>GET http://$url</h2> +<h2>GET http:$url</h2> </body></html>" test http-7.1 {http::mapReply} { |