figenc

[RADIOACTIVE] rsa and symmetric key encryption scripts and executables
git clone git://git.figbert.com/figenc.git
Log | Files | Refs | README

history.tcl (7900B)


      1 # history.tcl --
      2 #
      3 # Implementation of the history command.
      4 #
      5 # Copyright (c) 1997 Sun Microsystems, Inc.
      6 #
      7 # See the file "license.terms" for information on usage and redistribution of
      8 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
      9 #
     10 
     11 # The tcl::history array holds the history list and some additional
     12 # bookkeeping variables.
     13 #
     14 # nextid	the index used for the next history list item.
     15 # keep		the max size of the history list
     16 # oldest	the index of the oldest item in the history.
     17 
     18 namespace eval ::tcl {
     19     variable history
     20     if {![info exists history]} {
     21 	array set history {
     22 	    nextid	0
     23 	    keep	20
     24 	    oldest	-20
     25 	}
     26     }
     27 
     28     namespace ensemble create -command ::tcl::history -map {
     29 	add	::tcl::HistAdd
     30 	change	::tcl::HistChange
     31 	clear	::tcl::HistClear
     32 	event	::tcl::HistEvent
     33 	info	::tcl::HistInfo
     34 	keep	::tcl::HistKeep
     35 	nextid	::tcl::HistNextID
     36 	redo	::tcl::HistRedo
     37     }
     38 }
     39 
     40 # history --
     41 #
     42 #	This is the main history command.  See the man page for its interface.
     43 #	This does some argument checking and calls the helper ensemble in the
     44 #	tcl namespace.
     45 
     46 proc ::history {args} {
     47     # If no command given, we're doing 'history info'. Can't be done with an
     48     # ensemble unknown handler, as those don't fire when no subcommand is
     49     # given at all.
     50 
     51     if {![llength $args]} {
     52 	set args info
     53     }
     54 
     55     # Tricky stuff needed to make stack and errors come out right!
     56     tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args
     57 }
     58 
     59 # (unnamed) --
     60 #
     61 #	Callback when [::history] is destroyed. Destroys the implementation.
     62 #
     63 # Parameters:
     64 #	oldName    what the command was called.
     65 #	newName    what the command is now called (an empty string).
     66 #	op	   the operation (= delete).
     67 #
     68 # Results:
     69 #	none
     70 #
     71 # Side Effects:
     72 #	The implementation of the [::history] command ceases to exist.
     73 
     74 trace add command ::history delete [list apply {{oldName newName op} {
     75     variable history
     76     unset -nocomplain history
     77     foreach c [info procs ::tcl::Hist*] {
     78 	rename $c {}
     79     }
     80     rename ::tcl::history {}
     81 } ::tcl}]
     82 
     83 # tcl::HistAdd --
     84 #
     85 #	Add an item to the history, and optionally eval it at the global scope
     86 #
     87 # Parameters:
     88 #	event		the command to add
     89 #	exec		(optional) a substring of "exec" causes the command to
     90 #			be evaled.
     91 # Results:
     92 # 	If executing, then the results of the command are returned
     93 #
     94 # Side Effects:
     95 #	Adds to the history list
     96 
     97 proc ::tcl::HistAdd {event {exec {}}} {
     98     variable history
     99 
    100     if {
    101 	[prefix longest {exec {}} $exec] eq ""
    102 	&& [llength [info level 0]] == 3
    103     } then {
    104 	return -code error "bad argument \"$exec\": should be \"exec\""
    105     }
    106 
    107     # Do not add empty commands to the history
    108     if {[string trim $event] eq ""} {
    109 	return ""
    110     }
    111 
    112     # Maintain the history
    113     set history([incr history(nextid)]) $event
    114     unset -nocomplain history([incr history(oldest)])
    115 
    116     # Only execute if 'exec' (or non-empty prefix of it) given
    117     if {$exec eq ""} {
    118 	return ""
    119     }
    120     tailcall eval $event
    121 }
    122 
    123 # tcl::HistKeep --
    124 #
    125 #	Set or query the limit on the length of the history list
    126 #
    127 # Parameters:
    128 #	limit	(optional) the length of the history list
    129 #
    130 # Results:
    131 #	If no limit is specified, the current limit is returned
    132 #
    133 # Side Effects:
    134 #	Updates history(keep) if a limit is specified
    135 
    136 proc ::tcl::HistKeep {{count {}}} {
    137     variable history
    138     if {[llength [info level 0]] == 1} {
    139 	return $history(keep)
    140     }
    141     if {![string is integer -strict $count] || ($count < 0)} {
    142 	return -code error "illegal keep count \"$count\""
    143     }
    144     set oldold $history(oldest)
    145     set history(oldest) [expr {$history(nextid) - $count}]
    146     for {} {$oldold <= $history(oldest)} {incr oldold} {
    147 	unset -nocomplain history($oldold)
    148     }
    149     set history(keep) $count
    150 }
    151 
    152 # tcl::HistClear --
    153 #
    154 #	Erase the history list
    155 #
    156 # Parameters:
    157 #	none
    158 #
    159 # Results:
    160 #	none
    161 #
    162 # Side Effects:
    163 #	Resets the history array, except for the keep limit
    164 
    165 proc ::tcl::HistClear {} {
    166     variable history
    167     set keep $history(keep)
    168     unset history
    169     array set history [list \
    170 	nextid	0	\
    171 	keep	$keep	\
    172 	oldest	-$keep	\
    173     ]
    174 }
    175 
    176 # tcl::HistInfo --
    177 #
    178 #	Return a pretty-printed version of the history list
    179 #
    180 # Parameters:
    181 #	num	(optional) the length of the history list to return
    182 #
    183 # Results:
    184 #	A formatted history list
    185 
    186 proc ::tcl::HistInfo {{count {}}} {
    187     variable history
    188     if {[llength [info level 0]] == 1} {
    189 	set count [expr {$history(keep) + 1}]
    190     } elseif {![string is integer -strict $count]} {
    191 	return -code error "bad integer \"$count\""
    192     }
    193     set result {}
    194     set newline ""
    195     for {set i [expr {$history(nextid) - $count + 1}]} \
    196 	    {$i <= $history(nextid)} {incr i} {
    197 	if {![info exists history($i)]} {
    198 	    continue
    199 	}
    200         set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]]
    201 	append result $newline[format "%6d  %s" $i $cmd]
    202 	set newline \n
    203     }
    204     return $result
    205 }
    206 
    207 # tcl::HistRedo --
    208 #
    209 #	Fetch the previous or specified event, execute it, and then replace
    210 #	the current history item with that event.
    211 #
    212 # Parameters:
    213 #	event	(optional) index of history item to redo.  Defaults to -1,
    214 #		which means the previous event.
    215 #
    216 # Results:
    217 #	Those of the command being redone.
    218 #
    219 # Side Effects:
    220 #	Replaces the current history list item with the one being redone.
    221 
    222 proc ::tcl::HistRedo {{event -1}} {
    223     variable history
    224 
    225     set i [HistIndex $event]
    226     if {$i == $history(nextid)} {
    227 	return -code error "cannot redo the current event"
    228     }
    229     set cmd $history($i)
    230     HistChange $cmd 0
    231     tailcall eval $cmd
    232 }
    233 
    234 # tcl::HistIndex --
    235 #
    236 #	Map from an event specifier to an index in the history list.
    237 #
    238 # Parameters:
    239 #	event	index of history item to redo.
    240 #		If this is a positive number, it is used directly.
    241 #		If it is a negative number, then it counts back to a previous
    242 #		event, where -1 is the most recent event.
    243 #		A string can be matched, either by being the prefix of a
    244 #		command or by matching a command with string match.
    245 #
    246 # Results:
    247 #	The index into history, or an error if the index didn't match.
    248 
    249 proc ::tcl::HistIndex {event} {
    250     variable history
    251     if {![string is integer -strict $event]} {
    252 	for {set i [expr {$history(nextid)-1}]} {[info exists history($i)]} \
    253 		{incr i -1} {
    254 	    if {[string match $event* $history($i)]} {
    255 		return $i
    256 	    }
    257 	    if {[string match $event $history($i)]} {
    258 		return $i
    259 	    }
    260 	}
    261 	return -code error "no event matches \"$event\""
    262     } elseif {$event <= 0} {
    263 	set i [expr {$history(nextid) + $event}]
    264     } else {
    265 	set i $event
    266     }
    267     if {$i <= $history(oldest)} {
    268 	return -code error "event \"$event\" is too far in the past"
    269     }
    270     if {$i > $history(nextid)} {
    271 	return -code error "event \"$event\" hasn't occured yet"
    272     }
    273     return $i
    274 }
    275 
    276 # tcl::HistEvent --
    277 #
    278 #	Map from an event specifier to the value in the history list.
    279 #
    280 # Parameters:
    281 #	event	index of history item to redo.  See index for a description of
    282 #		possible event patterns.
    283 #
    284 # Results:
    285 #	The value from the history list.
    286 
    287 proc ::tcl::HistEvent {{event -1}} {
    288     variable history
    289     set i [HistIndex $event]
    290     if {![info exists history($i)]} {
    291 	return ""
    292     }
    293     return [string trimright $history($i) \ \n]
    294 }
    295 
    296 # tcl::HistChange --
    297 #
    298 #	Replace a value in the history list.
    299 #
    300 # Parameters:
    301 #	newValue  The new value to put into the history list.
    302 #	event	  (optional) index of history item to redo.  See index for a
    303 #		  description of possible event patterns.  This defaults to 0,
    304 #		  which specifies the current event.
    305 #
    306 # Side Effects:
    307 #	Changes the history list.
    308 
    309 proc ::tcl::HistChange {newValue {event 0}} {
    310     variable history
    311     set i [HistIndex $event]
    312     set history($i) $newValue
    313 }
    314 
    315 # tcl::HistNextID --
    316 #
    317 #	Returns the number of the next history event.
    318 #
    319 # Parameters:
    320 #	None.
    321 #
    322 # Side Effects:
    323 #	None.
    324 
    325 proc ::tcl::HistNextID {} {
    326     variable history
    327     return [expr {$history(nextid) + 1}]
    328 }
    329 
    330 return
    331 
    332 # Local Variables:
    333 # mode: tcl
    334 # fill-column: 78
    335 # End: