Implement a generic proc splitLink { link node_type } for splitting a link

in two.  The proc creates two nodes of type $node_type and replaces the
current $link with two new ones, connecting existing link endpoints to the
newly created nodes.

Implement a "move to another canvas" operation on selected nodes.

Speedup the loadCfg proc by a factor of two by replacing iterative removal
of existing nodes / links with an atomic clearing of *_list globals.  This
particularly speeds up the undo / redo operations which rely on loadCfg.

TODO: merging of cross-canvas links when moving existing nodes from one
canvas to another.  NB this means currently moving "pseudo" nodes over
cross-canvas boundaries is not yet handled properly and will yield
undefined / unexpected results.

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

diff --git a/cfgparse.tcl b/cfgparse.tcl
index e50e6fee4ba09b031e0490bd58c2f447c16cca3c..4593d92ba30ba0e06792e6e24be4ba04bc351196 100755 (executable)
--- a/cfgparse.tcl
+++ b/cfgparse.tcl
@@ -133,13 +133,10 @@ proc loadCfg { cfg } {
     global showIfNames showNodeLabels showLinkLabels
     global showIfIPaddrs showIfIPv6addrs
 
-    # Cleanup first - this also automatically deletes all associated links
-    foreach node $node_list {
-       removeNode $node
-    }
-    foreach canvas $canvas_list {
-       removeCanvas $canvas
-    }
+    # Cleanup first
+    set node_list {}
+    set link_list {}
+    set canvas_list {}
 
     set class ""
     set object ""
@@ -150,6 +147,7 @@ proc loadCfg { cfg } {
        } elseif {"$object" == ""} {
            set object $entry
            global $object
+           set $object {}
            if {"$class" == "node"} {
                lappend node_list $object
            }

diff --git a/editor.tcl b/editor.tcl
index 750ad36a26b9233c0bf4c4dc2c187099ce9f8e33..21847eece8eb749db1a805e75ef3dc24c0472c4f 100755 (executable)
--- a/editor.tcl
+++ b/editor.tcl
@@ -502,8 +502,47 @@ proc button3link { c x y } {
 }
 
 
+proc movetoCanvas { canvas } {
+    global changed
+
+    set selected_nodes {}
+    set border_links {}
+    foreach obj [.c find withtag "node && selected"] {
+       set node [lindex [.c gettags $obj] 1]
+       lappend selected_nodes $node
+       setNodeCanvas $node $canvas
+       set changed 1
+    }
+    foreach obj [.c find withtag "linklabel"] {
+       set link [lindex [.c gettags $obj] 1]
+       set link_peers [linkPeers $link]
+       set peer1 [lindex $link_peers 0]
+       set peer2 [lindex $link_peers 1]
+       set peer1_in_selected [lsearch $selected_nodes $peer1]
+       set peer2_in_selected [lsearch $selected_nodes $peer2]
+       if { ($peer1_in_selected == -1 && $peer2_in_selected != -1) ||
+           ($peer1_in_selected != -1 && $peer2_in_selected == -1) } {
+           lappend border_links $link
+           set new_nodes [splitLink $link pseudo]
+           set new_node1 [lindex $new_nodes 0]
+           set new_node2 [lindex $new_nodes 1]
+           setNodeMirror $new_node1 $new_node2
+           setNodeMirror $new_node2 $new_node1
+           setNodeName $new_node1 $peer2
+           setNodeName $new_node2 $peer1
+           set link1 [linkByPeers $peer1 $new_node1]
+           set link2 [linkByPeers $peer2 $new_node2]
+           setLinkMirror $link1 $link2
+           setLinkMirror $link2 $link1
+       }
+    }
+    updateUndoLog
+    redrawAll
+}
+
+
 proc button3node { c x y } {
-    global oper_mode env eid canvas_list node_list
+    global oper_mode env eid canvas_list node_list curcanvas
 
     set node [lindex [$c gettags {node && current}] 1]
     if { $node == "" } {
@@ -513,6 +552,12 @@ proc button3node { c x y } {
        }
     }
 
+    if { [$c gettags "node && $node && selected"] == "" } {
+       $c dtag node selected
+       $c delete -withtags selectmark
+       selectNode $c [$c find withtag "current"]
+    }
+
     .button3menu delete 0 end
 
     #
@@ -561,15 +606,36 @@ proc button3node { c x y } {
        }
     }
 
+    #
+    # Move to another canvas
+    #
+    .button3menu.moveto delete 0 end
+    if { [nodeType $node] == "pseudo" } {
+       .button3menu add cascade -label "Move to" \
+           -menu .button3menu.moveto -state disabled
+    } else {
+       .button3menu add cascade -label "Move to" \
+           -menu .button3menu.moveto
+    }
+    .button3menu.moveto add command -label "Canvas:" -state disabled
+    foreach canvas $canvas_list {
+       if { $canvas != $curcanvas } {
+           .button3menu.moveto add command \
+               -label [getCanvasName $canvas] \
+               -command "movetoCanvas $canvas"
+       } else {
+           .button3menu.moveto add command \
+               -label [getCanvasName $canvas] -state disabled
+       }
+    }
+
     #
     # Delete selection
     #
     if { $oper_mode != "exec" } {
-       .button3menu add command -label "Delete" \
-           -command deleteSelection
+       .button3menu add command -label "Delete" -command deleteSelection
     } else {
-       .button3menu add command -label "Delete" \
-           -state disabled
+       .button3menu add command -label "Delete" -state disabled
     }
 
     #

diff --git a/initgui.tcl b/initgui.tcl
index 719e40441c508d1c9a71e2376f5370aedcb5f98d..bcb67bce3ceb6f440f12f8ddd26889713b8a7375 100755 (executable)
--- a/initgui.tcl
+++ b/initgui.tcl
@@ -341,6 +341,7 @@ bind $c <5> "$c yview scroll -1 units"
 #
 menu .button3menu -tearoff 0
 menu .button3menu.connect -tearoff 0
+menu .button3menu.moveto -tearoff 0
 menu .button3menu.shell -tearoff 0
 menu .button3menu.ethereal -tearoff 0
 

diff --git a/linkcfg.tcl b/linkcfg.tcl
index c6f971576b2e3b6359054d568a0dbac1c26446e0..8adf07b884f331b6b9cafa435f7cfed4c6f1d59d 100755 (executable)
--- a/linkcfg.tcl
+++ b/linkcfg.tcl
@@ -103,7 +103,6 @@ proc removeLink { link } {
         set i [lsearch [set $node] "interface-peer {$ifc $peer}"]
         set $node [lreplace [set $node] $i $i]
     }
-    unset $link
     set i [lsearch -exact $link_list $link]
     set link_list [lreplace $link_list $i $i]
     return
@@ -252,3 +251,56 @@ proc setLinkMirror { link value } {
     }
     return
 }
+
+
+proc splitLink { link nodetype } {
+    global link_list $link
+
+    set orig_nodes [linkPeers $link]
+    set orig_node1 [lindex $orig_nodes 0]
+    set orig_node2 [lindex $orig_nodes 1]
+    set new_node1 [newNode $nodetype]
+    set new_node2 [newNode $nodetype]
+    set new_link1 [newObjectId link]
+    lappend link_list $new_link1
+    set new_link2 [newObjectId link]
+    lappend link_list $new_link2
+    set ifc1 [ifcByPeer $orig_node1 $orig_node2]
+    set ifc2 [ifcByPeer $orig_node2 $orig_node1]
+
+    global $orig_node1 $orig_node2 $new_node1 $new_node2
+    global $new_link1 $new_link2
+    set $new_link1 {}
+    set $new_link2 {}
+
+    set i [lsearch [set $orig_node1] "interface-peer {* $orig_node2}"]
+    set $orig_node1 [lreplace [set $orig_node1] $i $i \
+                       "interface-peer {$ifc1 $new_node1}"]
+    set i [lsearch [set $orig_node2] "interface-peer {* $orig_node1}"]
+    set $orig_node2 [lreplace [set $orig_node2] $i $i \
+                       "interface-peer {$ifc2 $new_node2}"]
+
+    lappend $new_link1 "nodes {$orig_node1 $new_node1}"
+    lappend $new_link2 "nodes {$orig_node2 $new_node2}"
+
+    setNodeCanvas $new_node1 [getNodeCanvas $orig_node1]
+    setNodeCanvas $new_node2 [getNodeCanvas $orig_node2]
+    setNodeCoords $new_node1 [getNodeCoords $orig_node2]
+    setNodeCoords $new_node2 [getNodeCoords $orig_node1]
+    if { $nodetype != "pseudo" } {
+       setNodeLabelCoords $new_node1 [getNodeLabelCoords $orig_node2]
+       setNodeLabelCoords $new_node2 [getNodeLabelCoords $orig_node1]
+    } else {
+       setNodeLabelCoords $new_node1 [getNodeCoords $orig_node2]
+       setNodeLabelCoords $new_node2 [getNodeCoords $orig_node1]
+    }
+    lappend $new_node1 "interface-peer {0 $orig_node2}"
+    lappend $new_node2 "interface-peer {0 $orig_node1}"
+
+    # XXX TODO: copy properties of orig to new links
+
+    set i [lsearch -exact $link_list $link]
+    set link_list [lreplace $link_list $i $i]
+
+    return "$new_node1 $new_node2"
+}

diff --git a/nodecfg.tcl b/nodecfg.tcl
index 5e8e511da0944a827303afadfc1aed3d82ed32da..4a92aed6054369480f1b6899dbdb83e925569372 100755 (executable)
--- a/nodecfg.tcl
+++ b/nodecfg.tcl
@@ -805,7 +805,6 @@ proc removeNode { node } {
        set link [linkByPeers $node $peer]
         removeLink $link
     }
-    unset $node
     set i [lsearch -exact $node_list $node]
     set node_list [lreplace $node_list $i $i]
     return
@@ -844,6 +843,7 @@ proc newNode { type } {
 
     set node [newObjectId node]
     global $node
+    set $node {}
     lappend $node "type $type"
     if { $type == "router" } {
        lappend $node "model $def_router_model"