diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/http11.test | 33 | ||||
| -rw-r--r-- | tests/httpd11.tcl | 15 | ||||
| -rw-r--r-- | tests/io.test | 86 | ||||
| -rw-r--r-- | tests/oo.test | 53 | ||||
| -rw-r--r-- | tests/ooNext2.test | 190 |
5 files changed, 362 insertions, 15 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/io.test b/tests/io.test index 06ae81d..6b6ad6d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1517,6 +1517,39 @@ test io-12.7 {ReadChars: too many chars read [bc5b790099]} { } close $c } {} +test io-12.8 {ReadChars: multibyte chars split} { + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xc2\xa0 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 -buffersize 10 + set in [read $f] + close $f + scan [string index $in end] %c +} 160 +test io-12.9 {ReadChars: multibyte chars split} { + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xc2 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 -buffersize 10 + set in [read $f] + close $f + scan [string index $in end] %c +} 194 +test io-12.10 {ReadChars: multibyte chars split} { + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xc2 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 -buffersize 11 + set in [read $f] + close $f + scan [string index $in end] %c +} 194 test io-13.1 {TranslateInputEOL: cr mode} {} { set f [open $path(test1) w] @@ -7355,7 +7388,7 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven set result "" fileevent $f1 read [namespace code { append result [read $f1 1024] - if {[string length $result] >= [string length $big]} { + if {[string length $result] >= [string length $big]+1} { set x done } }] @@ -7364,6 +7397,38 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven set big {} set x } done +test io-53.4.1 {Bug 894da183c8} {stdio fcopy} { + set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n + variable x + for {set x 0} {$x < 12} {incr x} { + append big $big + } + file delete $path(pipe) + set f1 [open $path(pipe) w] + puts $f1 [list file delete $path(test1)] + puts $f1 { + puts ready + set f [open io-53.4.1 w] + chan configure $f -translation lf + fcopy stdin $f -command { set x } + vwait x + close $f + } + puts $f1 "close \[[list open $path(test1) w]]" + close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set result [gets $f1] + fconfigure $f1 -blocking 0 -buffersize 125000 -translation lf + puts $f1 $big + fconfigure $f1 -blocking 1 + close $f1 + set big {} + while {[catch {glob $path(test1)}]} {after 50} + file delete $path(test1) + set check [file size io-53.4.1] + file delete io-53.4.1 + set check +} 266241 set result {} proc FcopyTestAccept {sock args} { after 1000 "close $sock" @@ -8542,6 +8607,25 @@ test io-73.4 {[5adc350683] [read] after EOF} -setup { } -result {1 1 {more data } 1} +test io-73.5 {effect of eof on encoding end flags} -setup { + set fn [makeFile {} io-73.5] + set rfd [open $fn r] + set wfd [open $fn a] + chan configure $wfd -buffering none -translation binary + chan configure $rfd -buffersize 5 -encoding utf-8 + read $rfd +} -body { + set result [eof $rfd] + puts -nonewline $wfd "more\u00c2\u00a0data" + lappend result [eof $rfd] + lappend result [read $rfd] + lappend result [eof $rfd] +} -cleanup { + close $wfd + close $rfd + removeFile io-73.5 +} -result [list 1 1 more\u00a0data 1] + # ### ### ### ######### ######### ######### # cleanup 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 |