From 5e86c93adf8d3a23361d8e09aaae609f3a550f05 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 25 Jul 2009 21:51:02 +0000
Subject: Make [history] (well, [::tcl::history]) be a real ensemble.

---
 ChangeLog           |   6 ++
 library/history.tcl | 300 +++++++++++++++++++++-------------------------------
 tests/history.test  |  18 ++--
 3 files changed, 134 insertions(+), 190 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 12ff42e..3be3af2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2009-07-25  Donal K. Fellows  <dkf@users.sf.net>
+
+	* library/history.tcl (history): Reworked the history mechanism in
+	terms of ensembles, rather than the ad hoc ensemble-lite mechanism
+	used previously.
+
 2009-07-24  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/self.n (self class): [Bug 2704302]: Add some text to make it
diff --git a/library/history.tcl b/library/history.tcl
index 3a3f16a..077d604 100644
--- a/library/history.tcl
+++ b/library/history.tcl
@@ -2,22 +2,22 @@
 #
 # Implementation of the history command.
 #
-# RCS: @(#) $Id: history.tcl,v 1.7 2005/07/23 04:12:49 dgp Exp $
+# RCS: @(#) $Id: history.tcl,v 1.8 2009/07/25 21:51:02 dkf Exp $
 #
 # Copyright (c) 1997 Sun Microsystems, Inc.
 #
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-
-# The tcl::history array holds the history list and
-# some additional bookkeeping variables.
+
+# The tcl::history array holds the history list and some additional
+# bookkeeping variables.
 #
 # nextid	the index used for the next history list item.
 # keep		the max size of the history list
 # oldest	the index of the oldest item in the history.
 
