Fix several instances of undo not properly logging recent changes.

Implement browsing through canvases via PgUp / PgDown or menu.

Canvases can now be deleted.

Bug found by:
Submitted by:
Requested by:
Reviewed by:
Approved by:
Obtained from:

diff --git a/editor.tcl b/editor.tcl
index 596a1e07db6885be828c7cc2199c24932c87c7b3..e7bda3383efd158a0992859a8ba6a71f4c8b3258 100755 (executable)
--- a/editor.tcl
+++ b/editor.tcl
@@ -55,8 +55,8 @@ proc animateCursor {} {
 }
 
 
-proc removeGUILink { link } {
-    global .c
+proc removeGUILink { link atomic } {
+    global changed
 
     set nodes [linkPeers $link]
     set node1 [lindex $nodes 0]
@@ -77,18 +77,20 @@ proc removeGUILink { link } {
        removeLink $link
     }
     .c delete $link
+    if { $atomic == "atomic" } {
+       set changed 1
+       updateUndoLog
+    }
     return
 }
 
 
 proc removeGUINode { node } {
-    global .c
-
     set type [nodeType $node]
     foreach ifc [ifcList $node] {
        set peer [peerByIfc $node $ifc]
        set link [lindex [.c gettags "link && $node && $peer"] 1]
-       removeGUILink $link
+       removeGUILink $link non-atomic
     }
     if { $type != "pseudo" } {
        removeNode $node
@@ -400,7 +402,7 @@ proc redrawAllLinks {} {
 
 
 proc redrawLink { link } {
-    global .c $link
+    global $link
 
     set limages [.c find withtag "link && $link"]
     set limage1 [lindex $limages 0]
@@ -486,10 +488,10 @@ proc button3link { c x y } {
     #
     if { $oper_mode != "exec" } {
        .button3menu add command -label "Delete" \
-           -command "removeGUILink $link"
+           -command "removeGUILink $link atomic"
     } else {
        .button3menu add command -label "Delete" \
-           -command "removeGUILink $link" -state disabled
+           -state disabled
     }
 
     set x [winfo pointerx .]
@@ -551,7 +553,7 @@ proc button3node { c x y } {
            [ifcByLogicalPeer $node $peer_node] == "" } {
            .button3menu.connect.$canvas add command \
                -label [getNodeName $peer_node] \
-               -command "newLink $c $node $peer_node"
+               -command "newLink $node $peer_node atomic"
        } elseif { [nodeType $peer_node] != "pseudo" } {
            .button3menu.connect.$canvas add command \
                -label [getNodeName $peer_node] \
@@ -564,10 +566,10 @@ proc button3node { c x y } {
     #
     if { $oper_mode != "exec" } {
        .button3menu add command -label "Delete" \
-           -command "delete_object $c $x $y"
+           -command deleteSelection
     } else {
        .button3menu add command -label "Delete" \
-           -command "delete_object $c $x $y" -state disabled
+           -state disabled
     }
 
     #
@@ -773,12 +775,12 @@ proc pseudo.layer {} {
 }
 
 
-proc newLink { c lnode1 lnode2 } {
+proc newLink { lnode1 lnode2 atomic } {
     global link_list
     global $lnode1 $lnode2
     global defEthBandwidth defSerBandwidth defSerDelay
     global defLinkColor defLinkWidth
-    global curcanvas
+    global curcanvas changed
 
     #
     # When linking nodes residing in different canvases, we actually
@@ -790,8 +792,8 @@ proc newLink { c lnode1 lnode2 } {
        set pnode1 [newNode pseudo]
        setNodeCanvas $pnode1 [getNodeCanvas $lnode1]
        setNodeName $pnode1 $lnode2
-       setNodeCoords $pnode1 "100 100"
-       setNodeLabelCoords $pnode1 "100 100"
+       setNodeCoords $pnode1 [getNodeCoords $lnode2]
+       setNodeLabelCoords $pnode1 [getNodeCoords $lnode2]
        if { [getNodeCanvas $lnode1] == $curcanvas } {
            drawNode $pnode1
        }
@@ -799,8 +801,8 @@ proc newLink { c lnode1 lnode2 } {
        set pnode2 [newNode pseudo]
        setNodeCanvas $pnode2 [getNodeCanvas $lnode2]
        setNodeName $pnode2 $lnode1
-       setNodeCoords $pnode2 "100 100"
-       setNodeLabelCoords $pnode2 "100 100"
+       setNodeCoords $pnode2 [getNodeCoords $lnode1]
+       setNodeLabelCoords $pnode2 [getNodeCoords $lnode1]
        if { [getNodeCanvas $lnode2] == $curcanvas } {
            drawNode $pnode2
        }
@@ -808,8 +810,8 @@ proc newLink { c lnode1 lnode2 } {
        setNodeMirror $pnode1 $pnode2
        setNodeMirror $pnode2 $pnode1
 
-       newLink $c $lnode1 $pnode1
-       newLink $c $lnode2 $pnode2
+       newLink $lnode1 $pnode1 recursive
+       newLink $lnode2 $pnode2 recursive
 
        set link1 [linkByPeers $lnode1 $pnode1]
        set link2 [linkByPeers $lnode2 $pnode2]
@@ -829,17 +831,21 @@ proc newLink { c lnode1 lnode2 } {
        # Redraw our node so interface labels gets properly populated
        #
        if { [getNodeCanvas $lnode1] == $curcanvas } {
-           $c delete -withtags "node && $pnode1"
-           $c delete -withtags "nodelabel && $pnode1"
+           .c delete -withtags "node && $pnode1"
+           .c delete -withtags "nodelabel && $pnode1"
            drawNode $pnode1
            updateIfcLabel $lnode1 $pnode1
        } else {
-           $c delete -withtags "node && $pnode2"
-           $c delete -withtags "nodelabel && $pnode2"
+           .c delete -withtags "node && $pnode2"
+           .c delete -withtags "nodelabel && $pnode2"
            drawNode $pnode2
            updateIfcLabel $lnode2 $pnode2
        }
 
+       if { $atomic == "atomic" } {
+           set changed 1
+           updateUndoLog
+       }
        return yes
     }
 
@@ -877,7 +883,7 @@ proc newLink { c lnode1 lnode2 } {
        # XXX what is this -> makes no sense / cannot work!
        #
        global $link
-       if { [$c find withtag "link && $lnode1 && $lnode2"] != "" } {
+       if { [.c find withtag "link && $lnode1 && $lnode2"] != "" } {
            set regular no
        }
     }
@@ -919,10 +925,14 @@ proc newLink { c lnode1 lnode2 } {
        if { [getNodeCanvas $lnode1] == $curcanvas } {
            drawLink $link
            updateLinkLabel $link
-           nodeEnter $c
+           nodeEnter .c
            redrawLink $link
        }
 
+       if { $atomic == "atomic" } {
+           set changed 1
+           updateUndoLog
+       }
     }
 
     return $regular
@@ -953,7 +963,7 @@ proc button1-release { c x y } {
        if {$destobj != "" && $curobj != "" && $destobj != $curobj} {
            set lnode1 [lindex [$c gettags $curobj] 1]
            set lnode2 [lindex [$c gettags $destobj] 1]
-           if { [newLink $c $lnode1 $lnode2] == "yes" } {
+           if { [newLink $lnode1 $lnode2 non-atomic] == "yes" } {
                set changed 1
            }
        }
@@ -1778,32 +1788,22 @@ proc printCanvas { w } {
 }
 
 
-proc delete_object { c x y } {
+proc deleteSelection { } {
     global changed
     global background 
 
-    set node [lindex [$c gettags {node && current}] 1]
-    set link [lindex [$c gettags {link && current}] 1]
-    if { $link == "" } {
-       set link [lindex [$c gettags {linklabel && current}] 1]
-    }
-    if { $link != "" } {
-       removeGUILink $link
-        set changed 1
-    } 
-    if { $node != "" } {
-        removeGUINode $node 
-        set changed 1
-    }
-    foreach obj [$c find withtag "node && selected"] {
-        removeGUINode [lindex [$c gettags $obj] 1]
+    foreach obj [.c find withtag "node && selected"] {
+       set lnode [lindex [.c gettags $obj] 1]
+       if { $lnode != "" } {
+            removeGUINode $lnode
+       }
         set changed 1
     }
-    $c raise link background
-    $c raise linklabel "link || background"
-    $c raise interface "linklabel || link || background"
-    $c raise node "interface || linklabel || link || background"
-    $c raise nodelabel "node || interface || linklabel || link || background"
+    .c raise link background
+    .c raise linklabel "link || background"
+    .c raise interface "linklabel || link || background"
+    .c raise node "interface || linklabel || link || background"
+    .c raise nodelabel "node || interface || linklabel || link || background"
     updateUndoLog
 }
 
@@ -1811,7 +1811,6 @@ proc delete_object { c x y } {
 proc rearrange { mode } {
     global link_list autorearrange_enabled sizex sizey curcanvas
 
-    set c .c
     set autorearrange_enabled 1
     .menubar.tools entryconfigure "Rearrange all" -state disabled
     .menubar.tools entryconfigure "Rearrange selected" -state disabled
@@ -1834,11 +1833,11 @@ proc rearrange { mode } {
            set otime $ntime
        }
 
-       set objects [$c find withtag $tagmatch]
-       set peer_objects [$c find withtag node]
+       set objects [.c find withtag $tagmatch]
+       set peer_objects [.c find withtag node]
        foreach obj $peer_objects {
-            set node [lindex [$c gettags $obj] 1]
-           set coords [$c coords $obj]
+            set node [lindex [.c gettags $obj] 1]
+           set coords [.c coords $obj]
            set x [lindex $coords 0]
            set y [lindex $coords 1]
            set x_t($node) $x
@@ -1872,13 +1871,13 @@ proc rearrange { mode } {
        }
 
        foreach obj $objects {
-            set node [lindex [$c gettags $obj] 1]
+            set node [lindex [.c gettags $obj] 1]
            set i [lsearch -exact $peer_objects $obj]
            set peer_objects [lreplace $peer_objects $i $i]
            set x $x_t($node)
            set y $y_t($node)
            foreach other_obj $peer_objects {
-               set other [lindex [$c gettags $other_obj] 1]
+               set other [lindex [.c gettags $other_obj] 1]
                set o_x $x_t($other)
                set o_y $y_t($other)
                set dx [expr $x - $o_x]
@@ -1920,7 +1919,7 @@ proc rearrange { mode } {
        }
 
        foreach obj $objects {
-            set node [lindex [$c gettags $obj] 1]
+            set node [lindex [.c gettags $obj] 1]
            if { [catch "set v_t($node)" v] } {
                set vx 0.0
                set vy 0.0
@@ -1940,23 +1939,51 @@ proc rearrange { mode } {
            set v_t($node) "$vx $vy"
 
            setNodeCoords $node "$x $y"
-           $c move $obj $dx $dy
-           set img [$c find withtag "selectmark && $node"]
-           $c move $img $dx $dy
-           set img [$c find withtag "nodelabel && $node"]
-           $c move $img $dx $dy
-           setNodeLabelCoords $node [$c coords $img]
-           $c addtag need_redraw withtag "link && $node"
-       }
-       foreach link [$c find withtag "link && need_redraw"] {
-           redrawLink [lindex [$c gettags $link] 1]
-       }
-       $c dtag link need_redraw
+           .c move $obj $dx $dy
+           set img [.c find withtag "selectmark && $node"]
+           .c move $img $dx $dy
+           set img [.c find withtag "nodelabel && $node"]
+           .c move $img $dx $dy
+           setNodeLabelCoords $node [.c coords $img]
+           .c addtag need_redraw withtag "link && $node"
+       }
+       foreach link [.c find withtag "link && need_redraw"] {
+           redrawLink [lindex [.c gettags $link] 1]
+       }
+       .c dtag link need_redraw
        update
     }
     .menubar.tools entryconfigure "Rearrange all" -state normal
     .menubar.tools entryconfigure "Rearrange selected" -state normal
     .bottom.mbuf config -text ""
+    return
+}
+
+
+proc switchCanvas { direction } {
+    global canvas_list curcanvas
+
+    set i [lsearch $canvas_list $curcanvas]
+    switch -exact -- $direction {
+       prev {
+           incr i -1
+           if { $i < 0 } {
+               set curcanvas [lindex $canvas_list end]
+           } else {
+               set curcanvas [lindex $canvas_list $i]
+           }
+       }
+       next {
+           incr i
+           if { $i >= [llength $canvas_list] } {
+               set curcanvas [lindex $canvas_list 0]
+           } else {
+               set curcanvas [lindex $canvas_list $i]
+           }
+       }
+    }
+    redrawAll
+    return
 }
 
 
@@ -1964,11 +1991,17 @@ proc refreshCanvasMenu {} {
     global canvas_list curcanvas
 
     .menubar.canvas delete 0 end
+    .menubar.canvas add command -label "Previous" -accelerator "PgUp" \
+       -command { switchCanvas prev }
+    .menubar.canvas add command -label "Next" -accelerator "PgDown" \
+       -command { switchCanvas next }
+    .menubar.canvas add separator
     foreach canvas $canvas_list {
        .menubar.canvas add radiobutton -label [getCanvasName $canvas] \
                -command redrawAll -indicatoron true \
                -value $canvas -variable curcanvas
     }
+    return
 }
 
 
@@ -1986,4 +2019,5 @@ proc animate {} {
     } else {
        after 1500 animate
     }
+    return
 }

diff --git a/filemgmt.tcl b/filemgmt.tcl
index ec4ffb7c33c3975ce42430cd88ee9d7634f216c7..b277ef5f83ad6315c18a4cea50084008a692e611 100755 (executable)
--- a/filemgmt.tcl
+++ b/filemgmt.tcl
@@ -79,11 +79,13 @@ set fileTypes {{"IMUNES network configuration" {.imn} }
 
 proc newFile {} {
     global currentFile oper_mode
+    global canvas_list curcanvas
 
     if { $oper_mode == "exec" } {
        vimageCleanup
     }
     loadCfg ""
+    set curcanvas [lindex $canvas_list 0]
     redrawAll
     set currentFile ""
     wm title . "IMUNES"
@@ -92,10 +94,8 @@ proc newFile {} {
 
 proc openFile {} {
     global currentFile 
-    global undolevel
-    global redolevel
-    global undolog
-    global activetool
+    global undolevel redolevel undolog activetool
+    global canvas_list curcanvas
     
     set fileName [file tail $currentFile]
     wm title . "IMUNES $fileName"
@@ -106,6 +106,7 @@ proc openFile {} {
     }
     close $fileId
     loadCfg $cfg
+    set curcanvas [lindex $canvas_list 0]
     redrawAll
     set undolevel 0
     set redolevel 0

diff --git a/initgui.tcl b/initgui.tcl
index a0fd16a59a6b8a7c1a2153a895875fa27123501e..6d96cc0cd697bbddbf8a61f1e1f470e4127b25fb 100755 (executable)
--- a/initgui.tcl
+++ b/initgui.tcl
@@ -41,7 +41,7 @@
 set newlink ""
 set selectbox ""
 set selected ""
-newCanvas default
+newCanvas ""
 
 set animatephase 0
 set undolevel 0
@@ -153,17 +153,52 @@ bind . <Control-z> undo
     -accelerator "Ctrl+Y" -command redo
 bind . <Control-y> redo
 .menubar.edit add separator
+.menubar.edit add command -label "Select all" \
+    -accelerator "Ctrl+A" -command {
+       foreach obj [.c find withtag node] {
+           selectNode .c $obj
+       }
+    }
+bind . <Control-a> {
+       foreach obj [.c find withtag node] {
+           selectNode .c $obj
+       }
+    }
+.menubar.edit add separator
 .menubar.edit add command -label "New canvas" -underline 0 \
     -command {
        newCanvas ""
+       set curcanvas [lindex $canvas_list 0]
+       switchCanvas prev
+       set changed 1
+       updateUndoLog
+       refreshCanvasMenu
+    }
+.menubar.edit add command -label "Delete canvas" -underline 0 \
+    -command {
+       if { [llength $canvas_list] == 1 } {
+           return
+       }
+       foreach obj [.c find withtag node] {
+           selectNode .c $obj
+       }
+       deleteSelection
+       set i [lsearch $canvas_list $curcanvas]
+       switchCanvas next
+       set canvas_list [lreplace $canvas_list $i $i]
+       set changed 1
+       updateUndoLog
        refreshCanvasMenu
     }
 
 
+
 #
 # Canvas
 #
 menu .menubar.canvas -tearoff 0
+bind . <Prior> { switchCanvas prev }
+bind . <Next> { switchCanvas next }
 
 
 #
@@ -301,7 +336,6 @@ pack .bottom.oper_mode .bottom.mbuf .bottom.cpu_load .bottom.textbox \
 #
 # Event bindings and procedures for main canvas:
 #
-
 $c bind node <Any-Enter> "nodeEnter $c"
 $c bind link <Any-Enter> "linkEnter $c"
 $c bind linklabel <Any-Enter> "linkEnter $c"
@@ -319,7 +353,7 @@ bind $c <1> "button1 $c %x %y none"
 bind $c <Control-Button-1> "button1 $c %x %y ctrl"
 bind $c <B1-Motion> "button1-motion $c %x %y"
 bind $c <B1-ButtonRelease> "button1-release $c %x %y"
-bind . <Delete> "delete_object $c %x %y"
+bind . <Delete> deleteSelection
 bind .menubar <Destroy> {setOperMode edit}
 
 # Scrolling and panning support