util/src/TclTk/tcl8.6.12/library/history.tcl

   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 \f
  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 \f
  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 \f
  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 \f
  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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 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 \f
 330 return
 331
 332 # Local Variables:
 333 # mode: tcl
 334 # fill-column: 78
 335 # End: