path: root/library/history.tcl

# history.tcl --
#
# Implementation of the history command.
#
# RCS: @(#) $Id: history.tcl,v 1.10 2009/11/19 11:59:54 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.
#

# 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 {
    variable history
    if {![info exists history]} {
	array set history {
	    nextid	0
	    keep	20
	    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 some argument checking and calls the helper ensemble in the
#	tcl namespace.

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 {[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:
#	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 {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 $event] eq ""} {
	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
#
# Parameters:
#	limit	(optional) the length of the history list
#
# Results:
#	If no limit is specified, the current limit is returned
#
# Side Effects:
#	Updates history(keep) if a limit is specified

proc ::tcl::HistKeep {{count {}}} {
    variable history
    if {[llength [info level 0]] == 1} {
	return $history(keep)
    }
    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
#
# Parameters:
#	none
#
# Results:
#	none
#
# Side Effects:
#	Resets the history array, except for the keep limit

proc ::tcl::HistClear {} {
    variable history
    set keep $history(keep)
    unset history
    array set history [list \
	nextid	0	\
	keep	$keep	\
	oldest	-$keep	\
    ]
}

# tcl::HistInfo --
#
#	Return a pretty-printed version of the history list
#
# Parameters:
#	num	(optional) the length of the history list to return
#
# Results:
#	A formatted history list

proc ::tcl::HistInfo {{count {}}} {
    variable history
    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) - $count + 1}]} \
	    {$i <= $history(nextid)} {incr i} {
	if {![info exists history($i)]} {
	    continue
	}
        set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]]
	append result $newline[format "%6d  %s" $i $cmd]
	set newline \n
    }
    return $result
}

# tcl::HistRedo --
#
#	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,
#		which means the previous event.
#
# Results:
#	Those of the command being redone.
#
# Side Effects:
#	Replaces the current history list item with the one being redone.

proc ::tcl::HistRedo {{event -1}} {
    variable history

    set i [HistIndex $event]
    if {$i == $history(nextid)} {
	return -code error "cannot redo the current event"
    }
    set cmd $history($i)
    HistChange $cmd 0
    tailcall eval $cmd
}

# tcl::HistIndex --
#
#	Map from an event specifier to an index in the history list.
#
# Parameters:
#	event	index of history item to redo.
#		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.
#
# Results:
#	The index into history, or an error if the index didn't match.

proc ::tcl::HistIndex {event} {
    variable history
    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;
	    }
	    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
}

# 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.
#
# Results:
#	The value from the history list.

proc ::tcl::HistEvent {{event -1}} {
    variable history
    set i [HistIndex $event]
    if {![info exists history($i)]} {
	return ""
    }
    return [string trimright $history($i) \ \n]
}

# tcl::HistChange --
#
#	Replace a value in the history list.
#
# Parameters:
#	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 {newValue {event 0}} {
    variable history
    set i [HistIndex $event]
    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: