summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2016-10-30 08:31:21 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2016-10-30 08:31:21 (GMT)
commit0fd35ed40dcf60d680dd8f063be7f6a66f531e20 (patch)
tree5b90fdc81afcbed854492b6a6a456ede133ab0fe
parent45a4c375a86403b18e66a8401235bf8a3a53f867 (diff)
parentdf54f23b9fdd17bc3eb02a15f3fd9513e6261b7e (diff)
downloadtcl-0fd35ed40dcf60d680dd8f063be7f6a66f531e20.zip
tcl-0fd35ed40dcf60d680dd8f063be7f6a66f531e20.tar.gz
tcl-0fd35ed40dcf60d680dd8f063be7f6a66f531e20.tar.bz2
[1ae12987cb] Ensure that deleting the [history] command deletes its storage.
-rw-r--r--generic/tclZlib.c7
-rw-r--r--library/history.tcl24
-rw-r--r--tests/history.test58
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