From df54f23b9fdd17bc3eb02a15f3fd9513e6261b7e Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 30 Oct 2016 08:22:13 +0000
Subject: [1ae12987cb] Ensure that deleting the [history] command deletes its
 storage.

---
 library/history.tcl | 24 ++++++++++++++++++++++
 tests/history.test  | 58 +++++++++++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 80 insertions(+), 2 deletions(-)

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 7549beb..3201ad7 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
-- 
cgit v0.12