From: marko <marko>
Date: Tue, 25 Oct 2005 10:29:42 +0000 (+0000)
Subject: A partial implementation of cross-canvas links.  Breaks exec.tcl
X-Git-Url: https://git.entuzijast.net/?a=commitdiff_plain;h=3d2870368733b262c895bd043a467e939ef46b29;p=imunes.git

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 3eda1bd..4c0e61b 100755
--- 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 d882e10..5f3c0ec 100755
--- 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]
([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 82730c8..702d6ce 100755
--- 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 0cb0cf8..a7bc072 100755
--- 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 b694efb..c6f9715 100755
--- 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 696e6fd..f0d8d58 100755
--- 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
+}