proc comment text {}

proc dbg args { tk_messageBox -message "$args" ; return 1}

  proc testop {s S P V} { ;# this is the validation routine for entry e2
        puts "testop validating $s $S -> $P type $V"
        return 1 ;# or 0 if not OK!
  }

  proc undomenu {menubtn menu} {
        puts "Undoing $menubtn $menu [$menubtn cget -text]"
  }
  proc scalevalue {w v} {
        puts "scale $w set to value $v"
  }
  proc testUndo {} { ;# create an interface using "undoable" Tk items.
        console show ;# debug and check infomration appears here via puts commands.

        pack [frame .fr]
        pack [button .fr.undo -text Undo -command "undolast"] -side left
        pack [button .fr.redo -text Redo -command "redolast"] -side left
        bind . <Control-z> "undolast"
        bind . <Control-y> "redolast"
        pack [button .fr.undos -text "Show Undos" -command "showundos"] -side left
        pack [button .fr.redos -text "Show Redos" -command "showredos"] -side left
        pack [button .fr.exit -text Exit -command "exit 1"] -side left
        set testfr [frame .tests]
        pack $testfr
        # default type is an entry.
        pack [undoable $testfr.e1  -validate focus] -side top
        pack [undoable $testfr.e2 -kind entry -vcmd "testop %s %S %P %V"  -validate all] -side top
        pack [undoable $testfr.sp2 -kind spinbox -from 1 -to 12 \
                -vcmd "testop %s %S %P %V" -validate all] -side top

        pack [undoable $testfr.b1 -kind menubutton -bg red -menu $testfr.b1.menu1 -textvariable menval -bd 2 -relief raised] -side top
        undoable $testfr.b1.menu1 -kind menu -tearoff 0 -undocommand "undomenu $testfr.b1 $testfr.b1.menu1"
        foreach num {One Two Three} {        $testfr.b1.menu1 add command -label $num -command "puts \"menu item $num chosen\"; set ::menval $num"}
        $testfr.b1.menu1 add cascade -label "Roman" -menu $testfr.b1.menu1.cascade
        undoable $testfr.b1.menu1.cascade -kind menu -tearoff 0 -undocommand "puts \"Undoing $testfr.b1.menu1.cascade\""
        foreach num {I II III} {        $testfr.b1.menu1.cascade add command -label $num -command "puts \"menu item $num chosen\"; set ::menval $num"}
        set ::menval Number

        pack [undoable $testfr.bmen1 -kind menubutton  -menu $testfr.bmen1.menu1 -text "Dropdown Menu" -bd 2 -relief raised] -side top
        undoable $testfr.bmen1.menu1 -kind menu -tearoff 0 -undocommand "undomenu $testfr.bmen1 $testfr.bmen1.menu1"
        foreach num {One Two Three} {        $testfr.bmen1.menu1 add command -label $num -command "puts \"menu item $num chosen\""}
        $testfr.bmen1.menu1 add cascade -label "Roman" -menu $testfr.bmen1.menu1.cascade
        undoable $testfr.bmen1.menu1.cascade -kind menu -tearoff 0 -undocommand "puts \"Undoing $testfr.bmen1.menu1.cascade\""
        foreach num {I II III} {        $testfr.bmen1.menu1.cascade add command -label $num -command "puts \"menu item $num chosen\""}
         
        pack [undoable $testfr.b2 -kind button -text "Press Me" -command "puts {Button pressed}" \
                -undocommand "puts {Button press undone}" ] -side top
        pack [undoable $testfr.b3 -kind checkbutton -text "Check Me" -command "puts {checkButton pressed}" \
                -undocommand "puts {checkButton press undone}" ] -side top
        pack [undoable $testfr.b4 -kind radiobutton -text "Check Me" -command "puts {radioButton pressed}" \
                -undocommand "puts {radioButton press undone}" ] -side top
        pack [undoable $testfr.e3 -kind entry \
                -vcmd "puts {validating %s %S -> %P type %V}; return 1" \
                -validate all] -side top
        pack [undoable $testfr.s1 -kind scale -from 100 -to 200 \
                -command "scalevalue $testfr.s1" -orient horiz] -side top
        pack [undoable $testfr.s2 -kind scale -from 0 -to 120 \
                -command "scalevalue $testfr.s2" -orient horiz] -side top
        pack [undoable $testfr.lb2 -kind listbox -command "puts {Listbox Selected}" \
                -undocommand "puts {Listbox undone}" ] -side top
        foreach fruit [list "Apple" "Peach" "Pear" "Banana" "Strawberry" \
                                "Lingonberry" "Blackberry" "Damson" "Plum"]  {
                $testfr.lb2 insert end $fruit 
        }
        pack [undoable $testfr.tx1 -kind text -undo true ] -side top
  }

 comment {
This is the important part - a list of undoable events, and a redo list (in case you undid
an event and realised it should not have been undone).

Each undo event has two parts (it is a list) - the record of old values needing to be undone,
and the redo event (a copy of the original event).

The class undoable is a [polymorphism%|%polymorphic] or Template class which records the actions
of any Tk widget and can 'undo' these actions. 

Records events in all undoable widgets as a list, then you can undo the list 
(and possibly redo). All Tk widgets (except canvas?) can be used as undoables.
"Polymorphism" means that the undoable widget can inherit from any of the Tk widgets.
It should also be able to represent an Iwidget or BWidget.

Usually 'entry' 'menu' and 'scale' widgets won't need an undocommand as they call the 
return the value of the widget to its previous value, which calls the standard        
'item changed command' for the widget (which should cause all changes to be reset
as if the menu/entry/scale had been set manually). 

undoableCmd is the place where the undo events are coded and interpreted.
 }

  global undoings ;# list of undoable things - each is a 2 part list 
        # first the arguments to undo the operation;
        # then the arguments to redo the operation.
  set undoings {}
  global redoings ;# list of redoable things - copy of those undoings which have been undone.
  set redoings {}


  proc showundos {} { ;# display list of undo operations.
        global undoings
        foreach un $undoings { puts "Undo:: [lindex $un 0] ::redo:: [lindex $un 1]"}
  }
  proc showredos {} { ;# display list of redo operations.
        global redoings
        foreach un $redoings { puts "Redo:: [lindex $un 0] ::undo:: [lindex $un 1]"}
  }

  proc undolast {} { ;# undoes last undoable operation.
        global undoings
        if {[llength $undoings]>0} {
                set undothis [lindex [lindex $undoings end] 0]
                set widget [lindex $undothis 0]
                eval $widget undo $undothis
                global redoings

                lappend redoings [lindex $undoings end]
                set undoings [lrange $undoings 0 end-1]
        } else {
                puts "No more undoable events"
        }
  }

  proc redolast {} {
        global redoings
        if {[llength $redoings]>0} {
                set redothis [lindex $redoings end]
                set redocommand [lindex $redothis 1]
                set widget [lindex $redocommand 0]
                eval $widget undo $widget [lrange $redocommand 1 end]
                update idletasks
                set redoings [lrange $redoings 0 end-1]

                global undoings
                lappend undoings $redothis
        }
  }

  proc undoable {w args} { ;# an undoable is a widget
        # and allows new smooth shaped buttons.
        global $w.props ;# an array of options specific to the undoable 'class'
        # set by .this -<option> <value>
        array set $w.props {-kind entry -undoing 0 -undocommand "" -command "" oldvalue "0"}
        # define the option list and default values
        # kind is the type of Tk widget (entry, button, menu ection...)
        # undoing is true if we are in an undo operation (does not get put on the undoable list)
        # undocommand may be supplied for items such as buttons which may invoke complex operations
        #  and hence require a complex undo operation. 
        upvar #0 $w.props props ;# get local address for global array

        set baseArgs {} ;# list of arguments not specific to the class
        set options(-kind) entry
        set options(-vcmd) "return 1"
        # extract special arguments for w - command is special in that commands (from buttons etc)
        # need to record their actions to be undone
        foreach {opt val} $args {
                if {[array names $w.props $opt]!=""} { 
                        set options($opt) $val
                        set $w.props($opt) $val
                } else {        lappend baseArgs $opt $val }
        }
        # make the base widget
        eval $options(-kind) $w $baseArgs ;# create the "procedure" w

        interp hide {} $w
        # Install the alias:
        interp alias {} $w {} undoableCmd $w ;# undoableCmd processes sub-commands for undoable class
        switch [winfo class $w] {
                {Listbox} {
                        bind $w <ButtonPress-1> "$w Select %y"
                }
                {Text} {
                        bind $w <Enter> "$w TextSavepoint"
                        bind $w <Leave> "$w TextSavepoint"
                }
                default {}
        }
        foreach opt [array names options] {
                if {[$w isanoption $opt] != ""} {
                        switch -- $opt {
                                "-command" { ;# assemble complete validation command - saves history of behaviours
                                         set undocmd "$w undooptions ; $options($opt)"
                                        eval interp invokehidden {{}} $w configure "$opt" \"$undocmd\"
                                }
                                "-validatecommand" -
                                "-vcmd" { ;# assemble complete Entry validation command - saves history of behaviours
                                         set undocmd "$w undooptions %P ; $options($opt)"
                                        eval interp invokehidden {{}} $w configure "$opt" \"$undocmd\"
                                }
                                default {        $w configure $opt "$options($opt)" }
                        }
                } else { 
                        set $w.props($opt) $options($opt)
                }
        }
        return $w ;# the original object
  }

  proc undoableCmd {self cmd args} {
        global $self.props
        switch -- $cmd {
                configure {eval undoableConfigure $self $args}
                cget {eval undoableCget $self $args}
                {undooptions} { ;# save undooptions sufficient to undo and redo an action
                        if {![$self cget -undoing]} { ;# not in an undo so save event.
                                global  undoings ;# store state before and after event change.
                                set dodata [lindex $args end] ;# and record the redo event
                                switch [winfo class $self] {
                                        {Menu} { ;#  [file rootname $self] is the menu parent - button or cascade
                                                set menubutt [file rootname $self]
                                                while {[winfo class $menubutt]!="Menubutton"} {
                        # ascend tree to an actual menubutton.
                                                        set menubutt [file rootname $menubutt]
                                                }
                                                set tvar [$menubutt cget -text]
                                                set dodata [list $self $cmd $menubutt $args]
                                                set undodata [list $self $cmd $menubutt $tvar]
                                        }
                                        {Button} -
                                        {Checkbutton} -
                                        {Radiobutton} {
                                                set undodata [list $self $cmd $args]
                                                set dodata [list $self $cmd $args ]
                                        }
                                        {Entry} {
                                                set undodata [list $self [$self oldvalue] ]
                                                set dodata [list $self $args ]
                                        }
                                        {Scale} {
                                                set dodata [list $self [$self oldvalue] ]
                                                set undodata [list $self [$self cget oldvalue]]
                                                puts "Undo scale save $self [$self oldvalue] [$self cget oldvalue]"
                                        }
                                        {Listbox} {
                                                set undodata [list $self [$self curselection ] ]
                                                set dodata [list $self [lindex $args 0]]
                                        }
                                        {Text} { 
                        # NB this records undo state when mouse enters into text widget
                                                set undodata [list $self "[$self oldvalue]"]
                                                set dodata $undodata
                                        }
                                        {Spinbox} {
                                                set undodata [list $self [$self get ] ]
                                                set dodata [list $self $args]
                                        }
                                        default {
                                                set undodata [list $self "Dont know how to undo [winfo class $self]"]
                                        }
                                }
                                # foreach un $undoings { puts "Undo:: $un"}
                                lappend undoings [list $undodata $dodata] ;# and record the undo event
                        } ;# else { puts "In undo dont save event $cmd $args"}
                        set $self.props(oldvalue) [$self oldvalue] ;# saved for redo record.
                }
                {undo} { ;# the action invoked by an undo
                        set $self.props(-undoing) 1
                        switch [winfo class $self] {
                                 {Entry} {
                                        $self selection range 0 end                                 
                                        if {[$self selection present]} {                $self delete sel.first sel.last                }
                                        $self insert insert [lindex $args 1] ;# insert
                                }
                                {Menu} { ;# here we want to perform some undoing mechanism
                                        set tvar [ [lindex $args 2] cget -textvariable]
                                        if {$tvar !=""} { 
                                                global $tvar
                                                set $tvar [lindex $args 3] 
                                        }
                                        puts "menu $self undo [winfo class $self] event $args"
                                }
                                {Listbox} {
                                        $self selection clear 0 end
                                        if {[lindex $args 1]!=""} {
                                                $self selection set [lindex $args 1]
                                                puts "Undo [lindex $args 0] oldvalues [lindex $args 1] new [lindex $args 2]"
                                        }
                                }
                                {Checkbutton} -
                                {Radiobutton} -
                                {Button} { ;# these Tk items usually need their own undocommand
                                        puts "Undoing [winfo class $self] called $self"
                                }
                                {Scale} { ;# scale set should call its own -command option
                                        eval $self set [lindex $args 1]
                                }
                                {Spinbox} {
                                        eval $self set [lindex $args 1]
                                }
                                {Text} { ;# NB this reverts to state at time of mouse entering/leaving text widget
                                        $self delete 0.0 end
                                        $self insert end [lindex $args 1]
                                }
                                default {
                                        puts "? undo [winfo class $self] event $args"
                                }
                        }
                        set undoc [$self cget "-undocommand"]
                        if {$undoc!=""} { eval $undoc}
                        update idletasks ;# updates all the -vcmds etc before setting the undo flag
                        set $self.props(-undoing) 0 ;# start collecitng widget events for undoing again
                }
                  {Select} { ;# in Listbox - no automatic setting of current selection in Tk(!)
                        set y [$self nearest [lindex $args 0]]
                        $self undooptions $y
                        $self selection set $y
                        upvar #0 $self.props props 
                        eval $props(-command)
                  }
                {TextSavepoint} { ;# mouse has entered or left text - create an undo event
                        $self undooptions 
                }
                {oldvalue} { ;# for generic resetting - some classes save the old value
                        switch [winfo class $self] {
                                {Entry} -
                                {Scale} { return [$self get]}
                                {Text} { return [$self get 0.0 end]}
                                default { return ""}
                        }
                }

                {isanoption} { ;# check all the declared options of self for $args being valid.
                        foreach op [$self config] {
                                set n [lsearch $op $args]
                                if {$n>=0} { return $op}
                        }
                        return ""
                }
                {add} { ;# for type menu add an option (command etc) means add an undoable menu item
                        if {[$self isanoption $cmd] != ""} {
                                puts "$self Could not $cmd with $args - $self should be a menu item."
                        } else {
                                set undoargs [lindex $args 0]
                                set pog [lsearch $args "-label"]
                                if {$pog>0} {
                                        incr pog
                                        set pog [lindex $args $pog]
                                }
                                foreach {opt val} [lrange $args 1 end] {  ;# first arg arg[0] is command (or radiobutton, checkbutton, etc)
                                        switch -- $opt {
                                                {-command} {
                                                        lappend undoargs $opt "$self undooptions $pog  ; $val"
                                                }
                                                default {lappend undoargs $opt $val }
                                        }
                                }
                                set id [eval interp invokehidden {{}} $self $cmd $undoargs]
                        }
                }
                {default} { ;# use default $cmd to widget
                        eval interp invokehidden {{}} $self $cmd $args
                }
        }
  }

  proc undoableConfigure {self args} {
        # 3 scenarios:
        #
        # $args is empty -> return all options with their values
        # $args is one element -> return current values
        # $args is 2+ elements -> configure the options
        #puts "Config comd $self $cmd $args [llength $args]"
        global $self.props
        switch [llength $args] {
                0 { ;# return all options
                        set result [array names $self.props]
                        return $result
                }
                1 { ;# return argument values
                        if {[array names $w.props $opt]!=""} { lappend opts [$self cget $args]
                        } else { puts "No option $opt in $self specific arguments." }
                        return $opts
                }
                default { ;# >1 arg - an option and its value
                        # go through each option:
                        foreach {option value} [lrange $args 0 end] {
                                if {[array names $self.props $option]!=""} { ;# set global array element for special option.
                                        set $self.props($option) "$value"
                                } else {
                                        eval interp invokehidden {{}} $self configure $option $value
                                }
                        }
                        return {}
                }
        }
  }

  proc undoableCget {self args} {        ;# cget defaults done by the interp cget command
        upvar #0 $self.props props ;# get local address for global array
        if {[array names props $args ]!=""} {
                return $props($args)
        }
        return [uplevel 1 [list interp invokehidden {} $self cget $args]]
  }

  testUndo ;# call the test routine

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References