summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2015-05-18 14:44:16 (GMT)
committerdgp <dgp@users.sourceforge.net>2015-05-18 14:44:16 (GMT)
commitbeff5c1af7bf750d576575804688f897d55ad3b9 (patch)
tree337298bddad20a3e2e1ceeded3791635035d8a51 /tests
parentedc419b297d95a7a21b718d7f447f9c249500a28 (diff)
parentf2aa46953cedd6fe3b80766c84fb9720ae37f771 (diff)
downloadtcl-bug_3608714.zip
tcl-bug_3608714.tar.gz
tcl-bug_3608714.tar.bz2
merge trunkbug_3608714
Diffstat (limited to 'tests')
-rw-r--r--tests/http.test24
-rw-r--r--tests/http11.test33
-rw-r--r--tests/httpd11.tcl15
-rw-r--r--tests/oo.test53
-rw-r--r--tests/ooNext2.test190
5 files changed, 296 insertions, 19 deletions
diff --git a/tests/http.test b/tests/http.test
index a0a26de..41820cb 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -306,7 +306,6 @@ test http-3.13 {http::geturl socket leak test} {
for {set i 0} {$i < 3} {incr i} {
catch {http::geturl $badurl -timeout 5000}
}
-
# No extra channels should be taken
expr {[llength [file channels]] == $chanCount}
} 1
@@ -372,11 +371,11 @@ test http-3.27 {http::geturl: -headers override -type} -body {
http::data $token
} -cleanup {
http::cleanup $token
-} -match regexp -result {(?n)Accept \*/\*
-Host .*
+} -match regexp -result {(?n)Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
+Accept \*/\*
Accept-Encoding .*
Content-Length 5}
test http-3.28 {http::geturl: -headers override -type default} -body {
@@ -385,11 +384,11 @@ test http-3.28 {http::geturl: -headers override -type default} -body {
http::data $token
} -cleanup {
http::cleanup $token
-} -match regexp -result {(?n)Accept \*/\*
-Host .*
+} -match regexp -result {(?n)Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
+Accept \*/\*
Accept-Encoding .*
Content-Length 5}
test http-3.29 {http::geturl IPv6 address} -body {
@@ -418,6 +417,21 @@ test http-3.31 {http::geturl fragment without path} -body {
} -cleanup {
catch { http::cleanup $token }
} -result 200
+# Bug c11a51c482
+test http-3.32 {http::geturl: -headers override -accept default} -body {
+ set token [http::geturl $url/headers -query dummy \
+ -headers [list "Accept" "text/plain,application/tcl-test-value"]]
+ http::data $token
+} -cleanup {
+ http::cleanup $token
+} -match regexp -result {(?n)Host .*
+User-Agent .*
+Connection close
+Accept text/plain,application/tcl-test-value
+Accept-Encoding .*
+Content-Type application/x-www-form-urlencoded
+Content-Length 5}
+
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
upvar #0 $token data
diff --git a/tests/http11.test b/tests/http11.test
index 230ce5a..c9ded0b 100644
--- a/tests/http11.test
+++ b/tests/http11.test
@@ -70,11 +70,8 @@ proc check_crc {tok args} {
return "ok"
}
-makeFile "<html><head><title>test</title></head>\
-<body><p>this is a test</p>\n\
-[string repeat {<p>This is a tcl test file.</p>} 4192]\n\
-</body></html>" testdoc.html
-
+makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html
+
# -------------------------------------------------------------------------
test http11-1.0 "normal request for document " -setup {
@@ -447,7 +444,8 @@ test http11-2.10 "-channel,deflate,keepalive" -setup {
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- -timeout 5000 -channel $chan -keepalive 1]
+ -timeout 5000 -channel $chan -keepalive 1 \
+ -headers {accept-encoding deflate}]
http::wait $tok
seek $chan 0
set data [read $chan]
@@ -482,6 +480,27 @@ test http11-2.11 "-channel,identity,keepalive" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} {} chunked}
+test http11-2.12 "-channel,negotiate,keepalive" -setup {
+ variable httpd [create_httpd]
+ set chan [open [makeFile {} testfile.tmp] wb+]
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
+ -timeout 5000 -channel $chan -keepalive 1]
+ http::wait $tok
+ seek $chan 0
+ set data [read $chan]
+ list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+ [meta $tok connection] [meta $tok content-encoding]\
+ [meta $tok transfer-encoding] [meta $tok x-requested-encodings]\
+ [expr {[file size testdoc.html]-[file size testfile.tmp]}]
+} -cleanup {
+ http::cleanup $tok
+ close $chan
+ removeFile testfile.tmp
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate,compress 0}
+
+
# -------------------------------------------------------------------------
#
# The following tests for the -handler option will require changes in
@@ -644,7 +663,7 @@ test http11-4.3 "normal post request, check channel query length" -setup {
removeFile testfile.tmp
halt_httpd
} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 122880}
-
+
# -------------------------------------------------------------------------
foreach p {create_httpd httpd_read halt_httpd meta check_crc} {
diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl
index 9c543dc..267f409 100644
--- a/tests/httpd11.tcl
+++ b/tests/httpd11.tcl
@@ -158,13 +158,13 @@ proc Service {chan addr port} {
}
if {$protocol eq "HTTP/1.1"} {
- if {[string match "*deflate*" [dict get? $meta accept-encoding]]} {
- set encoding deflate
- } elseif {[string match "*gzip*" [dict get? $meta accept-encoding]]} {
- set encoding gzip
- } elseif {[string match "*compress*" [dict get? $meta accept-encoding]]} {
- set encoding compress
- }
+ foreach enc [split [dict get? $meta accept-encoding] ,] {
+ set enc [string trim $enc]
+ if {$enc in {deflate gzip compress}} {
+ set encoding $enc
+ break
+ }
+ }
set transfer chunked
} else {
set close 1
@@ -189,6 +189,7 @@ proc Service {chan addr port} {
if {$close} {
Puts $chan "connection: close"
}
+ Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]"
if {$encoding eq "identity"} {
Puts $chan "content-length: [string length $data]"
} else {
diff --git a/tests/oo.test b/tests/oo.test
index 5fa760b..f35b70a 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -416,6 +416,31 @@ test oo-2.8 {construction, method calls and ensembles - Bug 3514761} -setup {
} -returnCodes error -cleanup {
namespace delete k
} -result {wrong # args: should be "k next j"}
+test oo-2.9 {construction failures and self creation} -setup {
+ set ::result {}
+ oo::class create Root
+} -body {
+ oo::class create A {
+ superclass Root
+ constructor {} {
+ lappend ::result "in A"
+ error "failure in A"
+ }
+ destructor {lappend ::result [self]}
+ }
+ oo::class create B {
+ superclass Root
+ constructor {} {
+ lappend ::result "in B [self]"
+ error "failure in B"
+ }
+ destructor {lappend ::result [self]}
+ }
+ lappend ::result [catch {A create a} msg] $msg
+ lappend ::result [catch {B create b} msg] $msg
+} -cleanup {
+ Root destroy
+} -result {{in A} ::a 1 {failure in A} {in B ::b} ::b 1 {failure in B}}
test oo-3.1 {basic test of OO functionality: destructor} -setup {
# This is a bit complex because it needs to run in a sub-interp as we're
@@ -1544,6 +1569,34 @@ test oo-12.7 {OO: filters} -setup {
} -cleanup {
Aclass destroy
} -result {foo {{::Aclass outerfoo} {::Aclass InnerFoo}}}
+test oo-12.8 {OO: filters and destructors} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+ set ::log {}
+} -body {
+ oo::define Aclass {
+ constructor {} {
+ lappend ::log "in constructor"
+ }
+ destructor {
+ lappend ::log "in destructor"
+ }
+ method bar {} {
+ lappend ::log "in method"
+ }
+ method Boo args {
+ lappend ::log [self target]
+ next {*}$args
+ }
+ filter Boo
+ }
+ set obj [Aclass new]
+ $obj bar
+ $obj destroy
+ return $::log
+} -cleanup {
+ Aclass destroy
+} -result {{in constructor} {::Aclass bar} {in method} {::oo::object destroy} {in destructor}}
test oo-13.1 {OO: changing an object's class} {
oo::class create Aclass
diff --git a/tests/ooNext2.test b/tests/ooNext2.test
index 5ecd209..6a48d28 100644
--- a/tests/ooNext2.test
+++ b/tests/ooNext2.test
@@ -866,6 +866,196 @@ test oo-call-3.4 {current call introspection: in destructors} -setup {
} -cleanup {
root destroy
} -result {{{{method <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}}
+
+# Contributed tests from aspect, related to [0f42ff7871]
+#
+# dkf's "Principles Leading to a Fix"
+#
+# A method ought to work "the same" whether or not it has been overridden by
+# a subclass. A tailcalled command ought to have as parent stack the same
+# thing you'd get with uplevel 1. A subclass will often expect the
+# superclass's result to be the result that would be returned if the
+# subclass was not there.
+
+# Common setup:
+# any invocation of bar should emit "abc\nhi\n" then return to its
+# caller
+set testopts {
+ -setup {
+ oo::class create Master
+ oo::class create Foo {
+ superclass Master
+ method bar {} {
+ puts abc
+ tailcall puts hi
+ puts xyz
+ }
+ }
+ oo::class create Foo2 {
+ superclass Master
+ }
+ }
+ -cleanup {
+ Master destroy
+ }
+}
+
+# these succeed, showing that without [next] the bug doesn't fire
+test next-tailcall-simple-1 "trivial case with one method" {*}$testopts -body {
+ [Foo create foo] bar
+} -output [join {abc hi} \n]\n
+test next-tailcall-simple-2 "my bar" {*}$testopts -body {
+ oo::define Foo method baz {} {
+ puts a
+ my bar
+ puts b
+ }
+ [Foo create foo] baz
+} -output [join {a abc hi b} \n]\n
+test next-tailcall-simple-3 "\[self\] bar" {*}$testopts -body {
+ oo::define Foo method baz {} {
+ puts a
+ [self] bar
+ puts b
+ }
+ [Foo create foo] baz
+} -output [join {a abc hi b} \n]\n
+test next-tailcall-simple-4 "foo bar" {*}$testopts -body {
+ oo::define Foo method baz {} {
+ puts a
+ foo bar
+ puts b
+ }
+ [Foo create foo] baz
+} -output [join {a abc hi b} \n]\n
+
+# everything from here on uses [next], and fails on 8.6.4 with compilation
+test next-tailcall-superclass-1 "next superclass" {*}$testopts -body {
+ oo::define Foo2 {
+ superclass Foo
+ method bar {} {
+ puts a
+ next
+ puts b
+ }
+ }
+ [Foo2 create foo] bar
+} -output [join {a abc hi b} \n]\n
+test next-tailcall-superclass-2 "nextto superclass" {*}$testopts -body {
+ oo::define Foo2 {
+ superclass Foo
+ method bar {} {
+ puts a
+ nextto Foo
+ puts b
+ }
+ }
+ [Foo2 create foo] bar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-mixin-1 "class mixin" {*}$testopts -body {
+ oo::define Foo2 {
+ method Bar {} {
+ puts a
+ next
+ puts b
+ }
+ filter Bar
+ }
+ oo::define Foo mixin Foo2
+ Foo create foo
+ foo bar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-objmixin-1 "object mixin" {*}$testopts -body {
+ oo::define Foo2 {
+ method Bar {} {
+ puts a
+ next
+ puts b
+ }
+ filter Bar
+ }
+ Foo create foo
+ oo::objdefine foo mixin Foo2
+ foo bar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-filter-1 "filter method" {*}$testopts -body {
+ oo::define Foo method Filter {} {
+ puts a
+ next
+ puts b
+ }
+ oo::define Foo filter Filter
+ [Foo new] bar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-forward-1 "forward method" {*}$testopts -body {
+ proc foobar {} {
+ puts "abc"
+ tailcall puts "hi"
+ puts "xyz"
+ }
+ oo::define Foo forward foobar foobar
+ oo::define Foo2 {
+ superclass Foo
+ method foobar {} {
+ puts a
+ next
+ puts b
+ }
+ }
+ [Foo2 new] foobar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-constructor-1 "next in constructor" -body {
+ oo::class create Foo {
+ constructor {} {
+ puts abc
+ tailcall puts hi
+ puts xyz
+ }
+ }
+ oo::class create Foo2 {
+ superclass Foo
+ constructor {} {
+ puts a
+ next
+ puts b
+ }
+ }
+ list [Foo new] [Foo2 new]
+ return ""
+} -cleanup {
+ Foo destroy
+} -output [join {abc hi a abc hi b} \n]\n
+
+test next-tailcall-destructor-1 "next in destructor" -body {
+ oo::class create Foo {
+ destructor {
+ puts abc
+ tailcall puts hi
+ puts xyz
+ }
+ }
+ oo::class create Foo2 {
+ superclass Foo
+ destructor {
+ puts a
+ next
+ puts b
+ }
+ }
+ Foo create foo
+ Foo2 create foo2
+ foo destroy
+ foo2 destroy
+} -output [join {abc hi a abc hi b} \n]\n -cleanup {
+ Foo destroy
+}
+
+unset testopts
cleanupTests
return
generated by cgit v0.12 at 2025-06-06 07:57:35 (GMT)