Tcl Source Code

Check-in [859df7220f]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:merge 8.6
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | rc1 | core-8-6-7-rc
Files: files | file ages | folders
SHA1: 859df7220fbcddec6858e703c87277c8fb1ff22f
User & Date: dgp 2017-08-03 14:40:48
Context
2017-08-08
16:42
Merge core-8-6-branch check-in: 216c54cb51 user: andy tags: core-8-6-7-rc
2017-08-03
14:40
merge 8.6 check-in: 859df7220f user: dgp tags: rc1, core-8-6-7-rc
14:39
Improved test http-4.16. check-in: 26055ab3e1 user: dgp tags: core-8-6-branch
2017-08-01
16:05
update changes check-in: 23702a8e3a user: dgp tags: core-8-6-7-rc
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to tests/http.test.

31
32
33
34
35
36
37







38
39
40
41
42
43
44
...
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
...
588
589
590
591
592
593
594
595




596
597
598
599

600
601


602
603
604
605
606
607
608
609
...
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
proc bgerror {args} {
    global errorInfo
    puts stderr "http.test bgerror"
    puts stderr [join $args]
    puts stderr $errorInfo
}








set port 8010
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}

# Ensure httpd file exists

................................................................................

test http-3.1 {http::geturl} -returnCodes error -body {
    http::geturl -bogus flag
} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
test http-3.2 {http::geturl} -returnCodes error -body {
    http::geturl http:junk
} -result {Unsupported URL: http:junk}
set url //[info hostname]:$port
set badurl //[info hostname]:[expr $port+1]
test http-3.3 {http::geturl} -body {
    set token [http::geturl $url]
    http::data $token
} -cleanup {
    http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET /</h2>
</body></html>"
set tail /a/b/c
set url //[info hostname]:$port/a/b/c
set fullurl HTTP://user:[email protected][info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set xmlurl //[info hostname]:$port/xml
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
set authorityurl //[info hostname]:$port
set ipv6url http://\[::1\]:$port/
test http-3.4 {http::geturl} -body {
    set token [http::geturl $url]
    http::data $token
} -cleanup {
    http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
proc selfproxy {host} {
    global port
    return [list [info hostname] $port]
}
test http-3.5 {http::geturl} -body {
    http::config -proxyfilter selfproxy
    set token [http::geturl $url]
    http::data $token
} -cleanup {
    http::config -proxyfilter http::ProxyRequired
................................................................................
    set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command \#]
    http::wait $token
    http::status $token
    # error codes vary among platforms.
} -cleanup {
    catch {http::cleanup $token}
} -returnCodes 1 -match glob -result "couldn't open socket*"
test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -body {




    set before [chan names]
    set token [http::geturl $url -headers {X-Connection keep-alive}]
    http::cleanup $token
    update

    set after [chan names]
    expr {$before eq $after}


} -result 1

test http-5.1 {http::formatQuery} {
    http::formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value%20two}
# test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5
test http-5.3 {http::formatQuery} {
    http::formatQuery lines "line1\nline2\nline3"
................................................................................
    http::config -urlencoding iso8859-1
    set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2]
    http::config -urlencoding $enc
    set res
} {name1=~bwelch&name2=%A1%A2%A2}

test http-6.1 {http::ProxyRequired} -body {
    http::config -proxyhost [info hostname] -proxyport $port
    set token [http::geturl $url]
    http::wait $token
    upvar #0 $token data
    set data(body)
} -cleanup {
    http::config -proxyhost {} -proxyport {}
    http::cleanup $token






>
>
>
>
>
>
>







 







|
|










|
|
|
|
|
|
|












|







 







|
>
>
>
>




>
|
<
>
>
|







 







|







31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
...
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
...
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612

613
614
615
616
617
618
619
620
621
622
...
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
proc bgerror {args} {
    global errorInfo
    puts stderr "http.test bgerror"
    puts stderr [join $args]
    puts stderr $errorInfo
}

if {$::tcl_platform(os) eq "Darwin"} {
    # Name resolution often a problem on OSX; not focus of HTTP package anyway
    set HOST localhost
} else {
    set HOST [info hostname]
}

set port 8010
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}

# Ensure httpd file exists

................................................................................

test http-3.1 {http::geturl} -returnCodes error -body {
    http::geturl -bogus flag
} -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate}
test http-3.2 {http::geturl} -returnCodes error -body {
    http::geturl http:junk
} -result {Unsupported URL: http:junk}
set url //${::HOST}:$port
set badurl //${::HOST}:[expr $port+1]
test http-3.3 {http::geturl} -body {
    set token [http::geturl $url]
    http::data $token
} -cleanup {
    http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET /</h2>
</body></html>"
set tail /a/b/c
set url //${::HOST}:$port/a/b/c
set fullurl HTTP://user:[email protected]${::HOST}:$port/a/b/c
set binurl //${::HOST}:$port/binary
set xmlurl //${::HOST}:$port/xml
set posturl //${::HOST}:$port/post
set badposturl //${::HOST}:$port/droppost
set authorityurl //${::HOST}:$port
set ipv6url http://\[::1\]:$port/
test http-3.4 {http::geturl} -body {
    set token [http::geturl $url]
    http::data $token
} -cleanup {
    http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
proc selfproxy {host} {
    global port
    return [list ${::HOST} $port]
}
test http-3.5 {http::geturl} -body {
    http::config -proxyfilter selfproxy
    set token [http::geturl $url]
    http::data $token
} -cleanup {
    http::config -proxyfilter http::ProxyRequired
................................................................................
    set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command \#]
    http::wait $token
    http::status $token
    # error codes vary among platforms.
} -cleanup {
    catch {http::cleanup $token}
} -returnCodes 1 -match glob -result "couldn't open socket*"
test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup {
    proc list-difference {l1 l2} {
	lmap item $l2 {if {$item in $l1} continue; set item}
    }
} -body {
    set before [chan names]
    set token [http::geturl $url -headers {X-Connection keep-alive}]
    http::cleanup $token
    update
    # Compute what channels have been unexpectedly leaked past cleanup
    list-difference $before [chan names]

} -cleanup {
    rename list-difference {}
} -result {}

test http-5.1 {http::formatQuery} {
    http::formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value%20two}
# test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5
test http-5.3 {http::formatQuery} {
    http::formatQuery lines "line1\nline2\nline3"
................................................................................
    http::config -urlencoding iso8859-1
    set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2]
    http::config -urlencoding $enc
    set res
} {name1=~bwelch&name2=%A1%A2%A2}

test http-6.1 {http::ProxyRequired} -body {
    http::config -proxyhost ${::HOST} -proxyport $port
    set token [http::geturl $url]
    http::wait $token
    upvar #0 $token data
    set data(body)
} -cleanup {
    http::config -proxyhost {} -proxyport {}
    http::cleanup $token

Changes to tests/httpd.

5
6
7
8
9
10
11







12
13
14
15
16
17
18
...
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
# Copyright (c) 1997-1998 Sun Microsystems, Inc.
# Copyright (c) 1999-2000 Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#set httpLog 1








proc httpd_init {{port 8015}} {
    socket -server httpdAccept $port
}
proc httpd_log {args} {
    global httpLog
    if {[info exists httpLog] && $httpLog} {
................................................................................

proc httpdRespond { sock } {
    global httpd bindata port
    upvar #0 httpd$sock data

    switch -glob -- $data(url) {
	*binary* {
	    set html "$bindata[info hostname]:$port$data(url)"
	    set type application/octet-stream
	}
	*xml* {
	    set html [encoding convertto utf-8 "<test>\u1234</test>"]
	    set type "application/xml;charset=UTF-8"
	}
	*post* {






>
>
>
>
>
>
>







 







|







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
# Copyright (c) 1997-1998 Sun Microsystems, Inc.
# Copyright (c) 1999-2000 Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#set httpLog 1

if {$::tcl_platform(os) eq "Darwin"} {
    # Name resolution often a problem on OSX; not focus of HTTP package anyway
    set HOST localhost
} else {
    set HOST [info hostname]
}

proc httpd_init {{port 8015}} {
    socket -server httpdAccept $port
}
proc httpd_log {args} {
    global httpLog
    if {[info exists httpLog] && $httpLog} {
................................................................................

proc httpdRespond { sock } {
    global httpd bindata port
    upvar #0 httpd$sock data

    switch -glob -- $data(url) {
	*binary* {
	    set html "$bindata${::HOST}:$port$data(url)"
	    set type application/octet-stream
	}
	*xml* {
	    set html [encoding convertto utf-8 "<test>\u1234</test>"]
	    set type "application/xml;charset=UTF-8"
	}
	*post* {

Changes to tests/httpold.test.

28
29
30
31
32
33
34







35
36
37
38
39
40
41
..
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
...
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
	$interp eval [list set argv $argv]
	$interp eval [list source [info script]]
	interp delete $interp
	::tcltest::cleanupTests
	return
    }
}








set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}

##
## The httpd script implement a stub http server
##
................................................................................
    catch {http_get -bogus flag}
} 1
test httpold-3.2 {http_get} {
    catch {http_get http:junk} err
    set err
} {Unsupported URL: http:junk}

set url [info hostname]:$port
test httpold-3.3 {http_get} {
    set token [http_get $url]
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET /</h2>
</body></html>"

set tail /a/b/c
set url [info hostname]:$port/a/b/c
set binurl [info hostname]:$port/binary

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

proc selfproxy {host} {
    global port
    return [list [info hostname] $port]
}
test httpold-3.5 {http_get} {
    http_config -proxyfilter selfproxy
    set token [http_get $url]
    http_config -proxyfilter httpProxyRequired
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
................................................................................

test httpold-5.3 {http_formatQuery} {
    http_formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}

test httpold-6.1 {httpProxyRequired} {
    update
    http_config -proxyhost [info hostname] -proxyport $port
    set token [http_get $url]
    http_wait $token
    http_config -proxyhost {} -proxyport {}
    upvar #0 $token data
    set data(body)
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>






>
>
>
>
>
>
>







 







|









|
|











|







 







|







28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
..
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
...
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
	$interp eval [list set argv $argv]
	$interp eval [list source [info script]]
	interp delete $interp
	::tcltest::cleanupTests
	return
    }
}

if {$::tcl_platform(os) eq "Darwin"} {
    # Name resolution often a problem on OSX; not focus of HTTP package anyway
    set HOST localhost
} else {
    set HOST [info hostname]
}

set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}

##
## The httpd script implement a stub http server
##
................................................................................
    catch {http_get -bogus flag}
} 1
test httpold-3.2 {http_get} {
    catch {http_get http:junk} err
    set err
} {Unsupported URL: http:junk}

set url ${::HOST}:$port
test httpold-3.3 {http_get} {
    set token [http_get $url]
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET /</h2>
</body></html>"

set tail /a/b/c
set url ${::HOST}:$port/a/b/c
set binurl ${::HOST}:$port/binary

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

proc selfproxy {host} {
    global port
    return [list ${::HOST} $port]
}
test httpold-3.5 {http_get} {
    http_config -proxyfilter selfproxy
    set token [http_get $url]
    http_config -proxyfilter httpProxyRequired
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
................................................................................

test httpold-5.3 {http_formatQuery} {
    http_formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}

test httpold-6.1 {httpProxyRequired} {
    update
    http_config -proxyhost ${::HOST} -proxyport $port
    set token [http_get $url]
    http_wait $token
    http_config -proxyhost {} -proxyport {}
    upvar #0 $token data
    set data(body)
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>