diff options
| -rw-r--r-- | generic/tclOO.c | 9 | ||||
| -rw-r--r-- | library/http/http.tcl | 6 | ||||
| -rw-r--r-- | library/http/pkgIndex.tcl | 2 | ||||
| -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 | ||||
| -rw-r--r-- | unix/Makefile.in | 4 | ||||
| -rw-r--r-- | win/Makefile.in | 4 | ||||
| -rwxr-xr-x[-rw-r--r--] | win/tclWinFile.c | 0 |
10 files changed, 169 insertions, 124 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c index 77e668b..e2ef1ae 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1675,10 +1675,13 @@ Tcl_NewObjectInstance( /* * Take care to not delete a deleted object; that would be - * bad. [Bug 2903011] + * bad. [Bug 2903011] Also take care to make sure that we have + * the name of the command before we delete it. [Bug + * 9dd1bd7a74] */ if (!Deleted(oPtr)) { + (void) TclOOObjectName(interp, oPtr); Tcl_DeleteCommandFromToken(interp, oPtr->command); } return NULL; @@ -1821,10 +1824,12 @@ FinalizeAlloc( /* * Take care to not delete a deleted object; that would be bad. [Bug - * 2903011] + * 2903011] Also take care to make sure that we have the name of the + * command before we delete it. [Bug 9dd1bd7a74] */ if (!Deleted(oPtr)) { + (void) TclOOObjectName(interp, oPtr); Tcl_DeleteCommandFromToken(interp, oPtr->command); } DelRef(oPtr); diff --git a/library/http/http.tcl b/library/http/http.tcl index a6b2bfd..751ca13 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6 # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.8.8 +package provide http 2.8.9 namespace eval http { # Allow resourcing to not clobber existing data @@ -739,7 +739,7 @@ proc http::Connected { token proto phost srvurl} { } } if {!$accept_encoding_seen && ![info exists state(-handler)]} { - puts $sock "Accept-Encoding: deflate,gzip,compress" + puts $sock "Accept-Encoding: gzip,deflate,compress" } if {$isQueryChannel && $state(querylength) == 0} { # Try to determine size of data in channel. If we cannot seek, the @@ -1299,7 +1299,7 @@ proc http::Eof {token {force 0}} { set state(body) [zlib $coding $state(body)] } } err]} { - Log "error doing $coding '$state(body)'" + Log "error doing decompression: $err" return [Finish $token $err] } diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 27ba795..6e0301a 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6]} {return} -package ifneeded http 2.8.8 [list tclPkgSetup $dir http 2.8.8 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.8.9 [list tclPkgSetup $dir http 2.8.9 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] 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 diff --git a/unix/Makefile.in b/unix/Makefile.in index 46ff5cd..958e759 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -844,8 +844,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; - @echo "Installing package http 2.8.8 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.8.tm; + @echo "Installing package http 2.8.9 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.9.tm; @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ diff --git a/win/Makefile.in b/win/Makefile.in index 71d3fe6..168da2e 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -643,8 +643,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.8.8 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.8.tm; + @echo "Installing package http 2.8.9 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.9.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ diff --git a/win/tclWinFile.c b/win/tclWinFile.c index a5b14b4..a5b14b4 100644..100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c |