namespace eval tcl {
variable history
if {![info exists history]} {
array set history {
nextid 0
keep 20
oldest -20
}
}
}
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* {
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* {
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* {
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* {
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* {
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* {
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* {
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* {
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"
}
}
}
proc tcl::HistAdd {command {exec {}}} {
variable history
set i [incr history(nextid)]
set history($i) $command
set j [incr history(oldest)]
if {[info exists history($j)]} {unset history($j)}
if {[string match e* $exec]} {
return [uplevel } else {
return {}
}
}
proc tcl::HistKeep {{limit {}}} {
variable history
if {[string length $limit] == 0} {
return $history(keep)
} else {
set oldold $history(oldest)
set history(oldest) [expr {$history(nextid) - $limit}]
for {} {$oldold <= $history(oldest)} {incr oldold} {
if {[info exists history($oldold)]} {unset history($oldold)}
}
set history(keep) $limit
}
}
proc tcl::HistClear {} {
variable history
set keep $history(keep)
unset history
array set history [list \
nextid 0 \
keep $keep \
oldest -$keep \
]
}
proc tcl::HistInfo {{num {}}} {
variable history
if {$num == {}} {
set num [expr {$history(keep) + 1}]
}
set result {}
set newline ""
for {set i [expr {$history(nextid) - $num + 1}]} \
{$i <= $history(nextid)} {incr i} {
if {![info exists history($i)]} {
continue
}
set cmd [string trimright $history($i) \ \n]
regsub -all \n $cmd "\n\t" cmd
append result $newline[format "%6d %s" $i $cmd]
set newline \n
}
return $result
}
proc tcl::HistRedo {{event -1}} {
variable history
if {[string length $event] == 0} {
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 }
proc tcl::HistIndex {event} {
variable history
if {[catch {expr {~$event}}]} {
for {set i $history(nextid)} {[info exists history($i)]} {incr i -1} {
if {[string match $event* $history($i)]} {
return $i;
}
if {[string match $event $history($i)]} {
return $i;
}
}
return -code error "no event matches \"$event\""
} elseif {$event <= 0} {
set i [expr {$history(nextid) + $event}]
} else {
set i $event
}
if {$i <= $history(oldest)} {
return -code error "event \"$event\" is too far in the past"
}
if {$i > $history(nextid)} {
return -code error "event \"$event\" hasn't occured yet"
}
return $i
}
proc tcl::HistEvent {event} {
variable history
set i [HistIndex $event]
if {[info exists history($i)]} {
return [string trimright $history($i) \ \n]
} else {
return "";
}
}
proc tcl::HistChange {cmd {event 0}} {
variable history
set i [HistIndex $event]
set history($i) $cmd
}