-namespace eval tcl {
+namespace eval ::tcl {
     variable history
     if {![info exists history]} {
 	array set history {
@@ -26,163 +26,78 @@ namespace eval tcl {
 	    oldest	-20
 	}
     }
-}
 
+    namespace ensemble create -command ::tcl::history -map {
+	add	::tcl::HistAdd
+	change	::tcl::HistChange
+	clear	::tcl::HistClear
+	event	::tcl::HistEvent
+	info	::tcl::HistInfo
+	keep	::tcl::HistKeep
+	nextid	::tcl::HistNextID
+	redo	::tcl::HistRedo
+    }
+}
+
 # history --
 #
 #	This is the main history command.  See the man page for its interface.
-#	This does argument checking and calls helper procedures in the
-#	history namespace.
-
-proc history {args} {
-    set len [llength $args]
-    if {$len == 0} {
-	return [tcl::HistInfo]
-    }
-    set key [lindex $args 0]
-    set options "add, change, clear, event, info, keep, nextid, or redo"
-    switch -glob -- $key {
-	a* { # history add
-
-	    if {$len > 3} {
-		return -code error "wrong # args: should be \"history add event ?exec?\""
-	    }
-	    if {![string match $key* add]} {
-		return -code error "bad option \"$key\": must be $options"
-	    }
-	    if {$len == 3} {
-		set arg [lindex $args 2]
-		if {! ([string match e* $arg] && [string match $arg* exec])} {
-		    return -code error "bad argument \"$arg\": should be \"exec\""
-		}
-	    }
-	    return [tcl::HistAdd [lindex $args 1] [lindex $args 2]]
-	}
-	ch* { # history change
-
-	    if {($len > 3) || ($len < 2)} {
-		return -code error "wrong # args: should be \"history change newValue ?event?\""
-	    }
-	    if {![string match $key* change]} {
-		return -code error "bad option \"$key\": must be $options"
-	    }
-	    if {$len == 2} {
-		set event 0
-	    } else {
-		set event [lindex $args 2]
-	    }
-
-	    return [tcl::HistChange [lindex $args 1] $event]
-	}
-	cl* { # history clear
-
-	    if {($len > 1)} {
-		return -code error "wrong # args: should be \"history clear\""
-	    }
-	    if {![string match $key* clear]} {
-		return -code error "bad option \"$key\": must be $options"
-	    }
-	    return [tcl::HistClear]
-	}
-	e* { # history event
-
-	    if {$len > 2} {
-		return -code error "wrong # args: should be \"history event ?event?\""
-	    }
-	    if {![string match $key* event]} {
-		return -code error "bad option \"$key\": must be $options"
-	    }
-	    if {$len == 1} {
-		set event -1
-	    } else {
-		set event [lindex $args 1]
-	    }
-	    return [tcl::HistEvent $event]
-	}
-	i* { # history info
-
-	    if {$len > 2} {
-		return -code error "wrong # args: should be \"history info ?count?\""
-	    }
-	    if {![string match $key* info]} {
-		return -code error "bad option \"$key\": must be $options"
-	    }
-	    return [tcl::HistInfo [lindex $args 1]]
-	}
-	k* { # history keep
+#	This does some argument checking and calls the helper ensemble in the
+#	tcl namespace.
 
-	    if {$len > 2} {
-		return -code error "wrong # args: should be \"history keep ?count?\""
-	    }
-	    if {$len == 1} {
-		return [tcl::HistKeep]
-	    } else {
-		set limit [lindex $args 1]
-		if {[catch {expr {~$limit}}] || ($limit < 0)} {
-		    return -code error "illegal keep count \"$limit\""
-		}
-		return [tcl::HistKeep $limit]
-	    }
-	}
-	n* { # history nextid
-
-	    if {$len > 1} {
-		return -code error "wrong # args: should be \"history nextid\""
-	    }
-	    if {![string match $key* nextid]} {
-		return -code error "bad option \"$key\": must be $options"
-	    }
-	    return [expr {$tcl::history(nextid) + 1}]
-	}
-	r* { # history redo
+proc ::history {args} {
+    # If no command given, we're doing 'history info'. Can't be done with an
+    # ensemble unknown handler, as those don't fire when no subcommand is
+    # given at all.
 
-	    if {$len > 2} {
-		return -code error "wrong # args: should be \"history redo ?event?\""
-	    }
-	    if {![string match $key* redo]} {
-		return -code error "bad option \"$key\": must be $options"
-	    }
-	    return [tcl::HistRedo [lindex $args 1]]
-	}
-	default {
-	    return -code error "bad option \"$key\": must be $options"
-	}
+    if {[llength $args] == 0} {
+	set args info
     }
-}
 
+    # Tricky stuff needed to make stack and errors come out right!
+    tailcall apply {args {tailcall history {*}$args} ::tcl} {*}$args
+}
+
 # tcl::HistAdd --
 #
 #	Add an item to the history, and optionally eval it at the global scope
 #
 # Parameters:
-#	command		the command to add
-#	exec		(optional) a substring of "exec" causes the
-#			command to be evaled.
+#	event		the command to add
+#	exec		(optional) a substring of "exec" causes the command to
+#			be evaled.
 # Results:
 # 	If executing, then the results of the command are returned
 #
 # Side Effects:
 #	Adds to the history list
 
- proc tcl::HistAdd {command {exec {}}} {
+proc ::tcl::HistAdd {event {exec {}}} {
     variable history
 
+    if {
+	[prefix longest {exec {}} $exec] eq ""
+	&& [llength [info level 0]] == 3
+    } then {
+	return -code error "bad argument \"$exec\": should be \"exec\""
+    }
+
     # Do not add empty commands to the history
-    if {[string trim $command] eq ""} {
+    if {[string trim $event] eq ""} {
 	return ""
     }
 
-    set i [incr history(nextid)]
-    set history($i) $command
-    set j [incr history(oldest)]
-    unset -nocomplain history($j)
-    if {[string match e* $exec]} {
-	return [uplevel #0 $command]
-    } else {
-	return {}
+    # Maintain the history
+    set history([incr history(nextid)]) $event
+    unset -nocomplain history([incr history(oldest)])
+
+    # Only execute if 'exec' (or non-empty prefix of it) given
+    if {$exec eq ""} {
+	return ""
     }
+    tailcall eval $event
 }
-
+
 # tcl::HistKeep --
 #
 #	Set or query the limit on the length of the history list
@@ -196,20 +111,22 @@ proc history {args} {
 # Side Effects:
 #	Updates history(keep) if a limit is specified
 
- proc tcl::HistKeep {{limit {}}} {
+proc ::tcl::HistKeep {{count {}}} {
     variable history
-    if {$limit eq ""} {
+    if {[llength [info level 0]] == 1} {
 	return $history(keep)
-    } else {
-	set oldold $history(oldest)
-	set history(oldest) [expr {$history(nextid) - $limit}]
-	for {} {$oldold <= $history(oldest)} {incr oldold} {
-	    unset -nocomplain history($oldold)
-	}
-	set history(keep) $limit
     }
+    if {![string is integer -strict $count] || ($count < 0)} {
+	return -code error "illegal keep count \"$count\""
+    }
+    set oldold $history(oldest)
+    set history(oldest) [expr {$history(nextid) - $count}]
+    for {} {$oldold <= $history(oldest)} {incr oldold} {
+	unset -nocomplain history($oldold)
+    }
+    set history(keep) $count
 }
-
+
 # tcl::HistClear --
 #
 #	Erase the history list
@@ -223,7 +140,7 @@ proc history {args} {
 # Side Effects:
 #	Resets the history array, except for the keep limit
 
- proc tcl::HistClear {} {
+proc ::tcl::HistClear {} {
     variable history
     set keep $history(keep)
     unset history
@@ -233,7 +150,7 @@ proc history {args} {
 	oldest	-$keep	\
     ]
 }
-
+
 # tcl::HistInfo --
 #
 #	Return a pretty-printed version of the history list
@@ -244,14 +161,16 @@ proc history {args} {
 # Results:
 #	A formatted history list
 
- proc tcl::HistInfo {{num {}}} {
+proc ::tcl::HistInfo {{count {}}} {
     variable history
-    if {$num eq ""} {
-	set num [expr {$history(keep) + 1}]
+    if {[llength [info level 0]] == 1} {
+	set count [expr {$history(keep) + 1}]
+    } elseif {![string is integer -strict $count]} {
+	return -code error "bad integer \"$count\""
     }
     set result {}
     set newline ""
-    for {set i [expr {$history(nextid) - $num + 1}]} \
+    for {set i [expr {$history(nextid) - $count + 1}]} \
 	    {$i <= $history(nextid)} {incr i} {
 	if {![info exists history($i)]} {
 	    continue
@@ -262,11 +181,11 @@ proc history {args} {
     }
     return $result
 }
-
+
 # tcl::HistRedo --
 #
-#	Fetch the previous or specified event, execute it, and then
-#	replace the current history item with that event.
+#	Fetch the previous or specified event, execute it, and then replace
+#	the current history item with that event.
 #
 # Parameters:
 #	event	(optional) index of history item to redo.  Defaults to -1,
@@ -278,20 +197,18 @@ proc history {args} {
 # Side Effects:
 #	Replaces the current history list item with the one being redone.
 
- proc tcl::HistRedo {{event -1}} {
+proc ::tcl::HistRedo {{event -1}} {
     variable history
-    if {$event eq ""} {
-	set event -1
-    }
+
     set i [HistIndex $event]
     if {$i == $history(nextid)} {
 	return -code error "cannot redo the current event"
     }
     set cmd $history($i)
     HistChange $cmd 0
-    uplevel #0 $cmd
+    tailcall eval $cmd
 }
-
+
 # tcl::HistIndex --
 #
 #	Map from an event specifier to an index in the history list.
@@ -301,15 +218,15 @@ proc history {args} {
 #		If this is a positive number, it is used directly.
 #		If it is a negative number, then it counts back to a previous
 #		event, where -1 is the most recent event.
-#		A string can be matched, either by being the prefix of
-#		a command or by matching a command with string match.
+#		A string can be matched, either by being the prefix of a
+#		command or by matching a command with string match.
 #
 # Results:
 #	The index into history, or an error if the index didn't match.
 
- proc tcl::HistIndex {event} {
+proc ::tcl::HistIndex {event} {
     variable history
-    if {[catch {expr {~$event}}]} {
+    if {![string is integer -strict $event]} {
 	for {set i [expr {$history(nextid)-1}]} {[info exists history($i)]} \
 		{incr i -1} {
 	    if {[string match $event* $history($i)]} {
@@ -333,43 +250,64 @@ proc history {args} {
     }
     return $i
 }
-
+
 # tcl::HistEvent --
 #
 #	Map from an event specifier to the value in the history list.
 #
 # Parameters:
-#	event	index of history item to redo.  See index for a
-#		description of possible event patterns.
+#	event	index of history item to redo.  See index for a description of
+#		possible event patterns.
 #
 # Results:
 #	The value from the history list.
 
- proc tcl::HistEvent {event} {
+proc ::tcl::HistEvent {{event -1}} {
     variable history
     set i [HistIndex $event]
-    if {[info exists history($i)]} {
-	return [string trimright $history($i) \ \n]
-    } else {
-	return "";
+    if {![info exists history($i)]} {
+	return ""
     }
+    return [string trimright $history($i) \ \n]
 }
-
+
 # tcl::HistChange --
 #
 #	Replace a value in the history list.
 #
 # Parameters:
-#	cmd	The new value to put into the history list.
-#	event	(optional) index of history item to redo.  See index for a
-#		description of possible event patterns.  This defaults
-#		to 0, which specifies the current event.
+#	newValue  The new value to put into the history list.
+#	event	  (optional) index of history item to redo.  See index for a
+#		  description of possible event patterns.  This defaults to 0,
+#		  which specifies the current event.
 #
 # Side Effects:
 #	Changes the history list.
 
- proc tcl::HistChange {cmd {event 0}} {
+proc ::tcl::HistChange {newValue {event 0}} {
     variable history
     set i [HistIndex $event]
-    set history($i) $cmd
+    set history($i) $newValue
 }
+
+# tcl::HistNextID --
+#
+#	Returns the number of the next history event.
+#
+# Parameters:
+#	None.
+#
+# Side Effects:
+#	None.
+
+proc ::tcl::HistNextID {} {
+    variable history
+    return [expr {$history(nextid) + 1}]
+}
+
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/tests/history.test b/tests/history.test
index b283b1a..3f02aa0 100644
--- a/tests/history.test
+++ b/tests/history.test
@@ -1,17 +1,17 @@
 # Commands covered:  history
 #
-# This file contains a collection of tests for one or more of the Tcl
-# built-in commands.  Sourcing this file into Tcl runs the tests and
-# generates output for errors.  No output means no errors were found.
+# This file contains a collection of tests for one or more of the Tcl built-in
+# commands.  Sourcing this file into Tcl runs the tests and generates output
+# for errors.  No output means no errors were found.
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994 Sun Microsystems, Inc.
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 #
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: history.test,v 1.6 2004/05/19 12:43:03 dkf Exp $
+# RCS: @(#) $Id: history.test,v 1.7 2009/07/25 21:51:02 dkf Exp $
   
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -35,7 +35,7 @@ if {[testConstraint history]} {
     # Dummy value, must be numeric
     set num 0
 }
-
+
 # "history event"
 
 test history-1.1 {event option} history {history event -1} \
@@ -245,8 +245,8 @@ test history-9.1 {miscellaneous} history {catch {history gorp} msg} 1
 test history-9.2 {miscellaneous} history {
     catch {history gorp} msg
     set msg
-} {bad option "gorp": must be add, change, clear, event, info, keep, nextid, or redo}
-
+} {unknown or ambiguous subcommand "gorp": must be add, change, clear, event, info, keep, nextid, or redo}
+
 # cleanup
 ::tcltest::cleanupTests
 return
-- 
cgit v0.12