5351 lines
156 KiB
Tcl
5351 lines
156 KiB
Tcl
#
|
|
# Copyright 2004-2008 University of Zagreb, Croatia.
|
|
#
|
|
# Redistribution and use in source and binary forms, with or without
|
|
# modification, are permitted provided that the following conditions
|
|
# are met:
|
|
# 1. Redistributions of source code must retain the above copyright
|
|
# notice, this list of conditions and the following disclaimer.
|
|
# 2. Redistributions in binary form must reproduce the above copyright
|
|
# notice, this list of conditions and the following disclaimer in the
|
|
# documentation and/or other materials provided with the distribution.
|
|
#
|
|
# THIS SOFTWARE IS PROVIDED BY AUTHOR AND CONTRIBUTORS ``AS IS'' AND
|
|
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
|
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
|
# ARE DISCLAIMED. IN NO EVENT SHALL AUTHOR OR CONTRIBUTORS BE LIABLE
|
|
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
|
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
|
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
|
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
|
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
|
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
|
# SUCH DAMAGE.
|
|
#
|
|
# This work was supported in part by the Croatian Ministry of Science
|
|
# and Technology through the research contract #IP-2003-143.
|
|
#
|
|
|
|
#****h* imunes/editor.tcl
|
|
# NAME
|
|
# editor.tcl -- file used for defining functions that can be used in
|
|
# edit mode as well as all the functions which change the appearance
|
|
# of the imunes GUI.
|
|
# FUNCTION
|
|
# This module is used for defining all possible actions in imunes
|
|
# edit mode. It is also used for all the GUI related actions.
|
|
#****
|
|
|
|
|
|
proc animateCursor {} {
|
|
global cursorState
|
|
global clock_seconds
|
|
|
|
if { [clock seconds] == $clock_seconds } {
|
|
update
|
|
return
|
|
}
|
|
set clock_seconds [clock seconds]
|
|
if { $cursorState } {
|
|
.c config -cursor watch
|
|
set cursorState 0
|
|
} else {
|
|
.c config -cursor pirate
|
|
set cursorState 1
|
|
}
|
|
update
|
|
}
|
|
|
|
#****f* editor.tcl/removeGUILink
|
|
# NAME
|
|
# removeGUILink -- remove link from GUI
|
|
# SYNOPSIS
|
|
# renoveGUILink $link_id $atomic
|
|
# FUNCTION
|
|
# Removes link from GUI. It removes standard links as well as
|
|
# split links and links connecting nodes on different canvases.
|
|
# INPUTS
|
|
# * link_id -- the link id
|
|
# * atomic -- defines if the remove was atomic action or a part
|
|
# of a composed, non-atomic action (relevant for updating log
|
|
# for undo).
|
|
#****
|
|
|
|
proc removeGUILink { link atomic } {
|
|
global changed
|
|
|
|
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
|
|
if { $atomic == "atomic" } {
|
|
set changed 1
|
|
updateUndoLog
|
|
}
|
|
}
|
|
|
|
#****f* editor.tcl/removeGUINode
|
|
# NAME
|
|
# removeGUINode -- remove node from GUI
|
|
# SYNOPSIS
|
|
# renoveGUINode $node_id
|
|
# FUNCTION
|
|
# Removes node from GUI. When removing a node from GUI the links
|
|
# connected to that node are also removed.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
#****
|
|
|
|
proc removeGUINode { node } {
|
|
set type [nodeType $node]
|
|
foreach ifc [ifcList $node] {
|
|
set peer [peerByIfc $node $ifc]
|
|
set link [lindex [.c gettags "link && $node && $peer"] 1]
|
|
removeGUILink $link non-atomic
|
|
}
|
|
if { [lsearch -exact "oval rectangle label text marker" $type] != -1 } {
|
|
deleteAnnotation .c $type $node
|
|
} elseif { $type != "pseudo" } {
|
|
removeNode $node
|
|
.c delete $node
|
|
}
|
|
}
|
|
|
|
#****f* editor.tcl/updateUndoLog
|
|
# NAME
|
|
# updateUndoLog -- update the undo log
|
|
# SYNOPSIS
|
|
# updateUndoLog
|
|
# FUNCTION
|
|
# Updates the undo log. Writes the current configuration to the
|
|
# undolog array and updates the undolevel variable.
|
|
#****
|
|
|
|
proc updateUndoLog {} {
|
|
global changed undolog undolevel redolevel
|
|
|
|
if { $changed } {
|
|
global t_undolog undolog
|
|
set t_undolog ""
|
|
dumpCfg string t_undolog
|
|
incr undolevel
|
|
set undolog($undolevel) $t_undolog
|
|
set redolevel $undolevel
|
|
updateUndoRedoMenu ""
|
|
# Boeing: XXX why is this set here?
|
|
set changed 0
|
|
}
|
|
}
|
|
|
|
#****f* editor.tcl/undo
|
|
# NAME
|
|
# undo -- undo function
|
|
# SYNOPSIS
|
|
# undo
|
|
# FUNCTION
|
|
# Undo the change. Reads the undolog and updates the current
|
|
# configuration. Reduces the value of undolevel.
|
|
#****
|
|
|
|
proc undo {} {
|
|
global undolevel undolog oper_mode
|
|
|
|
if {$oper_mode == "edit" && $undolevel > 0} {
|
|
incr undolevel -1
|
|
updateUndoRedoMenu ""
|
|
.c config -cursor watch
|
|
loadCfg $undolog($undolevel)
|
|
switchCanvas none
|
|
}
|
|
}
|
|
|
|
#****f* editor.tcl/redo
|
|
# NAME
|
|
# redo
|
|
# SYNOPSIS
|
|
# redo
|
|
# FUNCTION
|
|
# Redo the change if possible (redolevel is greater than
|
|
# undolevel). Reads the configuration from undolog and
|
|
# updates the current configuration. Increases the value
|
|
# of undolevel.
|
|
#****
|
|
|
|
proc redo {} {
|
|
global undolevel redolevel undolog oper_mode
|
|
|
|
if {$oper_mode == "edit" && $redolevel > $undolevel} {
|
|
incr undolevel
|
|
updateUndoRedoMenu ""
|
|
.c config -cursor watch
|
|
loadCfg $undolog($undolevel)
|
|
switchCanvas none
|
|
}
|
|
}
|
|
|
|
proc updateUndoRedoMenu { forced } {
|
|
global undolevel redolevel
|
|
|
|
if { $forced == "" } {
|
|
if { $undolevel > 0 } { set undo "normal" } else { set undo "disabled" }
|
|
if { $redolevel > $undolevel } { set redo "normal"
|
|
} else { set redo "disabled" }
|
|
} else {
|
|
set undo $forced
|
|
set redo $forced
|
|
}
|
|
|
|
.menubar.edit entryconfigure "Undo" -state $undo
|
|
.menubar.edit entryconfigure "Redo" -state $redo
|
|
}
|
|
|
|
#****f* editor.tcl/redrawAll
|
|
# NAME
|
|
# redrawAll
|
|
# SYNOPSIS
|
|
# redrawAll
|
|
# FUNCTION
|
|
# Redraws all the objects on the current canvas.
|
|
#****
|
|
|
|
|
|
proc redrawAll {} {
|
|
global node_list plot_list link_list annotation_list plot_list background sizex sizey grid
|
|
global curcanvas zoom
|
|
global showAnnotations showGrid
|
|
|
|
#Call_Trace ;# debugging when things disappear
|
|
|
|
.bottom.zoom config -text "zoom [expr {int($zoom * 100)}]%"
|
|
set e_sizex [expr {int($sizex * $zoom)}]
|
|
set e_sizey [expr {int($sizey * $zoom)}]
|
|
set border 28
|
|
.c configure -scrollregion \
|
|
"-$border -$border [expr {$e_sizex + $border}] \
|
|
[expr {$e_sizey + $border}]"
|
|
|
|
|
|
saveRestoreWlanLinks .c save
|
|
.c delete all
|
|
set background [.c create rectangle 0 0 $e_sizex $e_sizey \
|
|
-fill white -tags "background"]
|
|
# Boeing: wallpaper
|
|
set wallpaper [lindex [getCanvasWallpaper $curcanvas] 0]
|
|
set wallpaperStyle [lindex [getCanvasWallpaper $curcanvas] 1]
|
|
if { $wallpaper != "" } {
|
|
drawWallpaper .c $wallpaper $wallpaperStyle
|
|
}
|
|
# end Boeing
|
|
|
|
if { $showAnnotations == 1 } {
|
|
foreach obj $annotation_list {
|
|
# fix annotations having no canvas (from old config)
|
|
if { [getNodeCanvas $obj] == "" } { setNodeCanvas $obj $curcanvas}
|
|
if { [getNodeCanvas $obj] == $curcanvas } {
|
|
drawAnnotation $obj
|
|
}
|
|
}
|
|
}
|
|
|
|
# Grid
|
|
set e_grid [expr {int($grid * $zoom)}]
|
|
set e_grid2 [expr {$e_grid * 2}]
|
|
if { $showGrid } {
|
|
for { set x $e_grid } { $x < $e_sizex } { incr x $e_grid } {
|
|
if { [expr {$x % $e_grid2}] != 0 } {
|
|
if { $zoom > 0.5 } {
|
|
.c create line $x 1 $x $e_sizey \
|
|
-fill gray -dash {1 7} -tags "grid"
|
|
}
|
|
} else {
|
|
.c create line $x 1 $x $e_sizey -fill gray -dash {1 3} \
|
|
-tags "grid"
|
|
}
|
|
}
|
|
for { set y $e_grid } { $y < $e_sizey } { incr y $e_grid } {
|
|
if { [expr {$y % $e_grid2}] != 0 } {
|
|
if { $zoom > 0.5 } {
|
|
.c create line 1 $y $e_sizex $y \
|
|
-fill gray -dash {1 7} -tags "grid"
|
|
}
|
|
} else {
|
|
.c create line 1 $y $e_sizex $y -fill gray -dash {1 3} \
|
|
-tags "grid"
|
|
}
|
|
}
|
|
}
|
|
|
|
.c lower -withtags background
|
|
|
|
foreach node $node_list {
|
|
if { [getNodeCanvas $node] == $curcanvas } {
|
|
drawNode .c $node
|
|
}
|
|
}
|
|
|
|
redrawAllThruplots
|
|
foreach link $link_list {
|
|
set nodes [linkPeers $link]
|
|
if { [getNodeCanvas [lindex $nodes 0]] != $curcanvas ||
|
|
[getNodeCanvas [lindex $nodes 1]] != $curcanvas } {
|
|
continue
|
|
}
|
|
drawLink $link
|
|
redrawLink $link
|
|
updateLinkLabel $link
|
|
}
|
|
saveRestoreWlanLinks .c restore
|
|
|
|
.c config -cursor left_ptr
|
|
|
|
raiseAll .c
|
|
}
|
|
|
|
#****f* editor.tcl/drawNode
|
|
# NAME
|
|
# drawNode
|
|
# SYNOPSIS
|
|
# drawNode node_id
|
|
# FUNCTION
|
|
# Draws the specified node. Draws node's image (router pc
|
|
# host lanswitch rj45 hub pseudo) and label.
|
|
# The visibility of the label depends on the showNodeLabels
|
|
# variable for all types of nodes and on invisible variable
|
|
# for pseudo nodes.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
#****
|
|
|
|
proc drawNode { c node } {
|
|
global showNodeLabels
|
|
global router pc host lanswitch rj45 hub pseudo OVS
|
|
global curcanvas zoom
|
|
global wlan
|
|
if { $c == "" } { set c .c } ;# default canvas
|
|
|
|
set type [nodeType $node]
|
|
set coords [getNodeCoords $node]
|
|
set x [expr {[lindex $coords 0] * $zoom}]
|
|
set y [expr {[lindex $coords 1] * $zoom}]
|
|
# special handling for custom images, dummy nodes
|
|
# could move this to separate getImage function
|
|
set model ""
|
|
set cimg ""
|
|
set imgzoom $zoom
|
|
if { $zoom == 0.75 || $zoom == 1.5 } { set imgzoom 1.0 }
|
|
if { $type == "router" || $type == "OVS" } {
|
|
set model [getNodeModel $node]
|
|
set cimg [getNodeTypeImage $model normal]
|
|
}
|
|
set tmp [absPathname [getCustomImage $node]]
|
|
if { $tmp != "" } { set cimg $tmp }
|
|
if { $cimg != "" } {
|
|
# name of global variable storing the image is the filename without path
|
|
set img [file tail $cimg]
|
|
# create the variable if the image hasn't been loaded before
|
|
global [set img]
|
|
if { ![info exists $img] } {
|
|
if { [catch {
|
|
set [set img] [image create photo -file $cimg]
|
|
createScaledImages $img
|
|
} e ] } { ;# problem loading image file
|
|
puts "icon error: $e"
|
|
set cimg "" ;# fall back to default model icon
|
|
setCustomImage $node "" ;# prevent errors elsewhere
|
|
}
|
|
}
|
|
if { $cimg != "" } { ;# only if image file loaded
|
|
global $img$imgzoom
|
|
$c create image $x $y -image [set $img$imgzoom] -tags "node $node"
|
|
}
|
|
}
|
|
if { $cimg == "" } {
|
|
if { $type == "pseudo" } {
|
|
$c create image $x $y -image [set $type] -tags "node $node"
|
|
} else {
|
|
# create scaled images based on zoom level
|
|
global $type$imgzoom
|
|
$c create image $x $y -image [set $type$imgzoom] \
|
|
-tags "node $node"
|
|
}
|
|
}
|
|
set coords [getNodeLabelCoords $node]
|
|
set x [expr {[lindex $coords 0] * $zoom}]
|
|
set y [expr {[lindex $coords 1] * $zoom}]
|
|
if { [nodeType $node] != "pseudo" } { ;# Boeing: show remote server
|
|
set loc [getNodeLocation $node]
|
|
set labelstr0 ""
|
|
if { $loc != "" } { set labelstr0 "([getNodeLocation $node]):" }
|
|
set labelstr1 [getNodeName $node];
|
|
set labelstr2 ""
|
|
if [info exists getNodePartition] { [getNodePartition $node]; }
|
|
set l [format "%s%s\n%s" $labelstr0 $labelstr1 $labelstr2];
|
|
set label [$c create text $x $y -fill blue \
|
|
-text "$l" \
|
|
-tags "nodelabel $node"]
|
|
} else {
|
|
set pnode [getNodeName $node]
|
|
set pcanvas [getNodeCanvas $pnode]
|
|
set ifc [ifcByPeer $pnode [getNodeMirror $node]]
|
|
if { $pcanvas != $curcanvas } {
|
|
set label [$c create text $x $y -fill blue \
|
|
-text "[getNodeName $pnode]:$ifc
|
|
@[getCanvasName $pcanvas]" \
|
|
-tags "nodelabel $node" -justify center]
|
|
} else {
|
|
set label [$c create text $x $y -fill blue \
|
|
-text "[getNodeName $pnode]:$ifc" \
|
|
-tags "nodelabel $node" -justify center]
|
|
}
|
|
}
|
|
if { $showNodeLabels == 0} {
|
|
$c itemconfigure $label -state hidden
|
|
}
|
|
global invisible
|
|
if { $invisible == 1 && [nodeType $node] == "pseudo" } {
|
|
$c itemconfigure $label -state hidden
|
|
}
|
|
}
|
|
|
|
#****f* editor.tcl/drawLink
|
|
# NAME
|
|
# drawLink
|
|
# SYNOPSIS
|
|
# drawLink link_id
|
|
# FUNCTION
|
|
# Draws the specified link. An arrow is displayed for links
|
|
# connected to pseudo nodes. If the variable invisible
|
|
# is specified link connecting a pseudo node stays hidden.
|
|
# INPUTS
|
|
# * link_id -- link id
|
|
#****
|
|
|
|
proc drawLink { link } {
|
|
set nodes [linkPeers $link]
|
|
set lnode1 [lindex $nodes 0]
|
|
set lnode2 [lindex $nodes 1]
|
|
set lwidth [getLinkWidth $link]
|
|
if { [getLinkMirror $link] != "" } {
|
|
set newlink [.c create line 0 0 0 0 \
|
|
-fill [getLinkColor $link] -width $lwidth \
|
|
-tags "link $link $lnode1 $lnode2" -arrow both]
|
|
} else {
|
|
set newlink [.c create line 0 0 0 0 \
|
|
-fill [getLinkColor $link] -width $lwidth \
|
|
-tags "link $link $lnode1 $lnode2"]
|
|
}
|
|
# Boeing: links between two nodes on different servers
|
|
if { [getNodeLocation $lnode1] != [getNodeLocation $lnode2]} {
|
|
.c itemconfigure $newlink -dash ",";
|
|
}
|
|
# end Boeing
|
|
# XXX Invisible pseudo-liks
|
|
global invisible
|
|
if { $invisible == 1 && [getLinkMirror $link] != "" } {
|
|
.c itemconfigure $link -state hidden
|
|
}
|
|
# Boeing: wlan links are hidden
|
|
if { [nodeType $lnode1] == "wlan" || [nodeType $lnode2] == "wlan" } {
|
|
global zoom
|
|
set imgzoom $zoom
|
|
if { $zoom == 0.75 || $zoom == 1.5 } { set imgzoom 1.0 }
|
|
global antenna$imgzoom
|
|
.c itemconfigure $link -state hidden
|
|
.c create image 0 0 -image [set antenna$imgzoom] \
|
|
-tags "antenna $lnode2 $link"
|
|
.c create text 0 0 -tags "interface $lnode1 $link" -justify center
|
|
.c create text 0 0 -tags "interface $lnode2 $link" -justify center
|
|
.c raise interface "link || linklabel || background"
|
|
} else {
|
|
.c raise $newlink background
|
|
.c create text 0 0 -tags "linklabel $link" -justify center
|
|
.c create text 0 0 -tags "interface $lnode1 $link" -justify center
|
|
.c create text 0 0 -tags "interface $lnode2 $link" -justify center
|
|
.c raise linklabel "link || background"
|
|
.c raise interface "link || linklabel || background"
|
|
}
|
|
foreach n [list $lnode1 $lnode2] {
|
|
if { [getNodeHidden $n] } {
|
|
hideNode $n
|
|
statline "Hidden node(s) exist."
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
# draw a green link between wireless nodes (or other color if multiple WLANs)
|
|
# WLAN links appear on the canvas but not in the global link_list
|
|
proc drawWlanLink { node1 node2 wlan } {
|
|
global zoom defLinkWidth curcanvas
|
|
set c .c
|
|
|
|
set wlanlink [$c find withtag "wlanlink && $node1 && $node2 && $wlan"]
|
|
if { $wlanlink != "" } {
|
|
return $wlanlink ;# already exists
|
|
}
|
|
|
|
set color [getWlanColor $wlan]
|
|
|
|
set xy [getNodeCoords $node1]
|
|
set x [lindex $xy 0]; set y [lindex $xy 1]
|
|
set pxy [getNodeCoords $node2]
|
|
set px [lindex $pxy 0]; set py [lindex $pxy 1]
|
|
|
|
set wlanlink [$c create line [expr {$x*$zoom}] [expr {$y*$zoom}] \
|
|
[expr {$px*$zoom}] [expr {$py*$zoom}] \
|
|
-fill $color -width $defLinkWidth \
|
|
-tags "wlanlink $node1 $node2 $wlan"]
|
|
|
|
if { [getNodeCanvas $node1] == $curcanvas &&
|
|
[getNodeCanvas $node2] == $curcanvas} {
|
|
$c itemconfigure $wlanlink -state normal
|
|
$c raise $wlanlink "background || grid || oval || rectangle"
|
|
} else {
|
|
$c itemconfigure $wlanlink -state hidden
|
|
}
|
|
|
|
return $wlanlink
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/chooseIfName
|
|
# NAME
|
|
# chooseIfName -- choose interface name
|
|
# SYNOPSIS
|
|
# set ifcName [chooseIfName $lnode1 $lnode2]
|
|
# FUNCTION
|
|
# Choose intreface name. The name can be:
|
|
# * eth -- for interface connecting pc, host and router
|
|
# * e -- for interface connecting hub and lanswitch
|
|
# INPUTS
|
|
# * link_id -- link id
|
|
# RESULT
|
|
# * ifcName -- the name of the interface
|
|
#****
|
|
|
|
proc chooseIfName { lnode1 lnode2 } {
|
|
global $lnode1 $lnode2
|
|
|
|
# TODO: just check if layer == NETWORK and return eth, LINK return e
|
|
switch -exact -- [nodeType $lnode1] {
|
|
pc {
|
|
return eth
|
|
}
|
|
host {
|
|
return eth
|
|
}
|
|
hub {
|
|
return e
|
|
}
|
|
lanswitch {
|
|
return e
|
|
}
|
|
router {
|
|
return eth
|
|
}
|
|
rj45 {
|
|
return
|
|
}
|
|
tunnel {
|
|
return e
|
|
}
|
|
ktunnel {
|
|
return
|
|
}
|
|
wlan {
|
|
return e
|
|
}
|
|
default {
|
|
return eth
|
|
# end Boeing: below
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/listLANNodes
|
|
# NAME
|
|
# listLANNodes -- list LAN nodes
|
|
# SYNOPSIS
|
|
# set l2peers [listLANNodes $l2node $l2peers]
|
|
# FUNCTION
|
|
# Recursive function for finding all link layer nodes that are
|
|
# connected to node l2node. Returns the list of all link layer
|
|
# nodes that are on the same LAN as l2node.
|
|
# INPUTS
|
|
# * l2node -- node id of a link layer node
|
|
# * l2peers -- old link layer nodes on the same LAN
|
|
# RESULT
|
|
# * l2peers -- new link layer nodes on the same LAN
|
|
#****
|
|
|
|
proc listLANnodes { l2node l2peers } {
|
|
lappend l2peers $l2node
|
|
foreach ifc [ifcList $l2node] {
|
|
set peer [logicalPeerByIfc $l2node $ifc]
|
|
set type [nodeType $peer]
|
|
# Boeing
|
|
if { [ lsearch {lanswitch hub wlan} $type] != -1 } {
|
|
if { [lsearch $l2peers $peer] == -1 } {
|
|
set l2peers [listLANnodes $peer $l2peers]
|
|
}
|
|
}
|
|
}
|
|
return $l2peers
|
|
}
|
|
|
|
#****f* editor.tcl/calcDxDy
|
|
# NAME
|
|
# calcDxDy lnode -- list LAN nodes
|
|
# SYNOPSIS
|
|
# calcDxDy $lnode
|
|
# FUNCTION
|
|
# Calculates dx and dy variables of the calling function.
|
|
# INPUTS
|
|
# * lnode -- node id of a node whose dx and dy coordinates are
|
|
# calculated
|
|
#****
|
|
|
|
proc calcDxDy { lnode } {
|
|
global showIfIPaddrs showIfIPv6addrs zoom
|
|
upvar dx x
|
|
upvar dy y
|
|
|
|
if { $zoom > 1.0 } {
|
|
set x 1
|
|
set y 1
|
|
return
|
|
}
|
|
switch -exact -- [nodeType $lnode] {
|
|
hub {
|
|
set x [expr {1.5 / $zoom}]
|
|
set y [expr {2.6 / $zoom}]
|
|
}
|
|
lanswitch {
|
|
set x [expr {1.5 / $zoom}]
|
|
set y [expr {2.6 / $zoom}]
|
|
}
|
|
router {
|
|
set x [expr {1 / $zoom}]
|
|
set y [expr {2 / $zoom}]
|
|
}
|
|
rj45 {
|
|
set x [expr {1 / $zoom}]
|
|
set y [expr {1 / $zoom}]
|
|
}
|
|
tunnel {
|
|
set x [expr {1 / $zoom}]
|
|
set y [expr {1 / $zoom}]
|
|
}
|
|
wlan {
|
|
set x [expr {1.5 / $zoom}]
|
|
set y [expr {2.6 / $zoom}]
|
|
}
|
|
default {
|
|
set x [expr {1 / $zoom}]
|
|
set y [expr {2 / $zoom}]
|
|
}
|
|
}
|
|
return
|
|
}
|
|
|
|
#****f* editor.tcl/updateIfcLabel
|
|
# NAME
|
|
# updateIfcLabel -- update interface label
|
|
# SYNOPSIS
|
|
# updateIfcLabel $lnode1 $lnode2
|
|
# FUNCTION
|
|
# Updates the interface label, including interface name,
|
|
# interface state (* for interfaces that are down), IPv4
|
|
# address and IPv6 address.
|
|
# INPUTS
|
|
# * lnode1 -- node id of a node where the interface resides
|
|
# * lnode2 -- node id of the node that is connected by this
|
|
# interface.
|
|
#****
|
|
proc updateIfcLabel { lnode1 lnode2 } {
|
|
global showIfNames showIfIPaddrs showIfIPv6addrs
|
|
|
|
set link [lindex [.c gettags "link && $lnode1 && $lnode2"] 1]
|
|
set ifc [ifcByPeer $lnode1 $lnode2]
|
|
set ifipv4addr [getIfcIPv4addr $lnode1 $ifc]
|
|
set ifipv6addr [getIfcIPv6addr $lnode1 $ifc]
|
|
if { $ifc == 0 } {
|
|
set ifc ""
|
|
}
|
|
if { [getIfcOperState $lnode1 $ifc] == "down" } {
|
|
set labelstr "*"
|
|
} else {
|
|
set labelstr ""
|
|
}
|
|
if { $showIfNames } {
|
|
set labelstr "$labelstr$ifc
|
|
"
|
|
}
|
|
if { $showIfIPaddrs && $ifipv4addr != "" } {
|
|
set labelstr "$labelstr$ifipv4addr
|
|
"
|
|
}
|
|
if { $showIfIPv6addrs && $ifipv6addr != "" } {
|
|
set labelstr "$labelstr$ifipv6addr
|
|
"
|
|
}
|
|
set labelstr \
|
|
[string range $labelstr 0 [expr {[string length $labelstr] - 2}]]
|
|
.c itemconfigure "interface && $lnode1 && $link" \
|
|
-text "$labelstr"
|
|
# Boeing: hide ifc label on wlans
|
|
if { [nodeType $lnode1] == "wlan" } {
|
|
.c itemconfigure "interface && $lnode1 && $link" -state hidden
|
|
}
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/updateLinkLabel
|
|
# NAME
|
|
# updateLinkLabel -- update link label
|
|
# SYNOPSIS
|
|
# updateLinkLabel $link
|
|
# FUNCTION
|
|
# Updates the link label, including link bandwidth, link delay,
|
|
# BER and duplicate values.
|
|
# INPUTS
|
|
# * link -- link id of the link whose labels are updated.
|
|
#****
|
|
proc updateLinkLabel { link } {
|
|
global showLinkLabels
|
|
|
|
set bwstr [getLinkBandwidthString $link]
|
|
set delstr [getLinkDelayString $link]
|
|
set berstr [getLinkBERString $link]
|
|
set dupstr [getLinkDupString $link]
|
|
set labelstr "
|
|
"
|
|
if { "$bwstr" != "" } {
|
|
set labelstr "$labelstr$bwstr
|
|
"
|
|
}
|
|
if { "$delstr" != "" } {
|
|
set labelstr "$labelstr$delstr
|
|
"
|
|
}
|
|
if { "$berstr" != "" } {
|
|
set labelstr "$labelstr$berstr
|
|
"
|
|
}
|
|
if { "$dupstr" != "" } {
|
|
set labelstr "$labelstr$dupstr
|
|
"
|
|
}
|
|
set labelstr \
|
|
[string range $labelstr 0 [expr {[string length $labelstr] - 2}]]
|
|
.c itemconfigure "linklabel && $link" -text "$labelstr"
|
|
if { $showLinkLabels == 0} {
|
|
.c itemconfigure "linklabel && $link" -state hidden
|
|
}
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/redrawAllLinks
|
|
# NAME
|
|
# redrawAllLinks -- redraw all links
|
|
# SYNOPSIS
|
|
# redrawAllLinks
|
|
# FUNCTION
|
|
# Redraws all links on the current canvas.
|
|
#****
|
|
proc redrawAllLinks {} {
|
|
global link_list curcanvas
|
|
|
|
foreach link $link_list {
|
|
set nodes [linkPeers $link]
|
|
if { [getNodeCanvas [lindex $nodes 0]] != $curcanvas ||
|
|
[getNodeCanvas [lindex $nodes 1]] != $curcanvas } {
|
|
continue
|
|
}
|
|
redrawLink $link
|
|
}
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/redrawLink
|
|
# NAME
|
|
# redrawLink -- redraw a links
|
|
# SYNOPSIS
|
|
# redrawLink $link
|
|
# FUNCTION
|
|
# Redraws the specified link.
|
|
# INPUTS
|
|
# * link -- link id
|
|
#****
|
|
proc redrawLink { link } {
|
|
global $link
|
|
|
|
set limages [.c find withtag "link && $link"]
|
|
set limage1 [lindex $limages 0]
|
|
set limage2 [lindex $limages 1]
|
|
set tags [.c gettags $limage1]
|
|
set link [lindex $tags 1]
|
|
set lnode1 [lindex $tags 2]
|
|
set lnode2 [lindex $tags 3]
|
|
|
|
set coords1 [.c coords "node && $lnode1"]
|
|
set coords2 [.c coords "node && $lnode2"]
|
|
set x1 [lindex $coords1 0]
|
|
set y1 [lindex $coords1 1]
|
|
set x2 [lindex $coords2 0]
|
|
set y2 [lindex $coords2 1]
|
|
|
|
.c coords $limage1 $x1 $y1 $x2 $y2
|
|
.c coords $limage2 $x1 $y1 $x2 $y2
|
|
|
|
set lx [expr {0.5 * ($x1 + $x2)}]
|
|
set ly [expr {0.5 * ($y1 + $y2)}]
|
|
.c coords "linklabel && $link" $lx $ly
|
|
|
|
set n [expr {sqrt (($x1 - $x2) * ($x1 - $x2) + \
|
|
($y1 - $y2) * ($y1 - $y2)) * 0.015}]
|
|
if { $n < 1 } {
|
|
set n 1
|
|
}
|
|
|
|
calcDxDy $lnode1
|
|
set lx [expr {($x1 * ($n * $dx - 1) + $x2) / $n / $dx}]
|
|
set ly [expr {($y1 * ($n * $dy - 1) + $y2) / $n / $dy}]
|
|
.c coords "interface && $lnode1 && $link" $lx $ly
|
|
updateIfcLabel $lnode1 $lnode2
|
|
|
|
calcDxDy $lnode2
|
|
set lx [expr {($x1 + $x2 * ($n * $dx - 1)) / $n / $dx}]
|
|
set ly [expr {($y1 + $y2 * ($n * $dy - 1)) / $n / $dy}]
|
|
.c coords "interface && $lnode2 && $link" $lx $ly
|
|
updateIfcLabel $lnode2 $lnode1
|
|
# Boeing - wlan antennas
|
|
if { [nodeType $lnode1] == "wlan" } {
|
|
global zoom
|
|
set an [lsearch -exact [findWlanNodes $lnode2] $lnode1]
|
|
if { $an < 0 || $an >= 5 } { set an 0 }
|
|
set dx [expr {20 - (10*$an)}]
|
|
.c coords "antenna && $lnode2 && $link" [expr {$x2-($dx*$zoom)}] \
|
|
[expr {$y2-(20*$zoom)}]
|
|
}
|
|
}
|
|
|
|
# Boeing
|
|
proc redrawWlanLink { link } {
|
|
global $link
|
|
|
|
set tags [.c gettags $link]
|
|
set lnode1 [lindex $tags 1]
|
|
set lnode2 [lindex $tags 2]
|
|
set coords1 [.c coords "node && $lnode1"]
|
|
set coords2 [.c coords "node && $lnode2"]
|
|
set x1 [lindex $coords1 0]
|
|
set y1 [lindex $coords1 1]
|
|
set x2 [lindex $coords2 0]
|
|
set y2 [lindex $coords2 1]
|
|
set lx [expr {0.5 * ($x1 + $x2)}]
|
|
set ly [expr {0.5 * ($y1 + $y2)}]
|
|
|
|
.c coords $link $x1 $y1 $x2 $y2
|
|
.c coords "linklabel && $lnode2 && $lnode1" $lx $ly
|
|
|
|
return
|
|
}
|
|
# end Boeing
|
|
|
|
#****f* editor.tcl/splitGUILink
|
|
# NAME
|
|
# splitGUILink -- splits a links
|
|
# SYNOPSIS
|
|
# splitGUILink $link
|
|
# FUNCTION
|
|
# Splits the link and draws new links and new pseudo nodes
|
|
# on the canvas.
|
|
# INPUTS
|
|
# * link -- link id
|
|
#****
|
|
proc splitGUILink { link } {
|
|
global changed zoom
|
|
|
|
set peer_nodes [linkPeers $link]
|
|
set new_nodes [splitLink $link pseudo]
|
|
set orig_node1 [lindex $peer_nodes 0]
|
|
set orig_node2 [lindex $peer_nodes 1]
|
|
set new_node1 [lindex $new_nodes 0]
|
|
set new_node2 [lindex $new_nodes 1]
|
|
set new_link1 [linkByPeers $orig_node1 $new_node1]
|
|
set new_link2 [linkByPeers $orig_node2 $new_node2]
|
|
setLinkMirror $new_link1 $new_link2
|
|
setLinkMirror $new_link2 $new_link1
|
|
setNodeMirror $new_node1 $new_node2
|
|
setNodeMirror $new_node2 $new_node1
|
|
setNodeName $new_node1 $orig_node2
|
|
setNodeName $new_node2 $orig_node1
|
|
|
|
set x1 [lindex [getNodeCoords $orig_node1] 0]
|
|
set y1 [lindex [getNodeCoords $orig_node1] 1]
|
|
set x2 [lindex [getNodeCoords $orig_node2] 0]
|
|
set y2 [lindex [getNodeCoords $orig_node2] 1]
|
|
|
|
setNodeCoords $new_node1 \
|
|
"[expr {($x1 + 0.4 * ($x2 - $x1)) / $zoom}] \
|
|
[expr {($y1 + 0.4 * ($y2 - $y1)) / $zoom}]"
|
|
setNodeCoords $new_node2 \
|
|
"[expr {($x1 + 0.6 * ($x2 - $x1)) / $zoom}] \
|
|
[expr {($y1 + 0.6 * ($y2 - $y1)) / $zoom}]"
|
|
setNodeLabelCoords $new_node1 [getNodeCoords $new_node1]
|
|
setNodeLabelCoords $new_node2 [getNodeCoords $new_node2]
|
|
|
|
set changed 1
|
|
updateUndoLog
|
|
redrawAll
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/selectNode
|
|
# NAME
|
|
# selectNode -- select node
|
|
# SYNOPSIS
|
|
# selectNode $c $obj
|
|
# FUNCTION
|
|
# Crates the selecting box around the specified canvas
|
|
# object.
|
|
# INPUTS
|
|
# * c -- tk canvas
|
|
# * obj -- tk canvas object tag id
|
|
#****
|
|
proc selectNode { c obj } {
|
|
set node [lindex [$c gettags $obj] 1]
|
|
if { $node == "" } { return } ;# Boeing: fix occassional error
|
|
$c addtag selected withtag "node && $node"
|
|
if { [nodeType $node] == "pseudo" } {
|
|
set bbox [$c bbox "nodelabel && $node"]
|
|
} elseif { [nodeType $node] == "rectangle" } {
|
|
$c addtag selected withtag "rectangle && $node"
|
|
set bbox [$c bbox "rectangle && $node"]
|
|
} elseif { [nodeType $node] == "text" } {
|
|
$c addtag selected withtag "text && $node"
|
|
set bbox [$c bbox "text && $node"]
|
|
} elseif { [nodeType $node] == "oval" } {
|
|
$c addtag selected withtag "oval && $node"
|
|
set bbox [$c bbox "oval && $node"]
|
|
} else {
|
|
set bbox [$c bbox "node && $node"]
|
|
}
|
|
set bx1 [expr {[lindex $bbox 0] - 2}]
|
|
set by1 [expr {[lindex $bbox 1] - 2}]
|
|
set bx2 [expr {[lindex $bbox 2] + 1}]
|
|
set by2 [expr {[lindex $bbox 3] + 1}]
|
|
$c delete -withtags "selectmark && $node"
|
|
$c create line $bx1 $by1 $bx2 $by1 $bx2 $by2 $bx1 $by2 $bx1 $by1 \
|
|
-dash {6 4} -fill black -width 1 -tags "selectmark $node"
|
|
}
|
|
|
|
proc selectNodes { nodelist } {
|
|
foreach node $nodelist {
|
|
selectNode .c [.c find withtag "node && $node"]
|
|
}
|
|
}
|
|
|
|
proc selectedNodes {} {
|
|
set selected {}
|
|
foreach obj [.c find withtag "node && selected"] {
|
|
lappend selected [lindex [.c gettags $obj] 1]
|
|
}
|
|
foreach obj [.c find withtag "oval && selected"] {
|
|
lappend selected [lindex [.c gettags $obj] 1]
|
|
}
|
|
foreach obj [.c find withtag "rectangle && selected"] {
|
|
lappend selected [lindex [.c gettags $obj] 1]
|
|
}
|
|
foreach obj [.c find withtag "text && selected"] {
|
|
lappend selected [lindex [.c gettags $obj] 1]
|
|
}
|
|
return $selected
|
|
}
|
|
|
|
proc selectedRealNodes {} {
|
|
set selected {}
|
|
foreach obj [.c find withtag "node && selected"] {
|
|
set node [lindex [.c gettags $obj] 1]
|
|
if { [getNodeMirror $node] != "" ||
|
|
[nodeType $node] == "rj45" } {
|
|
continue
|
|
}
|
|
lappend selected $node
|
|
}
|
|
return $selected
|
|
}
|
|
|
|
proc selectAdjacent {} {
|
|
global curcanvas
|
|
|
|
set selected [selectedNodes]
|
|
set adjacent {}
|
|
foreach node $selected {
|
|
foreach ifc [ifcList $node] {
|
|
set peer [peerByIfc $node $ifc]
|
|
if { [getNodeMirror $peer] != "" } {
|
|
return
|
|
}
|
|
if { [lsearch $adjacent $peer] < 0 } {
|
|
lappend adjacent $peer
|
|
}
|
|
}
|
|
}
|
|
selectNodes $adjacent
|
|
}
|
|
|
|
#****f* editor.tcl/button3link
|
|
# NAME
|
|
# button3link
|
|
# SYNOPSIS
|
|
# button3link $c $x $y
|
|
# FUNCTION
|
|
# This procedure is called when a right mouse button is
|
|
# clicked on the canvas. If there is a link on the place of
|
|
# mouse click this procedure creates and configures a popup
|
|
# menu. The options in the menu are:
|
|
# * Configure -- configure the link
|
|
# * Delete -- delete the link
|
|
# * Split -- split the link
|
|
# * Merge -- this option is active only if the link is previously
|
|
# been split, by this action the link is merged.
|
|
# INPUTS
|
|
# * c -- tk canvas
|
|
# * x -- x coordinate for popup menu
|
|
# * y -- y coordinate for popup menu
|
|
#****
|
|
proc button3link { c x y } {
|
|
global oper_mode env eid canvas_list node_list
|
|
global curcanvas
|
|
|
|
set link [lindex [$c gettags {link && current}] 1]
|
|
if { $link == "" } {
|
|
set link [lindex [$c gettags {linklabel && current}] 1]
|
|
if { $link == "" } {
|
|
return
|
|
}
|
|
}
|
|
|
|
.button3menu delete 0 end
|
|
|
|
#
|
|
# Configure link
|
|
#
|
|
.button3menu add command -label "Configure" \
|
|
-command "popupConfigDialog $c"
|
|
|
|
#
|
|
# Delete link
|
|
#
|
|
if { $oper_mode != "exec" } {
|
|
.button3menu add command -label "Delete" \
|
|
-command "removeGUILink $link atomic"
|
|
} else {
|
|
.button3menu add command -label "Delete" \
|
|
-state disabled
|
|
}
|
|
|
|
#
|
|
# Split link
|
|
#
|
|
if { $oper_mode != "exec" && [getLinkMirror $link] == "" } {
|
|
.button3menu add command -label "Split" \
|
|
-command "splitGUILink $link"
|
|
} else {
|
|
.button3menu add command -label "Split" \
|
|
-state disabled
|
|
}
|
|
|
|
#
|
|
# Merge two pseudo nodes / links
|
|
#
|
|
if { $oper_mode != "exec" && [getLinkMirror $link] != "" &&
|
|
[getNodeCanvas [getNodeMirror [lindex [linkPeers $link] 1]]] ==
|
|
$curcanvas } {
|
|
.button3menu add command -label "Merge" \
|
|
-command "mergeGUINode [lindex [linkPeers $link] 1]"
|
|
} else {
|
|
.button3menu add command -label "Merge" -state disabled
|
|
}
|
|
|
|
set x [winfo pointerx .]
|
|
set y [winfo pointery .]
|
|
tk_popup .button3menu $x $y
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/movetoCanvas
|
|
# NAME
|
|
# movetoCanvas -- move to canvas
|
|
# SYNOPSIS
|
|
# movetoCanvas $canvas
|
|
# FUNCTION
|
|
# This procedure moves all the nodes selected in the GUI to
|
|
# the specified canvas.
|
|
# INPUTS
|
|
# * canvas -- canvas id.
|
|
#****
|
|
proc movetoCanvas { canvas } {
|
|
global changed
|
|
|
|
set selected_nodes [selectedNodes]
|
|
foreach node $selected_nodes {
|
|
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) } {
|
|
if { [nodeType $peer2] == "pseudo" } {
|
|
setNodeCanvas $peer2 $canvas
|
|
if { [getNodeCanvas [getNodeMirror $peer2]] == $canvas } {
|
|
mergeLink $link
|
|
}
|
|
continue
|
|
}
|
|
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
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/mergeGUINode
|
|
# NAME
|
|
# mergeGUINode -- merge GUI node
|
|
# SYNOPSIS
|
|
# mergeGUINode $node
|
|
# FUNCTION
|
|
# This procedure removes the specified pseudo node as well
|
|
# as it's mirror copy. Also this procedure removes the
|
|
# pseudo links and reestablish the original link between
|
|
# the non-pseudo nodes.
|
|
# INPUTS
|
|
# * node -- node id of a pseudo node.
|
|
#****
|
|
proc mergeGUINode { node } {
|
|
set link [lindex [linkByIfc $node [ifcList $node]] 0]
|
|
mergeLink $link
|
|
redrawAll
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/button3node
|
|
# NAME
|
|
# button3node
|
|
# SYNOPSIS
|
|
# button3node $c $x $y
|
|
# FUNCTION
|
|
# This procedure is called when a right mouse button is
|
|
# clicked on the canvas. Also called when double-clicking
|
|
# on a node during runtime.
|
|
# If there is a node on the place of
|
|
# mouse click this procedure creates and configures a popup
|
|
# menu. The options in the menu are:
|
|
# * Configure -- configure the node
|
|
# * Create link to -- create a link to any available node,
|
|
# it can be on the same canvas or on a different canvas.
|
|
# * Move to -- move to some other canvas
|
|
# * Merge -- this option is available only for pseudo nodes
|
|
# that have mirror nodes on the same canvas (Pseudo nodes
|
|
# created by splitting a link).
|
|
# * Delete -- delete the node
|
|
# * Shell window -- specifies the shell window to open in
|
|
# exec mode. This option is available only to nodes on a
|
|
# network layer
|
|
# * Ethereal -- opens a Ethereal program for the specified
|
|
# node and the specified interface. This option is available
|
|
# only for network layer nodes in exec mode.
|
|
# INPUTS
|
|
# * c -- tk canvas
|
|
# * x -- x coordinate for popup menu
|
|
# * y -- y coordinate for popup menu
|
|
#****
|
|
#old proc button3node { c x y }
|
|
#Boeing
|
|
proc button3node { c x y button } {
|
|
global oper_mode env eid canvas_list node_list curcanvas systype g_prefs
|
|
|
|
set node [lindex [$c gettags {node && current}] 1]
|
|
if { $node == "" } {
|
|
set node [lindex [$c gettags {nodelabel && current}] 1]
|
|
if { $node == "" } {
|
|
return
|
|
}
|
|
}
|
|
set mirror_node [getNodeMirror $node]
|
|
|
|
if { [$c gettags "node && $node && selected"] == "" } {
|
|
$c dtag node selected
|
|
$c delete -withtags selectmark
|
|
selectNode $c [$c find withtag "current"]
|
|
}
|
|
|
|
# open up shells upon double-click or shift/ctrl-click
|
|
set shell $g_prefs(shell)
|
|
if { $button == "shift" || $button == "ctrl" } {
|
|
if { [nodeType $node] == "pseudo" } {
|
|
#
|
|
# Hyperlink to another canvas
|
|
#
|
|
set curcanvas [getNodeCanvas [getNodeMirror $node]]
|
|
switchCanvas none
|
|
return
|
|
}
|
|
# only open bash shells for NETWORK nodes and remote routers
|
|
if { [[typemodel $node].layer] != "NETWORK" } {
|
|
if { [typemodel $node] == "wlan" } {
|
|
wlanDoubleClick $node $button
|
|
}
|
|
return
|
|
}
|
|
if { $button == "shift" } { ;# normal bash shell
|
|
spawnShell $node $shell
|
|
} else { ;# right-click vtysh shell
|
|
set cmd [[typemodel $node].shellcmd $node]
|
|
if { $cmd != "/bin/sh" && $cmd != "" } { spawnShell $node $cmd }
|
|
}
|
|
return ;# open shell, don't post a menu
|
|
}
|
|
|
|
#
|
|
# below here we build and post a menu
|
|
#
|
|
.button3menu delete 0 end
|
|
|
|
#
|
|
# Configure node
|
|
#
|
|
if { [nodeType $node] != "pseudo" } {
|
|
.button3menu add command -label "Configure" \
|
|
-command "popupConfigDialog $c"
|
|
} else {
|
|
.button3menu add command -label "Configure" \
|
|
-command "popupConfigDialog $c" -state disabled
|
|
}
|
|
|
|
#
|
|
# Select adjacent
|
|
#
|
|
if { [nodeType $node] != "pseudo" } {
|
|
.button3menu add command -label "Select adjacent" \
|
|
-command "selectAdjacent"
|
|
} else {
|
|
.button3menu add command -label "Select adjacent" \
|
|
-command "selectAdjacent" -state disabled
|
|
}
|
|
|
|
#
|
|
# Create a new link - can be between different canvases
|
|
#
|
|
.button3menu.connect delete 0 end
|
|
if { $oper_mode == "exec" || [nodeType $node] == "pseudo" } {
|
|
#.button3menu add cascade -label "Create link to" \
|
|
-menu .button3menu.connect -state disabled
|
|
} else {
|
|
.button3menu add cascade -label "Create link to" \
|
|
-menu .button3menu.connect
|
|
}
|
|
destroy .button3menu.connect.selected
|
|
menu .button3menu.connect.selected -tearoff 0
|
|
.button3menu.connect add cascade -label "Selected" \
|
|
-menu .button3menu.connect.selected
|
|
.button3menu.connect.selected add command \
|
|
-label "Chain" -command "P \[selectedRealNodes\]"
|
|
.button3menu.connect.selected add command \
|
|
-label "Star" \
|
|
-command "Kb \[lindex \[selectedRealNodes\] 0\] \
|
|
\[lrange \[selectedNodes\] 1 end\]"
|
|
.button3menu.connect.selected add command \
|
|
-label "Cycle" -command "C \[selectedRealNodes\]"
|
|
.button3menu.connect.selected add command \
|
|
-label "Clique" -command "K \[selectedRealNodes\]"
|
|
.button3menu.connect add separator
|
|
foreach canvas $canvas_list {
|
|
destroy .button3menu.connect.$canvas
|
|
menu .button3menu.connect.$canvas -tearoff 0
|
|
.button3menu.connect add cascade -label [getCanvasName $canvas] \
|
|
-menu .button3menu.connect.$canvas
|
|
}
|
|
foreach peer_node $node_list {
|
|
set canvas [getNodeCanvas $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 "newGUILink $node $peer_node"
|
|
} elseif { [nodeType $peer_node] != "pseudo" } {
|
|
.button3menu.connect.$canvas add command \
|
|
-label [getNodeName $peer_node] \
|
|
-state disabled
|
|
}
|
|
}
|
|
#
|
|
# assign to emulation server
|
|
#
|
|
if { $oper_mode != "exec" } {
|
|
global exec_servers node_location
|
|
.button3menu.assign delete 0 end
|
|
.button3menu add cascade -label "Assign to" -menu .button3menu.assign
|
|
.button3menu.assign add command -label "(none)" \
|
|
-command "assignSelection \"\""
|
|
foreach server [lsort -dictionary [array names exec_servers]] {
|
|
.button3menu.assign add command -label "$server" \
|
|
-command "assignSelection $server"
|
|
}
|
|
}
|
|
|
|
#
|
|
# wlan link to all nodes
|
|
#
|
|
if { [nodeType $node] == "wlan" } {
|
|
.button3menu add command -label "Link to all routers" \
|
|
-command "linkAllNodes $node"
|
|
set msg "Select new WLAN $node members:"
|
|
set cmd "linkSelectedNodes $node"
|
|
.button3menu add command -label "Select WLAN members..." \
|
|
-command "popupSelectNodes \"$msg\" \"\" {$cmd}"
|
|
set state normal
|
|
if { $oper_mode != "exec" } { set state disabled }
|
|
.button3menu add command -label "Mobility script..." \
|
|
-command "showMobilityScriptPopup $node" -state $state
|
|
}
|
|
|
|
#
|
|
# Move to another canvas
|
|
#
|
|
.button3menu.moveto delete 0 end
|
|
if { $oper_mode != "exec" && [nodeType $node] != "pseudo" } {
|
|
.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
|
|
}
|
|
}
|
|
}
|
|
|
|
#
|
|
# Merge two pseudo nodes / links
|
|
#
|
|
if { $oper_mode != "exec" && [nodeType $node] == "pseudo" && \
|
|
[getNodeCanvas $mirror_node] == $curcanvas } {
|
|
.button3menu add command -label "Merge" \
|
|
-command "mergeGUINode $node"
|
|
}
|
|
|
|
#
|
|
# Delete selection
|
|
#
|
|
if { $oper_mode != "exec" } {
|
|
.button3menu add command -label "Cut" -command cutSelection
|
|
.button3menu add command -label "Copy" -command copySelection
|
|
.button3menu add command -label "Paste" -command pasteSelection
|
|
.button3menu add command -label "Delete" -command deleteSelection
|
|
}
|
|
|
|
.button3menu add command -label "Hide" -command "hideSelected"
|
|
|
|
# Boeing: flag used below
|
|
set execstate disabled
|
|
if { $oper_mode == "exec" } { set execstate normal }
|
|
|
|
#
|
|
# Shell selection
|
|
#
|
|
.button3menu.shell delete 0 end
|
|
if { $oper_mode == "exec" && [[typemodel $node].layer] == "NETWORK" } {
|
|
.button3menu add cascade -label "Shell window" \
|
|
-menu .button3menu.shell
|
|
set cmd [[typemodel $node].shellcmd $node]
|
|
if { $cmd != "/bin/sh" && $cmd != "" } { ;# typically adds vtysh
|
|
.button3menu.shell add command -label "$cmd" \
|
|
-command "spawnShell $node $cmd"
|
|
}
|
|
.button3menu.shell add command -label "/bin/sh" \
|
|
-command "spawnShell $node sh"
|
|
.button3menu.shell add command -label "$shell" \
|
|
-command "spawnShell $node $shell"
|
|
}
|
|
|
|
#
|
|
# services
|
|
#
|
|
.button3menu.services delete 0 end
|
|
if { $oper_mode == "exec" && [[typemodel $node].layer] == "NETWORK" } {
|
|
addServicesRightClickMenu .button3menu $node
|
|
} else {
|
|
.button3menu add command -label "Services..." -command \
|
|
"sendConfRequestMessage -1 $node services 0x1 -1 \"\""
|
|
}
|
|
|
|
#
|
|
# Tcpdump, gpsd
|
|
#
|
|
if { $oper_mode == "exec" && [[typemodel $node].layer] == "NETWORK" } {
|
|
addInterfaceCommand $node .button3menu "Tcpdump" "tcpdump -n -l -i" \
|
|
$execstate 1
|
|
addInterfaceCommand $node .button3menu "TShark" "tshark -n -l -i" \
|
|
$execstate 1
|
|
addInterfaceCommand $node .button3menu "Wireshark" "wireshark -k -i" \
|
|
$execstate 0
|
|
# wireshark on host veth pair -- need veth pair name
|
|
#wireshark -k -i
|
|
if { [lindex $systype 0] == "Linux" } {
|
|
set name [getNodeName $node]
|
|
.button3menu add command -label "View log..." -state $execstate \
|
|
-command "spawnShell $node \"less ../$name.log\""
|
|
}
|
|
}
|
|
|
|
#
|
|
# Finally post the popup menu on current pointer position
|
|
#
|
|
set x [winfo pointerx .]
|
|
set y [winfo pointery .]
|
|
|
|
tk_popup .button3menu $x $y
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/spawnShell
|
|
# NAME
|
|
# spawnShell -- spawn shell
|
|
# SYNOPSIS
|
|
# spawnShell $node $cmd
|
|
# FUNCTION
|
|
# This procedure spawns a new shell for a specified node.
|
|
# The shell is specified in cmd parameter.
|
|
# INPUTS
|
|
# * node -- node id of the node for which the shell
|
|
# is spawned.
|
|
# * cmd -- the path to the shell.
|
|
#****
|
|
proc spawnShell { node cmd } {
|
|
# request an interactive terminal
|
|
set sock [lindex [getEmulPlugin $node] 2]
|
|
set flags 0x44 ;# set TTY, critical flags
|
|
set exec_num [newExecCallbackRequest shell]
|
|
sendExecMessage $sock $node $cmd $exec_num $flags
|
|
}
|
|
|
|
# add a sub-menu to the parentmenu with the given command for each interface
|
|
proc addInterfaceCommand { node parentmenu txt cmd state isnodecmd } {
|
|
global g_current_session
|
|
set childmenu "$parentmenu.[lindex $cmd 0]"
|
|
$childmenu delete 0 end
|
|
$parentmenu add cascade -label $txt -menu $childmenu -state $state
|
|
if { ! $isnodecmd } {
|
|
if { $g_current_session == 0 } { set state disabled }
|
|
set ssid [shortSessionID $g_current_session]
|
|
}
|
|
foreach ifc [ifcList $node] {
|
|
set addr [lindex [getIfcIPv4addr $node $ifc] 0]
|
|
if { $addr != "" } { set addr " ($addr)" }
|
|
if { $isnodecmd } { ;# run command in a node
|
|
set icmd "spawnShell $node \"$cmd $ifc\""
|
|
} else { ;# exec a command directly
|
|
set node_num [string range $node 1 end]
|
|
set hex [format "%x" $node_num]
|
|
set ifnum [string range $ifc 3 end]
|
|
set ifname "veth$hex\\.$ifnum\\.$ssid"
|
|
set icmd "exec $cmd $ifname &"
|
|
}
|
|
$childmenu add command -label "$ifc$addr" -state $state -command $icmd
|
|
}
|
|
}
|
|
|
|
# Boeing: consolodate various raise statements here
|
|
proc raiseAll {c} {
|
|
$c raise rectangle background
|
|
$c raise oval "rectangle || background"
|
|
$c raise grid "oval || rectangle || background"
|
|
$c raise link "grid || oval || rectangle || background"
|
|
$c raise linklabel "link || grid || oval || rectangle || background"
|
|
$c raise newlink "linklabel || link || grid || oval || rectangle || background"
|
|
$c raise wlanlink "newlink || linklabel || link || grid || oval || rectangle || background"
|
|
$c raise antenna "wlanlink || newlink || linklabel || link || grid || oval || rectangle || background"
|
|
$c raise interface "antenna || wlanlink || newlink || linklabel || link || grid || oval || rectangle || background"
|
|
$c raise node "interface || antenna || wlanlink || newlink || linklabel || link || grid || oval || rectangle || background"
|
|
$c raise nodelabel "node || interface || antenna || wlanlink || newlink || linklabel || link || grid || oval || rectangle || background"
|
|
$c raise text "nodelabel || node || interface || antenna || wlanlink || newlink || linklabel || link || grid || oval || rectangle || background"
|
|
$c raise -cursor
|
|
}
|
|
# end Boeing
|
|
|
|
|
|
#****f* editor.tcl/button1
|
|
# NAME
|
|
# button1
|
|
# SYNOPSIS
|
|
# button1 $c $x $y $button
|
|
# FUNCTION
|
|
# This procedure is called when a left mouse button is
|
|
# clicked on the canvas. This procedure selects a new
|
|
# node or creates a new node, depending on the selected
|
|
# tool.
|
|
# INPUTS
|
|
# * c -- tk canvas
|
|
# * x -- x coordinate
|
|
# * y -- y coordinate
|
|
# * button -- the keyboard button that is pressed.
|
|
#****
|
|
proc button1 { c x y button } {
|
|
global node_list plot_list curcanvas zoom
|
|
global activetool activetoolp newlink curobj changed def_router_model
|
|
global router pc host lanswitch rj45 hub OVS
|
|
global oval rectangle text
|
|
global lastX lastY
|
|
global background selectbox
|
|
global defLinkColor defLinkWidth
|
|
global resizemode resizeobj
|
|
global wlan g_twoNodeSelect
|
|
global g_view_locked
|
|
|
|
set x [$c canvasx $x]
|
|
set y [$c canvasy $y]
|
|
|
|
set lastX $x
|
|
set lastY $y
|
|
|
|
# TODO: clean this up
|
|
# - too many global variables
|
|
# - too many hardcoded cases (lanswitch, router, etc)
|
|
# - should be functionalized since lengthy if-else difficult to read
|
|
|
|
set curobj [$c find withtag current]
|
|
set curtype [lindex [$c gettags current] 0]
|
|
|
|
|
|
if { $curtype == "node" || \
|
|
$curtype == "oval" || $curtype == "rectangle" || $curtype == "text" \
|
|
|| ( $curtype == "nodelabel" && \
|
|
[nodeType [lindex [$c gettags $curobj] 1]] == "pseudo") } {
|
|
set node [lindex [$c gettags current] 1]
|
|
set wasselected \
|
|
[expr {[lsearch [$c find withtag "selected"] \
|
|
[$c find withtag "node && $node"]] > -1}]
|
|
if { $button == "ctrl" } {
|
|
if { $wasselected } {
|
|
$c dtag $node selected
|
|
$c delete -withtags "selectmark && $node"
|
|
}
|
|
} elseif { !$wasselected } {
|
|
$c dtag node selected
|
|
$c delete -withtags selectmark
|
|
}
|
|
if { $activetool == "select" && !$wasselected} {
|
|
selectNode $c $curobj
|
|
}
|
|
} elseif { $curtype == "selectmark" } {
|
|
setResizeMode $c $x $y
|
|
} elseif { $activetool == "plot" } {
|
|
# plot tool: create new plot windows when clicking on a link
|
|
set link ""
|
|
set tags [$c gettags $curobj]
|
|
if { $curtype == "link" || $curtype == "linklabel" } {
|
|
set link [lindex $tags 1]
|
|
} elseif { $curtype == "interface" } {
|
|
set link [lindex $tags 2]
|
|
}
|
|
if { $link != "" } {
|
|
thruPlot $c $link $x $y 150 220 false
|
|
}
|
|
return
|
|
} elseif { $button != "ctrl" || $activetool != "select" } {
|
|
$c dtag node selected
|
|
$c delete -withtags selectmark
|
|
}
|
|
# user has clicked on a blank area or background item
|
|
if { [lsearch [.c gettags $curobj] background] != -1 ||
|
|
[lsearch [.c gettags $curobj] grid] != -1 ||
|
|
[lsearch [.c gettags $curobj] annotation] != -1 } {
|
|
# left mouse button pressed to create a new node
|
|
if { [lsearch {select marker link mobility twonode run stop oval \
|
|
rectangle text} $activetool] < 0 } {
|
|
if { $g_view_locked == 1 } { return }
|
|
if { $activetoolp == "routers" } {
|
|
if {$activetool != "OVS"} {
|
|
set node [newNode router]
|
|
} else {
|
|
set node [newNode OVS]}
|
|
setNodeModel $node $activetool
|
|
} else {
|
|
set node [newNode $activetool]
|
|
}
|
|
setNodeCanvas $node $curcanvas
|
|
setNodeCoords $node "[expr {$x / $zoom}] [expr {$y / $zoom}]"
|
|
lassign [getDefaultLabelOffsets $activetool] dx dy
|
|
setNodeLabelCoords $node "[expr {$x / $zoom + $dx}] \
|
|
[expr {$y / $zoom + $dy}]"
|
|
drawNode $c $node
|
|
selectNode $c [$c find withtag "node && $node"]
|
|
set changed 1
|
|
# remove any existing select box
|
|
} elseif { $activetool == "select" \
|
|
&& $curtype != "node" && $curtype != "nodelabel"} {
|
|
$c config -cursor cross
|
|
set lastX $x
|
|
set lastY $y
|
|
if {$selectbox != ""} {
|
|
# We actually shouldn't get here!
|
|
$c delete $selectbox
|
|
set selectbox ""
|
|
}
|
|
# begin drawing an annotation
|
|
} elseif { $activetoolp == "bgobjs" } {
|
|
set newcursor cross
|
|
if { $activetool == "text" } { set newcursor xterm }
|
|
$c config -cursor $newcursor
|
|
set lastX $x
|
|
set lastY $y
|
|
# draw with the marker
|
|
} elseif { $activetool == "marker" } {
|
|
global markersize markercolor
|
|
set newline [$c create oval $lastX $lastY $x $y \
|
|
-width $markersize -outline $markercolor -tags "marker"]
|
|
$c raise $newline "background || link || linklabel || interface"
|
|
set lastX $x
|
|
set lastY $y
|
|
}
|
|
} else {
|
|
if {$curtype == "node" || $curtype == "nodelabel"} {
|
|
$c config -cursor fleur
|
|
}
|
|
if {$activetool == "link" && $curtype == "node"} {
|
|
$c config -cursor cross
|
|
set lastX [lindex [$c coords $curobj] 0]
|
|
set lastY [lindex [$c coords $curobj] 1]
|
|
set newlink [$c create line $lastX $lastY $x $y \
|
|
-fill $defLinkColor -width $defLinkWidth \
|
|
-tags "link"]
|
|
# twonode tool support
|
|
} elseif {$g_twoNodeSelect != "" && $curtype == "node"} {
|
|
set curnode [lindex [$c gettags $curobj] 1]
|
|
selectTwoNode $curnode
|
|
} elseif { $curtype == "node" } {
|
|
selectNode $c $curobj
|
|
}
|
|
# end Boeing
|
|
}
|
|
|
|
raiseAll $c
|
|
}
|
|
|
|
proc setResizeMode { c x y } {
|
|
set isThruplot false
|
|
set type1 notset
|
|
|
|
if {$c == ".c"} {
|
|
set t1 [$c gettags current]
|
|
set o1 [lindex $t1 1]
|
|
set type1 [nodeType $o1]
|
|
} else {
|
|
set o1 $c
|
|
set c .c
|
|
set isThruplot true
|
|
}
|
|
#DYL
|
|
#puts "RESIZE NODETYPE = $type1"
|
|
global resizemode resizeobj
|
|
if {$type1== "oval" || $type1== "rectangle" || $isThruplot == true} {
|
|
set resizeobj $o1
|
|
set bbox1 [$c bbox $o1]
|
|
set x1 [lindex $bbox1 0]
|
|
set y1 [lindex $bbox1 1]
|
|
set x2 [lindex $bbox1 2]
|
|
set y2 [lindex $bbox1 3]
|
|
set l 0 ;# left
|
|
set r 0 ;# right
|
|
set u 0 ;# up
|
|
set d 0 ;# down
|
|
|
|
if { $x < [expr $x1+($x2-$x1)/8.0]} { set l 1 }
|
|
if { $x > [expr $x2-($x2-$x1)/8.0]} { set r 1 }
|
|
if { $y < [expr $y1+($y2-$y1)/8.0]} { set u 1 }
|
|
if { $y > [expr $y2-($y2-$y1)/8.0]} { set d 1 }
|
|
|
|
if {$l==1} {
|
|
if {$u==1} {
|
|
set resizemode lu
|
|
} elseif {$d==1} {
|
|
set resizemode ld
|
|
} else {
|
|
set resizemode l
|
|
}
|
|
} elseif {$r==1} {
|
|
if {$u==1} {
|
|
set resizemode ru
|
|
} elseif {$d==1} {
|
|
set resizemode rd
|
|
} else {
|
|
set resizemode r
|
|
}
|
|
} elseif {$u==1} {
|
|
set resizemode u
|
|
} elseif {$d==1} {
|
|
set resizemode d
|
|
} else {
|
|
set resizemode false
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/button1-motion
|
|
# NAME
|
|
# button1-motion
|
|
# SYNOPSIS
|
|
# button1-motion $c $x $y
|
|
# FUNCTION
|
|
# This procedure is called when a left mouse button is
|
|
# pressed and the mouse is moved around the canvas.
|
|
# This procedure creates new select box, moves the
|
|
# selected nodes or draws a new link.
|
|
# INPUTS
|
|
# * c -- tk canvas
|
|
# * x -- x coordinate
|
|
# * y -- y coordinate
|
|
#****
|
|
proc button1-motion { c x y } {
|
|
global activetool newlink changed
|
|
global lastX lastY sizex sizey selectbox background
|
|
global oper_mode newoval newrect resizemode
|
|
global zoom
|
|
global g_view_locked
|
|
global thruPlotCur thruPlotDragStart
|
|
|
|
set x [$c canvasx $x]
|
|
set y [$c canvasy $y]
|
|
|
|
if {$thruPlotDragStart == "dragging"} {
|
|
#puts "active tool is $activetool"
|
|
thruPlotDrag $c $thruPlotCur $x $y null true
|
|
return
|
|
}
|
|
|
|
# fix occasional error
|
|
if { $x == "" || $y == "" || $lastX == "" || $lastY == "" } { return }
|
|
|
|
set curobj [$c find withtag current]
|
|
set curtype [lindex [$c gettags current] 0]
|
|
|
|
# display <x, y> coordinates in the status bar
|
|
set zoomx [expr {$x / $zoom}]
|
|
set zoomy [expr {$y / $zoom}]
|
|
.bottom.textbox config -text "<$zoomx, $zoomy>"
|
|
|
|
# prevent dragging outside of the canvas area
|
|
if { $x < 0 } {
|
|
set x 0
|
|
} elseif { $x > $sizex } {
|
|
set x $sizex
|
|
}
|
|
if { $y < 0 } {
|
|
set y 0
|
|
} elseif { $y > $sizey } {
|
|
set y $sizey
|
|
}
|
|
|
|
# marker tool drawing on the canvas
|
|
if { $activetool == "marker" } {
|
|
global markersize markercolor
|
|
set dx [expr {$x-$lastX} ]
|
|
set dy [expr {$y-$lastY} ]
|
|
# this provides smoother drawing
|
|
if { $dx > $markersize || $dy > $markersize } {
|
|
set mark [$c create line $lastX $lastY $x $y \
|
|
-width $markersize -fill $markercolor -tags "marker"]
|
|
$c raise $mark \
|
|
"marker || background || link || linklabel || interface"
|
|
}
|
|
set mark [$c create oval $x $y $x $y \
|
|
-width $markersize -fill $markercolor \
|
|
-outline $markercolor -tags "marker"]
|
|
$c raise $mark "marker || background || link || linklabel || interface"
|
|
set lastX $x
|
|
set lastY $y
|
|
return
|
|
}
|
|
# disable all other mouse drags in locked mode
|
|
if { $g_view_locked == 1 } { return }
|
|
|
|
# don't move nodelabels in exec mode, use calcx,y instead of x,y
|
|
if {$oper_mode == "exec" && $curtype == "nodelabel" } {
|
|
set node [lindex [$c gettags $curobj] 1]
|
|
set curobj [$c find withtag "node && $node"]
|
|
set curtype "node"
|
|
set coords [$c coords $curobj]
|
|
set calcx [expr {[lindex $coords 0] / $zoom}]
|
|
set calcy [expr {[lindex $coords 1] / $zoom}]
|
|
selectNode $c $curobj
|
|
} else {
|
|
set calcx $x
|
|
set calcy $y
|
|
}
|
|
# drawing a new link
|
|
if {$activetool == "link" && $newlink != ""} {
|
|
$c coords $newlink $lastX $lastY $x $y
|
|
# draw a selection box
|
|
} elseif { $activetool == "select" && \
|
|
( $curobj == $selectbox || $curtype == "background" || $curtype == "grid")} {
|
|
if {$selectbox == ""} {
|
|
set selectbox [$c create line \
|
|
$lastX $lastY $x $lastY $x $y $lastX $y $lastX $lastY \
|
|
-dash {10 4} -fill black -width 1 -tags "selectbox"]
|
|
$c raise $selectbox "background || link || linklabel || interface"
|
|
} else {
|
|
$c coords $selectbox \
|
|
$lastX $lastY $x $lastY $x $y $lastX $y $lastX $lastY
|
|
}
|
|
# move a text annotation
|
|
} elseif { $activetool == "select" && $curtype == "text" } {
|
|
$c move $curobj [expr {$x - $lastX}] [expr {$y - $lastY}]
|
|
set changed 1
|
|
set lastX $x
|
|
set lastY $y
|
|
$c delete [$c find withtag "selectmark"]
|
|
# move a nodelabel apart from a node (edit mode only)
|
|
} elseif { $activetool == "select" && $curtype == "nodelabel" \
|
|
&& [nodeType [lindex [$c gettags $curobj] 1]] != "pseudo" } {
|
|
$c move $curobj [expr {$x - $lastX}] [expr {$y - $lastY}]
|
|
set changed 1
|
|
set lastX $x
|
|
set lastY $y
|
|
# actually we should check if curobj==bkgImage
|
|
# annotations
|
|
} elseif { $activetool == "oval" && \
|
|
( $curobj == $newoval || $curobj == $background || $curtype == "background" || $curtype == "grid")} {
|
|
# Draw a new oval
|
|
if {$newoval == ""} {
|
|
set newoval [$c create oval $lastX $lastY $x $y \
|
|
-dash {10 4} -width 1 -tags "newoval"]
|
|
$c raise $newoval "background || link || linklabel || interface"
|
|
} else {
|
|
$c coords $newoval \
|
|
$lastX $lastY $x $y
|
|
}
|
|
# actually we should check if curobj==bkgImage
|
|
} elseif { $activetool == "rectangle" && \
|
|
( $curobj == $newrect || $curobj == $background || $curtype == "background" || $curtype == "grid")} {
|
|
# Draw a new rectangle
|
|
if {$newrect == ""} {
|
|
set newrect [$c create rectangle $lastX $lastY $x $y \
|
|
-outline blue \
|
|
-dash {10 4} -width 1 -tags "newrect"]
|
|
$c raise $newrect "oval || background || link || linklabel || interface"
|
|
} else {
|
|
$c coords $newrect $lastX $lastY $x $y
|
|
}
|
|
# resizing an annotation
|
|
} elseif { $curtype == "selectmark" } {
|
|
foreach o [$c find withtag "selected"] {
|
|
set node [lindex [$c gettags $o] 1]
|
|
set tagovi [$c gettags $o]
|
|
set koord [getNodeCoords $node]
|
|
|
|
set oldX1 [lindex $koord 0]
|
|
set oldY1 [lindex $koord 1]
|
|
set oldX2 [lindex $koord 2]
|
|
set oldY2 [lindex $koord 3]
|
|
switch -exact -- $resizemode {
|
|
lu {
|
|
set oldX1 $x
|
|
set oldY1 $y
|
|
}
|
|
ld {
|
|
set oldX1 $x
|
|
set oldY2 $y
|
|
}
|
|
l {
|
|
set oldX1 $x
|
|
}
|
|
ru {
|
|
set oldX2 $x
|
|
set oldY1 $y
|
|
}
|
|
rd {
|
|
set oldX2 $x
|
|
set oldY2 $y
|
|
}
|
|
r {
|
|
set oldX2 $x
|
|
}
|
|
u {
|
|
set oldY1 $y
|
|
}
|
|
d {
|
|
set oldY2 $y
|
|
}
|
|
}
|
|
if {$selectbox == ""} {
|
|
# Boeing: fix "bad screen distance" error
|
|
if { $oldX1 == "" || $oldX2 == "" || $oldY1 == "" || \
|
|
$oldY2 == "" } { return }
|
|
# end Boeing
|
|
set selectbox [$c create line \
|
|
$oldX1 $oldY1 $oldX2 $oldY1 $oldX2 $oldY2 $oldX1 \
|
|
$oldY2 $oldX1 $oldY1 \
|
|
-dash {10 4} -fill black -width 1 -tags "selectbox"]
|
|
$c raise $selectbox \
|
|
"background || link || linklabel || interface"
|
|
} else {
|
|
$c coords $selectbox \
|
|
$oldX1 $oldY1 $oldX2 $oldY1 $oldX2 $oldY2 $oldX1 \
|
|
$oldY2 $oldX1 $oldY1
|
|
}
|
|
}
|
|
# selected node(s) are being moved
|
|
} else {
|
|
foreach img [$c find withtag "selected"] {
|
|
set node [lindex [$c gettags $img] 1]
|
|
set newcoords [$c coords $img] ;# different than getNodeCoords
|
|
set img [$c find withtag "selectmark && $node"]
|
|
if {$curtype == "oval" || $curtype == "rectangle"} {
|
|
$c move $img [expr {($x - $lastX) / 2}] \
|
|
[expr {($y - $lastY) / 2}]
|
|
} else {
|
|
$c move $img [expr {$x - $lastX}] [expr {$y - $lastY}]
|
|
set img [$c find withtag "node && $node"]
|
|
$c move $img [expr {$x - $lastX}] [expr {$y - $lastY}]
|
|
set img [$c find withtag "nodelabel && $node"]
|
|
$c move $img [expr {$x - $lastX}] [expr {$y - $lastY}]
|
|
set img [$c find withtag "twonode && $node"]
|
|
if {$img != "" } {; # move Two Node Tool circles around node
|
|
$c move $img [expr {$x - $lastX}] [expr {$y - $lastY}]
|
|
};
|
|
set img [$c find withtag "rangecircles && $node"]
|
|
if {$img != "" } {; # move throughput circles around node
|
|
$c move $img [expr {$x - $lastX}] [expr {$y - $lastY}]
|
|
};
|
|
$c addtag need_redraw withtag "link && $node"
|
|
}
|
|
if { $oper_mode == "exec" } {
|
|
set newx [expr {[lindex $newcoords 0] / $zoom}]
|
|
set newy [expr {[lindex $newcoords 1] / $zoom}]
|
|
sendNodePosMessage -1 $node -1 $newx $newy -1 0
|
|
}
|
|
$c addtag need_redraw withtag "wlanlink && $node"
|
|
widgets_move_node $c $node 0
|
|
}
|
|
foreach link [$c find withtag "link && need_redraw"] {
|
|
redrawLink [lindex [$c gettags $link] 1]
|
|
}
|
|
foreach wlanlink [$c find withtag "wlanlink && need_redraw"] {
|
|
redrawWlanLink $wlanlink
|
|
}
|
|
$c dtag wlanlink need_redraw
|
|
$c dtag link need_redraw
|
|
set changed 1
|
|
set lastX $x
|
|
set lastY $y
|
|
}
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/pseudo.layer
|
|
# NAME
|
|
# pseudo.layer
|
|
# SYNOPSIS
|
|
# set layer [pseudo.layer]
|
|
# FUNCTION
|
|
# Returns the layer on which the pseudo node operates
|
|
# i.e. returns no layer.
|
|
# RESULT
|
|
# * layer -- returns an empty string
|
|
#****
|
|
proc pseudo.layer {} {
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/newGUILink
|
|
# NAME
|
|
# newGUILink -- new GUI link
|
|
# SYNOPSIS
|
|
# newGUILink $lnode1 $lnode2
|
|
# FUNCTION
|
|
# This procedure is called to create a new link between
|
|
# nodes lnode1 and lnode2. Nodes can be on the same canvas
|
|
# or on different canvases. The result of this function
|
|
# is directly visible in GUI.
|
|
# INPUTS
|
|
# * lnode1 -- node id of the first node
|
|
# * lnode2 -- node id of the second node
|
|
#****
|
|
proc newGUILink { lnode1 lnode2 } {
|
|
global changed
|
|
|
|
set link [newLink $lnode1 $lnode2]
|
|
if { $link == "" } {
|
|
return
|
|
}
|
|
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
|
|
}
|
|
redrawAll
|
|
set changed 1
|
|
updateUndoLog
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/button1-release
|
|
# NAME
|
|
# button1-release
|
|
# SYNOPSIS
|
|
# button1-release $c $x $y
|
|
# FUNCTION
|
|
# This procedure is called when a left mouse button is
|
|
# released.
|
|
# The result of this function depends on the actions
|
|
# during the button1-motion procedure.
|
|
# INPUTS
|
|
# * c -- tk canvas
|
|
# * x -- x coordinate
|
|
# * y -- y coordinate
|
|
#****
|
|
proc button1-release { c x y } {
|
|
global node_list plot_list activetool newlink curobj grid
|
|
global changed undolog undolevel redolevel selectbox
|
|
global lastX lastY sizex sizey zoom
|
|
global autorearrange_enabled
|
|
global resizemode resizeobj
|
|
set redrawNeeded 0
|
|
global oper_mode
|
|
global g_prefs
|
|
global g_view_locked
|
|
|
|
set x [$c canvasx $x]
|
|
set y [$c canvasy $y]
|
|
|
|
$c config -cursor left_ptr
|
|
# place a new link between items
|
|
if {$activetool == "link" && $newlink != ""} {
|
|
if { $g_view_locked == 1 } { return }
|
|
$c delete $newlink
|
|
set newlink ""
|
|
set destobj ""
|
|
foreach obj [$c find overlapping $x $y $x $y] {
|
|
if {[lindex [$c gettags $obj] 0] == "node"} {
|
|
set destobj $obj
|
|
break
|
|
}
|
|
}
|
|
if {$destobj != "" && $curobj != "" && $destobj != $curobj} {
|
|
set lnode1 [lindex [$c gettags $curobj] 1]
|
|
set lnode2 [lindex [$c gettags $destobj] 1]
|
|
if { [ifcByLogicalPeer $lnode1 $lnode2] == "" } {
|
|
set link [newLink $lnode1 $lnode2]
|
|
if { $link != "" } {
|
|
drawLink $link
|
|
redrawLink $link
|
|
updateLinkLabel $link
|
|
set changed 1
|
|
}
|
|
}
|
|
}
|
|
# annotations
|
|
} elseif {$activetool == "rectangle" || $activetool == "oval" } {
|
|
if { $g_view_locked == 1 } { return }
|
|
popupAnnotationDialog $c 0 "false"
|
|
# edit text annotation
|
|
} elseif {$activetool == "text" } {
|
|
if { $g_view_locked == 1 } { return }
|
|
textEnter $c $x $y
|
|
}
|
|
|
|
if { $changed == 1 } {
|
|
set regular true
|
|
if { [lindex [$c gettags $curobj] 0] == "nodelabel" } {
|
|
set node [lindex [$c gettags $curobj] 1]
|
|
selectNode $c [$c find withtag "node && $node"]
|
|
}
|
|
set selected {}
|
|
foreach img [$c find withtag "selected"] {
|
|
set node [lindex [$c gettags $img] 1]
|
|
lappend selected $node
|
|
set coords [$c coords $img]
|
|
set x [expr {[lindex $coords 0] / $zoom}]
|
|
set y [expr {[lindex $coords 1] / $zoom}]
|
|
if { $autorearrange_enabled == 0 && $g_prefs(gui_snap_grid)} {
|
|
set dx [expr {(int($x / $grid + 0.5) * $grid - $x) * $zoom}]
|
|
set dy [expr {(int($y / $grid + 0.5) * $grid - $y) * $zoom}]
|
|
$c move $img $dx $dy
|
|
set coords [$c coords $img]
|
|
set x [expr {[lindex $coords 0] / $zoom}]
|
|
set y [expr {[lindex $coords 1] / $zoom}]
|
|
} else {
|
|
set dx 0
|
|
set dy 0
|
|
}
|
|
if {$x < 0 || $y < 0 || $x > $sizex || $y > $sizey} {
|
|
set regular false
|
|
}
|
|
# nodes with four coordinates
|
|
if { [lindex [$c gettags $node] 0] == "oval" ||
|
|
[lindex [$c gettags $node] 0] == "rectangle" } {
|
|
set bbox [$c bbox "selectmark && $node"]
|
|
# Boeing: bbox causes annotations to grow, subtract 5
|
|
if { [llength $bbox] > 3 } {
|
|
set x1 [lindex $bbox 0]
|
|
set y1 [lindex $bbox 1]
|
|
set x2 [expr {[lindex $bbox 2] - 5}]
|
|
set y2 [expr {[lindex $bbox 3] - 5}]
|
|
setNodeCoords $node "$x1 $y1 $x2 $y2"
|
|
set redrawNeeded 1
|
|
if {$x1 < 0 || $y1 < 0 || $x1 > $sizex || $y1 > $sizey || \
|
|
$x2 < 0 || $y2 < 0 || $x2 > $sizex || $y2 > $sizey} {
|
|
set regular false
|
|
}
|
|
}
|
|
# nodes with two coordinates
|
|
} else {
|
|
setNodeCoords $node "$x $y"
|
|
}
|
|
if {[$c find withtag "nodelabel && $node"] != "" } {
|
|
$c move "nodelabel && $node" $dx $dy
|
|
set coords [$c coords "nodelabel && $node"]
|
|
set x [expr {[lindex $coords 0] / $zoom}]
|
|
set y [expr {[lindex $coords 1] / $zoom}]
|
|
setNodeLabelCoords $node "$x $y"
|
|
if {$x < 0 || $y < 0 || $x > $sizex || $y > $sizey} {
|
|
set regular false
|
|
}
|
|
}
|
|
$c move "selectmark && $node" $dx $dy
|
|
$c addtag need_redraw withtag "link && $node"
|
|
set changed 1
|
|
if { $oper_mode == "exec" } {
|
|
# send node position update using x,y stored in node
|
|
set xy [getNodeCoords $node] ;# read new coordinates
|
|
sendNodePosMessage -1 $node -1 [lindex $xy 0] [lindex $xy 1] \
|
|
-1 0
|
|
widgets_move_node $c $node 1
|
|
}
|
|
$c addtag need_redraw withtag "wlanlink && $node"
|
|
} ;# end of: foreach img selected
|
|
if {$regular == "true"} {
|
|
# user has dragged something within the canvas boundaries
|
|
foreach link [$c find withtag "link && need_redraw"] {
|
|
redrawLink [lindex [$c gettags $link] 1]
|
|
}
|
|
} else {
|
|
# user has dragged something beyond the canvas boundaries
|
|
.c config -cursor watch
|
|
loadCfg $undolog($undolevel)
|
|
redrawAll
|
|
if {$activetool == "select" } {
|
|
selectNodes $selected
|
|
}
|
|
set changed 0
|
|
}
|
|
$c dtag link need_redraw
|
|
nodeEnter $c
|
|
|
|
# $changed!=1
|
|
} elseif {$activetool == "select" } {
|
|
if {$selectbox == ""} {
|
|
set x1 $x
|
|
set y1 $y
|
|
rearrange_off
|
|
} else {
|
|
set coords [$c coords $selectbox]
|
|
set x [lindex $coords 0]
|
|
set y [lindex $coords 1]
|
|
set x1 [lindex $coords 4]
|
|
set y1 [lindex $coords 5]
|
|
$c delete $selectbox
|
|
set selectbox ""
|
|
}
|
|
|
|
if { $resizemode == "false" } {
|
|
# select tool mouse button release while drawing select box
|
|
set enclosed {}
|
|
# fix occasional error
|
|
if { $x == "" || $y == "" || $x1 == "" || $y1 == "" } { return }
|
|
foreach obj [$c find enclosed $x $y $x1 $y1] {
|
|
set tags [$c gettags $obj]
|
|
if {[lindex $tags 0] == "node" && [lsearch $tags selected] == -1} {
|
|
lappend enclosed $obj
|
|
}
|
|
if {[lindex $tags 0] == "oval" && [lsearch $tags selected] == -1} {
|
|
lappend enclosed $obj
|
|
}
|
|
if {[lindex $tags 0] == "rectangle" && [lsearch $tags selected] == -1} {
|
|
lappend enclosed $obj
|
|
}
|
|
if {[lindex $tags 0] == "text" && [lsearch $tags selected] == -1} {
|
|
lappend enclosed $obj
|
|
}
|
|
}
|
|
foreach obj $enclosed {
|
|
selectNode $c $obj
|
|
}
|
|
} else {
|
|
# select tool resizing an object by dragging its handles
|
|
# DYL bugfix. if x,y does not change, do not resize!
|
|
# fixes a bug where the object dissappears
|
|
if { $x != $x1 || $y != $y1 } {
|
|
setNodeCoords $resizeobj "$x $y $x1 $y1"
|
|
}
|
|
set redrawNeeded 1
|
|
set resizemode false
|
|
}
|
|
}
|
|
|
|
if { $redrawNeeded } {
|
|
set redrawNeeded 0
|
|
redrawAll
|
|
} else {
|
|
raiseAll $c
|
|
}
|
|
update
|
|
updateUndoLog
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/nodeEnter
|
|
# NAME
|
|
# nodeEnter
|
|
# SYNOPSIS
|
|
# nodeEnter $c
|
|
# FUNCTION
|
|
# This procedure prints the node id, node name and
|
|
# node model (if exists), as well as all the interfaces
|
|
# of the node in the status line.
|
|
# Information is presented for the node above which is
|
|
# the mouse pointer.
|
|
# INPUTS
|
|
# * c -- tk canvas
|
|
#****
|
|
proc nodeEnter { c } {
|
|
global activetool
|
|
|
|
set curtags [$c gettags current]
|
|
if { [lsearch -exact "node nodelabel" [lindex $curtags 0]] < 0 } {
|
|
return ;# allow this proc to be called from button1-release
|
|
}
|
|
set node [lindex $curtags 1]
|
|
set type [nodeType $node]
|
|
set name [getNodeName $node]
|
|
set model [getNodeModel $node]
|
|
if { $model != "" } {
|
|
set line "{$node} $name ($model):"
|
|
} else {
|
|
set line "{$node} $name:"
|
|
}
|
|
if { $type != "rj45" && $type != "tunnel" } {
|
|
foreach ifc [ifcList $node] {
|
|
set line "$line $ifc:[getIfcIPv4addr $node $ifc]"
|
|
}
|
|
}
|
|
set xy [getNodeCoords $node]
|
|
set line "$line <[lindex $xy 0], [lindex $xy 1]>"
|
|
.bottom.textbox config -text "$line"
|
|
widgetObserveNode $c $node
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/linkEnter
|
|
# NAME
|
|
# linkEnter
|
|
# SYNOPSIS
|
|
# linkEnter $c
|
|
# FUNCTION
|
|
# This procedure prints the link id, link bandwidth
|
|
# and link delay in the status line.
|
|
# Information is presented for the link above which is
|
|
# the mouse pointer.
|
|
# INPUTS
|
|
# * c -- tk canvas
|
|
#****
|
|
proc linkEnter {c} {
|
|
global activetool link_list
|
|
|
|
set link [lindex [$c gettags current] 1]
|
|
if { [lsearch $link_list $link] == -1 } {
|
|
return
|
|
}
|
|
set line "$link: [getLinkBandwidthString $link] [getLinkDelayString $link]"
|
|
.bottom.textbox config -text "$line"
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/anyLeave
|
|
# NAME
|
|
# anyLeave
|
|
# SYNOPSIS
|
|
# anyLeave $c
|
|
# FUNCTION
|
|
# This procedure clears the status line.
|
|
# INPUTS
|
|
# * c -- tk canvas
|
|
#****
|
|
proc anyLeave {c} {
|
|
global activetool
|
|
|
|
.bottom.textbox config -text ""
|
|
# Boeing
|
|
widgetObserveNode $c ""
|
|
# nodeHighlights $c "" off ""
|
|
# end Boeing
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/checkIntRange
|
|
# NAME
|
|
# checkIntRange -- check integer range
|
|
# SYNOPSIS
|
|
# set check [checkIntRange $str $low $high]
|
|
# FUNCTION
|
|
# This procedure checks the input string to see if it is
|
|
# an integer between the low and high value.
|
|
# INPUTS
|
|
# str -- string to check
|
|
# low -- the bottom value
|
|
# high -- the top value
|
|
# RESULT
|
|
# * check -- set to 1 if the str is string between low and high
|
|
# value, 0 otherwise.
|
|
#****
|
|
proc checkIntRange { str low high } {
|
|
if { $str == "" } {
|
|
return 1
|
|
}
|
|
set str [string trimleft $str 0]
|
|
if { $str == "" } {
|
|
set str 0
|
|
}
|
|
if { ![string is integer $str] } {
|
|
return 0
|
|
}
|
|
if { $str < $low || $str > $high } {
|
|
return 0
|
|
}
|
|
return 1
|
|
}
|
|
|
|
proc checkFloatRange { str low high } {
|
|
if { $str == "" } {
|
|
return 1
|
|
}
|
|
set str [string trimleft $str 0]
|
|
if { $str == "" } {
|
|
set str 0
|
|
}
|
|
if { ![string is double $str] } {
|
|
return 0
|
|
}
|
|
if { $str < $low || $str > $high } {
|
|
return 0
|
|
}
|
|
return 1
|
|
}
|
|
|
|
proc checkHostname { str } {
|
|
# per RFC 952 and RFC 1123, any letter, number, or hyphen
|
|
return [regexp {^[A-Za-z0-9-]+$} $str]
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/focusAndFlash
|
|
# NAME
|
|
# focusAndFlash -- focus and flash
|
|
# SYNOPSIS
|
|
# focusAndFlash $W $count
|
|
# FUNCTION
|
|
# This procedure sets the focus on the bad entry field
|
|
# and on this filed it provides an effect of flashing
|
|
# for approximately 1 second.
|
|
# INPUTS
|
|
# * W -- textbox field that caused the bed entry
|
|
# * count -- the parameter that causes flashes.
|
|
# It can be left blank.
|
|
#****
|
|
proc focusAndFlash {W {count 9}} {
|
|
global badentry
|
|
|
|
set fg black
|
|
set bg white
|
|
|
|
if { $badentry == -1 } {
|
|
return
|
|
} else {
|
|
set badentry 1
|
|
}
|
|
|
|
focus -force $W
|
|
if {$count<1} {
|
|
$W configure -foreground $fg -background $bg
|
|
set badentry 0
|
|
} else {
|
|
if {$count%2} {
|
|
$W configure -foreground $bg -background $fg
|
|
} else {
|
|
$W configure -foreground $fg -background $bg
|
|
}
|
|
after 200 [list focusAndFlash $W [expr {$count - 1}]]
|
|
}
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/popupConfigDialog
|
|
# NAME
|
|
# popupConfigDialog -- popup Configuration Dialog Box
|
|
# SYNOPSIS
|
|
# popupConfigDialog $c
|
|
# FUNCTION
|
|
# Dynamically creates a popup dialog box for configuring
|
|
# links or nodes in IMUNES.
|
|
# INPUTS
|
|
# * c -- canvas id
|
|
#****
|
|
proc popupConfigDialog { c } {
|
|
global activetool router_model link_color oper_mode
|
|
global badentry curcanvas
|
|
global node_location systype
|
|
global plugin_img_del
|
|
set type ""
|
|
|
|
set wi .popup
|
|
if { [winfo exists $wi ] } {
|
|
return
|
|
}
|
|
catch {destroy $wi}
|
|
toplevel $wi
|
|
|
|
wm transient $wi .
|
|
wm resizable $wi 1 1
|
|
|
|
set object_type ""
|
|
set tk_type [lindex [$c gettags current] 0]
|
|
set target [lindex [$c gettags current] 1]
|
|
if { [lsearch {node nodelabel interface} $tk_type] > -1 } {
|
|
set object_type node
|
|
}
|
|
if { [lsearch {link linklabel} $tk_type] > -1 } {
|
|
set object_type link
|
|
}
|
|
if { [lsearch {oval} $tk_type] > -1 } {
|
|
set object_type oval
|
|
}
|
|
if { [lsearch {rectangle} $tk_type] > -1 } {
|
|
set object_type rectangle
|
|
}
|
|
if { [lsearch {text} $tk_type] > -1 } {
|
|
set object_type text
|
|
}
|
|
if { "$object_type" == ""} {
|
|
destroy $wi
|
|
return
|
|
}
|
|
if { $object_type == "link" } {
|
|
set n0 [lindex [linkPeers $target] 0]
|
|
set n1 [lindex [linkPeers $target] 1]
|
|
# Boeing: added tunnel check
|
|
#if { [nodeType $n0] == "rj45" || [nodeType $n1] == "rj45" || \
|
|
# [nodeType $n0] == "tunnel" || [nodeType $n1] == "tunnel" } {
|
|
# destroy $wi
|
|
# return
|
|
#}
|
|
}
|
|
$c dtag node selected
|
|
$c delete -withtags selectmark
|
|
|
|
switch -exact -- $object_type {
|
|
node {
|
|
set type [nodeType $target]
|
|
if { $type == "pseudo" } {
|
|
#
|
|
# Hyperlink to another canvas
|
|
#
|
|
destroy $wi
|
|
set curcanvas [getNodeCanvas [getNodeMirror $target]]
|
|
switchCanvas none
|
|
return
|
|
}
|
|
set model [getNodeModel $target]
|
|
set router_model $model
|
|
wm title $wi "$type configuration"
|
|
ttk::frame $wi.ftop -borderwidth 4
|
|
ttk::entry $wi.ftop.name -width 16 \
|
|
-validate focus -invalidcommand "focusAndFlash %W"
|
|
if { $type == "rj45" } {
|
|
ttk::label $wi.ftop.name_label -text "Physical interface:"
|
|
} elseif { $type == "tunnel" } {
|
|
ttk::label $wi.ftop.name_label -text "IP address of tunnel peer:"
|
|
} else {
|
|
ttk::label $wi.ftop.name_label -text "Node name:"
|
|
$wi.ftop.name configure -validatecommand {checkHostname %P}
|
|
}
|
|
$wi.ftop.name insert 0 [getNodeName $target]
|
|
set img [getNodeImage $target]
|
|
ttk::button $wi.ftop.img -image $img -command "popupCustomImage $target"
|
|
|
|
if { $type == "rj45" } {
|
|
rj45ifclist $wi $target 0
|
|
}
|
|
# execution server
|
|
global exec_servers node_location
|
|
set node_location [getNodeLocation $target]
|
|
set servers [lsort -dictionary [array names exec_servers]]
|
|
set servers "(none) $servers"
|
|
if { $node_location == "" } { set node_location "(none)" }
|
|
eval tk_optionMenu $wi.ftop.menu node_location $servers
|
|
pack $wi.ftop.img $wi.ftop.menu $wi.ftop.name $wi.ftop.name_label \
|
|
-side right -padx 4 -pady 4
|
|
# end Boeing
|
|
pack $wi.ftop -side top
|
|
if { $type == "router" || $type == "OVS"} {
|
|
|
|
ttk::frame $wi.model -borderwidth 4
|
|
ttk::label $wi.model.label -text "Type:"
|
|
set runstate "disabled"
|
|
if { $oper_mode == "edit" } {
|
|
eval tk_optionMenu $wi.model.menu router_model \
|
|
[getNodeTypeNames]
|
|
set runstate "normal"
|
|
} else {
|
|
tk_optionMenu $wi.model.menu router_model $model
|
|
}
|
|
# would be nice to update the image upon selection; binding to
|
|
# <ButtonRelease> will not work
|
|
#tkwait variable router_model "customImageApply $wi $target"
|
|
set sock [lindex [getEmulPlugin $target] 2]
|
|
ttk::button $wi.model.services -text "Services..." -state $runstate \
|
|
-command \
|
|
"sendConfRequestMessage $sock $target services 0x1 -1 \"\""
|
|
pack $wi.model.services $wi.model.menu $wi.model.label \
|
|
-side right -padx 0 -pady 0
|
|
pack $wi.model -side top
|
|
}
|
|
|
|
if { $type == "wlan" } {
|
|
wlanConfigDialogHelper $wi $target 0
|
|
} elseif { $type == "tunnel" } {
|
|
#
|
|
# tunnel controls
|
|
#
|
|
ttk::frame $wi.con2
|
|
global conntap
|
|
set conntap [netconfFetchSection $target "tunnel-tap"]
|
|
if { $conntap == "" } { set conntap off }
|
|
# TODO: clean this up
|
|
ttk::radiobutton $wi.con2.dotap0 \
|
|
-variable conntap -value off \
|
|
-text "tunnel to another CORE emulation"
|
|
ttk::frame $wi.con2.key
|
|
ttk::label $wi.con2.key.lab -text "GRE key:"
|
|
ttk::entry $wi.con2.key.key -width 6
|
|
ttk::radiobutton $wi.con2.dotap1 -state disabled \
|
|
-variable conntap -value on \
|
|
-text "tunnel to the virtual TAP interface of another system"
|
|
pack $wi.con2.key.lab $wi.con2.key.key -side left
|
|
pack $wi.con2.dotap0 -side top -anchor w
|
|
pack $wi.con2.key -side top
|
|
pack $wi.con2.dotap1 -side top -anchor w
|
|
pack $wi.con2 -side top
|
|
set key [netconfFetchSection $target "tunnel-key"]
|
|
if { $key == "" } { set key 1 }
|
|
$wi.con2.key.key insert 0 $key
|
|
|
|
# TODO: clean this up
|
|
ttk::frame $wi.conn
|
|
ttk::label $wi.conn.label -text "Transport type:"
|
|
tk_optionMenu $wi.conn.conntype conntype "UDP" "TCP"
|
|
$wi.conn.conntype configure -state disabled
|
|
pack $wi.conn.label $wi.conn.conntype -side left -anchor w
|
|
pack $wi.conn -side top
|
|
global conntype
|
|
set conntype [netconfFetchSection $target "tunnel-type"]
|
|
if { $conntype == "" } { set conntype "UDP" }
|
|
|
|
|
|
# TODO: clean this up
|
|
ttk::frame $wi.linfo
|
|
ttk::label $wi.linfo.label -text "Local hook:"
|
|
ttk::entry $wi.linfo.local -state disabled
|
|
set localhook [netconfFetchSection $target "local-hook"]
|
|
if { $localhook == "" || $localhook == "(none)" } {
|
|
# automatically generate local hook name
|
|
set ifc [lindex [ifcList $target] 0]
|
|
if { $ifc != "" } {
|
|
set hname [info hostname]
|
|
set peer [peerByIfc $target $ifc]
|
|
set localhook "$hname$peer"
|
|
} else {
|
|
set localhook "(none)"
|
|
}
|
|
}
|
|
$wi.linfo.local insert 0 $localhook
|
|
pack $wi.linfo.label $wi.linfo.local -side left -anchor w
|
|
pack $wi.linfo -side top
|
|
|
|
ttk::frame $wi.pinfo
|
|
ttk::label $wi.pinfo.label -text "Peer hook:"
|
|
ttk::entry $wi.pinfo.peer -state disabled
|
|
$wi.pinfo.peer insert 0 \
|
|
[netconfFetchSection $target "peer-hook"]
|
|
pack $wi.pinfo.label $wi.pinfo.peer -side left -anchor w
|
|
pack $wi.pinfo -side top
|
|
}
|
|
|
|
# interface list
|
|
if { [[typemodel $target].layer] == "NETWORK" } {
|
|
# canvas used for scrolling frames for each interface
|
|
ttk::frame $wi.ifaces
|
|
set height [expr {100 * [llength [ifcList $target]]}]
|
|
if { $height > 300 } { set height 300 }
|
|
canvas $wi.ifaces.c -height $height -highlightthickness 0 \
|
|
-yscrollcommand "$wi.ifaces.scroll set"
|
|
scrollbar $wi.ifaces.scroll -command "$wi.ifaces.c yview"
|
|
pack $wi.ifaces.c -side left -fill both -expand 1
|
|
pack $wi.ifaces.scroll -side right -fill y
|
|
pack $wi.ifaces -side top -fill both -expand 1
|
|
set y 0
|
|
|
|
foreach ifc [lsort -ascii [ifcList $target]] {
|
|
set fr $wi.ifaces.c.if$ifc
|
|
ttk::labelframe $fr -text "Interface $ifc"
|
|
$wi.ifaces.c create window 4 $y -window $fr -anchor nw
|
|
incr y 100
|
|
|
|
set peer [peerByIfc $target $ifc]
|
|
if { [isEmane $peer] } {
|
|
ttk::frame $fr.opts
|
|
set caps [getCapabilities $peer "mobmodel"]
|
|
set cap [lindex $caps 0]
|
|
set cmd "sendConfRequestMessage -1 $target $cap 0x1 -1 \"\""
|
|
ttk::button $fr.opts.cfg -command $cmd \
|
|
-text "$cap options..."
|
|
pack $fr.opts.cfg -side left -padx 4
|
|
pack $fr.opts -side top -anchor w
|
|
incr y 28
|
|
}
|
|
|
|
ttk::frame $fr.cfg
|
|
#
|
|
# MAC address
|
|
#
|
|
ttk::frame $fr.cfg.mac
|
|
ttk::label $fr.cfg.mac.addrl -text "MAC address" \
|
|
-anchor w
|
|
set macaddr [getIfcMacaddr $target $ifc]
|
|
global if${ifc}_auto_mac
|
|
if { $macaddr == "" } {
|
|
set if${ifc}_auto_mac 1
|
|
set state disabled
|
|
} else {
|
|
set if${ifc}_auto_mac 0
|
|
set state normal
|
|
}
|
|
ttk::checkbutton $fr.cfg.mac.auto -text "auto-assign" \
|
|
-variable if${ifc}_auto_mac \
|
|
-command "macEntryHelper $wi $ifc"
|
|
ttk::entry $fr.cfg.mac.addrv -width 15 \
|
|
-state $state
|
|
$fr.cfg.mac.addrv insert 0 $macaddr
|
|
pack $fr.cfg.mac.addrl $fr.cfg.mac.auto \
|
|
$fr.cfg.mac.addrv -side left -padx 4
|
|
pack $fr.cfg.mac -side top -anchor w
|
|
|
|
#
|
|
# IPv4 address
|
|
#
|
|
ttk::frame $fr.cfg.ipv4
|
|
ttk::label $fr.cfg.ipv4.addrl -text "IPv4 address" \
|
|
-anchor w
|
|
ttk::entry $fr.cfg.ipv4.addrv -width 30 \
|
|
-validate focus -invalidcommand "focusAndFlash %W"
|
|
$fr.cfg.ipv4.addrv insert 0 \
|
|
[getIfcIPv4addr $target $ifc]
|
|
$fr.cfg.ipv4.addrv configure \
|
|
-validatecommand {checkIPv4Net %P}
|
|
ttk::button $fr.cfg.ipv4.clear -image $plugin_img_del \
|
|
-command "$fr.cfg.ipv4.addrv delete 0 end"
|
|
pack $fr.cfg.ipv4.addrl $fr.cfg.ipv4.addrv \
|
|
$fr.cfg.ipv4.clear -side left
|
|
pack $fr.cfg.ipv4 -side top -anchor w -padx 4
|
|
|
|
#
|
|
# IPv6 address
|
|
#
|
|
ttk::frame $fr.cfg.ipv6
|
|
ttk::label $fr.cfg.ipv6.addrl -text "IPv6 address" \
|
|
-anchor w
|
|
ttk::entry $fr.cfg.ipv6.addrv -width 30 \
|
|
-validate focus -invalidcommand "focusAndFlash %W"
|
|
$fr.cfg.ipv6.addrv insert 0 \
|
|
[getIfcIPv6addr $target $ifc]
|
|
$fr.cfg.ipv6.addrv configure -validatecommand {checkIPv6Net %P}
|
|
ttk::button $fr.cfg.ipv6.clear -image $plugin_img_del \
|
|
-command "$fr.cfg.ipv6.addrv delete 0 end"
|
|
pack $fr.cfg.ipv6.addrl $fr.cfg.ipv6.addrv \
|
|
$fr.cfg.ipv6.clear -side left
|
|
pack $fr.cfg.ipv6 -side top -anchor w -padx 4
|
|
pack $fr.cfg -side left
|
|
bind $fr.cfg <4> "$wi.ifaces.c yview scroll -1 units"
|
|
bind $fr.cfg <5> "$wi.ifaces.c yview scroll 1 units"
|
|
} ;# end foreach ifc
|
|
$wi.ifaces.c configure -scrollregion "0 0 250 $y"
|
|
# mouse wheel bindings for scrolling
|
|
foreach ctl [list $wi.ifaces.c $wi.ifaces.scroll] {
|
|
bind $ctl <4> "$wi.ifaces.c yview scroll -1 units"
|
|
bind $ctl <5> "$wi.ifaces.c yview scroll 1 units"
|
|
bind $ctl <Up> "$wi.ifaces.c yview scroll -1 units"
|
|
bind $ctl <Down> "$wi.ifaces.c yview scroll 1 units"
|
|
}
|
|
}
|
|
}
|
|
oval {
|
|
destroy $wi
|
|
annotationConfig $c $target
|
|
return
|
|
}
|
|
rectangle {
|
|
destroy $wi
|
|
annotationConfig $c $target
|
|
return
|
|
}
|
|
text {
|
|
destroy $wi
|
|
annotationConfig $c $target
|
|
return
|
|
}
|
|
link {
|
|
wm title $wi "link configuration"
|
|
ttk::frame $wi.ftop -borderwidth 6
|
|
set nam0 [getNodeName $n0]
|
|
set nam1 [getNodeName $n1]
|
|
ttk::label $wi.ftop.name_label -justify left -text \
|
|
"Link from $nam0 to $nam1"
|
|
pack $wi.ftop.name_label -side right
|
|
pack $wi.ftop -side top
|
|
|
|
set spinbox [getspinbox]
|
|
global g_link_config_uni_state
|
|
set g_link_config_uni_state "bid"
|
|
|
|
ttk::frame $wi.preset -borderwidth 4
|
|
global link_preset_val
|
|
set link_preset_val unlimited
|
|
set linkpreMenu [tk_optionMenu $wi.preset.linkpre link_preset_val a]
|
|
# unidirectional links not always supported
|
|
if { [isUniSupported $n0 $n1] } {
|
|
set unistate normal
|
|
} else {
|
|
set unistate disabled
|
|
}
|
|
ttk::button $wi.preset.uni -text " >> " -state $unistate \
|
|
-command "linkConfigUni $wi"
|
|
pack $wi.preset.uni $wi.preset.linkpre -side right
|
|
linkPresets $wi $linkpreMenu init
|
|
pack $wi.preset -side top -anchor e
|
|
|
|
ttk::frame $wi.unilabel -borderwidth 4
|
|
ttk::label $wi.unilabel.updown -text "Symmetric link effects:"
|
|
pack $wi.unilabel.updown -side left -anchor w
|
|
pack $wi.unilabel -side top -anchor w
|
|
|
|
ttk::frame $wi.bandwidth -borderwidth 4
|
|
ttk::label $wi.bandwidth.label -anchor e -text "Bandwidth (bps):"
|
|
$spinbox $wi.bandwidth.value -justify right -width 10 \
|
|
-validate focus -invalidcommand "focusAndFlash %W"
|
|
$wi.bandwidth.value insert 0 [getLinkBandwidth $target]
|
|
$wi.bandwidth.value configure \
|
|
-validatecommand {checkIntRange %P 0 1000000000} \
|
|
-from 0 -to 1000000000 -increment 1000000
|
|
pack $wi.bandwidth.value $wi.bandwidth.label -side right
|
|
pack $wi.bandwidth -side top -anchor e
|
|
|
|
ttk::frame $wi.delay -borderwidth 4
|
|
ttk::label $wi.delay.label -anchor e -text "Delay (us):"
|
|
$spinbox $wi.delay.value -justify right -width 10 \
|
|
-validate focus -invalidcommand "focusAndFlash %W"
|
|
$wi.delay.value insert 0 [getLinkDelay $target]
|
|
# 274 seconds is maximum netem delay for Linux 3.2.0-60-generic kernel
|
|
$wi.delay.value configure \
|
|
-validatecommand {checkIntRange %P 0 274000000} \
|
|
-from 0 -to 10000000 -increment 5
|
|
pack $wi.delay.value $wi.delay.label -side right
|
|
pack $wi.delay -side top -anchor e
|
|
|
|
ttk::frame $wi.jitter -borderwidth 4
|
|
ttk::label $wi.jitter.label -anchor e -text "Jitter (us):"
|
|
$spinbox $wi.jitter.value -justify right -width 10 \
|
|
-validate focus -invalidcommand "focusAndFlash %W"
|
|
$wi.jitter.value insert 0 [getLinkJitter $target]
|
|
$wi.jitter.value configure \
|
|
-validatecommand {checkIntRange %P 0 10000000} \
|
|
-from 0 -to 10000000 -increment 5
|
|
pack $wi.jitter.value $wi.jitter.label -side right
|
|
pack $wi.jitter -side top -anchor e
|
|
|
|
ttk::frame $wi.ber -borderwidth 4
|
|
if { [lindex $systype 0] == "Linux" } {
|
|
set bertext "Loss (%):"
|
|
set berinc 0.1
|
|
set bermax 100.0
|
|
} else { ;# netgraph uses BER
|
|
set bertext "BER (1/N):"
|
|
set berinc 1000
|
|
set bermax 10000000000000
|
|
}
|
|
ttk::label $wi.ber.label -anchor e -text $bertext
|
|
$spinbox $wi.ber.value -justify right -width 10 \
|
|
-validate focus -invalidcommand "focusAndFlash %W"
|
|
$wi.ber.value insert 0 [getLinkBER $target]
|
|
$wi.ber.value configure \
|
|
-validatecommand "checkFloatRange %P 0.0 $bermax" \
|
|
-from 0.0 -to $bermax -increment $berinc
|
|
pack $wi.ber.value $wi.ber.label -side right
|
|
pack $wi.ber -side top -anchor e
|
|
|
|
ttk::frame $wi.dup -borderwidth 4
|
|
ttk::label $wi.dup.label -anchor e -text "Duplicate (%):"
|
|
$spinbox $wi.dup.value -justify right -width 10 \
|
|
-validate focus -invalidcommand "focusAndFlash %W"
|
|
$wi.dup.value insert 0 [getLinkDup $target]
|
|
$wi.dup.value configure \
|
|
-validatecommand {checkFloatRange %P 0 50} \
|
|
-from 0 -to 50 -increment 1
|
|
pack $wi.dup.value $wi.dup.label -side right
|
|
pack $wi.dup -side top -anchor e
|
|
|
|
# Boeing: jitter
|
|
# frame $wi.jitter -borderwidth 4
|
|
# label $wi.jitter.label -anchor e -text "Jitter (us):"
|
|
# spinbox $wi.jitter.value -bg white -justify right -width 10 \
|
|
# -validate focus -invalidcommand "focusAndFlash %W"
|
|
# $wi.jitter.value insert 0 [getLinkJitter $target]
|
|
# $wi.jitter.value configure \
|
|
# -validatecommand {checkIntRange %P 0 10000000} \
|
|
# -from 0 -to 10000000 -increment 5
|
|
# pack $wi.jitter.value $wi.jitter.label -side right
|
|
# pack $wi.jitter -side top -anchor e
|
|
# end Boeing
|
|
|
|
ttk::frame $wi.color -borderwidth 4
|
|
ttk::label $wi.color.label -anchor e -text "Color:"
|
|
set link_color [getLinkColor $target]
|
|
tk_optionMenu $wi.color.value link_color \
|
|
Red Green Blue Yellow Magenta Cyan Black
|
|
$wi.color.value configure -width 8
|
|
pack $wi.color.value $wi.color.label -side right
|
|
pack $wi.color -side top -anchor e
|
|
|
|
ttk::frame $wi.width -borderwidth 4
|
|
ttk::label $wi.width.label -anchor e -text "Width:"
|
|
$spinbox $wi.width.value -justify right -width 10 \
|
|
-validate focus -invalidcommand "focusAndFlash %W"
|
|
$wi.width.value insert 0 [getLinkWidth $target]
|
|
$wi.width.value configure \
|
|
-validatecommand {checkIntRange %P 1 8} \
|
|
-from 1 -to 8 -increment 1
|
|
pack $wi.width.value $wi.width.label -side right
|
|
pack $wi.width -side top -anchor e
|
|
|
|
# auto-expand upstream if values exist
|
|
set bw [getLinkBandwidth $target up]
|
|
set dl [getLinkDelay $target up]
|
|
set jt [getLinkJitter $target up]
|
|
set ber [getLinkBER $target up]
|
|
set dup [getLinkDup $target up]
|
|
if { $bw > 0 || $dl > 0 || $jt > 0 || $ber > 0 || $dup > 0 } {
|
|
linkConfigUni $wi
|
|
$wi.bandwidth.value2 delete 0 end
|
|
$wi.bandwidth.value2 insert 0 $bw
|
|
$wi.delay.value2 delete 0 end
|
|
$wi.delay.value2 insert 0 $dl
|
|
$wi.jitter.value2 delete 0 end
|
|
$wi.jitter.value2 insert 0 $jt
|
|
$wi.ber.value2 delete 0 end
|
|
$wi.ber.value2 insert 0 $ber
|
|
$wi.dup.value2 delete 0 end
|
|
$wi.dup.value2 insert 0 $dup
|
|
}
|
|
}
|
|
} ;# end switch
|
|
|
|
ttk::frame $wi.butt -borderwidth 6
|
|
# NOTE: plugins.tcl:popupCapabilityConfig may read this command option
|
|
ttk::button $wi.butt.apply -text "Apply" -command \
|
|
"popupConfigApply $wi $object_type $target 0"
|
|
focus $wi.butt.apply
|
|
# Boeing: remove range circles upon cancel
|
|
if {$type == "wlan"} {
|
|
set cancelcmd "set badentry -1 ; destroy $wi;"
|
|
set cancelcmd "$cancelcmd updateRangeCircles $target 0"
|
|
} else {
|
|
set cancelcmd "set badentry -1 ; destroy $wi"
|
|
}
|
|
ttk::button $wi.butt.cancel -text "Cancel" -command $cancelcmd
|
|
#end Boeing
|
|
pack $wi.butt.cancel $wi.butt.apply -side right
|
|
pack $wi.butt -side bottom
|
|
bind $wi <Key-Escape> $cancelcmd
|
|
# bind $wi <Key-Return> "popupConfigApply $wi $object_type $target 0"
|
|
}
|
|
|
|
|
|
proc linkConfigUni { wi } {
|
|
global g_link_config_uni_state
|
|
|
|
set capt [lindex [$wi.preset.uni configure -text] 4]
|
|
|
|
if { $capt == " >> " } {
|
|
set g_link_config_uni_state "uni"
|
|
$wi.preset.uni configure -text " << "
|
|
set txt "Asymmetric effects: downstream / upstream"
|
|
$wi.unilabel.updown configure -text $txt
|
|
|
|
set spinbox [getspinbox]
|
|
if { ![winfo exists $wi.bandwidth.value2] } {
|
|
$spinbox $wi.bandwidth.value2 -justify right \
|
|
-width 10 -validate focus -invalidcommand "focusAndFlash %W"
|
|
$wi.bandwidth.value2 configure \
|
|
-validatecommand {checkIntRange %P 0 1000000000} \
|
|
-from 0 -to 1000000000 -increment 1000000
|
|
}
|
|
$wi.bandwidth.value2 delete 0 end
|
|
$wi.bandwidth.value2 insert 0 [$wi.bandwidth.value get]
|
|
pack $wi.bandwidth.value2 -side right
|
|
pack $wi.bandwidth.value2 -before $wi.bandwidth.value
|
|
|
|
if { ![winfo exists $wi.delay.value2] } {
|
|
$spinbox $wi.delay.value2 -justify right -width 10 \
|
|
-validate focus -invalidcommand "focusAndFlash %W"
|
|
$wi.delay.value2 configure \
|
|
-validatecommand {checkIntRange %P 0 10000000} \
|
|
-from 0 -to 10000000 -increment 5
|
|
}
|
|
$wi.delay.value2 delete 0 end
|
|
$wi.delay.value2 insert 0 [$wi.delay.value get]
|
|
pack $wi.delay.value2 -side right
|
|
pack $wi.delay.value2 -before $wi.delay.value
|
|
|
|
if { ![winfo exists $wi.jitter.value2] } {
|
|
$spinbox $wi.jitter.value2 -justify right -width 10 \
|
|
-validate focus -invalidcommand "focusAndFlash %W"
|
|
$wi.jitter.value2 configure \
|
|
-validatecommand {checkIntRange %P 0 10000000} \
|
|
-from 0 -to 10000000 -increment 5
|
|
}
|
|
$wi.jitter.value2 delete 0 end
|
|
$wi.jitter.value2 insert 0 [$wi.jitter.value get]
|
|
pack $wi.jitter.value2 -side right
|
|
pack $wi.jitter.value2 -before $wi.jitter.value
|
|
|
|
if { ![winfo exists $wi.ber.value2] } {
|
|
$spinbox $wi.ber.value2 -justify right -width 10 \
|
|
-validate focus -invalidcommand "focusAndFlash %W"
|
|
$wi.ber.value2 configure \
|
|
-validatecommand "checkFloatRange %P 0.0 100.0" \
|
|
-from 0.0 -to 100.0 -increment 0.1
|
|
}
|
|
$wi.ber.value2 delete 0 end
|
|
$wi.ber.value2 insert 0 [$wi.ber.value get]
|
|
pack $wi.ber.value2 -side right
|
|
pack $wi.ber.value2 -before $wi.ber.value
|
|
|
|
if { ![winfo exists $wi.dup.value2] } {
|
|
$spinbox $wi.dup.value2 -justify right -width 10 \
|
|
-validate focus -invalidcommand "focusAndFlash %W"
|
|
$wi.dup.value2 configure \
|
|
-validatecommand {checkFloatRange %P 0 50} \
|
|
-from 0 -to 50 -increment 1
|
|
}
|
|
$wi.dup.value2 delete 0 end
|
|
$wi.dup.value2 insert 0 [$wi.dup.value get]
|
|
pack $wi.dup.value2 -side right
|
|
pack $wi.dup.value2 -before $wi.dup.value
|
|
} else {
|
|
set g_link_config_uni_state "bid"
|
|
$wi.preset.uni configure -text " >> "
|
|
$wi.unilabel.updown configure -text "Symmetric link effects:"
|
|
pack forget $wi.bandwidth.value2
|
|
pack forget $wi.delay.value2
|
|
pack forget $wi.jitter.value2
|
|
pack forget $wi.ber.value2
|
|
pack forget $wi.dup.value2
|
|
}
|
|
}
|
|
|
|
# unidirectional links are not always supported
|
|
proc isUniSupported { n1 n2 } {
|
|
set blacklist [list "hub" "lanswitch"]
|
|
set type1 [nodeType $n1]
|
|
set type2 [nodeType $n2]
|
|
# not yet supported for GRE tap device
|
|
if { $type1 == "tunnel" || $type2 == "tunnel" } {
|
|
return false
|
|
}
|
|
# unidirectional links are supported between two switches/hubs
|
|
if { [lsearch $blacklist $type1] != -1 && \
|
|
[lsearch $blacklist $type2] != -1 } {
|
|
return true
|
|
}
|
|
# unidirectional links not supported between hub/switch and something else
|
|
if { [lsearch $blacklist $type1] != -1 || \
|
|
[lsearch $blacklist $type2] != -1 } {
|
|
return false
|
|
}
|
|
# unidirectional links are supported between routers, rj45s, etc.
|
|
# WLANs not included here because they have no link dialog
|
|
return true
|
|
}
|
|
|
|
# toggle the state of the mac address entry, and insert MAC address template
|
|
proc macEntryHelper { wi ifc } {
|
|
set fr $wi.ifaces.c.if$ifc
|
|
set ctl $fr.cfg.mac.addrv
|
|
set s normal
|
|
if { [$ctl cget -state] == $s } { set s disabled }
|
|
$ctl configure -state $s
|
|
|
|
if { [$ctl get] == "" } { $ctl insert 0 "00:00:00:00:00:00" }
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/popupConfigApply
|
|
# NAME
|
|
# popupConfigApply -- popup configuration apply
|
|
# SYNOPSIS
|
|
# popupConfigApply $w $object_type $target $phase
|
|
# FUNCTION
|
|
# This procedure is called when the button apply is pressed in
|
|
# popup configuration dialog box. It reads different
|
|
# configuration parameters depending on the object_type.
|
|
# INPUTS
|
|
# * w -- widget
|
|
# * object_type -- describes the object type that is currently
|
|
# configured. It can be either link or node.
|
|
# * target -- node id of the configured node or link id of the
|
|
# configured link
|
|
# * phase -- This procedure is invoked in two diffenet phases
|
|
# to enable validation of the entry that was the last made.
|
|
# When calling this function always use the phase parameter
|
|
# set to 0.
|
|
#****
|
|
proc popupConfigApply { wi object_type target phase } {
|
|
global changed oper_mode router_model link_color badentry
|
|
global customEnabled ipsecEnabled
|
|
global eid
|
|
|
|
$wi config -cursor watch
|
|
update
|
|
if { $phase == 0 } {
|
|
set badentry 0
|
|
focus .
|
|
after 100 "popupConfigApply $wi $object_type $target 1"
|
|
return
|
|
} elseif { $badentry } {
|
|
$wi config -cursor left_ptr
|
|
return
|
|
}
|
|
switch -exact -- $object_type {
|
|
#
|
|
# Node
|
|
#
|
|
node {
|
|
set type [nodeType $target]
|
|
set model [getNodeModel $target]
|
|
set name [string trim [$wi.ftop.name get]]
|
|
set changed_to_remote 0
|
|
global node_location
|
|
if { $node_location != [getNodeLocation $target] } {
|
|
if { $node_location == "(none)" } { set node_location "" }
|
|
setNodeLocation $target $node_location
|
|
set changed 1
|
|
}
|
|
set node_location ""
|
|
if { $name != [getNodeName $target] } {
|
|
setNodeName $target $name
|
|
set changed 1
|
|
}
|
|
if { $oper_mode == "edit" && $type == "router" && \
|
|
$router_model != $model } {
|
|
setNodeModel $target $router_model
|
|
set changed 1
|
|
if { $router_model == "remote" } { set changed_to_remote 1 };#Boeing
|
|
}
|
|
|
|
# Boeing - added wlan, remote, tunnel, ktunnel items
|
|
if { $type == "wlan" } {
|
|
wlanConfigDialogHelper $wi $target 1
|
|
} elseif { $type == "tunnel" } {
|
|
#
|
|
# apply tunnel items
|
|
#
|
|
set ipaddr "$name/24" ;# tunnel name == IP address of peer
|
|
set oldipaddr [getIfcIPv4addr $target e0]
|
|
if { $ipaddr != $oldipaddr } {
|
|
setIfcIPv4addr $target e0 $ipaddr
|
|
}
|
|
global conntype conntap
|
|
set oldconntype [netconfFetchSection $target "tunnel-type"]
|
|
if { $oldconntype != $conntype } {
|
|
netconfInsertSection $target [list "tunnel-type" $conntype]
|
|
}
|
|
set oldconntap [netconfFetchSection $target "tunnel-tap"]
|
|
if { $oldconntap != $conntap } {
|
|
netconfInsertSection $target [list "tunnel-tap" $conntap]
|
|
}
|
|
set oldkey [netconfFetchSection $target "tunnel-key"]
|
|
set key [$wi.con2.key.key get]
|
|
if { $oldkey != $key } {
|
|
netconfInsertSection $target [list "tunnel-key" $key]
|
|
}
|
|
|
|
set oldlocal [netconfFetchSection $target "local-hook"]
|
|
set local [$wi.linfo.local get]
|
|
if { $oldlocal != $local } {
|
|
netconfInsertSection $target [list "local-hook" $local]
|
|
}
|
|
|
|
set oldpeer [netconfFetchSection $target "peer-hook"]
|
|
set peer [$wi.pinfo.peer get]
|
|
if { $oldpeer != $peer } {
|
|
netconfInsertSection $target [list "peer-hook" $peer]
|
|
}
|
|
} elseif { $type == "ktunnel" } {
|
|
#
|
|
# apply ktunnel items
|
|
#
|
|
set oldlocal [netconfFetchSection $target "local-hook"]
|
|
set local [$wi.linfo.local get]
|
|
if { $oldlocal != $local } {
|
|
netconfInsertSection $target [list "local-hook" $local]
|
|
}
|
|
# Boeing changing to interface name for RJ45
|
|
# } elseif { $type == "rj45" } {
|
|
# #
|
|
# # apply rj45 items
|
|
# #
|
|
# set ifcName [string trim [$wi.interface.name get]]
|
|
# puts "$ifcName\n"
|
|
#
|
|
} elseif { $type == "router" && [getNodeModel $target] == "remote" } {
|
|
if { $changed_to_remote == 0 } {
|
|
set i 1
|
|
set remoteIP [string trim [$wi.remoteinfo.ip.text get $i.0 $i.end]]
|
|
if { $remoteIP != [router.remote.getRemoteIP $target] } {
|
|
router.remote.setRemoteIP $target $remoteIP
|
|
set changed 1
|
|
}
|
|
set ifc [string trim [$wi.remoteinfo.ifc.text get $i.0 $i.end]]
|
|
if { $ifc != [router.remote.getCInterface $target] } {
|
|
router.remote.setCInterface $target $ifc
|
|
set changed 1
|
|
}
|
|
set startcmd [string trim [$wi.remotecommands.start.text get $i.0 $i.end]]
|
|
if { $startcmd != [router.remote.getStartCmd $target] } {
|
|
router.remote.setStartCmd $target $startcmd
|
|
set changed 1
|
|
}
|
|
set stopcmd [string trim [$wi.remotecommands.stop.text get $i.0 $i.end]]
|
|
if { $stopcmd != [router.remote.getStopCmd $target] } {
|
|
router.remote.setStopCmd $target $stopcmd
|
|
set changed 1
|
|
}
|
|
}
|
|
}
|
|
|
|
if {[[typemodel $target].layer] == "NETWORK"} {
|
|
foreach ifc [ifcList $target] {
|
|
set fr $wi.ifaces.c.if$ifc
|
|
set macaddr [$fr.cfg.mac.addrv get]
|
|
global if${ifc}_auto_mac
|
|
if { [set if${ifc}_auto_mac] == 1 } { set macaddr "" }
|
|
set oldmacaddr [getIfcMacaddr $target $ifc]
|
|
if { $macaddr != $oldmacaddr } {
|
|
setIfcMacaddr $target $ifc $macaddr
|
|
set changed 1
|
|
}
|
|
set ipaddr [$fr.cfg.ipv4.addrv get]
|
|
set oldipaddr [getIfcIPv4addr $target $ifc]
|
|
if { $ipaddr != $oldipaddr } {
|
|
setIfcIPv4addr $target $ifc $ipaddr
|
|
set changed 1
|
|
}
|
|
set ipaddr [$fr.cfg.ipv6.addrv get]
|
|
set oldipaddr [getIfcIPv6addr $target $ifc]
|
|
if { $ipaddr != $oldipaddr } {
|
|
setIfcIPv6addr $target $ifc $ipaddr
|
|
set changed 1
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
link {
|
|
global g_link_config_uni_state
|
|
set mirror [getLinkMirror $target]
|
|
|
|
if { [setIfChanged $target $mirror $wi "bandwidth" "LinkBandwidth"] } {
|
|
set changed 1
|
|
}
|
|
if { [setIfChanged $target $mirror $wi "delay" "LinkDelay"] } {
|
|
set changed 1
|
|
}
|
|
if { [setIfChanged $target $mirror $wi "ber" "LinkBER"] } {
|
|
set changed 1
|
|
}
|
|
if { [setIfChanged $target $mirror $wi "dup" "LinkDup"] } {
|
|
set changed 1
|
|
}
|
|
if { [setIfChanged $target $mirror $wi "jitter" "LinkJitter"] } {
|
|
set changed 1
|
|
}
|
|
|
|
if { $link_color != [getLinkColor $target] } {
|
|
setLinkColor $target $link_color
|
|
if { $mirror != "" } {
|
|
setLinkColor $mirror $link_color
|
|
}
|
|
set changed 1
|
|
}
|
|
set width [$wi.width.value get]
|
|
if { $width != [getLinkWidth $target] } {
|
|
setLinkWidth $target $width
|
|
if { $mirror != "" } {
|
|
setLinkWidth $mirror $width
|
|
}
|
|
set changed 1
|
|
}
|
|
if { $changed == 1 && $oper_mode == "exec" } {
|
|
execSetLinkParams $eid $target
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
popdownConfig $wi
|
|
}
|
|
|
|
# helper for Link Config dialog
|
|
# ctl must exist as $wi.$ctl.value{2}, and {get,set}$procname must be valid
|
|
# returns true when value has changed, false otherwise
|
|
proc setIfChanged { target mirror wi ctl procname } {
|
|
global g_link_config_uni_state
|
|
|
|
set val [$wi.$ctl.value get]
|
|
if { $g_link_config_uni_state == "uni" } {
|
|
set val [list $val [$wi.$ctl.value2 get]]
|
|
}
|
|
set oldval [get$procname $target]
|
|
set oldval2 [get$procname $target "up"]
|
|
if { $oldval2 != "" } {
|
|
set oldval [list $oldval $oldval2]
|
|
}
|
|
if { $val != $oldval } {
|
|
set$procname $target $val
|
|
if { $mirror != "" } {
|
|
set$procname $mirror $val
|
|
}
|
|
return true
|
|
}
|
|
return false
|
|
}
|
|
|
|
#****f* editor.tcl/printCanvas
|
|
# NAME
|
|
# printCanvas -- print canvas
|
|
# SYNOPSIS
|
|
# printCanvas $w
|
|
# FUNCTION
|
|
# This procedure is called when the print button in
|
|
# print dialog box is pressed.
|
|
# INPUTS
|
|
# * w -- print dialog widget
|
|
#****
|
|
proc printCanvas { w } {
|
|
global sizex sizey
|
|
|
|
set prncmd [$w.e1 get]
|
|
destroy $w
|
|
set p [open "|$prncmd" WRONLY]
|
|
puts $p [.c postscript -height $sizey -width $sizex -x 0 -y 0 -rotate yes -pageheight 297m -pagewidth 210m]
|
|
close $p
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/deleteSelection
|
|
# NAME
|
|
# deleteSelection -- delete selection
|
|
# SYNOPSIS
|
|
# deleteSelection
|
|
# FUNCTION
|
|
# By calling this procedure all the selected nodes in imunes will
|
|
# be deleted.
|
|
#****
|
|
proc deleteSelection { } {
|
|
global changed
|
|
global background
|
|
global viewid
|
|
catch {unset viewid}
|
|
.c config -cursor watch; update
|
|
|
|
foreach lnode [selectedNodes] {
|
|
if { $lnode != "" } {
|
|
removeGUINode $lnode
|
|
}
|
|
set changed 1
|
|
}
|
|
|
|
raiseAll .c
|
|
updateUndoLog
|
|
.c config -cursor left_ptr
|
|
.bottom.textbox config -text ""
|
|
}
|
|
|
|
|
|
proc assignSelection { server } {
|
|
global changed
|
|
.c config -cursor watch; update
|
|
|
|
foreach node [selectedNodes] {
|
|
if { $node != "" } {
|
|
setNodeLocation $node $server
|
|
}
|
|
set changed 1
|
|
}
|
|
|
|
redrawAll
|
|
updateUndoLog
|
|
.c config -cursor left_ptr
|
|
.bottom.textbox config -text ""
|
|
}
|
|
|
|
|
|
proc align2grid {} {
|
|
global sizex sizey grid zoom changed
|
|
|
|
set node_objects [.c find withtag node]
|
|
if { [llength $node_objects] == 0 } {
|
|
return
|
|
}
|
|
|
|
set step [expr {$grid * 4}]
|
|
|
|
for { set x $step } { $x <= [expr {$sizex - $step}] } { incr x $step } {
|
|
for { set y $step } { $y <= [expr {$sizey - $step}] } { incr y $step } {
|
|
if { [llength $node_objects] == 0 } {
|
|
set changed 1
|
|
updateUndoLog
|
|
redrawAll
|
|
return
|
|
}
|
|
set node [lindex [.c gettags [lindex $node_objects 0]] 1]
|
|
set node_objects [lreplace $node_objects 0 0]
|
|
setNodeCoords $node "$x $y"
|
|
lassign [getDefaultLabelOffsets [nodeType $node]] dx dy
|
|
setNodeLabelCoords $node "[expr {$x + $dx}] [expr {$y + $dy}]"
|
|
}
|
|
}
|
|
}
|
|
|
|
#****f* editor.tcl/rearrange
|
|
# NAME
|
|
# rearrange
|
|
# SYNOPSIS
|
|
# rearrange $mode
|
|
# FUNCTION
|
|
# This procedure rearranges the position of nodes in imunes.
|
|
# It can be used to rearrange all the nodes or only the selected
|
|
# nodes.
|
|
# INPUTS
|
|
# * mode -- when set to "selected" only the selected nodes will be
|
|
# rearranged.
|
|
#****
|
|
proc rearrange { mode } {
|
|
global link_list autorearrange_enabled sizex sizey curcanvas zoom activetool
|
|
|
|
set activetool select
|
|
|
|
if { $autorearrange_enabled } {
|
|
rearrange_off
|
|
return
|
|
}
|
|
set autorearrange_enabled 1
|
|
.bottom.mbuf config -text "autorearrange"
|
|
if { $mode == "selected" } {
|
|
.menubar.tools entryconfigure "Auto rearrange all" -state disabled
|
|
.menubar.tools entryconfigure "Auto rearrange all" -indicatoron off
|
|
.menubar.tools entryconfigure "Auto rearrange selected" -indicatoron on
|
|
set tagmatch "node && selected"
|
|
} else {
|
|
.menubar.tools entryconfigure "Auto rearrange all" -indicatoron on
|
|
.menubar.tools entryconfigure "Auto rearrange selected" -state disabled
|
|
.menubar.tools entryconfigure "Auto rearrange selected" -indicatoron off
|
|
set tagmatch "node"
|
|
}
|
|
set otime [clock clicks -milliseconds]
|
|
while { $autorearrange_enabled } {
|
|
set ntime [clock clicks -milliseconds]
|
|
if { $otime == $ntime } {
|
|
set dt 0.001
|
|
} else {
|
|
set dt [expr {($ntime - $otime) * 0.001}]
|
|
if { $dt > 0.2 } {
|
|
set dt 0.2
|
|
}
|
|
set otime $ntime
|
|
}
|
|
|
|
set objects [.c find withtag $tagmatch]
|
|
set peer_objects [.c find withtag node]
|
|
foreach obj $peer_objects {
|
|
set node [lindex [.c gettags $obj] 1]
|
|
set coords [.c coords $obj]
|
|
set x [expr {[lindex $coords 0] / $zoom}]
|
|
set y [expr {[lindex $coords 1] / $zoom}]
|
|
set x_t($node) $x
|
|
set y_t($node) $y
|
|
|
|
if { $x > 0 } {
|
|
set fx [expr {1000 / ($x * $x + 100)}]
|
|
} else {
|
|
set fx 10
|
|
}
|
|
set dx [expr {$sizex - $x}]
|
|
if { $dx > 0 } {
|
|
set fx [expr {$fx - 1000 / ($dx * $dx + 100)}]
|
|
} else {
|
|
set fx [expr {$fx - 10}]
|
|
}
|
|
|
|
if { $y > 0 } {
|
|
set fy [expr {1000 / ($y * $y + 100)}]
|
|
} else {
|
|
set fy 10
|
|
}
|
|
set dy [expr {$sizey - $y}]
|
|
if { $dy > 0 } {
|
|
set fy [expr {$fy - 1000 / ($dy * $dy + 100)}]
|
|
} else {
|
|
set fy [expr {$fy - 10}]
|
|
}
|
|
set fx_t($node) $fx
|
|
set fy_t($node) $fy
|
|
}
|
|
|
|
foreach obj $objects {
|
|
set node [lindex [.c gettags $obj] 1]
|
|
set i [lsearch -exact $peer_objects $obj]
|
|
set peer_objects [lreplace $peer_objects $i $i]
|
|
set x $x_t($node)
|
|
set y $y_t($node)
|
|
foreach other_obj $peer_objects {
|
|
set other [lindex [.c gettags $other_obj] 1]
|
|
set o_x $x_t($other)
|
|
set o_y $y_t($other)
|
|
set dx [expr {$x - $o_x}]
|
|
set dy [expr {$y - $o_y}]
|
|
set d [expr {hypot($dx, $dy)}]
|
|
set d2 [expr {$d * $d}]
|
|
set p_fx [expr {1000.0 * $dx / ($d2 * $d + 100)}]
|
|
set p_fy [expr {1000.0 * $dy / ($d2 * $d + 100)}]
|
|
if {[linkByPeers $node $other] != ""} {
|
|
set p_fx [expr {$p_fx - $dx * $d2 * .0000000005}]
|
|
set p_fy [expr {$p_fy - $dy * $d2 * .0000000005}]
|
|
}
|
|
set fx_t($node) [expr {$fx_t($node) + $p_fx}]
|
|
set fy_t($node) [expr {$fy_t($node) + $p_fy}]
|
|
set fx_t($other) [expr {$fx_t($other) - $p_fx}]
|
|
set fy_t($other) [expr {$fy_t($other) - $p_fy}]
|
|
}
|
|
|
|
foreach link $link_list {
|
|
set nodes [linkPeers $link]
|
|
if { [getNodeCanvas [lindex $nodes 0]] != $curcanvas ||
|
|
[getNodeCanvas [lindex $nodes 1]] != $curcanvas ||
|
|
[getLinkMirror $link] != "" } {
|
|
continue
|
|
}
|
|
set peers [linkPeers $link]
|
|
set coords0 [getNodeCoords [lindex $peers 0]]
|
|
set coords1 [getNodeCoords [lindex $peers 1]]
|
|
set o_x \
|
|
[expr {([lindex $coords0 0] + [lindex $coords1 0]) * .5}]
|
|
set o_y \
|
|
[expr {([lindex $coords0 1] + [lindex $coords1 1]) * .5}]
|
|
set dx [expr {$x - $o_x}]
|
|
set dy [expr {$y - $o_y}]
|
|
set d [expr {hypot($dx, $dy)}]
|
|
set d2 [expr {$d * $d}]
|
|
set fx_t($node) \
|
|
[expr {$fx_t($node) + 500.0 * $dx / ($d2 * $d + 100)}]
|
|
set fy_t($node) \
|
|
[expr {$fy_t($node) + 500.0 * $dy / ($d2 * $d + 100)}]
|
|
}
|
|
}
|
|
|
|
foreach obj $objects {
|
|
set node [lindex [.c gettags $obj] 1]
|
|
if { [catch "set v_t($node)" v] } {
|
|
set vx 0.0
|
|
set vy 0.0
|
|
} else {
|
|
set vx [lindex $v_t($node) 0]
|
|
set vy [lindex $v_t($node) 1]
|
|
}
|
|
set vx [expr {$vx + 1000.0 * $fx_t($node) * $dt}]
|
|
set vy [expr {$vy + 1000.0 * $fy_t($node) * $dt}]
|
|
set dampk [expr {0.5 + ($vx * $vx + $vy * $vy) * 0.00001}]
|
|
set vx [expr {$vx * exp( - $dampk * $dt)}]
|
|
set vy [expr {$vy * exp( - $dampk * $dt)}]
|
|
set dx [expr {$vx * $dt}]
|
|
set dy [expr {$vy * $dt}]
|
|
set x [expr {$x_t($node) + $dx}]
|
|
set y [expr {$y_t($node) + $dy}]
|
|
set v_t($node) "$vx $vy"
|
|
|
|
setNodeCoords $node "$x $y"
|
|
set e_dx [expr {$dx * $zoom}]
|
|
set e_dy [expr {$dy * $zoom}]
|
|
.c move $obj $e_dx $e_dy
|
|
set img [.c find withtag "selectmark && $node"]
|
|
.c move $img $e_dx $e_dy
|
|
set img [.c find withtag "nodelabel && $node"]
|
|
.c move $img $e_dx $e_dy
|
|
set x [expr {[lindex [.c coords $img] 0] / $zoom}]
|
|
set y [expr {[lindex [.c coords $img] 1] / $zoom}]
|
|
setNodeLabelCoords $node "$x $y"
|
|
.c addtag need_redraw withtag "link && $node"
|
|
}
|
|
foreach link [.c find withtag "link && need_redraw"] {
|
|
redrawLink [lindex [.c gettags $link] 1]
|
|
}
|
|
.c dtag link need_redraw
|
|
update
|
|
}
|
|
|
|
rearrange_off
|
|
.bottom.mbuf config -text ""
|
|
}
|
|
|
|
proc rearrange_off { } {
|
|
global autorearrange_enabled
|
|
set autorearrange_enabled 0
|
|
.menubar.tools entryconfigure "Auto rearrange all" -state normal
|
|
.menubar.tools entryconfigure "Auto rearrange all" -indicatoron off
|
|
.menubar.tools entryconfigure "Auto rearrange selected" -state normal
|
|
.menubar.tools entryconfigure "Auto rearrange selected" -indicatoron off
|
|
}
|
|
|
|
|
|
#****f* editor.tcl/switchCanvas
|
|
# NAME
|
|
# switchCanvas -- switch canvas
|
|
# SYNOPSIS
|
|
# switchCanvas $direction
|
|
# FUNCTION
|
|
# This procedure switches the canvas in one of the defined
|
|
# directions (previous, next, first and last).
|
|
# INPUTS
|
|
# * direction -- the direction of switching canvas. Can be: prev --
|
|
# previus, next -- next, first -- first, last -- last.
|
|
#****
|
|
proc switchCanvas { direction } {
|
|
global canvas_list curcanvas
|
|
global sizex sizey
|
|
|
|
set i [lsearch $canvas_list $curcanvas]
|
|
switch -exact -- $direction {
|
|
prev {
|
|
incr i -1
|
|
if { $i < 0 } {
|
|
set curcanvas [lindex $canvas_list end]
|
|
} else {
|
|
set curcanvas [lindex $canvas_list $i]
|
|
}
|
|
}
|
|
next {
|
|
incr i
|
|
if { $i >= [llength $canvas_list] } {
|
|
set curcanvas [lindex $canvas_list 0]
|
|
} else {
|
|
set curcanvas [lindex $canvas_list $i]
|
|
}
|
|
}
|
|
first {
|
|
set curcanvas [lindex $canvas_list 0]
|
|
}
|
|
last {
|
|
set curcanvas [lindex $canvas_list end]
|
|
}
|
|
}
|
|
|
|
.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}]
|
|
}
|
|
incr x 7
|
|
.hframe.t raise "$curcanvas"
|
|
.hframe.t itemconfigure "tab && $curcanvas" -fill #e0e0e0
|
|
.hframe.t configure -scrollregion "0 0 $x 18"
|
|
update
|
|
set width [lindex [.hframe.t configure -width] 4]
|
|
set lborder [lindex [.hframe.t bbox "tab && $curcanvas"] 0]
|
|
set rborder [lindex [.hframe.t bbox "tab && $curcanvas"] 2]
|
|
set lmargin [expr {[lindex [.hframe.t xview] 0] * $x - 1}]
|
|
set rmargin [expr {[lindex [.hframe.t xview] 1] * $x + 1}]
|
|
if { $lborder < $lmargin } {
|
|
.hframe.t xview moveto [expr {1.0 * ($lborder - 10) / $x}]
|
|
}
|
|
if { $rborder > $rmargin } {
|
|
.hframe.t xview moveto [expr {1.0 * ($rborder - $width + 10) / $x}]
|
|
}
|
|
|
|
set sizex [lindex [getCanvasSize $curcanvas] 0]
|
|
set sizey [lindex [getCanvasSize $curcanvas] 1]
|
|
|
|
redrawAll
|
|
}
|
|
|
|
proc resizeCanvasPopup {} {
|
|
global curcanvas
|
|
|
|
set w .canvasSizeScaleDialog
|
|
catch {destroy $w}
|
|
toplevel $w
|
|
|
|
wm transient $w .
|
|
wm title $w "Canvas Size and Scale"
|
|
|
|
frame $w.buttons
|
|
pack $w.buttons -side bottom -fill x -pady 2m
|
|
button $w.buttons.print -text "Apply" -command "resizeCanvasApply $w"
|
|
button $w.buttons.cancel -text "Cancel" -command "destroy $w"
|
|
pack $w.buttons.print $w.buttons.cancel -side left -expand 1
|
|
|
|
set cursize [getCanvasSize $curcanvas]
|
|
set x [lindex $cursize 0]
|
|
set y [lindex $cursize 1]
|
|
set scale [getCanvasScale $curcanvas]
|
|
set refpt [getCanvasRefPoint $curcanvas]
|
|
set refx [lindex $refpt 0]
|
|
set refy [lindex $refpt 1]
|
|
set latitude [lindex $refpt 2]
|
|
set longitude [lindex $refpt 3]
|
|
set altitude [lindex $refpt 4]
|
|
|
|
|
|
labelframe $w.size -text "Size"
|
|
frame $w.size.pixels
|
|
pack $w.size $w.size.pixels -side top -padx 4 -pady 4 -fill x
|
|
spinbox $w.size.pixels.x -bg white -width 5
|
|
$w.size.pixels.x insert 0 $x
|
|
$w.size.pixels.x configure -from 300 -to 5000 -increment 2
|
|
label $w.size.pixels.label -text "W x"
|
|
spinbox $w.size.pixels.y -bg white -width 5
|
|
$w.size.pixels.y insert 0 $y
|
|
$w.size.pixels.y configure -from 300 -to 5000 -increment 2
|
|
label $w.size.pixels.label2 -text "H pixels"
|
|
pack $w.size.pixels.x $w.size.pixels.label $w.size.pixels.y \
|
|
$w.size.pixels.label2 -side left -pady 2 -padx 2 -fill x
|
|
|
|
frame $w.size.meters
|
|
pack $w.size.meters -side top -padx 4 -pady 4 -fill x
|
|
spinbox $w.size.meters.x -bg white -width 7
|
|
$w.size.meters.x configure -from 300 -to 10000 -increment 100
|
|
label $w.size.meters.label -text "x"
|
|
spinbox $w.size.meters.y -bg white -width 7
|
|
$w.size.meters.y configure -from 300 -to 10000 -increment 100
|
|
label $w.size.meters.label2 -text "meters"
|
|
pack $w.size.meters.x $w.size.meters.label $w.size.meters.y \
|
|
$w.size.meters.label2 -side left -pady 2 -padx 2 -fill x
|
|
|
|
labelframe $w.scale -text "Scale"
|
|
frame $w.scale.ppm
|
|
pack $w.scale $w.scale.ppm -side top -padx 4 -pady 4 -fill x
|
|
label $w.scale.ppm.label -text "100 pixels ="
|
|
entry $w.scale.ppm.metersper100 -bg white -width 10
|
|
$w.scale.ppm.metersper100 insert 0 $scale
|
|
label $w.scale.ppm.label2 -text "meters"
|
|
pack $w.scale.ppm.label $w.scale.ppm.metersper100 \
|
|
$w.scale.ppm.label2 -side left -pady 2 -padx 2 -fill x
|
|
|
|
bind $w.size.pixels.x <Button> "syncSizeScale $w xp"
|
|
bind $w.size.pixels.y <Button> "syncSizeScale $w yp"
|
|
bind $w.size.pixels.x <FocusOut> "syncSizeScale $w xp"
|
|
bind $w.size.pixels.y <FocusOut> "syncSizeScale $w yp"
|
|
bind $w.size.meters.x <FocusOut> "syncSizeScale $w xm"
|
|
bind $w.size.meters.y <FocusOut> "syncSizeScale $w ym"
|
|
bind $w.size.meters.x <Button> "syncSizeScale $w xm"
|
|
bind $w.size.meters.y <Button> "syncSizeScale $w ym"
|
|
bind $w.scale.ppm.metersper100 <FocusOut> "syncSizeScale $w scale"
|
|
#bind $w.scale.ppm.metersper100 <KeyPress> "syncSizeScale $w"
|
|
|
|
labelframe $w.ref -text "Reference point"
|
|
frame $w.ref.pt
|
|
pack $w.ref $w.ref.pt -side top -padx 4 -pady 4 -fill x
|
|
set hlp "The default reference point is (0,0), the upper-left corner of"
|
|
set hlp "$hlp the canvas."
|
|
label $w.ref.pt.help -text $hlp
|
|
entry $w.ref.pt.x -bg white -width 4
|
|
label $w.ref.pt.label -text "X,"
|
|
entry $w.ref.pt.y -bg white -width 4
|
|
label $w.ref.pt.label2 -text "Y ="
|
|
entry $w.ref.pt.lat -bg white -width 12
|
|
label $w.ref.pt.label3 -text "lat,"
|
|
entry $w.ref.pt.long -bg white -width 12
|
|
label $w.ref.pt.label4 -text "long"
|
|
$w.ref.pt.x insert 0 $refx
|
|
$w.ref.pt.y insert 0 $refy
|
|
$w.ref.pt.lat insert 0 $latitude
|
|
$w.ref.pt.long insert 0 $longitude
|
|
pack $w.ref.pt.help -side top -anchor w
|
|
pack $w.ref.pt.x $w.ref.pt.label $w.ref.pt.y $w.ref.pt.label2 \
|
|
$w.ref.pt.lat $w.ref.pt.label3 $w.ref.pt.long $w.ref.pt.label4 \
|
|
-side left -pady 2 -padx 2 -fill x
|
|
|
|
frame $w.ref.alt
|
|
pack $w.ref.alt -side top -padx 6 -pady 6 -fill x
|
|
label $w.ref.alt.label -text "Altitude:"
|
|
entry $w.ref.alt.altitude -bg white -width 10
|
|
label $w.ref.alt.label2 -text "meters"
|
|
$w.ref.alt.altitude insert 0 $altitude
|
|
pack $w.ref.alt.label $w.ref.alt.altitude $w.ref.alt.label2 -side left \
|
|
-pady 2 -padx 2 -fill x
|
|
|
|
|
|
global resize_canvas_save_default
|
|
set resize_canvas_save_default 0
|
|
frame $w.default
|
|
checkbutton $w.default.save -text "Save as default" \
|
|
-variable resize_canvas_save_default
|
|
pack $w.default.save -side left -pady 2 -padx 2 -fill x
|
|
pack $w.default -side bottom -fill x
|
|
|
|
# update the size in meters based on pixels
|
|
syncSizeScale $w xp
|
|
}
|
|
|
|
# called when scale or size values change
|
|
proc syncSizeScale { w type } {
|
|
set xp [$w.size.pixels.x get]
|
|
set yp [$w.size.pixels.y get]
|
|
set xm [$w.size.meters.x get]
|
|
set ym [$w.size.meters.y get]
|
|
set scale [$w.scale.ppm.metersper100 get]
|
|
set newxp $xp
|
|
set newyp $yp
|
|
set newxm $xm
|
|
set newym $ym
|
|
|
|
# prevent some math errors
|
|
if { ![string is double $scale] } { puts "invalid scale=$scale"; return }
|
|
if { $scale == 0 } { puts "zero scale"; return }
|
|
|
|
switch -exact -- $type {
|
|
scale -
|
|
xp -
|
|
yp {
|
|
# changing the scale or size in pixels updates the size in meters
|
|
set newxm [expr { $xp * $scale / 100.0 }]
|
|
set newym [expr { $yp * $scale / 100.0 }]
|
|
}
|
|
xm -
|
|
ym {
|
|
# changing the size in meters updates the size in pixels
|
|
set newxp [expr { round(100.0 * $xm / $scale) } ]
|
|
set newyp [expr { round(100.0 * $ym / $scale) } ]
|
|
}
|
|
}
|
|
if {$xm != $newxm} {
|
|
$w.size.meters.x delete 0 end
|
|
$w.size.meters.x insert 0 $newxm
|
|
}
|
|
if {$ym != $newym} {
|
|
$w.size.meters.y delete 0 end
|
|
$w.size.meters.y insert 0 $newym
|
|
}
|
|
if {$xp != $newxp} {
|
|
$w.size.pixels.x delete 0 end
|
|
$w.size.pixels.x insert 0 $newxp
|
|
}
|
|
if {$yp != $newyp} {
|
|
$w.size.pixels.y delete 0 end
|
|
$w.size.pixels.y insert 0 $newyp
|
|
}
|
|
}
|
|
|
|
proc resizeCanvasApply { w } {
|
|
global curcanvas changed
|
|
global g_prefs resize_canvas_save_default
|
|
|
|
set x [$w.size.pixels.x get]
|
|
set y [$w.size.pixels.y get]
|
|
set scale [$w.scale.ppm.metersper100 get]
|
|
# refpt x,y
|
|
# refpt lat, long, alt
|
|
set refx [$w.ref.pt.x get]
|
|
set refy [$w.ref.pt.y get]
|
|
set latitude [$w.ref.pt.lat get]
|
|
set longitude [$w.ref.pt.long get]
|
|
set altitude [$w.ref.alt.altitude get]
|
|
set refpt [list $refx $refy $latitude $longitude $altitude]
|
|
|
|
if { $resize_canvas_save_default } {
|
|
array set g_prefs "gui_canvas_x $x gui_canvas_y $y"
|
|
array set g_prefs "gui_canvas_scale $scale"
|
|
array set g_prefs [list "gui_canvas_refpt" $refpt]
|
|
}
|
|
destroy $w
|
|
if { "$x $y" != [getCanvasSize $curcanvas] || \
|
|
$scale != [getCanvasScale $curcanvas] || \
|
|
$refpt != [getCanvasRefPoint $curcanvas] } {
|
|
set changed 1
|
|
}
|
|
setCanvasSize $curcanvas $x $y
|
|
setCanvasScale $curcanvas $scale
|
|
setCanvasRefPoint $curcanvas $refpt
|
|
switchCanvas none
|
|
updateUndoLog
|
|
}
|
|
|
|
#****f* editor.tcl/animate
|
|
# NAME
|
|
# animate
|
|
# SYNOPSIS
|
|
# animate
|
|
# FUNCTION
|
|
# This function animates the selectbox. The animation looks
|
|
# different for edit and exec mode.
|
|
#****
|
|
proc animate {} {
|
|
global animatephase oper_mode
|
|
.c raise -cursor
|
|
if { [catch { if { ![winfo exists .c] } { return } }] } {
|
|
return ;# user has exited using the window manager
|
|
}
|
|
.c itemconfigure "selectmark || selectbox" -dashoffset $animatephase
|
|
incr animatephase 2
|
|
if { $animatephase == 100 } {
|
|
set animatephase 0
|
|
}
|
|
|
|
if { $oper_mode == "edit" } {
|
|
after 250 animate
|
|
} else {
|
|
after 1500 animate
|
|
}
|
|
}
|
|
|
|
|
|
proc zoom { dir } {
|
|
global zoom
|
|
|
|
set stops ".25 .5 .75 1.0 1.5 2.0 4.0"
|
|
# set i [lsearch $stops $zoom]
|
|
set minzoom [lindex $stops 0]
|
|
set maxzoom [lindex $stops [expr [llength $stops] - 1]]
|
|
switch -exact -- $dir {
|
|
"down" {
|
|
if {$zoom > $maxzoom} {
|
|
set zoom $maxzoom
|
|
} elseif {$zoom < $minzoom} {
|
|
; # leave it unchanged
|
|
} else {
|
|
set newzoom $minzoom
|
|
foreach z $stops {
|
|
if {$zoom <= $z} {
|
|
break
|
|
} else {
|
|
set newzoom $z
|
|
}
|
|
}
|
|
set zoom $newzoom
|
|
}
|
|
redrawAll
|
|
}
|
|
"up" {
|
|
if {$zoom < $minzoom} {
|
|
set zoom $minzoom
|
|
} elseif {$zoom > $maxzoom} {
|
|
; # leave it unchanged
|
|
} else {
|
|
foreach z [lrange $stops 1 end] {
|
|
set newzoom $z
|
|
if {$zoom < $z} {
|
|
break
|
|
}
|
|
}
|
|
set zoom $newzoom
|
|
}
|
|
redrawAll
|
|
}
|
|
default {
|
|
if { $i < [expr [llength $stops] - 1] } {
|
|
set zoom [lindex $stops [expr $i + 1]]
|
|
redrawAll
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
#****h* editor.tcl/double1onGrid
|
|
# NAME
|
|
# double1onGrid.tcl -- called on Double-1 click on grid (bind command)
|
|
# SYNOPSIS
|
|
# double1onGrid $c %x %y
|
|
# FUNCTION
|
|
# As grid is layered above annotations this procedure is used to find
|
|
# annotation object closest to cursor
|
|
#****
|
|
|
|
proc double1onGrid { c x y } {
|
|
set obj [$c find closest $x $y]
|
|
set tags [$c gettags $obj]
|
|
set node [lindex $tags 1]
|
|
if {[lsearch $tags grid] != -1 || [lsearch $tags background] != -1} {
|
|
return
|
|
}
|
|
# Is this really necessary?
|
|
set coords [getNodeCoords $node]
|
|
set x1 [lindex $coords 0]
|
|
set y1 [lindex $coords 1]
|
|
set x2 [lindex $coords 2]
|
|
set y2 [lindex $coords 3]
|
|
if {$x < $x1 || $x > $x2 || $y < $y1 || $y > $y2} {
|
|
# cursor is not ON the closest object
|
|
return
|
|
} else {
|
|
annotationConfig $c $node
|
|
}
|
|
}
|
|
|
|
|
|
proc setZoomApply { w } {
|
|
global zoom changed
|
|
|
|
set newzoom [expr [$w.e1 get] / 100.0]
|
|
if { $newzoom != $zoom } {
|
|
set zoom $newzoom
|
|
redrawAll
|
|
}
|
|
destroy $w
|
|
}
|
|
|
|
proc selectZoom { x y } {
|
|
global curcanvas
|
|
global zoom
|
|
|
|
set stops ".25 .5 .75 1.0 1.5 2.0 4.0"
|
|
|
|
set w .entry1
|
|
catch {destroy $w}
|
|
toplevel $w -takefocus 1
|
|
|
|
if { $x == 0 && $y == 0 } {
|
|
set screen [wm maxsize .]
|
|
set x [expr {[lindex $screen 0] / 2}]
|
|
set y [expr {[lindex $screen 1] / 2}]
|
|
} else {
|
|
set x [expr {$x + 10}]
|
|
set y [expr {$y - 90}]
|
|
}
|
|
wm geometry $w +$x+$y
|
|
wm title $w "Select zoom %"
|
|
wm iconname $w "Select zoom %"
|
|
|
|
frame $w.buttons
|
|
pack $w.buttons -side bottom -fill x -pady 2m
|
|
button $w.buttons.print -text "Apply" -command "setZoomApply $w"
|
|
button $w.buttons.cancel -text "Cancel" -command "destroy $w"
|
|
pack $w.buttons.print $w.buttons.cancel -side left -expand 1
|
|
|
|
bind $w <Key-Escape> "destroy $w"
|
|
bind $w <Key-Return> "setZoomApply $w"
|
|
|
|
entry $w.e1 -bg white
|
|
$w.e1 insert 0 [expr {int($zoom * 100)}]
|
|
pack $w.e1 -side top -pady 5 -padx 10 -fill x
|
|
|
|
update
|
|
focus $w.e1
|
|
grab $w
|
|
}
|
|
|
|
|
|
# configure remote servers
|
|
# popup a dialog box for editing the remote server list
|
|
# results are stored in servers.conf file
|
|
proc configRemoteServers {} {
|
|
global exec_servers last_server_selected
|
|
global plugin_img_add plugin_img_save plugin_img_del
|
|
global DEFAULT_API_PORT
|
|
|
|
set wi .remoteConfig
|
|
catch {destroy $wi}
|
|
toplevel $wi
|
|
|
|
wm transient $wi .
|
|
wm resizable $wi 0 0
|
|
wm title $wi "CORE emulation servers"
|
|
|
|
set last_server_selected -1
|
|
|
|
# list of servers
|
|
frame $wi.s -borderwidth 4
|
|
listbox $wi.s.servers -selectmode single -width 60 \
|
|
-yscrollcommand "$wi.s.servers_scroll set" -exportselection 0
|
|
scrollbar $wi.s.servers_scroll -command "$wi.s.servers yview"
|
|
pack $wi.s.servers $wi.s.servers_scroll -fill both -side left
|
|
pack $wi.s -fill both -side top
|
|
# add scrollbar
|
|
|
|
bind $wi.s.servers <<ListboxSelect>> "selectRemoteServer $wi"
|
|
|
|
# populate the list
|
|
foreach server [lsort -dictionary [array names exec_servers]] {
|
|
$wi.s.servers insert end $server
|
|
}
|
|
|
|
# controls for editing entries
|
|
labelframe $wi.c -text "Server configuration"
|
|
frame $wi.c.c -borderwidth 4
|
|
label $wi.c.c.namelab -text "Name"
|
|
entry $wi.c.c.name -bg white -width 15
|
|
bind $wi.c.c.name <KeyPress> "$wi.c.c.add configure -state normal"
|
|
label $wi.c.c.iplab -text "IP"
|
|
entry $wi.c.c.ip -bg white -width 10
|
|
label $wi.c.c.portlab -text "port"
|
|
entry $wi.c.c.port -bg white -width 5
|
|
pack $wi.c.c.namelab $wi.c.c.name $wi.c.c.iplab $wi.c.c.ip -side left
|
|
pack $wi.c.c.portlab $wi.c.c.port -side left
|
|
pack $wi.c.c -fill x -side top
|
|
$wi.c.c.port insert 0 $DEFAULT_API_PORT
|
|
|
|
button $wi.c.c.add -image $plugin_img_add \
|
|
-command "configRemoteServersHelper $wi 1"
|
|
button $wi.c.c.mod -image $plugin_img_save \
|
|
-command "configRemoteServersHelper $wi 2"
|
|
button $wi.c.c.del -image $plugin_img_del \
|
|
-command "configRemoteServersHelper $wi 3"
|
|
pack $wi.c.c.add $wi.c.c.mod $wi.c.c.del -side left
|
|
pack $wi.c -fill x -side top
|
|
# assignment buttons
|
|
labelframe $wi.a -borderwidth 4 -text "Assign selected server to:"
|
|
button $wi.a.applyall -text "all nodes" -command {
|
|
global node_list last_server_selected
|
|
set wi .remoteConfig
|
|
if { $last_server_selected < 0 } { return }
|
|
set server [$wi.s.servers get $last_server_selected]
|
|
foreach node $node_list { setNodeLocation $node $server }
|
|
$wi.b.cancel configure -text "Close"
|
|
highlightAssignedServers $wi
|
|
redrawAll
|
|
}
|
|
button $wi.a.applysel -text "selected nodes" -command {
|
|
global last_server_selected
|
|
set wi .remoteConfig
|
|
if { $last_server_selected < 0 } { return }
|
|
set server [$wi.s.servers get $last_server_selected]
|
|
set items [.c find withtag "node && selected"]
|
|
foreach item $items {
|
|
set node [lindex [.c gettags $item] 1]
|
|
setNodeLocation $node $server
|
|
}
|
|
$wi.b.cancel configure -text "Close"
|
|
highlightAssignedServers $wi
|
|
redrawAll
|
|
}
|
|
label $wi.a.lab -text "Assigned servers are shown in blue."
|
|
pack $wi.a.applyall $wi.a.applysel $wi.a.lab -side left
|
|
pack $wi.a -fill x -side top
|
|
highlightAssignedServers $wi
|
|
|
|
# apply/cancel buttons
|
|
frame $wi.b -borderwidth 4
|
|
button $wi.b.apply -text "Apply" -command \
|
|
"writeServersConf; redrawAll; destroy $wi"
|
|
button $wi.b.cancel -text "Cancel" -command "loadServersConf; destroy $wi"
|
|
pack $wi.b.cancel $wi.b.apply -side right
|
|
pack $wi.b -side bottom
|
|
focus $wi.b.apply
|
|
|
|
after 100 { catch { grab .remoteConfig } }
|
|
}
|
|
|
|
# add/modify/remove server in list
|
|
proc configRemoteServersHelper { wi action } {
|
|
global exec_servers last_server_selected
|
|
set index end
|
|
set sock -1
|
|
|
|
# delete from list, array
|
|
if { $action > 1 } { ;# delete/modify
|
|
if { $last_server_selected < 0 } { return }
|
|
set server [$wi.s.servers get $last_server_selected]
|
|
$wi.s.servers delete $last_server_selected
|
|
set sock [lindex $exec_servers($server) 2]
|
|
array unset exec_servers $server
|
|
if { $action == 3 } {
|
|
$wi.c.c.add configure -state normal
|
|
$wi.s.servers selection set $index
|
|
set last_server_selected $index
|
|
return
|
|
}
|
|
set index $last_server_selected
|
|
}
|
|
|
|
# update the list
|
|
set newserver [$wi.c.c.name get]
|
|
$wi.s.servers insert $index $newserver
|
|
# update the array
|
|
set conf [list [$wi.c.c.ip get] [$wi.c.c.port get]]
|
|
array set exec_servers [list $newserver $conf]
|
|
$wi.s.servers selection set $index
|
|
set last_server_selected $index
|
|
$wi.c.c.add configure -state disabled
|
|
}
|
|
|
|
# connects the servers listbox with entry elements
|
|
proc selectRemoteServer { wi } {
|
|
global exec_servers last_server_selected
|
|
set selected [$wi.s.servers curselection]
|
|
|
|
# clear entries
|
|
$wi.c.c.name delete 0 end; $wi.c.c.ip delete 0 end;
|
|
$wi.c.c.port delete 0 end
|
|
|
|
set server [$wi.s.servers get $selected]
|
|
if { ![info exists exec_servers($server)] } { return }
|
|
$wi.c.c.add configure -state disabled
|
|
set last_server_selected $selected
|
|
|
|
# insert entries from array
|
|
$wi.c.c.name insert 0 $server
|
|
$wi.c.c.ip insert 0 [lindex $exec_servers($server) 0]
|
|
$wi.c.c.port insert 0 [lindex $exec_servers($server) 1]
|
|
}
|
|
|
|
# helper to highlight servers that have been assigned
|
|
proc highlightAssignedServers { wi } {
|
|
set servers [getAssignedRemoteServers]
|
|
set n [$wi.s.servers size]
|
|
for { set i 0 } { $i < $n } { incr i } {
|
|
set s [$wi.s.servers get $i]
|
|
set color blue
|
|
if { [lsearch -exact $servers $s] < 0 } { set color black }
|
|
$wi.s.servers itemconfigure $i -foreground $color
|
|
}
|
|
}
|
|
|
|
# Boeing: custom image dialog box
|
|
proc popupCustomImage { node } {
|
|
global CORE_DATA_DIR
|
|
|
|
set wi .customimagedialog
|
|
catch {destroy $wi}
|
|
toplevel $wi -takefocus 1
|
|
wm transient $wi .popup
|
|
wm resizable $wi 0 0
|
|
wm title $wi "[getNodeName $node] ($node) image"
|
|
grab $wi
|
|
|
|
frame $wi.ftop -borderwidth 4
|
|
label $wi.ftop.filelabel -text "Image file:"
|
|
entry $wi.ftop.filename -bg white -width 32
|
|
set cimg [getCustomImage $node]
|
|
$wi.ftop.filename insert 0 $cimg
|
|
|
|
global configwin
|
|
set configwin $wi
|
|
button $wi.ftop.filebtn -text "..." -command {
|
|
global configwin g_imageFileTypes
|
|
set f [tk_getOpenFile -filetypes $g_imageFileTypes \
|
|
-initialdir "$CORE_DATA_DIR/icons/normal"]
|
|
if { $f != "" } {
|
|
set node [string trim [lindex [wm title $configwin] 1] "()"]
|
|
$configwin.ftop.filename delete 0 end
|
|
$configwin.ftop.filename insert 0 $f
|
|
popupCustomImagePreview $configwin $node
|
|
}
|
|
}
|
|
pack $wi.ftop.filebtn $wi.ftop.filename $wi.ftop.filelabel \
|
|
-side right -padx 4 -pady 4
|
|
pack $wi.ftop -side top
|
|
|
|
frame $wi.fmid -borderwidth 4
|
|
canvas $wi.fmid.c -width 300 -height 100
|
|
pack $wi.fmid.c -side top -padx 4 -pady 4
|
|
pack $wi.fmid -side top
|
|
|
|
|
|
frame $wi.fbot -borderwidth 4
|
|
button $wi.fbot.apply -text "Apply" -command "customImageApply $wi $node"
|
|
set msg "Select nodes to apply custom image to:"
|
|
set cmd "customImageApplyMultiple $wi"
|
|
button $wi.fbot.applym -text "Apply to multiple..." \
|
|
-command "popupSelectNodes \"$msg\" $node {$cmd}"
|
|
button $wi.fbot.cancel -text "Cancel" -command "destroy $wi"
|
|
pack $wi.fbot.cancel $wi.fbot.applym $wi.fbot.apply \
|
|
-side right -padx 4 -pady 4
|
|
pack $wi.fbot -side bottom
|
|
|
|
popupCustomImagePreview $wi $node
|
|
}
|
|
|
|
proc popupCustomImagePreview { wi node } {
|
|
set coords_save [getNodeCoords $node]
|
|
set labelcoords_save [getNodeLabelCoords $node]
|
|
set img_save [getCustomImage $node]
|
|
set img_new [$wi.ftop.filename get]
|
|
|
|
setNodeCoords $node "150 50"
|
|
setNodeLabelCoords $node "150 78"
|
|
if { $img_save != $img_new } { setCustomImage $node $img_new }
|
|
$wi.fmid.c delete all
|
|
drawNode $wi.fmid.c $node
|
|
|
|
setNodeCoords $node $coords_save
|
|
setNodeLabelCoords $node $labelcoords_save
|
|
if { $img_save != $img_new } { setCustomImage $node $img_save }
|
|
}
|
|
|
|
# Boeing: helper for custom image apply button
|
|
proc customImageApply { wi node } {
|
|
global changed
|
|
setCustomImage $node [$wi.ftop.filename get]
|
|
set changed 1
|
|
# update the custom image button in the parent dialog
|
|
set img [getNodeImage $node]
|
|
.popup.ftop.img configure -image $img
|
|
destroy $wi
|
|
}
|
|
|
|
proc customImageApplyMultiple { wi nodes } {
|
|
global changed
|
|
set imgfile [$wi.ftop.filename get]
|
|
|
|
foreach node $nodes {
|
|
setCustomImage $node $imgfile
|
|
set changed 1
|
|
}
|
|
destroy $wi
|
|
}
|
|
|
|
|
|
# Boeing: create several scaled copies of an image for use with each zoomlevel
|
|
proc createScaledImages { img } {
|
|
global $img
|
|
set w [image width [set $img]]
|
|
set h [image height [set $img]]
|
|
# we skip 75% and 150% since resulting images are the same (due to int())
|
|
foreach size {.25 .5 1.0 2.0 4.0} {
|
|
# image will be globally accessible
|
|
global $img$size
|
|
# create empty photo object
|
|
set $img$size [image create photo]
|
|
# copy a scaled version
|
|
if { $size > 1.0 } {
|
|
[set $img$size] copy [set $img] -zoom [expr { int($size) } ]
|
|
} else {
|
|
[set $img$size] copy [set $img] -subsample \
|
|
[expr { int($w / ($w * $size)) }] \
|
|
[expr { int($h / ($h * $size)) }]
|
|
}
|
|
}
|
|
}
|
|
|
|
# Boeing: clear marker drawing
|
|
proc clearMarker { } {
|
|
.c delete -withtags marker
|
|
}
|
|
|
|
# Boeing: show or hide the marker options palette
|
|
proc markerOptions { show } {
|
|
global CORE_DATA_DIR markersize markercolor
|
|
|
|
catch { destroy .left.markeropt }
|
|
if { $show == "off" } { return }
|
|
|
|
frame .left.markeropt
|
|
# eraser
|
|
set img [image create photo -file $CORE_DATA_DIR/icons/tiny/eraser.gif]
|
|
button .left.markeropt.eraser -image $img \
|
|
-relief flat -command clearMarker
|
|
pack .left.markeropt.eraser -side top -pady 8
|
|
# marker sizes
|
|
canvas .left.markeropt.sizes -height 40 -width 32
|
|
pack .left.markeropt.sizes -side top
|
|
bind .left.markeropt.sizes <1> "markerSize %x %y"
|
|
drawMarkerSizes .left.markeropt.sizes [expr $markersize / 5]
|
|
# color selection buttons
|
|
set img [image create photo -file $CORE_DATA_DIR/icons/tiny/blank.gif]
|
|
foreach clr { black red yellow blue green } {
|
|
radiobutton .left.markeropt.$clr -indicatoron 0 -image $img \
|
|
-variable markercolor -value $clr -width 16 -height 16 \
|
|
-selectcolor $clr -highlightbackground $clr -background $clr \
|
|
-highlightcolor $clr -activebackground $clr
|
|
pack .left.markeropt.$clr -side top
|
|
}
|
|
pack .left.markeropt -side bottom
|
|
}
|
|
|
|
# Boeing: draw the marker sizes tool on a small canvas
|
|
proc drawMarkerSizes { c sel } {
|
|
# determine the coordinates of the selection box based on value of sel
|
|
if { $sel == 1 } { set coords {0 0 16 16}
|
|
} elseif { $sel == 2 } { set coords {16 0 32 16}
|
|
} elseif { $sel == 3 } { set coords {0 16 16 32}
|
|
} else { set coords {16 16 32 32} }
|
|
# draw the selection box
|
|
$c create rectangle $coords -fill gray -tag square -width 0
|
|
# draw each circle
|
|
$c create oval 8 8 8 8 -width 2 -fill blue -tag circle
|
|
$c create oval 24 8 24 8 -width 5 -fill black -tag circle
|
|
$c create oval 8 24 8 24 -width 10 -fill black -tag circl
|
|
$c create oval 24 24 24 24 -width 15 -fill black -tag circle
|
|
}
|
|
|
|
# Boeing: receive click from the marker sizes tool
|
|
proc markerSize { x y } {
|
|
global markersize
|
|
# determine which circle was selected, 1-4
|
|
if { $x > 16 } {
|
|
if { $y > 16 } { set sel 4
|
|
} else { set sel 2 }
|
|
} else {
|
|
if { $y > 16 } { set sel 3
|
|
} else { set sel 1 }
|
|
}
|
|
set markersize [expr {$sel * 5}]
|
|
# redraw selection tool
|
|
.left.markeropt.sizes delete -withtag "square || circle"
|
|
drawMarkerSizes .left.markeropt.sizes $sel
|
|
}
|
|
|
|
# Boeing: set canvas wallpaper
|
|
proc wallpaperPopup {} {
|
|
global curcanvas
|
|
|
|
set w .wallpaperDlg
|
|
catch {destroy $w}
|
|
toplevel $w
|
|
|
|
wm transient $w .
|
|
wm title $w "Set Canvas Wallpaper"
|
|
grab $w
|
|
|
|
# preview
|
|
canvas $w.preview -background white -relief sunken -width 200 -height 100 \
|
|
-borderwidth 1
|
|
pack $w.preview -side top -padx 10 -pady 10
|
|
$w.preview create text 100 50 -fill gray -text "(image preview)" \
|
|
-justify center -tag "wallpaper"
|
|
|
|
|
|
# file
|
|
frame $w.f
|
|
label $w.f.lab -text "Image filename:" -justify left
|
|
entry $w.f.file
|
|
|
|
# file browse button
|
|
global configwin
|
|
set configwin $w
|
|
button $w.f.filebtn -text "..." -command {
|
|
global configwin showGrid adjustCanvas fileDialogBox_initial
|
|
global g_imageFileTypes
|
|
# use default conf file path upon first run
|
|
if { $fileDialogBox_initial == 0} {
|
|
set fileDialogBox_initial 1
|
|
set dir $g_prefs(default_conf_path)
|
|
set f [tk_getOpenFile -filetypes $g_imageFileTypes -initialdir $dir]
|
|
} else {
|
|
set f [tk_getOpenFile -filetypes $g_imageFileTypes]
|
|
}
|
|
if { $f != "" } {
|
|
$configwin.f.file delete 0 end
|
|
$configwin.f.file insert 0 $f
|
|
set showGrid 0
|
|
set adjustCanvas 1
|
|
}
|
|
wallpaperPopupPreview $configwin
|
|
raise $configwin
|
|
}
|
|
|
|
# clear wallpaper button
|
|
button $w.f.clear -text "clear" -command {
|
|
global configwin wallpaperStyle
|
|
$configwin.f.file delete 0 end
|
|
$configwin.preview delete "wallpaper"
|
|
$configwin.preview create text 100 50 -fill gray \
|
|
-text "(image preview)" -justify center -tag "wallpaper"
|
|
set wallpaperStyle upperleft
|
|
raise $configwin
|
|
}
|
|
|
|
set currfile [lindex [getCanvasWallpaper $curcanvas] 0]
|
|
set currstyle [lindex [getCanvasWallpaper $curcanvas] 1]
|
|
pack $w.f.lab -side top -anchor w
|
|
pack $w.f.file $w.f.filebtn $w.f.clear -side left -fill x
|
|
pack $w.f -side top
|
|
$w.f.file insert 0 $currfile
|
|
|
|
# wallpaper style
|
|
frame $w.style
|
|
global wallpaperStyle
|
|
if {$currstyle == "" } {
|
|
set wallpaperStyle upperleft
|
|
} else {
|
|
set wallpaperStyle $currstyle
|
|
}
|
|
radiobutton $w.style.lft -text "upper-left" -variable wallpaperStyle \
|
|
-value upperleft -command "wallpaperPopupPreview $w"
|
|
radiobutton $w.style.ctr -text "centered" -variable wallpaperStyle \
|
|
-value centered -command "wallpaperPopupPreview $w"
|
|
radiobutton $w.style.scl -text "scaled" -variable wallpaperStyle \
|
|
-value scaled -command "wallpaperPopupPreview $w"
|
|
radiobutton $w.style.til -text "tiled" -variable wallpaperStyle \
|
|
-value tiled -command "wallpaperPopupPreview $w"
|
|
|
|
pack $w.style.lft $w.style.ctr -side left
|
|
pack $w.style.scl $w.style.til -side left
|
|
pack $w.style -side top
|
|
|
|
# options
|
|
frame $w.opts
|
|
checkbutton $w.opts.showgrid -text "Show grid" -variable showGrid
|
|
checkbutton $w.opts.adjcanvas \
|
|
-text "Adjust canvas size to image dimensions" \
|
|
-variable adjustCanvas
|
|
pack $w.opts.showgrid $w.opts.adjcanvas -side top -anchor w
|
|
pack $w.opts -side top
|
|
|
|
|
|
# buttons
|
|
frame $w.btns
|
|
button $w.btns.apply -text "Apply" -command {
|
|
global configwin wallpaperStyle curcanvas adjustCanvas
|
|
set f [$configwin.f.file get]
|
|
if {$adjustCanvas} {
|
|
wallpaperAdjustCanvas $curcanvas $f $wallpaperStyle
|
|
}
|
|
setCanvasWallpaper $curcanvas $f $wallpaperStyle
|
|
redrawAll
|
|
destroy $configwin
|
|
}
|
|
button $w.btns.cancel -text "Cancel" -command "destroy $w"
|
|
pack $w.btns.apply $w.btns.cancel -side left -fill x
|
|
pack $w.btns -side top
|
|
|
|
if {$currfile != ""} {
|
|
wallpaperPopupPreview $w
|
|
}
|
|
raise $w
|
|
}
|
|
|
|
# adjust wallpaper dialog preview canvas
|
|
proc wallpaperPopupPreview { w } {
|
|
global wallpaperStyle
|
|
|
|
set f [$w.f.file get]
|
|
if { $f == "" } {
|
|
return
|
|
}
|
|
drawWallpaper $w.preview $f $wallpaperStyle
|
|
}
|
|
|
|
# auto-adjust the canvas in an intelligent fashion
|
|
proc wallpaperAdjustCanvas { c f style } {
|
|
set cx [lindex [getCanvasSize $c] 0]
|
|
set cy [lindex [getCanvasSize $c] 1]
|
|
|
|
if {$f==""} { return }
|
|
set img [image create photo -file $f]
|
|
set imgx [image width $img]
|
|
set imgy [image height $img]
|
|
|
|
#puts -nonewline "wallpaperAdjustCanvas img($imgx, $imgy) $cx, $cy -> "
|
|
|
|
# For scaled and tiled styles, expand canvas x and y to a multiple of
|
|
# imgx, imgy for better stretching. If the image is larger than the canvas,
|
|
# just increase the canvas size to accomodate it.
|
|
if {$style == "scaled" || $style == "tiled"} {
|
|
if {$cx > $imgx} {
|
|
if { [expr { $cx % $imgx }] > 0} {
|
|
set cx [expr { (1+int($cx/$imgx)) * $imgx }]
|
|
}
|
|
} elseif { $cx < $imgx } {
|
|
set cx $imgx
|
|
}
|
|
if {$cy > $imgy} {
|
|
if { [expr { $cy % $imgy }] > 0} {
|
|
# there is a fractional part, round up
|
|
set cy [expr { (1+int($cy/$imgy)) * $imgy }]
|
|
}
|
|
} elseif { $cy < $imgy } {
|
|
set cy $imgy
|
|
}
|
|
# For topleft and centered, resize the canvas to fit the image
|
|
# if the size difference isn't too large
|
|
} elseif { $style == "topleft" || $style == "centered" } {
|
|
if { [expr {abs($cx - $imgx)} ] < 300 } {
|
|
set cx $imgx
|
|
}
|
|
if { [expr {abs($cy - $imgy)} ] < 300 } {
|
|
set cy $imgy
|
|
}
|
|
}
|
|
|
|
#puts "$cx, $cy"
|
|
setCanvasSize $c $cx $cy
|
|
switchCanvas none
|
|
updateUndoLog
|
|
}
|
|
|
|
# draw the image from filename f onto the wallpaper c in the specified style
|
|
proc drawWallpaper { c f style } {
|
|
global $c
|
|
|
|
# clear the canvas
|
|
$c delete "wallpaper"
|
|
if { $f == "" } {
|
|
return
|
|
}
|
|
|
|
if { $c == ".wallpaperDlg.preview" } {
|
|
set cx [expr [$c cget -width]-2]
|
|
set cy [expr [$c cget -height]-2]
|
|
} else {
|
|
global curcanvas
|
|
# subtract 2 for canvas border
|
|
set cx [expr [lindex [getCanvasSize $curcanvas] 0]-2]
|
|
set cy [expr [lindex [getCanvasSize $curcanvas] 1]-2]
|
|
}
|
|
set f [absPathname $f]
|
|
if { [ catch { set img [image create photo -file $f] } e ] } {
|
|
puts "Error: couldn't open wallpaper file $f: $e"
|
|
return
|
|
}
|
|
set imgx [image width $img]
|
|
set imgy [image height $img]
|
|
|
|
# scaled: grow/shrink the image to fit the canvas size
|
|
if { $style == "scaled" } {
|
|
set img2 [image create photo -width $cx -height $cy]
|
|
# grow image
|
|
if { $cx >= $imgx || $cy > $imgy } {
|
|
set x [expr 1+($cx / $imgx)]
|
|
set y [expr 1+($cy / $imgy)]
|
|
$img2 copy $img -zoom $x $y
|
|
# shrink image
|
|
} else {
|
|
$img2 copy $img -subsample \
|
|
[expr { int($imgx / $cx) }] \
|
|
[expr { int($imgy / $cy) }]
|
|
}
|
|
$c create image [expr 1+$cx/2] [expr 1+$cy/2] -image $img2 \
|
|
-tags "background wallpaper"
|
|
# centered: center of image at center of canvas
|
|
} elseif { $style == "centered" } {
|
|
$c create image [expr $cx/2] [expr $cy/2] -image $img \
|
|
-tags "background wallpaper"
|
|
# tiled: repeat image several times
|
|
} elseif { $style == "tiled" } {
|
|
for {set y [expr $imgy/2]} {$y < $cy} {incr y $imgy} {
|
|
for {set x [expr $imgx/2]} {$x < $cx} {incr x $imgx} {
|
|
$c create image $x $y -image $img -tags "background wallpaper"
|
|
}
|
|
}
|
|
# upper-left: top left corner of image at 0,0
|
|
} else {
|
|
set img2 [image create photo -width $cx -height $cy]
|
|
$img2 copy $img -shrink
|
|
$c create image [expr 1+$cx/2] [expr 1+$cy/2] -image $img2 \
|
|
-tags "background wallpaper"
|
|
}
|
|
|
|
raiseAll $c
|
|
|
|
}
|
|
|
|
# helper for close/cancel buttons
|
|
proc popdownConfig { w } {
|
|
global changed
|
|
if { $changed == 1 } {
|
|
redrawAll
|
|
updateUndoLog
|
|
}
|
|
destroy $w
|
|
}
|
|
|
|
# helper for rj45 config dialog
|
|
proc rj45ifclist { wi node wasclicked } {
|
|
# user has double-clicked an entry
|
|
if { $wasclicked } {
|
|
set selected [$wi.ftop.ifc.ifc_list curselection]
|
|
set chosen [$wi.ftop.ifc.ifc_list get $selected]
|
|
set ifname [lindex [split $chosen] 0]
|
|
$wi.ftop.name delete 0 end
|
|
$wi.ftop.name insert 0 $ifname
|
|
return
|
|
}
|
|
|
|
# build a list of interfaces
|
|
frame $wi.ftop.ifc
|
|
listbox $wi.ftop.ifc.ifc_list -height 4 -width 30 \
|
|
-selectmode browse -yscrollcommand "$wi.ftop.ifc.ifc_scroll set"
|
|
scrollbar $wi.ftop.ifc.ifc_scroll \
|
|
-command "$wi.ftop.ifc.ifc_list yview"
|
|
|
|
set ifname ""
|
|
set ifip ""
|
|
# this handles differences between ifconfig
|
|
foreach line [split [nexec localnode ifconfig -a] "\n"] {
|
|
set char [string index $line 0]
|
|
if { $char != " " && $char != " " } {
|
|
if { $ifname != "" } {
|
|
$wi.ftop.ifc.ifc_list insert end "$ifname ($ifip)"
|
|
set ifname ""
|
|
set ifip ""
|
|
}
|
|
if { [string match "*Link encap:*" $line] } {
|
|
set ifname [lindex [split $line " "] 0]
|
|
} else {
|
|
set ifname [lindex [split $line :] 0]
|
|
}
|
|
} elseif { [string match "*inet addr:*" $line] } {
|
|
set inetidx [string first i $line]
|
|
set t [lindex [split [string range $line $inetidx end]] 1]
|
|
set ifip [lindex [split $t ":"] 1]
|
|
} elseif { [string match " inet *" $line] } {
|
|
set ifip [lindex [split $line] 2]
|
|
}
|
|
}
|
|
if { $ifname != "" } {
|
|
$wi.ftop.ifc.ifc_list insert end "$ifname ($ifip)"
|
|
}
|
|
|
|
bind $wi.ftop.ifc.ifc_list <Double-1> "rj45ifclist $wi $node 1"
|
|
bind $wi.ftop.ifc.ifc_list <<ListboxSelect>> "rj45ifclist $wi $node 1"
|
|
pack $wi.ftop.ifc.ifc_list $wi.ftop.ifc.ifc_scroll -side left -fill y
|
|
pack $wi.ftop.ifc -side bottom -padx 4 -pady 4
|
|
}
|
|
|
|
# link preset values - bandwidth delay ber duplicate
|
|
array set link_presets {
|
|
"unlimited" { 0 0 0 0 0 }
|
|
"1000M" { 1000000000 100 0 0.0 0.0}
|
|
"100M" { 100000000 110 0 0.0 0.0}
|
|
"10M" { 10000000 160 0 0.0 0.0}
|
|
"512kbps" { 512000 50000 0 0.0 0.0}
|
|
"256kbps" { 256000 75000 0 0.0 0.0}
|
|
"64kbps" { 64000 80000 0 0.0 0.0}
|
|
}
|
|
|
|
# link presets
|
|
proc linkPresets { wi linkpreMenu cmd } {
|
|
global link_presets link_preset_val
|
|
global g_link_config_uni_state
|
|
|
|
if { $cmd == "init" } { ;# populate the list with presets and exit
|
|
$linkpreMenu delete 0
|
|
foreach p [lsort [array names link_presets]] {
|
|
$linkpreMenu add radiobutton -label $p -value $p \
|
|
-variable link_preset_val \
|
|
-command "linkPresets $wi $linkpreMenu set"
|
|
}
|
|
return
|
|
}
|
|
|
|
# set the selected link presets
|
|
set params $link_presets($link_preset_val)
|
|
$wi.bandwidth.value delete 0 end
|
|
$wi.delay.value delete 0 end
|
|
$wi.jitter.value delete 0 end
|
|
$wi.ber.value delete 0 end
|
|
$wi.dup.value delete 0 end
|
|
$wi.bandwidth.value insert 0 [lindex $params 0]
|
|
$wi.delay.value insert 0 [lindex $params 1]
|
|
$wi.jitter.value insert 0 [lindex $params 2]
|
|
$wi.ber.value insert 0 [lindex $params 3]
|
|
$wi.dup.value insert 0 [lindex $params 4]
|
|
if { $g_link_config_uni_state == "uni" } {
|
|
$wi.bandwidth.value2 delete 0 end
|
|
$wi.delay.value2 delete 0 end
|
|
$wi.jitter.value2 delete 0 end
|
|
$wi.ber.value2 delete 0 end
|
|
$wi.dup.value2 delete 0 end
|
|
$wi.bandwidth.value2 insert 0 [lindex $params 0]
|
|
$wi.delay.value2 insert 0 [lindex $params 1]
|
|
$wi.jitter.value2 insert 0 [lindex $params 2]
|
|
$wi.ber.value2 insert 0 [lindex $params 3]
|
|
$wi.dup.value2 insert 0 [lindex $params 4]
|
|
}
|
|
}
|
|
|
|
set last_nodeHighlights [clock clicks -milliseconds]
|
|
proc nodeHighlights { c node onoff color } {
|
|
global execMode zoom
|
|
if { $execMode != "interactive"} { return } ; # batch mode
|
|
#puts "nodeHighlights $c $node $onoff $color"
|
|
$c delete -withtags "highlight && $node"
|
|
if { $onoff == "off" } {
|
|
if { $node == "" } { ;# remove all highlights
|
|
$c delete -withtags highlight
|
|
}
|
|
return
|
|
} elseif { $onoff == "single" } {
|
|
# this was called from nodeEnter binding, perform rate limiting
|
|
set now [clock clicks -milliseconds]
|
|
global last_nodeHighlights
|
|
if { [expr $now - $last_nodeHighlights] < 100 } { return }
|
|
set last_nodeHighlights $now
|
|
}
|
|
|
|
# this could be improved to draw hidden items if not on current canvas,
|
|
# then properly unhide/hide when switching canvases
|
|
global curcanvas
|
|
if { [getNodeCanvas $node] != $curcanvas } { return }
|
|
|
|
set coords [getNodeCoords $node]
|
|
set x [lindex $coords 0]
|
|
set y [lindex $coords 1]
|
|
|
|
set wd 4; # line width
|
|
set d 35; # box size
|
|
set w [expr {50 * $zoom}]; # corner size
|
|
set x0 [expr {($x - $d) * $zoom}]
|
|
set y0 [expr {($y - $d) * $zoom}]
|
|
set x1 [expr {($x + $d) * $zoom}]
|
|
set y1 [expr {($y + $d) * $zoom}]
|
|
# upper left
|
|
$c create line $x0 $y0 [expr {$x1-$w}] $y0 \
|
|
-tags "marker highlight $node" -width $wd -fill $color
|
|
$c create line $x0 $y0 $x0 [expr {$y1-$w}] \
|
|
-tags "marker highlight $node" -width $wd -fill $color
|
|
# upper right
|
|
$c create line $x1 $y0 [expr {$x0+$w}] $y0 \
|
|
-tags "marker highlight $node" -width $wd -fill $color
|
|
$c create line $x1 $y0 $x1 [expr {$y1-$w}] \
|
|
-tags "marker highlight $node" -width $wd -fill $color
|
|
# lower left
|
|
$c create line $x0 $y1 [expr {$x1-$w}] $y1 \
|
|
-tags "marker highlight $node" -width $wd -fill $color
|
|
$c create line $x0 $y1 $x0 [expr {$y0+$w}] \
|
|
-tags "marker highlight $node" -width $wd -fill $color
|
|
# lower right
|
|
$c create line $x1 $y1 [expr {$x0+$w}] $y1 \
|
|
-tags "marker highlight $node" -width $wd -fill $color
|
|
$c create line $x1 $y1 $x1 [expr {$y0+$w}] \
|
|
-tags "marker highlight $node" -width $wd -fill $color
|
|
}
|
|
|
|
# show the hook scripts dialog for editing session hooks
|
|
proc popupHooksConfig {} {
|
|
global plugin_img_add plugin_img_edit plugin_img_del
|
|
global oper_mode
|
|
|
|
set wi .hooks
|
|
catch {destroy $wi}
|
|
toplevel $wi
|
|
|
|
wm transient $wi .
|
|
wm resizable $wi 0 0
|
|
wm title $wi "CORE Session Hooks"
|
|
|
|
labelframe $wi.f -text "Hooks"
|
|
listbox $wi.f.hooks -selectmode extended -width 50 -exportselection 0 \
|
|
-yscrollcommand "$wi.f.hooks_scroll set" -height 5
|
|
scrollbar $wi.f.hooks_scroll -command "$wi.f.hooks yview"
|
|
pack $wi.f.hooks $wi.f.hooks_scroll -pady 4 -fill both -side left
|
|
pack $wi.f -padx 4 -pady 4 -fill both -side top
|
|
bind $wi.f.hooks <Double-Button-1> "hooksHelper $wi edit"
|
|
|
|
frame $wi.bbar
|
|
button $wi.bbar.new -image $plugin_img_add -command "hooksHelper $wi new"
|
|
button $wi.bbar.save -image $plugin_img_edit \
|
|
-command "hooksHelper $wi edit"
|
|
button $wi.bbar.del -image $plugin_img_del -command "hooksHelper $wi del"
|
|
label $wi.bbar.help -text "Press the new button to create a hook script."
|
|
|
|
pack $wi.bbar.new $wi.bbar.save $wi.bbar.del -side left
|
|
pack $wi.bbar.help -padx 8 -side left
|
|
pack $wi.bbar -padx 4 -pady 4 -fill both -side top
|
|
|
|
frame $wi.b -borderwidth 4
|
|
button $wi.b.close -text "Close" -command "destroy $wi"
|
|
pack $wi.b.close -side bottom
|
|
pack $wi.b -side bottom
|
|
|
|
refreshHooksList $wi
|
|
}
|
|
|
|
proc hooksHelper { wi cmd } {
|
|
global g_hook_scripts
|
|
set selected [lindex [$wi.f.hooks curselection] 0]
|
|
set name ""
|
|
if { $selected != "" } { set name [$wi.f.hooks get $selected] }
|
|
# start/stop/delete selected
|
|
if { $cmd == "del" } {
|
|
removeHook $name
|
|
refreshHooksList $wi
|
|
return
|
|
}
|
|
|
|
if { $cmd == "edit" && $name == "" } { return }
|
|
if { $cmd == "new" } {
|
|
set name ""
|
|
}
|
|
popupHookScript $name
|
|
}
|
|
|
|
proc refreshHooksList { wi } {
|
|
global g_hook_scripts
|
|
|
|
$wi.f.hooks delete 0 end
|
|
if { ![info exists g_hook_scripts] } { set g_hook_scripts "" }
|
|
|
|
foreach hook $g_hook_scripts {
|
|
set name [lindex $hook 0]
|
|
$wi.f.hooks insert end $name
|
|
}
|
|
}
|
|
|
|
proc removeHook { name } {
|
|
global g_hook_scripts
|
|
for { set i 0 } { $i < [llength $g_hook_scripts] } { incr i } {
|
|
set flow [lindex $g_hook_scripts $i]
|
|
if { [lindex $flow 0] == $name } {
|
|
set g_hook_scripts [lreplace $g_hook_scripts $i $i]
|
|
return $i
|
|
}
|
|
}
|
|
return end
|
|
}
|
|
|
|
# show the script config dialog, for specifying an optional global session
|
|
# startup script that is run on the host after the emulation has been started
|
|
proc popupHookScript { name } {
|
|
global g_hook_scripts CORE_STATES plugin_img_open plugin_img_save
|
|
set wi .scriptConfig
|
|
|
|
catch {destroy $wi}
|
|
|
|
if { ![info exists g_hook_scripts] } { set g_hook_scripts "" }
|
|
toplevel $wi
|
|
wm transient $wi .hooks
|
|
wm resizable $wi 1 1
|
|
wm title $wi "CORE Hook Script"
|
|
|
|
# help text at top
|
|
ttk::frame $wi.top
|
|
set helptext "This is an optional script that is run"
|
|
set helptext "$helptext on the host when the\n emulation reaches the"
|
|
set helptext "$helptext specified state. It is saved with the config file."
|
|
ttk::label $wi.top.help -text $helptext
|
|
pack $wi.top.help -side top -fill both -expand true
|
|
pack $wi.top -padx 4 -pady 4 -side top
|
|
|
|
ttk::frame $wi.n
|
|
ttk::label $wi.n.lab -text "Hook script name:"
|
|
ttk::entry $wi.n.name -width 35
|
|
foreach c [list open save] {
|
|
ttk::button $wi.n.$c -image [set plugin_img_$c] -command \
|
|
"genericOpenSaveButtonPress $c $wi.mid.script $wi.n.name"
|
|
}
|
|
ttk::combobox $wi.n.state -width 15 -state readonly -exportselection 0 \
|
|
-values $CORE_STATES
|
|
pack $wi.n.lab $wi.n.name -padx 4 -pady 4 -side left
|
|
pack $wi.n.open $wi.n.save -pady 4 -side left
|
|
pack $wi.n.state -padx 4 -pady 4 -side left
|
|
pack $wi.n -padx 4 -pady 4 -side top -anchor w
|
|
|
|
bind $wi.n.state <<ComboboxSelected>> "setHookName $wi"
|
|
|
|
set hook ""
|
|
if { $name == "" } {
|
|
$wi.n.state current 4
|
|
setHookName $wi
|
|
} else {
|
|
$wi.n.name insert 0 $name
|
|
foreach hook $g_hook_scripts {
|
|
if { [lindex $hook 0] == $name } {
|
|
$wi.n.state current [lindex $hook 1]
|
|
break
|
|
}
|
|
}
|
|
}
|
|
|
|
# text box for script entry with scroll bar
|
|
ttk::frame $wi.mid
|
|
text $wi.mid.script -relief sunken -bd 2 \
|
|
-yscrollcommand "$wi.mid.scroll set" -setgrid 1 -height 30 -undo 1 \
|
|
-autosep 1 -background white
|
|
ttk::scrollbar $wi.mid.scroll -command "$wi.mid.script yview"
|
|
pack $wi.mid.script -side left -fill both -expand true
|
|
pack $wi.mid.scroll -side right -fill y
|
|
pack $wi.mid -side top -fill both -expand true
|
|
|
|
# load any existing script text
|
|
if { $hook == "" } { ;# some default text
|
|
$wi.mid.script insert end "#!/bin/sh\n"
|
|
$wi.mid.script insert end "# session hook script; write commands here to execute on the host at the\n# specified state\n"
|
|
} else {
|
|
$wi.mid.script insert end [lindex $hook 2]
|
|
}
|
|
|
|
# buttons on the bottom
|
|
ttk::frame $wi.btm
|
|
ttk::button $wi.btm.apply -text "Apply" -command \
|
|
"popupHookScriptApply $wi \"$name\""
|
|
ttk::button $wi.btm.cancel -text "Cancel" -command "destroy $wi"
|
|
pack $wi.btm.apply $wi.btm.cancel -side left
|
|
pack $wi.btm
|
|
|
|
focus $wi.mid.script
|
|
}
|
|
|
|
proc popupHookScriptApply { wi oldname } {
|
|
global g_hook_scripts CORE_STATES
|
|
|
|
set name [$wi.n.name get]
|
|
set state [$wi.n.state get]
|
|
# convert state to a number
|
|
for { set i 0 } { $i < [llength $CORE_STATES] } { incr i } {
|
|
if {[lindex $CORE_STATES $i] == $state } {
|
|
set state $i
|
|
break
|
|
}
|
|
}
|
|
set script [string trim [$wi.mid.script get 0.0 end-1c]]
|
|
|
|
set hook [list $name $state $script]
|
|
|
|
set i end
|
|
if { $oldname != "" } { set i [removeHook $oldname] }
|
|
set g_hook_scripts [linsert $g_hook_scripts $i $hook]
|
|
|
|
refreshHooksList .hooks
|
|
destroy $wi
|
|
}
|
|
|
|
proc setHookName { wi } {
|
|
global g_hook_scripts
|
|
set state [string tolower [$wi.n.state get]]
|
|
set name "${state}_hook.sh"
|
|
set n 1
|
|
set names ""
|
|
foreach hook $g_hook_scripts {
|
|
lappend names [lindex $hook 0]
|
|
}
|
|
while { [lsearch $names $name] >= 0 } {
|
|
incr n
|
|
set name "${state}${n}_hook.sh"
|
|
}
|
|
$wi.n.name delete 0 end
|
|
$wi.n.name insert 0 $name
|
|
}
|
|
|
|
# show the comments dialog for adding comments to a scenario
|
|
proc popupCommentsConfig {} {
|
|
global g_comments
|
|
set wi .commentsConfig
|
|
|
|
catch {destroy $wi}
|
|
|
|
if { ![info exists g_comments] } { set g_comments "" }
|
|
toplevel $wi
|
|
wm transient $wi .
|
|
wm resizable $wi 1 1
|
|
wm title $wi "CORE Session Comments"
|
|
|
|
# help text at top
|
|
frame $wi.top
|
|
set helptext "Optional text comments associated with this scenario may"
|
|
set helptext "$helptext be entered below and saved with the config file."
|
|
label $wi.top.help -text $helptext
|
|
pack $wi.top.help -side top -fill both -expand true
|
|
pack $wi.top -padx 4 -pady 4 -side top
|
|
|
|
# text box for comment entry with scroll bar
|
|
frame $wi.mid
|
|
text $wi.mid.comments -relief sunken -bd 2 \
|
|
-yscrollcommand "$wi.mid.scroll set" -setgrid 1 -height 30 -undo 1 \
|
|
-autosep 1 -background white
|
|
scrollbar $wi.mid.scroll -command "$wi.mid.comments yview"
|
|
pack $wi.mid.comments -side left -fill both -expand true
|
|
pack $wi.mid.scroll -side right -fill y
|
|
pack $wi.mid -side top -fill both -expand true
|
|
|
|
# load any existing comment text
|
|
if { $g_comments != "" } {
|
|
$wi.mid.comments insert end $g_comments
|
|
}
|
|
|
|
# buttons on the bottom
|
|
frame $wi.btm
|
|
button $wi.btm.apply -text "Apply" -command {
|
|
set wi .commentsConfig
|
|
global g_comments
|
|
set g_comments [string trim [$wi.mid.comments get 0.0 end-1c]]
|
|
destroy $wi
|
|
}
|
|
button $wi.btm.cancel -text "Cancel" -command "destroy $wi"
|
|
pack $wi.btm.apply $wi.btm.cancel -side left
|
|
pack $wi.btm
|
|
|
|
focus $wi.mid.comments
|
|
}
|
|
|
|
# show the contents of a file
|
|
proc popupFileView { pathname } {
|
|
set wi .fileview
|
|
catch {destroy $wi}
|
|
|
|
toplevel $wi
|
|
wm transient $wi .
|
|
wm resizable $wi 1 1
|
|
wm title $wi "File: $pathname"
|
|
|
|
ttk::frame $wi.top
|
|
ttk::label $wi.top.fnl -text "File:"
|
|
ttk::entry $wi.top.fn
|
|
#ttk::entry $wi.top.fn -state readonly
|
|
pack $wi.top.fnl -padx 4 -side left
|
|
pack $wi.top.fn -padx 4 -side left -fill both -expand true
|
|
pack $wi.top -padx 4 -pady 4 -side top -fill both -expand true
|
|
$wi.top.fn insert 0 $pathname
|
|
$wi.top.fn state readonly
|
|
|
|
ttk::frame $wi.mid
|
|
text $wi.mid.contents -relief sunken -bd 2 \
|
|
-yscrollcommand "$wi.mid.scroll set" -setgrid 1 -height 30 -undo 1 \
|
|
-autosep 1 -background white
|
|
ttk::scrollbar $wi.mid.scroll -command "$wi.mid.contents yview"
|
|
pack $wi.mid.contents -side left -fill both -expand true
|
|
pack $wi.mid.scroll -side right -fill y
|
|
pack $wi.mid -side top -fill both -expand true
|
|
|
|
if { [catch { set f [open $pathname r] } e] } {
|
|
$wi.mid.contents insert end "error: $e"
|
|
} else {
|
|
while { [ gets $f line] >= 0 } {
|
|
$wi.mid.contents insert end "$line\n"
|
|
}
|
|
close $f
|
|
}
|
|
|
|
# buttons on the bottom
|
|
ttk::frame $wi.btm
|
|
ttk::button $wi.btm.close -text "Close" -command "destroy $wi"
|
|
pack $wi.btm.close -side left
|
|
pack $wi.btm
|
|
|
|
$wi.mid.contents see end
|
|
focus $wi.mid.contents
|
|
}
|
|
|
|
# helper for "..." buttons for browsing for files
|
|
# ctl is the text entry to populate
|
|
proc fileButtonPopup { ctl initial } {
|
|
set f [tk_getOpenFile -initialdir $initial]
|
|
if { $f != "" } {
|
|
$ctl delete 0 end
|
|
$ctl insert 0 $f
|
|
}
|
|
}
|
|
|
|
# helper to get the name of the image representing a node; first, use any
|
|
# custom image defined, then customizable node type image, then finally the
|
|
# node's type name
|
|
proc getNodeImage { node } {
|
|
set type [nodeType $node]
|
|
set model [getNodeModel $node]
|
|
|
|
set imgname [getNodeTypeImage $model normal]
|
|
set cimg [absPathname [getCustomImage $node]]
|
|
if { $cimg != "" } { set imgname $cimg }
|
|
|
|
set imgname [file tail $imgname]
|
|
if { $imgname == "" } { set imgname $type}
|
|
global $imgname
|
|
return [set $imgname]
|
|
}
|
|
|
|
proc hideSelected { } {
|
|
foreach node [selectedNodes] { hideNode $node }
|
|
.c delete -withtags selectmark
|
|
}
|
|
|
|
proc hideNode { node } {
|
|
set c .c
|
|
setNodeHidden $node 1
|
|
$c itemconfigure "node && $node" -state hidden
|
|
$c itemconfigure "nodelabel && $node" -state hidden
|
|
$c itemconfigure "highlight && $node" -state hidden
|
|
$c itemconfigure "$node && antenna" -state hidden
|
|
$c itemconfigure "$node && link" -state hidden
|
|
$c itemconfigure "$node && interface" -state hidden
|
|
foreach l [$c find withtag "$node && link"] {
|
|
set link [lindex [$c gettags $l] 1]
|
|
$c itemconfigure "linklabel && $link" -state hidden
|
|
}
|
|
}
|
|
|
|
# this is a helper to save/restore the (green) WLAN wireless links used with
|
|
# the basic range model, because they are not saved on the global link_list
|
|
# called from proc redrawAll
|
|
proc saveRestoreWlanLinks { c cmd } {
|
|
global wlink_list
|
|
|
|
if { $cmd == "save" } {
|
|
set wlink_list {}
|
|
foreach item [$c find withtag "wlanlink"] {
|
|
set tags [$c gettags $item] ;# tags = "wlanlink n1 n2 wlan need_r"
|
|
lappend wlink_list [lrange $tags 1 3]
|
|
}
|
|
} elseif { $cmd == "restore" } {
|
|
if { ![info exists wlink_list] } {
|
|
return
|
|
}
|
|
foreach wlink $wlink_list {
|
|
lassign $wlink node1 node2 wlan
|
|
drawWlanLink $node1 $node2 $wlan
|
|
}
|
|
}
|
|
}
|
|
|
|
proc cutSelection {} {
|
|
editCopy
|
|
deleteSelection
|
|
}
|
|
|
|
proc copySelection {} {
|
|
global clipboard
|
|
set clipboard {}
|
|
set c .c
|
|
set copied ""
|
|
foreach img [$c find withtag "selected"] {
|
|
set tags [$c gettags $img]
|
|
set objtype [lindex $tags 0]
|
|
set objname [lindex $tags 1]
|
|
# some objects (e.g. oval) consist of multiple canvas objects
|
|
if { [lsearch $copied $objname] != -1 } { continue}
|
|
global $objname
|
|
if { ![info exists $objname] } { continue }
|
|
set item [list $tags [set $objname]]
|
|
lappend clipboard $item
|
|
lappend copied $objname
|
|
}
|
|
}
|
|
|
|
proc pasteSelection {} {
|
|
global clipboard
|
|
global node_list link_list annotation_list curcanvas
|
|
|
|
array set node_map ""
|
|
set new_nodes ""
|
|
set new_annotations ""
|
|
set v4blacklist ""
|
|
set v6blacklist ""
|
|
set dx 75; set dy 50 ;# paste offset
|
|
|
|
if { ![info exists clipboard] } { return }
|
|
|
|
# pass 1 - make new nodes
|
|
foreach item $clipboard {
|
|
set tags [lindex $item 0]
|
|
set olddata [lindex $item 1] ;# allows copy, change, paste
|
|
set old [lindex $tags 1]
|
|
|
|
# annotations
|
|
set type [nodeType $old]
|
|
if { [lsearch -exact "oval rectangle text" $type] != -1 } {
|
|
set new [newObjectId annotation]
|
|
global $new
|
|
set $new $olddata
|
|
lappend annotation_list $new
|
|
lappend new_annotations $new
|
|
moveAnnotation $new $dx $dy
|
|
continue
|
|
}
|
|
if { $type == "pseudo" } { continue }
|
|
|
|
set new [newObjectId node]
|
|
set node_map($old) $new
|
|
global $new
|
|
# set $new [set $old] would copy the current node's data, but using
|
|
# $olddata instead will copy node data at the time "copy" was invoked
|
|
set $new $olddata
|
|
lappend node_list $new
|
|
lappend new_nodes $new
|
|
if { [getNodeName $old] != $old } {
|
|
setNodeName $new [getNodeName $old] ;# preserve textual names
|
|
} else {
|
|
setNodeName $new $new
|
|
}
|
|
setNodeCanvas $new $curcanvas
|
|
|
|
if { [nodeType $new] == "wlan" } {
|
|
setIfcIPv4addr $new wireless "[findFreeIPv4Net 24].0/32"
|
|
setIfcIPv6addr $new wireless "[findFreeIPv6Net 64]::0/128"
|
|
continue
|
|
}
|
|
|
|
# remove existing addresses, generate new ones later
|
|
if { [[typemodel $new].layer] != "NETWORK" } { continue }
|
|
foreach ifc [ifcList $new] {
|
|
if { [getIfcIPv4addr $new $ifc] == "" } {
|
|
lappend v4blacklist ${new}_${ifc} ;# preserve empty addrs
|
|
} else {
|
|
setIfcIPv4addr $new $ifc ""
|
|
}
|
|
if { [getIfcIPv6addr $new $ifc] == "" } {
|
|
lappend v6blacklist ${new}_${ifc} ;# preserve empty addrs
|
|
} else {
|
|
setIfcIPv6addr $new $ifc ""
|
|
}
|
|
}
|
|
}
|
|
# pass 2 update interfaces and coordinates
|
|
foreach item $clipboard {
|
|
set tags [lindex $item 0]
|
|
set old [lindex $tags 1]
|
|
set type [nodeType $old]
|
|
if { [lsearch -exact "oval rectangle text pseudo" $type] != -1 } {
|
|
continue
|
|
}
|
|
set new $node_map($old)
|
|
|
|
# update coordinates, shifting by <dx, dy>
|
|
lassign [getNodeCoords $new] x y
|
|
setNodeCoords $new "[expr $x + $dx] [expr $y + $dy]"
|
|
lassign [getNodeLabelCoords $new] x y
|
|
setNodeLabelCoords $new "[expr $x + $dx] [expr $y + $dy]"
|
|
|
|
foreach ifc [ifcList $new] {
|
|
set old_peer [peerByIfc $new $ifc]
|
|
set i [lsearch [set $new] "interface-peer {$ifc $old_peer}"]
|
|
set logical [logicalPeerByIfc $new $ifc]
|
|
if { $logical != $old_peer } { ;# prune links to other canvases
|
|
set $new [lreplace [set $new] $i $i]; continue;
|
|
}
|
|
if { [lindex [array get node_map $old_peer] 1] != "" } {
|
|
set peer $node_map($old_peer)
|
|
set $new [lreplace [set $new] $i $i \
|
|
"interface-peer {$ifc $peer}"]
|
|
} else {
|
|
# old peer is not being copied, create a new interface
|
|
set peer $old_peer
|
|
set peer_ifc [newIfc [chooseIfName $peer $new] $peer]
|
|
global $old_peer
|
|
lappend $old_peer "interface-peer {$peer_ifc $new}"
|
|
if {[[typemodel $peer].layer] == "NETWORK"} {
|
|
autoIPv4addr $peer $peer_ifc
|
|
autoIPv6addr $peer $peer_ifc
|
|
}
|
|
}
|
|
|
|
# a new link already has been created (when peer interfaces were
|
|
# iterated)
|
|
if { [linkByPeers $new $peer] != "" } { continue }
|
|
set oldlink [linkByPeers $old $old_peer]
|
|
global $oldlink
|
|
if { [lindex [linkPeers $oldlink] 0] == $old } {
|
|
set newpeers "$new $peer"
|
|
} else {
|
|
set newpeers "$peer $new"
|
|
}
|
|
set newlink [newObjectId link]
|
|
global $newlink
|
|
set $newlink [set $oldlink] ;# copies all attributes
|
|
set i [lsearch [set $oldlink] "nodes {*}"]
|
|
set $newlink [lreplace [set $newlink] $i $i "nodes {$newpeers}"]
|
|
lappend link_list $newlink
|
|
}
|
|
}
|
|
|
|
# pass 3 - readdress (must occur after all links are updated above)
|
|
foreach new $new_nodes {
|
|
if {[[typemodel $new].layer] != "NETWORK"} { continue }
|
|
foreach ifc [ifcList $new] {
|
|
if { [lsearch -exact $v4blacklist ${new}_${ifc}] == -1 } {
|
|
autoIPv4addr $new $ifc
|
|
}
|
|
if { [lsearch -exact $v6blacklist ${new}_${ifc}] == -1 } {
|
|
autoIPv6addr $new $ifc
|
|
}
|
|
}
|
|
}
|
|
set changed 1
|
|
updateUndoLog
|
|
redrawAll
|
|
selectNodes $new_nodes
|
|
foreach a $new_annotations { selectNode .c $a }
|
|
}
|
|
|