Rewrite of the "move to canvas" routine.

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

diff --git a/editor.tcl b/editor.tcl
index d184cd9f237f92087a05c23e6429f8b99637495c..222bf5f2ef6b65c5a1850f88a0c61bc8869f835e 100755 (executable)
--- a/editor.tcl
+++ b/editor.tcl
@@ -122,6 +122,7 @@ proc undo {} {
     if {$oper_mode == "edit" && $undolevel > 0} {
        incr undolevel -1
        loadCfg $undolog($undolevel)
+       switchCanvas none
        redrawAll
     }
     return
@@ -134,13 +135,13 @@ proc redo {} {
     if {$oper_mode == "edit" && $redolevel > $undolevel} {
        incr undolevel
        loadCfg $undolog($undolevel)
+       switchCanvas none
        redrawAll
     }
     return
 }
 
 
-
 proc redrawAll {} {
     global node_list link_list background sizex sizey
     global curcanvas
@@ -168,7 +169,6 @@ proc redrawAll {} {
     }
 
     refreshCanvasMenu
-
     return
 }
 
@@ -212,7 +212,7 @@ proc drawNode { node } {
 }
 
 
-proc drawLink {link} {
+proc drawLink { link } {
     global defLinkWidth defLinkColor
 
     set nodes [linkPeers $link]
@@ -674,12 +674,12 @@ proc button3node { c x y } {
     }
     foreach peer_node $node_list {
        set canvas [getNodeCanvas $peer_node]
-       if { $node != $peer_node &&
+       if { $node != $peer_node && [nodeType $node] != "rj45" &&
            [lsearch {pseudo rj45} [nodeType $peer_node]] < 0 &&
            [ifcByLogicalPeer $node $peer_node] == "" } {
            .button3menu.connect.$canvas add command \
                -label [getNodeName $peer_node] \
-               -command "newLink $node $peer_node atomic"
+               -command "newGUILink $node $peer_node"
        } elseif { [nodeType $peer_node] != "pseudo" } {
            .button3menu.connect.$canvas add command \
                -label [getNodeName $peer_node] \
@@ -934,194 +934,33 @@ proc pseudo.layer {} {
 }
 
 
-proc newLink { lnode1 lnode2 atomic } {
-    global link_list
-    global $lnode1 $lnode2
-    global defEthBandwidth defSerBandwidth defSerDelay
-    global defLinkColor defLinkWidth
-    global curcanvas changed
-
-    #
-    # When linking nodes residing in different canvases, we actually
-    # have to create a connector-type pseudo-node in each canvas, and
-    # then recursively call newLink to connect requested nodes to those
-    # automatically created pseudo-nodes
-    #
-    if { [getNodeCanvas $lnode1] != [getNodeCanvas $lnode2] } {
-       set pnode1 [newNode pseudo]
-       setNodeCanvas $pnode1 [getNodeCanvas $lnode1]
-       setNodeName $pnode1 $lnode2
-       setNodeCoords $pnode1 [getNodeCoords $lnode2]
-       setNodeLabelCoords $pnode1 [getNodeCoords $lnode2]
-       if { [getNodeCanvas $lnode1] == $curcanvas } {
-           drawNode $pnode1
-       }
-
-       set pnode2 [newNode pseudo]
-       setNodeCanvas $pnode2 [getNodeCanvas $lnode2]
-       setNodeName $pnode2 $lnode1
-       setNodeCoords $pnode2 [getNodeCoords $lnode1]
-       setNodeLabelCoords $pnode2 [getNodeCoords $lnode1]
-       if { [getNodeCanvas $lnode2] == $curcanvas } {
-           drawNode $pnode2
-       }
-
-       setNodeMirror $pnode1 $pnode2
-       setNodeMirror $pnode2 $pnode1
-
-       newLink $lnode1 $pnode1 recursive
-       newLink $lnode2 $pnode2 recursive
-
-       set link1 [linkByPeers $lnode1 $pnode1]
-       set link2 [linkByPeers $lnode2 $pnode2]
-       setLinkMirror $link1 $link2
-       setLinkMirror $link2 $link1
-       
-       if {[[typemodel $lnode1].layer] == "NETWORK" } {
-           set ifc1 [ifcByPeer $lnode1 $pnode1]
-           autoIPv4addr $lnode1 $ifc1
-           autoIPv6addr $lnode1 $ifc1
-       }
-       if {[[typemodel $lnode2].layer] == "NETWORK" } {
-           set ifc2 [ifcByPeer $lnode2 $pnode2]
-           autoIPv4addr $lnode2 $ifc2
-           autoIPv6addr $lnode2 $ifc2
-       }
-       if {[[typemodel $lnode1].layer] == "NETWORK" &&
-           [nodeType $lnode1] != "router" } {
-           set ifc1 [ifcByPeer $lnode1 $pnode1]
-           autoIPv4defaultroute $lnode1 $ifc1
-           autoIPv6defaultroute $lnode1 $ifc1
-       }
-       if {[[typemodel $lnode2].layer] == "NETWORK" &&
-           [nodeType $lnode2] != "router" } {
-           set ifc2 [ifcByPeer $lnode2 $pnode2]
-           autoIPv4defaultroute $lnode2 $ifc2
-           autoIPv6defaultroute $lnode2 $ifc2
-       }
-
-       #
-       # Redraw our node so interface labels gets properly populated
-       #
-       if { [getNodeCanvas $lnode1] == $curcanvas } {
-           .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"
-           drawNode $pnode2
-           updateIfcLabel $lnode2 $pnode2
-       }
-
-       if { $atomic == "atomic" } {
-           set changed 1
-           updateUndoLog
-       }
-       return yes
-    }
-
-    set regular yes
-
-    if { [nodeType $lnode1] == "frswitch" && \
-       [nodeType $lnode2] != "router" && \
-       [nodeType $lnode2] != "frswitch" } { set regular no }
-    if { [nodeType $lnode2] == "frswitch" && \
-       [nodeType $lnode1] != "router" && \
-       [nodeType $lnode1] != "frswitch" } { set regular no }
-    if { [nodeType $lnode1] == "hub" && \
-       [nodeType $lnode2] == "hub" } { set regular no }
-    if { [nodeType $lnode1] == "rj45" || \
-       [nodeType $lnode2] == "rj45" } {
-       if { [nodeType $lnode1] == "rj45" } {
-           set rj45node $lnode1
-           set othernode $lnode2
-       } else {
-           set rj45node $lnode2
-           set othernode $lnode1
-       }
-       if { [lsearch {router lanswitch hub pc host} \
-         [nodeType $othernode]] < 0} {
-           set regular no
-       }
-       if { [lsearch [set $rj45node] "interface-peer *"] > 0 } {
-           set regular no
-       }
-
-    }
+proc newGUILink { lnode1 lnode2 } {
+    global changed
 
-    foreach link $link_list {
-       #
-       # XXX what is this -> makes no sense / cannot work!
-       #
-       global $link
-       if { [.c find withtag "link && $lnode1 && $lnode2"] != "" } {
-           set regular no
-       }
+    set link [newLink $lnode1 $lnode2]
+    if { $link == "" } {
+       return
     }
-
-    if { $regular == "yes" } {
-       set link [newObjectId link]
-       global $link
-       set $link {}
-
-       set ifname1 [newIfc [chooseIfName $lnode1 $lnode2] $lnode1]
-       lappend $lnode1 "interface-peer {$ifname1 $lnode2}"
-       set ifname2 [newIfc [chooseIfName $lnode2 $lnode1] $lnode2]
-       lappend $lnode2 "interface-peer {$ifname2 $lnode1}"
-
-       lappend $link "nodes {$lnode1 $lnode2}"
-       if { ([nodeType $lnode1] == "lanswitch" || \
-           [nodeType $lnode2] == "lanswitch" || \
-           [string first eth "$ifname1 $ifname2"] != -1) && \
-           [nodeType $lnode1] != "rj45" && \
-           [nodeType $lnode2] != "rj45" } {
-           lappend $link "bandwidth $defEthBandwidth"
-       } elseif { [string first ser "$ifname1 $ifname2"] != -1 } {
-           lappend $link "bandwidth $defSerBandwidth"
-           lappend $link "delay $defSerDelay"
-       }
-
-       lappend link_list $link
-
-       if { [nodeType $lnode2] != "pseudo" &&
-           [[typemodel $lnode1].layer] == "NETWORK" } {
-           autoIPv4addr $lnode1 $ifname1
-           autoIPv6addr $lnode1 $ifname1
-       }
-       if { [nodeType $lnode1] != "pseudo" &&
-           [[typemodel $lnode2].layer] == "NETWORK" } {
-           autoIPv4addr $lnode2 $ifname2
-           autoIPv6addr $lnode2 $ifname2
-       }
-       if { [nodeType $lnode1] != "router" &&
-           [nodeType $lnode2] != "pseudo" &&
-           [[typemodel $lnode1].layer] == "NETWORK" } {
-           autoIPv4defaultroute $lnode1 $ifname1
-           autoIPv6defaultroute $lnode1 $ifname1
-       }
-       if { [nodeType $lnode2] != "router" &&
-           [nodeType $lnode1] != "pseudo" &&
-           [[typemodel $lnode2].layer] == "NETWORK" } {
-           autoIPv4defaultroute $lnode2 $ifname2
-           autoIPv6defaultroute $lnode2 $ifname2
-       }
-
-       if { [getNodeCanvas $lnode1] == $curcanvas } {
-           drawLink $link
-           updateLinkLabel $link
-           nodeEnter .c
-           redrawLink $link
-       }
-
-       if { $atomic == "atomic" } {
-           set changed 1
-           updateUndoLog
-       }
+    if { [getNodeCanvas $lnode1] != [getNodeCanvas $lnode2] } {
+       set new_nodes [splitLink $link pseudo]
+       set orig_nodes [linkPeers $link]
+       set new_node1 [lindex $new_nodes 0]
+       set new_node2 [lindex $new_nodes 1]
+       set orig_node1 [lindex $orig_nodes 0]
+       set orig_node2 [lindex $orig_nodes 1]
+       set new_link1 [linkByPeers $orig_node1 $new_node1]
+       set new_link2 [linkByPeers $orig_node2 $new_node2]
+       setNodeMirror $new_node1 $new_node2
+       setNodeMirror $new_node2 $new_node1
+       setNodeName $new_node1 $orig_node2
+       setNodeName $new_node2 $orig_node1
+       setLinkMirror $new_link1 $new_link2
+       setLinkMirror $new_link2 $new_link1
     }
-
-    return $regular
+    redrawAll
+    set changed 1
+    updateUndoLog
+    return
 }
 
 
@@ -1149,15 +988,21 @@ 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 $lnode1 $lnode2 non-atomic] == "yes" } {
-               set changed 1
+           if { [ifcByLogicalPeer $lnode1 $lnode2] == "" } {
+               set link [newLink $lnode1 $lnode2]
+               if { $link != "" } {
+                   drawLink $link
+                   redrawLink $link
+                   updateLinkLabel $link
+                   set changed 1
+               }
            }
        }
     }
 
     if { $changed == 1 } {
        set regular true
-       if {[lindex [$c gettags $curobj] 0] == "nodelabel"} {
+       if { [lindex [$c gettags $curobj] 0] == "nodelabel" } {
            set node [lindex [$c gettags $curobj] 1]
            selectNode $c [$c find withtag "node && $node"]
        }
@@ -1764,7 +1609,6 @@ proc popupConfigApply { wi object_type target close phase } {
            set name [string trim [$wi.ftop.name get]]
            if { $name != [getNodeName $target] } {
                setNodeName $target $name
-               .c itemconfigure "nodelabel && $target" -text $name
                set changed 1
            }
            if { $oper_mode == "edit" && $type == "router" && \
@@ -1811,7 +1655,6 @@ proc popupConfigApply { wi object_type target close phase } {
                    set oldifoperstate [getIfcOperState $target $ifc]
                    if { $ifoperstate != $oldifoperstate } {
                        setIfcOperState $target $ifc $ifoperstate
-                       updateIfcLabel $target [peerByIfc $target $ifc]
                        set changed 1
                    }
 
@@ -1822,14 +1665,12 @@ proc popupConfigApply { wi object_type target close phase } {
                    set oldipaddr [getIfcIPv4addr $target $ifc]
                    if { $ipaddr != $oldipaddr } {
                        setIfcIPv4addr $target $ifc $ipaddr
-                       updateIfcLabel $target [peerByIfc $target $ifc]
                        set changed 1
                    }
                    set ipaddr [$wi.if$ifc.cfg.ipv6.addrv get]
                    set oldipaddr [getIfcIPv6addr $target $ifc]
                    if { $ipaddr != $oldipaddr } {
                        setIfcIPv6addr $target $ifc $ipaddr
-                       updateIfcLabel $target [peerByIfc $target $ifc]
                        set changed 1
                    }
 
@@ -1954,9 +1795,11 @@ proc popupConfigApply { wi object_type target close phase } {
                }
                set changed 1
            }
-           updateLinkLabel $target
        }
     }
+    if { $changed == 1 } {
+       redrawAll
+    }
     updateUndoLog
     if { $close == "close" } {
        destroy $wi
@@ -2172,18 +2015,44 @@ proc switchCanvas { direction } {
            }
        }
     }
+
+    .hframe.t delete all
+    set x 0
+    foreach canvas $canvas_list {
+       set text [.hframe.t create text 0 0 \
+           -text "[getCanvasName $canvas]" -tags "text $canvas"]
+       set ox [lindex [.hframe.t bbox $text] 2]
+       set oy [lindex [.hframe.t bbox $text] 3]
+       set tab [.hframe.t create polygon $x 0 [expr $x + 7] 18 \
+           [expr $x + 2 * $ox + 17] 18 [expr $x + 2 * $ox + 24] 0 $x 0 \
+           -fill gray -tags "tab $canvas"]
+       set line [.hframe.t create line 0 0 $x 0 [expr $x + 7] 18 \
+           [expr $x + 2 * $ox + 17] 18 [expr $x + 2 * $ox + 24] 0 999 0 \
+           -fill #808080 -width 2 -tags "line $canvas"]
+       .hframe.t coords $text [expr $x + $ox + 12] [expr $oy + 2]
+       .hframe.t raise $text
+       incr x [expr 2 * $ox + 17]
+    }
+    .hframe.t raise "$curcanvas"
+    .hframe.t itemconfigure "tab && $curcanvas" -fill #e0e0e0
+
     redrawAll
     return
 }
 
 
 proc renameCanvasApply { w } {
-    global curcanvas
+    global curcanvas changed
 
     set newname [$w.e1 get]
     destroy $w
+    if { $newname != [getCanvasName $curcanvas] } {
+       set changed 1
+    }
     setCanvasName $curcanvas $newname
     refreshCanvasMenu
+    switchCanvas none
+    updateUndoLog
 }
 
 
@@ -2229,8 +2098,8 @@ proc refreshCanvasMenu {} {
         }
         deleteSelection
         set i [lsearch $canvas_list $curcanvas]
-        switchCanvas next
         set canvas_list [lreplace $canvas_list $i $i]
+        switchCanvas none
         set changed 1
         updateUndoLog
         refreshCanvasMenu
@@ -2243,7 +2112,7 @@ proc refreshCanvasMenu {} {
     .menubar.canvas add separator
     foreach canvas $canvas_list {
        .menubar.canvas add radiobutton -label [getCanvasName $canvas] \
-               -command redrawAll -indicatoron true \
+               -command "switchCanvas none" -indicatoron true \
                -value $canvas -variable curcanvas
     }
     return

diff --git a/initgui.tcl b/initgui.tcl
index 1c9370a14759f44b9b2874acde5cc3b4d050d602..f089907da1387769ce6ae2ec3dc6a3b15ceb1f82 100755 (executable)
--- a/initgui.tcl
+++ b/initgui.tcl
@@ -290,7 +290,7 @@ set c [canvas .c -bd 0 -relief sunken -highlightthickness 0\
        -scrollregion "-32 -32 [expr $sizex + 32] [expr $sizey + 32]" \
        -xscrollcommand ".hframe.scroll set" \
        -yscrollcommand ".vframe.scroll set"]
-canvas .hframe.t -width 250 -height 18 -bd 0 -highlightthickness 0 \
+canvas .hframe.t -width 300 -height 18 -bd 0 -highlightthickness 0 \
        -background gray
 scrollbar .hframe.scroll -orient horiz -command "$c xview" \
        -bd 1 -width 14

diff --git a/linkcfg.tcl b/linkcfg.tcl
index c7a2adece7b60ae2435f98f7f64495cef239d519..5ada454a4b8d6490ffaf2704069713f253b02df1 100755 (executable)
--- a/linkcfg.tcl
+++ b/linkcfg.tcl
@@ -361,4 +361,88 @@ proc mergeLink { link } {
     set i [lsearch -exact $node_list $pseudo_node2]
     set node_list [lreplace $node_list $i $i]
 
+    return $new_link
+}
+
+
+proc newLink { lnode1 lnode2 } {
+    global link_list
+    global $lnode1 $lnode2
+    global defEthBandwidth defSerBandwidth defSerDelay
+    global defLinkColor defLinkWidth
+    global curcanvas
+
+    if { [nodeType $lnode1] == "frswitch" && \
+       [nodeType $lnode2] != "router" && \
+       [nodeType $lnode2] != "frswitch" } { set regular no }
+    if { [nodeType $lnode2] == "frswitch" && \
+       [nodeType $lnode1] != "router" && \
+       [nodeType $lnode1] != "frswitch" } { set regular no }
+    if { [nodeType $lnode1] == "hub" && \
+       [nodeType $lnode2] == "hub" } { set regular no }
+    if { [nodeType $lnode1] == "rj45" || \
+       [nodeType $lnode2] == "rj45" } {
+       if { [nodeType $lnode1] == "rj45" } {
+           set rj45node $lnode1
+           set othernode $lnode2
+       } else {
+           set rj45node $lnode2
+           set othernode $lnode1
+       }
+       if { [lsearch {router lanswitch hub pc host} \
+         [nodeType $othernode]] < 0} {
+           return
+       }
+       if { [lsearch [set $rj45node] "interface-peer *"] > 0 } {
+           return
+       }
+    }
+
+    set link [newObjectId link]
+    global $link
+    set $link {}
+
+    set ifname1 [newIfc [chooseIfName $lnode1 $lnode2] $lnode1]
+    lappend $lnode1 "interface-peer {$ifname1 $lnode2}"
+    set ifname2 [newIfc [chooseIfName $lnode2 $lnode1] $lnode2]
+    lappend $lnode2 "interface-peer {$ifname2 $lnode1}"
+
+    lappend $link "nodes {$lnode1 $lnode2}"
+    if { ([nodeType $lnode1] == "lanswitch" || \
+       [nodeType $lnode2] == "lanswitch" || \
+       [string first eth "$ifname1 $ifname2"] != -1) && \
+       [nodeType $lnode1] != "rj45" && \
+       [nodeType $lnode2] != "rj45" } {
+       lappend $link "bandwidth $defEthBandwidth"
+    } elseif { [string first ser "$ifname1 $ifname2"] != -1 } {
+       lappend $link "bandwidth $defSerBandwidth"
+       lappend $link "delay $defSerDelay"
+    }
+
+    lappend link_list $link
+
+    if { [nodeType $lnode2] != "pseudo" &&
+       [[typemodel $lnode1].layer] == "NETWORK" } {
+       autoIPv4addr $lnode1 $ifname1
+       autoIPv6addr $lnode1 $ifname1
+    }
+    if { [nodeType $lnode1] != "pseudo" &&
+       [[typemodel $lnode2].layer] == "NETWORK" } {
+       autoIPv4addr $lnode2 $ifname2
+       autoIPv6addr $lnode2 $ifname2
+    }
+    if { [nodeType $lnode1] != "router" &&
+       [nodeType $lnode2] != "pseudo" &&
+       [[typemodel $lnode1].layer] == "NETWORK" } {
+       autoIPv4defaultroute $lnode1 $ifname1
+       autoIPv6defaultroute $lnode1 $ifname1
+    }
+    if { [nodeType $lnode2] != "router" &&
+       [nodeType $lnode1] != "pseudo" &&
+       [[typemodel $lnode2].layer] == "NETWORK" } {
+       autoIPv4defaultroute $lnode2 $ifname2
+       autoIPv6defaultroute $lnode2 $ifname2
+    }
+
+    return $link
 }