diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/http11.test | 33 | ||||
| -rw-r--r-- | tests/httpd11.tcl | 15 | ||||
| -rw-r--r-- | tests/oo.test | 25 | ||||
| -rw-r--r-- | tests/ooNext2.test | 195 |
4 files changed, 154 insertions, 114 deletions
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..22e6cfb 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 diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 6c4f1ad..6a48d28 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -874,25 +874,29 @@ test oo-call-3.4 {current call introspection: in destructors} -setup { # 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. -# +# 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 +# Common setup: +# any invocation of bar should emit "abc\nhi\n" then return to its +# caller set testopts { -setup { - oo::class create Foo { - method bar {} { - puts abc - tailcall puts hi - puts xyz - } - } + 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 { - catch {Foo destroy} - catch {Foo2 destroy} ;# created by some tests + Master destroy } } @@ -900,68 +904,63 @@ set testopts { 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 + 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 + 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 + 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::class create Foo2 { - superclass Foo - method bar {} { - puts a - next - puts b - } + 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::class create Foo2 { - superclass Foo - method bar {} { - puts a - nextto Foo - puts b - } + 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::class create Foo2 { - method Bar {} { - puts a - next - puts b - } - filter Bar + oo::define Foo2 { + method Bar {} { + puts a + next + puts b + } + filter Bar } oo::define Foo mixin Foo2 Foo create foo @@ -969,13 +968,13 @@ test next-tailcall-mixin-1 "class mixin" {*}$testopts -body { } -output [join {a abc hi b} \n]\n test next-tailcall-objmixin-1 "object mixin" {*}$testopts -body { - oo::class create Foo2 { - method Bar {} { - puts a - next - puts b - } - filter Bar + oo::define Foo2 { + method Bar {} { + puts a + next + puts b + } + filter Bar } Foo create foo oo::objdefine foo mixin Foo2 @@ -984,9 +983,9 @@ test next-tailcall-objmixin-1 "object mixin" {*}$testopts -body { test next-tailcall-filter-1 "filter method" {*}$testopts -body { oo::define Foo method Filter {} { - puts a - next - puts b + puts a + next + puts b } oo::define Foo filter Filter [Foo new] bar @@ -994,37 +993,37 @@ test next-tailcall-filter-1 "filter method" {*}$testopts -body { test next-tailcall-forward-1 "forward method" {*}$testopts -body { proc foobar {} { - puts "abc" - tailcall puts "hi" - puts "xyz" + puts "abc" + tailcall puts "hi" + puts "xyz" } oo::define Foo forward foobar foobar - oo::class create Foo2 { - superclass Foo - method foobar {} { - puts a - next - puts b - } + 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 - } + constructor {} { + puts abc + tailcall puts hi + puts xyz + } } oo::class create Foo2 { - superclass Foo - constructor {} { - puts a - next - puts b - } + superclass Foo + constructor {} { + puts a + next + puts b + } } list [Foo new] [Foo2 new] return "" @@ -1032,35 +1031,31 @@ test next-tailcall-constructor-1 "next in constructor" -body { 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 - } + destructor { + puts abc + tailcall puts hi + puts xyz + } } oo::class create Foo2 { - superclass Foo - destructor { - puts a - next - puts b - } - } - Foo create foo + 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 - - - +} -output [join {abc hi a abc hi b} \n]\n -cleanup { + Foo destroy +} unset testopts - - cleanupTests return |