From 2da6da6e09ba0d2e679791dbb69e6023d781ffbf Mon Sep 17 00:00:00 2001 From: marko Date: Sun, 6 Nov 2005 10:28:19 +0000 Subject: [PATCH] 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: --- cfgparse.tcl | 12 ++++----- editor.tcl | 76 ++++++++++++++++++++++++++++++++++++++++++++++++---- initgui.tcl | 1 + linkcfg.tcl | 54 ++++++++++++++++++++++++++++++++++++- nodecfg.tcl | 2 +- 5 files changed, 131 insertions(+), 14 deletions(-) diff --git a/cfgparse.tcl b/cfgparse.tcl index e50e6fe..4593d92 100755 --- 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 750ad36..21847ee 100755 --- 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 719e404..bcb67bc 100755 --- 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 c6f9715..8adf07b 100755 --- 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 5e8e511..4a92aed 100755 --- 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" -- 2.39.5