A partial implementation of cross-canvas links. Breaks exec.tcl

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

diff --git a/cfgparse.tcl b/cfgparse.tcl
index 3eda1bd63777149c02c1d1a1e3a301008620cecc..4c0e61b4be15e85e344b859f1bfdea145ccf900e 100755 (executable)
--- a/cfgparse.tcl
+++ b/cfgparse.tcl
@@ -179,6 +179,9 @@ proc loadCfg { cfg } {
                        type {
                            lappend $object "type $value"
                        }
+                       mirror {
+                           lappend $object "mirror $value"
+                       }
                        model {
                            lappend $object "model $value"
                        }
@@ -231,6 +234,9 @@ proc loadCfg { cfg } {
                        nodes {
                            lappend $object "nodes {$value}"
                        }
+                       mirror {
+                           lappend $object "mirror $value"
+                       }
                        bandwidth {
                            lappend $object "bandwidth $value"
                        }

diff --git a/editor.tcl b/editor.tcl
index d882e105ce9e7819d980de17b8a35266d5996bb3..5f3c0ec260b392f5e2446685dd40438c37edba84 100755 (executable)
--- a/editor.tcl
+++ b/editor.tcl
@@ -58,7 +58,24 @@ proc animateCursor {} {
 proc removeGUILink { link } {
     global .c
 
-    removeLink $link
+    set nodes [linkPeers $link]
+    set node1 [lindex $nodes 0]
+    set node2 [lindex $nodes 1]
+    if { [nodeType $node1] == "pseudo" } {
+       removeLink [getLinkMirror $link]
+       removeLink $link
+       removeNode [getNodeMirror $node1]
+       removeNode $node1
+       .c delete $node1
+    } elseif { [nodeType $node2] == "pseudo" } {
+       removeLink [getLinkMirror $link]
+       removeLink $link
+       removeNode [getNodeMirror $node2]
+       removeNode $node2
+       .c delete $node2
+    } else {
+       removeLink $link
+    }
     .c delete $link
     return
 }
@@ -67,13 +84,16 @@ proc removeGUILink { link } {
 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
     }
-    removeNode $node
-    .c delete $node
+    if { $type != "pseudo" } {
+       removeNode $node
+       .c delete $node
+    }
     return
 }
 
@@ -153,7 +173,7 @@ proc redrawAll {} {
 
 proc drawNode { node } {
     global showNodeLabels
-    global router pc host lanswitch frswitch rj45 hub
+    global router pc host lanswitch frswitch rj45 hub pseudo
 
     set type [nodeType $node]
     set coords [getNodeCoords $node]
@@ -164,8 +184,18 @@ proc drawNode { node } {
     set coords [getNodeLabelCoords $node]
     set x [lindex $coords 0]
     set y [lindex $coords 1]
-    set label [.c create text $x $y -fill blue -text "[getNodeName $node]" \
-       -tags "nodelabel $node"]
+    if { [nodeType $node] != "pseudo" } {
+       set label [.c create text $x $y -fill blue \
+           -text "[getNodeName $node]" \
+           -tags "nodelabel $node"]
+    } else {
+       set pnode [getNodeName $node]
+       set pcanvas [getNodeCanvas $pnode]
+       set ifc [ifcByPeer $pnode [getNodeMirror $node]]
+       set label [.c create text $x $y -fill blue \
+           -text "$ifc@[getNodeName $pnode]\r([getCanvasName $pcanvas])" \
+           -tags "nodelabel $node" -justify center]
+    }
     if { $showNodeLabels == 0} {
        .c itemconfigure $label -state hidden
     }
@@ -181,10 +211,11 @@ proc drawLink {link} {
     set lnode2 [lindex $nodes 1]
     set newlink [.c create line 0 0 0 0 \
                -fill $defLinkColor -width $defLinkWidth \
-               -tags "link $link $lnode1 $lnode2"]
+               -tags "link $link $lnode1 $lnode2" \
+               -arrow both]
     .c raise $newlink background
     set newlink [.c create line 0 0 0 0 \
-               -fill white -width [expr $defLinkWidth * 4 ] \
+               -fill white -width [expr $defLinkWidth * 3 ] \
                -tags "link $link $lnode1 $lnode2"]
     .c raise $newlink background
     .c create text 0 0 -tags "linklabel $link" -justify center
@@ -483,14 +514,19 @@ proc button3node { c x y } {
     #
     # Configure node
     #
-    .button3menu add command -label "Configure" \
-       -command "popupConfigDialog $c"
+    if { [nodeType $node] != "pseudo" } {
+       .button3menu add command -label "Configure" \
+           -command "popupConfigDialog $c"
+    } else {
+       .button3menu add command -label "Configure" \
+           -command "popupConfigDialog $c" -state disabled
+    }
 
     #
     # Create a new link - can be between different canvases
     #
     .button3menu.connect delete 0 end
-    if { $oper_mode == "exec" } {
+    if { $oper_mode == "exec" || [nodeType $node] == "pseudo" } {
        .button3menu add cascade -label "Create link to" \
            -menu .button3menu.connect -state disabled
     } else {
@@ -507,7 +543,7 @@ proc button3node { c x y } {
            -menu .button3menu.connect.$canvas
     }
     foreach peer_node $node_list {
-       if { $node != $peer_node } {
+       if { $node != $peer_node && [nodeType $peer_node] != "pseudo" } {
            set canvas [getNodeCanvas $peer_node]
            .button3menu.connect.$canvas add command \
                -label [getNodeName $peer_node] \
@@ -629,37 +665,7 @@ proc button1 { c x y button } {
     }
     if { $curobj == $background } {
        if { [lsearch {select link} $activetool] < 0 } {
-           set node [newObjectId node]
-           global $node
-           lappend $node "type $activetool"
-           if { $activetool == "router" } {
-               lappend $node "model $def_router_model"
-           }
-           if {$activetool == "router"} {
-               set nconfig [list \
-                       "hostname $activetool[string range $node 1 end]" \
-                       ! \
-                       "router rip" \
-                       " redistribute static" \
-                       " redistribute connected" \
-                       " network 0.0.0.0/0" \
-                       ! \
-                       "router ripng" \
-                       " redistribute static" \
-                       " redistribute connected" \
-                       " network ::/0" \
-                       ! ]
-           } elseif {$activetool == "rj45"} {
-               set nconfig [list \
-                       "hostname UNASSIGNED" \
-                       ! ]
-           } else {
-               set nconfig [list \
-                       "hostname $activetool[string range $node 1 end]" \
-                       ! ]
-           }
-           lappend $node "network-config [list $nconfig]"
-           lappend node_list $node
+           set node [newNode $activetool]
            setNodeCanvas $node $curcanvas
            setNodeCoords $node "$x $y"
            set dy 32
@@ -677,7 +683,6 @@ proc button1 { c x y button } {
            set lastY $y
            if {$selectbox != ""} {
                # We actually shouldn't get here!
-puts XXXX 1
                $c delete $selectbox
                set selectbox ""
            }
@@ -753,17 +758,67 @@ proc button1-motion { c x y } {
 }
 
 
+proc pseudo.layer { node } {
+}
+
+
 proc newLink { c lnode1 lnode2 } {
     global link_list
     global $lnode1 $lnode2
     global defEthBandwidth defSerBandwidth defSerDelay
     global defLinkColor defLinkWidth
+    global curcanvas
 
     #
-    # We still do not support linking objects in different canvases.
+    # 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] } {
-       return no
+       set pnode1 [newNode pseudo]
+       setNodeCanvas $pnode1 [getNodeCanvas $lnode1]
+       setNodeName $pnode1 $lnode2
+       setNodeCoords $pnode1 "100 100"
+       setNodeLabelCoords $pnode1 "100 100"
+       if { [getNodeCanvas $lnode1] == $curcanvas } {
+           drawNode $pnode1
+       }
+
+       set pnode2 [newNode pseudo]
+       setNodeCanvas $pnode2 [getNodeCanvas $lnode2]
+       setNodeName $pnode2 $lnode1
+       setNodeCoords $pnode2 "100 100"
+       setNodeLabelCoords $pnode2 "100 100"
+       if { [getNodeCanvas $lnode2] == $curcanvas } {
+           drawNode $pnode2
+       }
+
+       setNodeMirror $pnode1 $pnode2
+       setNodeMirror $pnode2 $pnode1
+
+       newLink $c $lnode1 $pnode1
+       newLink $c $lnode2 $pnode2
+
+       set link1 [linkByPeers $lnode1 $pnode1]
+       set link2 [linkByPeers $lnode2 $pnode2]
+       setLinkMirror $link1 $link2
+       setLinkMirror $link2 $link1
+       
+       #
+       # 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
+       } else {
+           $c delete -withtags "node && $pnode2"
+           $c delete -withtags "nodelabel && $pnode2"
+           drawNode $pnode2
+       }
+
+       return yes
     }
 
     set regular yes
@@ -796,6 +851,9 @@ proc newLink { c lnode1 lnode2 } {
     }
 
     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
@@ -828,17 +886,19 @@ proc newLink { c lnode1 lnode2 } {
 
        set ifname2 [newIfc [chooseIfName $lnode2 $lnode1] $lnode2]
        lappend $lnode2 "interface-peer {$ifname2 $lnode1}"
-       if { [[typemodel $lnode2].layer] == "NETWORK" && \
-           [lsearch {lanswitch hub} [nodeType $lnode1]] >= 0 } {
-           setIfcIPv4addr $lnode2 $ifname2 [newLANIPv4 $lnode2 $lnode1]
-           setIfcIPv6addr $lnode2 $ifname2 [newLANIPv6 $lnode2 $lnode1]
-           set lannode $lnode1
-       } elseif { [[typemodel $lnode2].layer] == "NETWORK" } {
-           setIfcIPv4addr $lnode2 $ifname2 $ipv4net.2/24
-           setIfcIPv6addr $lnode2 $ifname2 $ipv6net\::2/64
-           if { [nodeType $lnode2] == "pc" || \
-               [nodeType $lnode2] == "host" } {
-               setStatIPv4routes $lnode2 [list "0.0.0.0/0 $ipv4net.1"]
+       if { [nodeType $lnode2] != "pseudo" } {
+           if { [[typemodel $lnode2].layer] == "NETWORK" && \
+               [lsearch {lanswitch hub} [nodeType $lnode1]] >= 0 } {
+               setIfcIPv4addr $lnode2 $ifname2 [newLANIPv4 $lnode2 $lnode1]
+               setIfcIPv6addr $lnode2 $ifname2 [newLANIPv6 $lnode2 $lnode1]
+               set lannode $lnode1
+           } elseif { [[typemodel $lnode2].layer] == "NETWORK" } {
+               setIfcIPv4addr $lnode2 $ifname2 $ipv4net.2/24
+               setIfcIPv6addr $lnode2 $ifname2 $ipv6net\::2/64
+               if { [nodeType $lnode2] == "pc" || \
+                   [nodeType $lnode2] == "host" } {
+                   setStatIPv4routes $lnode2 [list "0.0.0.0/0 $ipv4net.1"]
+               }
            }
        }
 
@@ -855,13 +915,16 @@ proc newLink { c lnode1 lnode2 } {
        }
 
        lappend link_list $link
-       drawLink $link
-       updateLinkLabel $link
        if { $lannode != "" } {
            updateLANdg $lannode
        }
-       nodeEnter $c
-       redrawLink $link
+
+       if { [getNodeCanvas $lnode1] == $curcanvas } {
+           drawLink $link
+           updateLinkLabel $link
+           nodeEnter $c
+           redrawLink $link
+       }
     }
 
     return $regular
@@ -1110,6 +1173,10 @@ proc popupConfigDialog { c } {
     switch -exact -- $object_type {
        node {
            set type [nodeType $target]
+           if { $type == "pseudo" } {
+               destroy $wi
+               return
+           }
            set model [getNodeModel $target]
            set router_model $model
            wm title $wi "$type configuration"
@@ -1486,6 +1553,9 @@ proc popupConfigApply { wi object_type target close phase } {
        return
     }
     switch -exact -- $object_type {
+       #
+       # Node
+       #
        node {
            set type [nodeType $target]
            set model [getNodeModel $target]
@@ -1645,6 +1715,9 @@ proc popupConfigApply { wi object_type target close phase } {
            }
        }
 
+       #
+       # Link
+       #
        link {
            set bw [$wi.bandwidth.value get]
            if { $bw != [getLinkBandwidth $target] } {

diff --git a/exec.tcl b/exec.tcl
index 82730c8493174a3f9d9770df343c43ac11859e8a..702d6ce5fe7d9b51bb1ef765f8a30d45865a0b95 100755 (executable)
--- a/exec.tcl
+++ b/exec.tcl
@@ -217,11 +217,17 @@ proc deployCfg {} {
        set node_id "$eid\_$node"
        set type [nodeType $node]
        set name [getNodeName $node]
-       statline "Creating node $name"
-       [typemodel $node].instantiate $eid $node
+       if { $type != "pseudo" } {
+           statline "Creating node $name"
+           [typemodel $node].instantiate $eid $node
+       }
     }
 
-    foreach link $link_list {
+    for { set pending_links $link_list } { $pending_links != "" } {} {
+       set link [lindex $pending_links 0]
+       set i [lsearch -exact $pending_links $link]
+       set pending_links [lreplace XXXX]
+
        statline "Creating link $link"
        set lnode1 [lindex [linkPeers $link] 0]
        set lnode2 [lindex [linkPeers $link] 1]
@@ -280,9 +286,12 @@ proc deployCfg {} {
 
     foreach node $node_list {
        global $node
+       set type [nodeType $node]
+       if { $type == "pseudo" } {
+           continue
+       }
        statline "Configuring node [getNodeName $node]"
        set node_id "$eid\_$node"
-       set type [nodeType $node]
        set model [getNodeModel $node]
        if { [lsearch -exact {router pc host} $type] >= 0 } {
            nexec rm -fr /tmp/$node_id

diff --git a/initgui.tcl b/initgui.tcl
index 0cb0cf891cb2c551cadf8d7d4d2ee601d8acb5de..a7bc072b438a052a7186478d5d55a785744cbb74 100755 (executable)
--- a/initgui.tcl
+++ b/initgui.tcl
@@ -268,6 +268,7 @@ foreach b {select link hub lanswitch router host pc rj45} {
 foreach b {router host pc hub lanswitch frswitch rj45} {
     set $b [image create photo -file $ROOTDIR/$LIBDIR/icons/normal/$b.gif]
 }
+set pseudo [image create photo -file $ROOTDIR/$LIBDIR/icons/tiny/delete.gif]
 
 
 frame .grid
@@ -311,7 +312,6 @@ $c bind nodelabel <Double-1> "popupConfigDialog $c"
 $c bind link <Double-1> "popupConfigDialog $c"
 $c bind linklabel <Double-1> "popupConfigDialog $c"
 $c bind node <3> "button3node $c %x %y"
-$c bind nodelabel <3> "button3node $c %x %y"
 $c bind link <3> "button3link $c %x %y"
 $c bind linklabel <3> "button3link $c %x %y"
 bind $c <1> "button1 $c %x %y none"

diff --git a/linkcfg.tcl b/linkcfg.tcl
index b694efb757fef8cde331eaee979e216cc6cb65ca..c6f971576b2e3b6359054d568a0dbac1c26446e0 100755 (executable)
--- a/linkcfg.tcl
+++ b/linkcfg.tcl
@@ -231,3 +231,24 @@ proc setLinkDup { link value } {
     }
     return
 }
+
+
+proc getLinkMirror { link } {
+    global $link
+
+    set entry [lsearch -inline [set $link] "mirror *"]
+    return [lindex $entry 1]
+}
+
+
+proc setLinkMirror { link value } {
+    global $link
+
+    set i [lsearch [set $link] "mirror *"]
+    if { $value == "" } {
+       set $link [lreplace [set $link] $i $i]
+    } else {
+       set $link [lreplace [set $link] $i $i "mirror $value"]
+    }
+    return
+}

diff --git a/nodecfg.tcl b/nodecfg.tcl
index 696e6fd7d84ad26475fb0c7c1b379fbaa43ba6d4..f0d8d5812bd83498f3ac8bd3d3339a57d33541a0 100755 (executable)
--- a/nodecfg.tcl
+++ b/nodecfg.tcl
@@ -799,3 +799,59 @@ proc newIfc { type node } {
     for { set id 0 } { [lsearch -exact $interfaces $type$id] >= 0 } {incr id} {}
     return $type$id
 }
+
+
+proc newNode { type } {
+    global node_list def_router_model
+
+    set node [newObjectId node]
+    global $node
+    lappend $node "type $type"
+    if { $type == "router" } {
+       lappend $node "model $def_router_model"
+       set nconfig [list \
+               "hostname $type[string range $node 1 end]" \
+               ! \
+               "router rip" \
+               " redistribute static" \
+               " redistribute connected" \
+               " network 0.0.0.0/0" \
+               ! \
+               "router ripng" \
+               " redistribute static" \
+               " redistribute connected" \
+               " network ::/0" \
+               ! ]
+    } elseif {$type == "rj45"} {
+       set nconfig [list \
+               "hostname UNASSIGNED" \
+               ! ]
+       } else {
+               set nconfig [list \
+               "hostname $type[string range $node 1 end]" \
+               ! ]
+    }
+    lappend $node "network-config [list $nconfig]"
+    lappend node_list $node
+    return $node
+}
+
+
+proc getNodeMirror { node } {
+    global $node
+
+    return [lindex [lsearch -inline [set $node] "mirror *"] 1]
+}
+
+
+proc setNodeMirror { node value } {
+    global $node
+
+    set i [lsearch [set $node] "mirror *"]
+    if { $value == "" } {
+       set $node [lreplace [set $node] $i $i]
+    } else {
+       set $node [linsert [set $node] end "mirror $value"]
+    }
+    return
+}