Tcl Source Code

Check-in [0df32cd91c]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Allow URLs that don't have a path, but a query, e.g. http://example.com?foo=bar and bump http to 2.5.8.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-4-branch
Files: files | file ages | folders
SHA1: 0df32cd91c463aee9761d719e3e9bddc510bf095
User & Date: jan.nijtmans 2013-04-09 11:04:49
Context
2013-04-12
11:08
Implement Tcl_Pkg* functions as macro's around Tcl_Pkg*Ex. This saves stack space, is (marginally) f... check-in: 71773cb9e6 user: jan.nijtmans tags: core-8-4-branch
2013-04-09
11:06
merge-mark check-in: 44252ce501 user: jan.nijtmans tags: core-8-5-branch
11:04
Allow URLs that don't have a path, but a query, e.g. http://example.com?foo=bar and bump http to 2.5... check-in: 0df32cd91c user: jan.nijtmans tags: core-8-4-branch
10:10
Make (deprecated) Tcl_EvalObj/Tcl_GlobalEvalObj macro's always, not only when using stubs. check-in: 58c923ed9e user: jan.nijtmans tags: core-8-4-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.







1
2
3
4
5
6
7






2013-04-08  Don Porter  <[email protected]>

	* generic/regc_color.c:	[Bug 3610026] Stop crash when the number of
	* generic/regerrs.h:	"colors" in a regular expression overflows
	* generic/regex.h:	a short int.  Thanks to Heikki Linnakangas
	* generic/regguts.h:	for the report and the patch.
	* tests/regexp.test:
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
2013-04-09  Reinhard Max  <[email protected]>

	* library/http/http.tcl (http::geturl): Allow URLs that don't have
	a path, but a query query, e.g. http://example.com?foo=bar .
	* Bump the http package to 2.5.8.

2013-04-08  Don Porter  <[email protected]>

	* generic/regc_color.c:	[Bug 3610026] Stop crash when the number of
	* generic/regerrs.h:	"colors" in a regular expression overflows
	* generic/regex.h:	a short int.  Thanks to Heikki Linnakangas
	* generic/regguts.h:	for the report and the patch.
	* tests/regexp.test:

Changes to library/http/http.tcl.

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
#	favor of raising an error
# 2.4	Added -binary option to http::geturl and charset element to the state
#	array.

package require Tcl 8.4
# Keep this in sync with pkgIndex.tcl and with the install directories
# in Makefiles
package provide http 2.5.7

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}
	-proxyport {}







|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
#	favor of raising an error
# 2.4	Added -binary option to http::geturl and charset element to the state
#	array.

package require Tcl 8.4
# Keep this in sync with pkgIndex.tcl and with the install directories
# in Makefiles
package provide http 2.5.8

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}
	-proxyport {}
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
		(
		    [^@/\#?]+		# <userinfo part of authority>
		) @
	    )?
	    ( [^/:\#?]+ )		# <host part of authority>
	    (?: : (\d+) )?		# <port part of authority>
	)?
	( / [^\#?]* (?: \? [^\#?]* )?)?	# <path> (including query)
	(?: \# (.*) )?			# <fragment>
	$
    }

    # Phase one: parse
    if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} {
	unset $token







|







342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
		(
		    [^@/\#?]+		# <userinfo part of authority>
		) @
	    )?
	    ( [^/:\#?]+ )		# <host part of authority>
	    (?: : (\d+) )?		# <port part of authority>
	)?
	( [/\?] [^\#]*)?		# <path> (including query)
	(?: \# (.*) )?			# <fragment>
	$
    }

    # Phase one: parse
    if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} {
	unset $token
385
386
387
388
389
390
391






392
393
394
395
396
397
398
		return -code error \
			"Illegal encoding character usage \"$bad\" in URL user"
	    }
	    return -code error "Illegal characters in URL user"
	}
    }
    if {$srvurl ne ""} {






	# Check for validity according to RFC 3986, Appendix A
	set validityRE {(?xi)
	    ^
	    # Path part (already must start with / character)
	    (?:	      [-\w.~!$&'()*+,;=:@/]  | %[0-9a-f][0-9a-f] )*
	    # Query part (optional, permits ? characters)
	    (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )?







>
>
>
>
>
>







385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
		return -code error \
			"Illegal encoding character usage \"$bad\" in URL user"
	    }
	    return -code error "Illegal characters in URL user"
	}
    }
    if {$srvurl ne ""} {
	# RFC 3986 allows empty paths (not even a /), but servers
	# return 400 if the path in the HTTP request doesn't start
	# with / , so add it here if needed.
	if {[string index $srvurl 0] ne "/"} {
	    set srvurl /$srvurl
	}
	# Check for validity according to RFC 3986, Appendix A
	set validityRE {(?xi)
	    ^
	    # Path part (already must start with / character)
	    (?:	      [-\w.~!$&'()*+,;=:@/]  | %[0-9a-f][0-9a-f] )*
	    # Query part (optional, permits ? characters)
	    (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )?

Changes to library/http/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
# Tcl package index file, version 1.1
# 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.

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded http 2.5.7 [list tclPkgSetup $dir http 2.5.7 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]











|
1
2
3
4
5
6
7
8
9
10
11
12
# Tcl package index file, version 1.1
# 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.

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded http 2.5.8 [list tclPkgSetup $dir http 2.5.8 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]

Changes to tests/http.test.

131
132
133
134
135
136
137

138
139
140
141
142
143
144
set tail /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 badcharurl //%user@[info hostname]:$port/a/^b/c


test http-3.4 {http::geturl} {
    set token [http::geturl $url]
    http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>







>







131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
set tail /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 badcharurl //%user@[info hostname]:$port/a/^b/c
set authorityurl //[info hostname]:$port

test http-3.4 {http::geturl} {
    set token [http::geturl $url]
    http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
336
337
338
339
340
341
342













343
344
345
346
347
348
349
    http::geturl http://somewhere/path?%query
} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
test http-3.25 {http::geturl parse failures} -body {
    set ::http::strict 0
    set token [http::geturl $badcharurl]
    http::cleanup $token
} -returnCodes ok -result {}














test http-4.1 {http::Event} {
    set token [http::geturl $url]
    upvar #0 $token data
    array set meta $data(meta)
    expr ($data(totalsize) == $meta(Content-Length))
} 1







>
>
>
>
>
>
>
>
>
>
>
>
>







337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
    http::geturl http://somewhere/path?%query
} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
test http-3.25 {http::geturl parse failures} -body {
    set ::http::strict 0
    set token [http::geturl $badcharurl]
    http::cleanup $token
} -returnCodes ok -result {}
test http-3.30 {http::geturl query without path} -body {
    set token [http::geturl $authorityurl?var=val]
    http::ncode $token
} -cleanup {
    catch { http::cleanup $token }
} -result 200
test http-3.31 {http::geturl fragment without path} -body {
    set token [http::geturl "$authorityurl#fragment42"]
    http::ncode $token
} -cleanup {
    catch { http::cleanup $token }
} -result 200


test http-4.1 {http::Event} {
    set token [http::geturl $url]
    upvar #0 $token data
    array set meta $data(meta)
    expr ($data(totalsize) == $meta(Content-Length))
} 1