GWM I thought a useful tool would be a general undo/redo mechanism for an interface with many widgets. Here it is Undo and Redo undoable widgets.
In Tcl/Tk 8.4 it's all done for you with the -undo flag.Text widget undo/redo limitations and enhancements
Bryan Oakley's supertext widget has undo capabilities built in. Its behavior is slightly different than the below code, in that the supertext can also undo "undone" text (it is modeled after emacs). Contrast that to the code below which uses a separate action to undo undone text (ie: redo). As a side effect, the supertext version lets you undo absolutely everything, but the undo/redo mechanism doesn't. Also, the code below implements "undo reset", which was unfortunately left out of the supertext widget (though it's easy to add).Some may prefer one behavior over the other. Plus, the supertext widget is a complete widget rather than a set of procs to attach to a plain widget, though it would probably be easy to extract the undo code. That might make for a nice project for someone...The supertext widget can be found here: http://www1.clearlight.com/~oakley/tcl/
It's interesting to note that both solutions are approximately the same number of lines of code -- mid-200's sans comments -- though supertext has more comments :-)
;# *************************************************************************
;# * File : undoer.tcl
;# * Purpose: Implement an undo/redo facility for a text widget
;# *
;# * Author : Tom Wilkason lifted from code by Jean-Luc Fontaine
;#
;# * Dated : 9/3/2000
;# *
;# *************************************************************************
set RH {
Revision History:
-----------------
$Revision: 1.8 $
$Log: 1333,v $
Revision 1.8 2006-09-07 18:00:05 jcw
1333-1157640938-84.92.246.238
Revision 1.5 2004/09/09 06:00:19 jcw
1333-1094647723-vince,62.244.183.98
}
if {![info exists classNewId]} {
# work around object creation between multiple include of this file problem
set classNewId 0
}
;##
;# Call this to get a new undoer for some text widget
;# e.g. UnDonew textUndoer .text.widget
;#
proc UnDonew {className args} {
# calls the constructor for the class with optional arguments
# and returns a unique object identifier independent of the class name
global classNewId
# use local variable for id for new can be called recursively
set id [incr classNewId]
if {[llength [info procs ${className}:$className]]>0} {
# avoid catch to track errors
eval ${className}:$className $id $args
}
return $id
}
proc UnDodelete {className id} {
# calls the destructor for the class and UnDodelete all the object data members
if {[llength [info procs ${className}:~$className]]>0} {
# avoid catch to track errors
catch {${className}:~$className $id}
}
global $className
# and UnDodelete all this object array members if any (assume that they were stored as $className($id,memberName))
foreach name [array names $className "$id,*"] {
unset ${className}($name)
}
}
proc udLifo:udLifo {id {size 2147483647}} {
global udLifo
set udLifo($id,maximumSize) $size
udLifo:empty $id
}
proc udLifo:push {id data} {
global udLifo saveTextMsg
set saveTextMsg 1
udLifo:tidyUp $id
if {$udLifo($id,size)>=$udLifo($id,maximumSize)} {
unset udLifo($id,data,$udLifo($id,first))
incr udLifo($id,first)
incr udLifo($id,size) -1
}
set udLifo($id,data,[incr udLifo($id,last)]) $data
incr udLifo($id,size)
}
proc udLifo:pop {id} {
global udLifo saveTextMsg
set saveTextMsg 1
udLifo:tidyUp $id
if {$udLifo($id,last)<$udLifo($id,first)} {
error "udLifo($id) pop error, empty"
}
# delay unsetting popped data to improve performance by avoiding a data copy
set udLifo($id,unset) $udLifo($id,last)
incr udLifo($id,last) -1
incr udLifo($id,size) -1
return $udLifo($id,data,$udLifo($id,unset))
}
proc udLifo:tidyUp {id} {
global udLifo
if {[info exists udLifo($id,unset)]} {
unset udLifo($id,data,$udLifo($id,unset))
unset udLifo($id,unset)
}
}
proc udLifo:empty {id} {
global udLifo
udLifo:tidyUp $id
foreach name [array names udLifo $id,data,*] {
unset udLifo($name)
}
set udLifo($id,size) 0
set udLifo($id,first) 0
set udLifo($id,last) -1
}
proc textUndoer:textUndoer {id widget {depth 2147483647}} {
global textUndoer
if {[string compare [winfo class $widget] Text]!=0} {
error "textUndoer error: widget $widget is not a text widget"
}
set textUndoer($id,widget) $widget
set textUndoer($id,originalBindingTags) [bindtags $widget]
bindtags $widget [concat $textUndoer($id,originalBindingTags) UndoBindings($id)]
bind UndoBindings($id) <Control-u> "textUndoer:undo $id"
# self destruct automatically when text widget is gone
bind UndoBindings($id) <Destroy> "UnDodelete textUndoer $id"
# rename widget command
rename $widget [set textUndoer($id,originalCommand) textUndoer:original$widget]
# and intercept modifying instructions before calling original command
proc $widget {args} "textUndoer:checkpoint $id \$args;
global search_count;
eval $textUndoer($id,originalCommand) \$args"
set textUndoer($id,commandStack) [UnDonew udLifo $depth]
set textUndoer($id,cursorStack) [UnDonew udLifo $depth]
#lee
textRedoer:textRedoer $id $widget $depth
}
proc textUndoer:~textUndoer {id} {
global textUndoer
bindtags $textUndoer($id,widget) $textUndoer($id,originalBindingTags)
rename $textUndoer($id,widget) ""
rename $textUndoer($id,originalCommand) $textUndoer($id,widget)
UnDodelete udLifo $textUndoer($id,commandStack)
UnDodelete udLifo $textUndoer($id,cursorStack)
#lee
textRedoer:~textRedoer $id
}
proc textUndoer:checkpoint {id arguments} {
global textUndoer textRedoer
# do nothing if non modifying command
if {[string compare [lindex $arguments 0] insert]==0} {
textUndoer:processInsertion $id [lrange $arguments 1 end]
if {$textRedoer($id,redo) == 0} {
textRedoer:reset $id
}
}
if {[string compare [lindex $arguments 0] delete]==0} {
textUndoer:processDeletion $id [lrange $arguments 1 end]
if {$textRedoer($id,redo) == 0} {
textRedoer:reset $id
}
}
}
proc textUndoer:processInsertion {id arguments} {
global textUndoer
set number [llength $arguments]
set length 0
# calculate total insertion length while skipping tags in arguments
for {set index 1} {$index<$number} {incr index 2} {
incr length [string length [lindex $arguments $index]]
}
if {$length>0} {
set index [$textUndoer($id,originalCommand) index [lindex $arguments 0]]
udLifo:push $textUndoer($id,commandStack) "delete $index $index+${length}c"
udLifo:push $textUndoer($id,cursorStack) [$textUndoer($id,originalCommand) index insert]
}
}
proc textUndoer:processDeletion {id arguments} {
global textUndoer
set command $textUndoer($id,originalCommand)
udLifo:push $textUndoer($id,cursorStack) [$command index insert]
set start [$command index [lindex $arguments 0]]
if {[llength $arguments]>1} {
udLifo:push $textUndoer($id,commandStack) "insert $start [list [$command get $start [lindex $arguments 1]]]"
} else {
udLifo:push $textUndoer($id,commandStack) "insert $start [list [$command get $start]]"
}
}
proc textUndoer:undo {id} {
global textUndoer
if {[catch {set cursor [udLifo:pop $textUndoer($id,cursorStack)]}]} {
return
}
if {[catch {set popArgs [udLifo:pop $textUndoer($id,commandStack)]}]} {
return
}
textRedoer:checkpoint $id $popArgs
eval $textUndoer($id,originalCommand) $popArgs
# now restore cursor position
$textUndoer($id,originalCommand) mark set insert $cursor
# make sure insertion point can be seen
$textUndoer($id,originalCommand) see insert
}
proc textUndoer:reset {id} {
global textUndoer
udLifo:empty $textUndoer($id,commandStack)
udLifo:empty $textUndoer($id,cursorStack)
}
#########################################################################
proc textRedoer:textRedoer {id widget {depth 2147483647}} {
global textRedoer
if {[string compare [winfo class $widget] Text]!=0} {
error "textRedoer error: widget $widget is not a text widget"
}
set textRedoer($id,commandStack) [UnDonew udLifo $depth]
set textRedoer($id,cursorStack) [UnDonew udLifo $depth]
set textRedoer($id,redo) 0
}
proc textRedoer:~textRedoer {id} {
global textRedoer
UnDodelete udLifo $textRedoer($id,commandStack)
UnDodelete udLifo $textRedoer($id,cursorStack)
}
proc textRedoer:checkpoint {id arguments} {
global textUndoer textRedoer
# do nothing if non modifying command
if {[string compare [lindex $arguments 0] insert]==0} {
textRedoer:processInsertion $id [lrange $arguments 1 end]
}
if {[string compare [lindex $arguments 0] delete]==0} {
textRedoer:processDeletion $id [lrange $arguments 1 end]
}
}
proc textRedoer:processInsertion {id arguments} {
global textUndoer textRedoer
set number [llength $arguments]
set length 0
# calculate total insertion length while skipping tags in arguments
for {set index 1} {$index<$number} {incr index 2} {
incr length [string length [lindex $arguments $index]]
}
if {$length>0} {
set index [$textUndoer($id,originalCommand) index [lindex $arguments 0]]
udLifo:push $textRedoer($id,commandStack) "delete $index $index+${length}c"
udLifo:push $textRedoer($id,cursorStack) [$textUndoer($id,originalCommand) index insert]
}
}
proc textRedoer:processDeletion {id arguments} {
global textUndoer textRedoer
set command $textUndoer($id,originalCommand)
udLifo:push $textRedoer($id,cursorStack) [$command index insert]
set start [$command index [lindex $arguments 0]]
if {[llength $arguments]>1} {
udLifo:push $textRedoer($id,commandStack) "insert $start [list [$command get $start [lindex $arguments 1]]]"
} else {
udLifo:push $textRedoer($id,commandStack) "insert $start [list [$command get $start]]"
}
}
proc textRedoer:redo {id} {
global textUndoer textRedoer
if {[catch {set cursor [udLifo:pop $textRedoer($id,cursorStack)]}]} {
return
}
set textRedoer($id,redo) 1
set popArgs [udLifo:pop $textRedoer($id,commandStack)]
textUndoer:checkpoint $id $popArgs
eval $textUndoer($id,originalCommand) $popArgs
set textRedoer($id,redo) 0
# now restore cursor position
$textUndoer($id,originalCommand) mark set insert $cursor
# make sure insertion point can be seen
$textUndoer($id,originalCommand) see insert
}
;##
;# Call this to reset the stacks, for example after reading a file in
;#
proc textRedoer:reset {id} {
global textRedoer
udLifo:empty $textRedoer($id,commandStack)
udLifo:empty $textRedoer($id,cursorStack)
}
package provide Undoer 1.0
;##
;# Create two text widgets, each with their own undo
;#
proc textUndoer:demo {} {
package require Undoer ;# This implements the undo stuff
;# Couple of extra keys for undo/redo
toplevel .top
pack [text .top.text1 -width 80 -height 10] -expand true -fill both
pack [text .top.text2 -width 80 -height 10] -expand true -fill both
set undo_id1 [UnDonew textUndoer .top.text1]
set undo_id2 [UnDonew textUndoer .top.text2]
bind .top.text1 <Control-z> [list textUndoer:undo $undo_id1]
bind .top.text2 <Control-z> [list textUndoer:undo $undo_id2]
bind .top.text1 <Control-y> [list textRedoer:redo $undo_id1]
bind .top.text2 <Control-y> [list textRedoer:redo $undo_id2]
}Category GUI - Category String Processing
