diff options
| -rw-r--r-- | generic/tclZlib.c | 7 | ||||
| -rw-r--r-- | library/history.tcl | 24 | ||||
| -rw-r--r-- | tests/history.test | 58 |
3 files changed, 82 insertions, 7 deletions
diff --git a/generic/tclZlib.c b/generic/tclZlib.c index fd8b3a1..7f7aff6 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -3177,10 +3177,8 @@ ZlibTransformFlush( * Get the bytes to go out of the compression engine. */ - cd->outStream.next_out = (Bytef *) cd->outBuffer; - cd->outStream.avail_out = cd->outAllocated; - - e = deflate(&cd->outStream, flushType); + e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated, + flushType, &len); if (e != Z_OK && e != Z_BUF_ERROR) { ConvertError(interp, e, cd->outStream.adler); return TCL_ERROR; @@ -3190,7 +3188,6 @@ ZlibTransformFlush( * Write the bytes we've received to the next layer. */ - len = cd->outStream.next_out - (Bytef *) cd->outBuffer; if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) < 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "problem flushing channel: %s", diff --git a/library/history.tcl b/library/history.tcl index 51d2404..ef9099b 100644 --- a/library/history.tcl +++ b/library/history.tcl @@ -56,6 +56,30 @@ proc ::history {args} { tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args } +# (unnamed) -- +# +# Callback when [::history] is destroyed. Destroys the implementation. +# +# Parameters: +# oldName what the command was called. +# newName what the command is now called (an empty string). +# op the operation (= delete). +# +# Results: +# none +# +# Side Effects: +# The implementation of the [::history] command ceases to exist. + +trace add command ::history delete [list apply {{oldName newName op} { + variable history + unset -nocomplain history + foreach c [info procs ::tcl::Hist*] { + rename $c {} + } + rename ::tcl::history {} +} ::tcl}] + # tcl::HistAdd -- # # Add an item to the history, and optionally eval it at the global scope diff --git a/tests/history.test b/tests/history.test index c2d2124..9ff41f2 100644 --- a/tests/history.test +++ b/tests/history.test @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } @@ -245,6 +245,60 @@ test history-9.2 {miscellaneous} history { catch {history gorp} msg set msg } {unknown or ambiguous subcommand "gorp": must be add, change, clear, event, info, keep, nextid, or redo} + +# History retains references; Bug 1ae12987cb +test history-10.1 {references kept by history} -constraints history -setup { + interp create histtest + histtest eval { + # Trigger any autoloading that might be present + catch {history} + proc refcount {x} { + set rep [::tcl::unsupported::representation $x] + regexp {with a refcount of (\d+)} $rep -> rc + # Ignore the references due to calling this procedure + return [expr {$rc - 3}] + } + } +} -body { + histtest eval { + # A fresh object, refcount 1 from the variable we write it to + set obj [expr rand()] + set baseline [refcount $obj] + lappend result [refcount $obj] + history add [list list $obj] + lappend result [refcount $obj] + history clear + lappend result [refcount $obj] + } +} -cleanup { + interp delete histtest +} -result {1 2 1} +test history-10.2 {references kept by history} -constraints history -setup { + interp create histtest + histtest eval { + # Trigger any autoloading that might be present + catch {history} + proc refcount {x} { + set rep [::tcl::unsupported::representation $x] + regexp {with a refcount of (\d+)} $rep -> rc + # Ignore the references due to calling this procedure + return [expr {$rc - 3}] + } + } +} -body { + histtest eval { + # A fresh object, refcount 1 from the variable we write it to + set obj [expr rand()] + set baseline [refcount $obj] + lappend result [refcount $obj] + history add [list list $obj] + lappend result [refcount $obj] + rename history {} + lappend result [refcount $obj] + } +} -cleanup { + interp delete histtest +} -result {1 2 1} # cleanup ::tcltest::cleanupTests |