summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-07-25 21:51:02 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-07-25 21:51:02 (GMT)
commit5e86c93adf8d3a23361d8e09aaae609f3a550f05 (patch)
tree7343d886a21893ffca2e61c14f2f73fef4550243
parente1465aee3a159ab7eb67703d6b658593ed7e8cee (diff)
downloadtcl-5e86c93adf8d3a23361d8e09aaae609f3a550f05.zip
tcl-5e86c93adf8d3a23361d8e09aaae609f3a550f05.tar.gz
tcl-5e86c93adf8d3a23361d8e09aaae609f3a550f05.tar.bz2
Make [history] (well, [::tcl::history]) be a real ensemble.
-rw-r--r--ChangeLog6
-rw-r--r--library/history.tcl300
-rw-r--r--tests/history.test18
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