diff options
Diffstat (limited to 'library/history.tcl')
| -rw-r--r-- | library/history.tcl | 302 |
1 files changed, 120 insertions, 182 deletions
diff --git a/library/history.tcl b/library/history.tcl index 888d144..fb722c8 100644 --- a/library/history.tcl +++ b/library/history.tcl @@ -4,18 +4,18 @@ # # 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 { @@ -24,163 +24,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]} { + 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 @@ -194,20 +109,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 @@ -221,7 +138,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 @@ -231,7 +148,7 @@ proc history {args} { oldest -$keep \ ] } - + # tcl::HistInfo -- # # Return a pretty-printed version of the history list @@ -242,14 +159,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 @@ -260,11 +179,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, @@ -276,20 +195,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. @@ -299,22 +216,22 @@ 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)]} { - return $i; + return $i } if {[string match $event $history($i)]} { - return $i; + return $i } } return -code error "no event matches \"$event\"" @@ -331,43 +248,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: |