global clock_seconds
if { [clock seconds] == $clock_seconds } {
- update
- return
+ update
+ return
}
set clock_seconds [clock seconds]
if { $cursorState } {
- .c config -cursor watch
- set cursorState 0
+ .c config -cursor watch
+ set cursorState 0
} else {
- .c config -cursor pirate
- set cursorState 1
+ .c config -cursor pirate
+ set cursorState 1
}
update
- return
}
#****f* editor.tcl/removeGUILink
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
+ 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
+ removeLink [getLinkMirror $link]
+ removeLink $link
+ removeNode [getNodeMirror $node2]
+ removeNode $node2
+ .c delete $node2
} else {
- removeLink $link
+ removeLink $link
}
.c delete $link
if { $atomic == "atomic" } {
- set changed 1
- updateUndoLog
+ set changed 1
+ updateUndoLog
}
- return
}
#****f* editor.tcl/removeGUINode
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
+ set peer [peerByIfc $node $ifc]
+ set link [lindex [.c gettags "link && $node && $peer"] 1]
+ removeGUILink $link non-atomic
}
if { $type != "pseudo" } {
- removeNode $node
- .c delete $node
+ removeNode $node
+ .c delete $node
}
- return
}
#****f* editor.tcl/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
- set changed 0
- }
- return
+ global t_undolog undolog
+ set t_undolog ""
+ dumpCfg string t_undolog
+ incr undolevel
+ set undolog($undolevel) $t_undolog
+ set redolevel $undolevel
+ set changed 0
+ }
}
#****f* editor.tcl/undo
global undolevel undolog oper_mode
if {$oper_mode == "edit" && $undolevel > 0} {
- incr undolevel -1
- loadCfg $undolog($undolevel)
- switchCanvas none
+ incr undolevel -1
+ .c config -cursor watch
+ loadCfg $undolog($undolevel)
+ switchCanvas none
}
- return
}
#****f* editor.tcl/redo
global undolevel redolevel undolog oper_mode
if {$oper_mode == "edit" && $redolevel > $undolevel} {
- incr undolevel
- loadCfg $undolog($undolevel)
- switchCanvas none
+ incr undolevel
+ .c config -cursor watch
+ loadCfg $undolog($undolevel)
+ switchCanvas none
}
- return
}
#****f* editor.tcl/redrawAll
#****
proc redrawAll {} {
- global node_list link_list background sizex sizey
- global curcanvas
+ global node_list link_list background sizex sizey grid
+ global curcanvas zoom
+
+ .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}]"
.c delete all
- set background [.c create rectangle 0 0 $sizex $sizey \
- -fill white -tags "background"]
- .c lower $background
+ set background [.c create rectangle 0 0 $e_sizex $e_sizey \
+ -fill white -tags "background"]
+
+ # Grid
+ set e_grid [expr {int($grid * $zoom)}]
+ set e_grid2 [expr {$e_grid * 2}]
+ if { 1 } {
+ for { set x $e_grid } { $x < $e_sizex } { incr x $e_grid } {
+ if { [expr {$x % $e_grid2}] != 0 } {
+ .c create line $x 1 $x $e_sizey -fill gray -dash {1 7} \
+ -tags "background"
+ } else {
+ .c create line $x 1 $x $e_sizey -fill gray -dash {1 3} \
+ -tags "background"
+ }
+ }
+ for { set y $e_grid } { $y < $e_sizey } { incr y $e_grid } {
+ if { [expr {$y % $e_grid2}] != 0 } {
+ .c create line 1 $y $e_sizex $y -fill gray -dash {1 7} \
+ -tags "background"
+ } else {
+ .c create line 1 $y $e_sizex $y -fill gray -dash {1 3} \
+ -tags "background"
+ }
+ }
+ }
+
+ .c lower -withtags background
foreach node $node_list {
- if { [getNodeCanvas $node] == $curcanvas } {
- drawNode $node
- }
+ if { [getNodeCanvas $node] == $curcanvas } {
+ drawNode $node
+ }
}
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
+ set nodes [linkPeers $link]
+ if { [getNodeCanvas [lindex $nodes 0]] != $curcanvas ||
+ [getNodeCanvas [lindex $nodes 1]] != $curcanvas } {
+ continue
+ }
+ drawLink $link
+ redrawLink $link
+ updateLinkLabel $link
}
- return
+
+ .c config -cursor left_ptr
}
#****f* editor.tcl/drawNode
proc drawNode { node } {
global showNodeLabels
global router pc host lanswitch frswitch rj45 hub pseudo
- global curcanvas
+ global curcanvas zoom
set type [nodeType $node]
set coords [getNodeCoords $node]
- set x [lindex $coords 0]
- set y [lindex $coords 1]
- .c create image $x $y -image [set $type] \
- -tags "node $node"
+ set x [expr {[lindex $coords 0] * $zoom}]
+ set y [expr {[lindex $coords 1] * $zoom}]
+ .c create image $x $y -image [set $type] -tags "node $node"
set coords [getNodeLabelCoords $node]
- set x [lindex $coords 0]
- set y [lindex $coords 1]
+ set x [expr {[lindex $coords 0] * $zoom}]
+ set y [expr {[lindex $coords 1] * $zoom}]
if { [nodeType $node] != "pseudo" } {
- set label [.c create text $x $y -fill blue \
- -text "[getNodeName $node]" \
- -tags "nodelabel $node"]
- } else {
- set pnode [getNodeName $node]
- set pcanvas [getNodeCanvas $pnode]
- set ifc [ifcByPeer $pnode [getNodeMirror $node]]
- if { $pcanvas != $curcanvas } {
- set label [.c create text $x $y -fill blue \
- -text "[getNodeName $pnode]:$ifc\r@[getCanvasName $pcanvas]" \
- -tags "nodelabel $node" -justify center]
+ set label [.c create text $x $y -fill blue \
+ -text "[getNodeName $node]" \
+ -tags "nodelabel $node"]
} else {
- set label [.c create text $x $y -fill blue \
- -text "[getNodeName $pnode]:$ifc" \
- -tags "nodelabel $node" -justify center]
- }
+ 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\r@[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
+ .c itemconfigure $label -state hidden
}
# XXX Invisible pseudo-node labels
global invisible
if { $invisible == 1 && [nodeType $node] == "pseudo" } {
- .c itemconfigure $label -state hidden
+ .c itemconfigure $label -state hidden
}
- return
}
#****f* editor.tcl/drawLink
#****
proc drawLink { link } {
- global defLinkWidth defLinkColor
-
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 $defLinkColor -width $defLinkWidth \
- -tags "link $link $lnode1 $lnode2" \
- -arrow both]
+ 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 $defLinkColor -width $defLinkWidth \
- -tags "link $link $lnode1 $lnode2"]
+ set newlink [.c create line 0 0 0 0 \
+ -fill [getLinkColor $link] -width $lwidth \
+ -tags "link $link $lnode1 $lnode2"]
}
# XXX Invisible pseudo-liks
global invisible
if { $invisible == 1 && [getLinkMirror $link] != "" } {
- .c itemconfigure $link -state hidden
+ .c itemconfigure $link -state hidden
}
.c raise $newlink background
set newlink [.c create line 0 0 0 0 \
- -fill white -width [expr $defLinkWidth * 3 ] \
+ -fill white -width [expr {$lwidth + 4}] \
-tags "link $link $lnode1 $lnode2"]
.c raise $newlink background
.c create text 0 0 -tags "linklabel $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"
- return
}
#****f* editor.tcl/chooseIfName
global $lnode1 $lnode2
switch -exact -- [nodeType $lnode1] {
- pc {
- return eth
- }
- host {
- return eth
- }
- hub {
- return e
- }
- lanswitch {
- return e
- }
- frswitch {
- return f
- }
- router {
- if { [nodeType $lnode2] == "router" || \
- [nodeType $lnode2] == "frswitch" } {
- #return ser
- return eth
- } else {
- return eth
- }
- }
- rj45 {
- return
- }
+ pc {
+ return eth
+ }
+ host {
+ return eth
+ }
+ hub {
+ return e
+ }
+ lanswitch {
+ return e
+ }
+ frswitch {
+ return f
+ }
+ router {
+ return eth
+ }
+ rj45 {
+ return
+ }
}
}
proc listLANnodes { l2node l2peers } {
lappend l2peers $l2node
foreach ifc [ifcList $l2node] {
- set peer [logicalPeerByIfc $l2node $ifc]
- set type [nodeType $peer]
- if { [ lsearch {lanswitch hub} $type] != -1 } {
- if { [lsearch $l2peers $peer] == -1 } {
- set l2peers [listLANnodes $peer $l2peers]
- }
- }
+ set peer [logicalPeerByIfc $l2node $ifc]
+ set type [nodeType $peer]
+ if { [ lsearch {lanswitch hub} $type] != -1 } {
+ if { [lsearch $l2peers $peer] == -1 } {
+ set l2peers [listLANnodes $peer $l2peers]
+ }
+ }
}
return $l2peers
}
#****
proc calcDxDy { lnode } {
- global showIfIPaddrs showIfIPv6addrs
+ global showIfIPaddrs showIfIPv6addrs zoom
upvar dx x
upvar dy y
- switch -exact -- [nodeType $lnode] {
- frswitch {
- set x 1.8
- set y 1.8
- }
- hub {
- set x 1.5
- set y 2.6
- }
- lanswitch {
- set x 1.5
- set y 2.6
- }
- router {
- set x 1
- set y 2
- }
- pc {
- if { $showIfIPaddrs || $showIfIPv6addrs } {
- set x 1.1
- } else {
- set x 1.4
- }
- set y 1.5
- }
- host {
- if { $showIfIPaddrs || $showIfIPv6addrs } {
- set x 1.0
- } else {
- set x 1.5
- }
- set y 1.5
- }
- rj45 {
- set x 1
- set y 1
+ if { $zoom > 1.0 } {
+ set x 1
+ set y 1
+ return
}
+ switch -exact -- [nodeType $lnode] {
+ frswitch {
+ set x [expr {1.8 / $zoom}]
+ set y [expr {1.8 / $zoom}]
+ }
+ 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}]
+ }
+ pc {
+ if { $showIfIPaddrs || $showIfIPv6addrs } {
+ set x [expr {1.1 / $zoom}]
+ } else {
+ set x [expr {1.4 / $zoom}]
+ }
+ set y [expr {1.5 / $zoom}]
+ }
+ host {
+ if { $showIfIPaddrs || $showIfIPv6addrs } {
+ set x [expr {1 / $zoom}]
+ } else {
+ set x [expr {1.5 / $zoom}]
+ }
+ set y [expr {1.5 / $zoom}]
+ }
+ rj45 {
+ set x [expr {1 / $zoom}]
+ set y [expr {1 / $zoom}]
+ }
}
- return
}
#****f* editor.tcl/updateIfcLabel
set ifipv4addr [getIfcIPv4addr $lnode1 $ifc]
set ifipv6addr [getIfcIPv6addr $lnode1 $ifc]
if { $ifc == 0 } {
- set ifc ""
+ set ifc ""
}
if { [getIfcOperState $lnode1 $ifc] == "down" } {
- set labelstr "*"
+ set labelstr "*"
} else {
- set labelstr ""
+ set labelstr ""
}
if { $showIfNames } {
- set labelstr "$labelstr$ifc\r"
+ set labelstr "$labelstr$ifc\r"
}
if { $showIfIPaddrs && $ifipv4addr != "" } {
- set labelstr "$labelstr$ifipv4addr\r"
+ set labelstr "$labelstr$ifipv4addr\r"
}
if { $showIfIPv6addrs && $ifipv6addr != "" } {
- set labelstr "$labelstr$ifipv6addr\r"
+ set labelstr "$labelstr$ifipv6addr\r"
}
set labelstr \
- [string range $labelstr 0 [expr [string length $labelstr] - 2]]
+ [string range $labelstr 0 [expr {[string length $labelstr] - 2}]]
.c itemconfigure "interface && $lnode1 && $link" \
- -text "$labelstr"
- return
+ -text "$labelstr"
}
set dup [getLinkDup $link]
set labelstr "$labelstr[getLinkBandwidthString $link]\r"
if { "$delstr" != "" } {
- set labelstr "$labelstr$delstr\r"
+ set labelstr "$labelstr$delstr\r"
}
if { "$ber" != "" } {
- set berstr "ber=$ber"
- set labelstr "$labelstr$berstr\r"
+ set berstr "ber=$ber"
+ set labelstr "$labelstr$berstr\r"
}
if { "$dup" != "" } {
- set dupstr "dup=$dup%"
- set labelstr "$labelstr$dupstr\r"
+ set dupstr "dup=$dup%"
+ set labelstr "$labelstr$dupstr\r"
}
- set labelstr [string range $labelstr 0 [expr [string length $labelstr] - 2]]
+ 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
+ .c itemconfigure "linklabel && $link" -state hidden
}
- return
}
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
+ set nodes [linkPeers $link]
+ if { [getNodeCanvas [lindex $nodes 0]] != $curcanvas ||
+ [getNodeCanvas [lindex $nodes 1]] != $curcanvas } {
+ continue
+ }
+ redrawLink $link
}
- return
}
.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)]
+ 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 }
+ 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]
+ 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]
+ 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
- return
}
# * link -- link id
#****
proc splitGUILink { link } {
- global changed
+ global changed zoom
set peer_nodes [linkPeers $link]
set new_nodes [splitLink $link pseudo]
set y2 [lindex [getNodeCoords $orig_node2] 1]
setNodeCoords $new_node1 \
- "[expr $x1 + 0.4 * ($x2 - $x1)] [expr $y1 + 0.4 * ($y2 - $y1)]"
+ "[expr {($x1 + 0.4 * ($x2 - $x1)) / $zoom}] \
+ [expr {($y1 + 0.4 * ($y2 - $y1)) / $zoom}]"
setNodeCoords $new_node2 \
- "[expr $x1 + 0.6 * ($x2 - $x1)] [expr $y1 + 0.6 * ($y2 - $y1)]"
+ "[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 node [lindex [$c gettags $obj] 1]
$c addtag selected withtag "node && $node"
if { [nodeType $node] == "pseudo" } {
- set bbox [$c bbox "nodelabel && $node"]
+ set bbox [$c bbox "nodelabel && $node"]
} else {
- set bbox [$c bbox "node && $node"]
+ 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]
+ 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"
- return
+ -dash {6 4} -fill black -width 1 -tags "selectmark $node"
+}
+
+proc selectNodes { nodelist } {
+ foreach node $nodelist {
+ selectNode .c [.c find withtag "node && $node"]
+ }
}
+proc selectAdjacent {} {
+ global curcanvas
+
+ set selected {}
+ set adjacent {}
+ foreach obj [.c find withtag "node && selected"] {
+ set node [lindex [.c gettags $obj] 1]
+ if { [getNodeCanvas $node] != $curcanvas || \
+ [getNodeMirror $node] != "" } {
+ return
+ }
+ lappend selected $node
+ }
+ 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
set link [lindex [$c gettags {link && current}] 1]
if { $link == "" } {
- set link [lindex [$c gettags {linklabel && current}] 1]
- if { $link == "" } {
- return
- }
+ 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"
+ -command "popupConfigDialog $c"
#
# Delete link
#
if { $oper_mode != "exec" } {
- .button3menu add command -label "Delete" \
- -command "removeGUILink $link atomic"
+ .button3menu add command -label "Delete" \
+ -command "removeGUILink $link atomic"
} else {
- .button3menu add command -label "Delete" \
- -state disabled
+ .button3menu add command -label "Delete" \
+ -state disabled
}
#
# Split link
#
if { $oper_mode != "exec" && [getLinkMirror $link] == "" } {
- .button3menu add command -label "Split" \
- -command "splitGUILink $link"
+ .button3menu add command -label "Split" \
+ -command "splitGUILink $link"
} else {
- .button3menu add command -label "Split" \
- -state disabled
+ .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]"
+ [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
+ .button3menu add command -label "Merge" -state disabled
}
set x [winfo pointerx .]
set y [winfo pointery .]
tk_popup .button3menu $x $y
-
- return
}
set selected_nodes {}
foreach obj [.c find withtag "node && selected"] {
- set node [lindex [.c gettags $obj] 1]
- lappend selected_nodes $node
- setNodeCanvas $node $canvas
- set changed 1
+ set node [lindex [.c gettags $obj] 1]
+ lappend selected_nodes $node
+ setNodeCanvas $node $canvas
+ set changed 1
}
foreach obj [.c find withtag "linklabel"] {
- set link [lindex [.c gettags $obj] 1]
- set link_peers [linkPeers $link]
- set peer1 [lindex $link_peers 0]
- set peer2 [lindex $link_peers 1]
- set peer1_in_selected [lsearch $selected_nodes $peer1]
- set peer2_in_selected [lsearch $selected_nodes $peer2]
- if { ($peer1_in_selected == -1 && $peer2_in_selected != -1) ||
- ($peer1_in_selected != -1 && $peer2_in_selected == -1) } {
- 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
- }
+ 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
set node [lindex [$c gettags {node && current}] 1]
if { $node == "" } {
- set node [lindex [$c gettags {nodelabel && current}] 1]
- if { $node == "" } {
- return
- }
+ 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"]
+ $c dtag node selected
+ $c delete -withtags selectmark
+ selectNode $c [$c find withtag "current"]
}
.button3menu delete 0 end
+ #
+ # 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
+ }
+
#
# Configure node
#
if { [nodeType $node] != "pseudo" } {
- .button3menu add command -label "Configure" \
- -command "popupConfigDialog $c"
+ .button3menu add command -label "Configure" \
+ -command "popupConfigDialog $c"
} else {
- .button3menu add command -label "Configure" \
- -command "popupConfigDialog $c" -state disabled
+ .button3menu add command -label "Configure" \
+ -command "popupConfigDialog $c" -state disabled
}
#
#
.button3menu.connect delete 0 end
if { $oper_mode == "exec" || [nodeType $node] == "pseudo" } {
- .button3menu add cascade -label "Create link to" \
- -menu .button3menu.connect -state disabled
+ .button3menu add cascade -label "Create link to" \
+ -menu .button3menu.connect -state disabled
} else {
- .button3menu add cascade -label "Create link to" \
- -menu .button3menu.connect
+ .button3menu add cascade -label "Create link to" \
+ -menu .button3menu.connect
}
.button3menu.connect add command -label "Canvas:" -state disabled
foreach canvas $canvas_list {
- destroy .button3menu.connect.$canvas
- menu .button3menu.connect.$canvas -tearoff 0
- .button3menu.connect.$canvas add command \
- -label "Node:" -state disabled
- .button3menu.connect add cascade -label [getCanvasName $canvas] \
- -menu .button3menu.connect.$canvas
+ destroy .button3menu.connect.$canvas
+ menu .button3menu.connect.$canvas -tearoff 0
+ .button3menu.connect.$canvas add command \
+ -label "Node:" -state disabled
+ .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
- }
+ 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
+ }
}
#
#
.button3menu.moveto delete 0 end
if { $oper_mode == "exec" || [nodeType $node] == "pseudo" } {
- .button3menu add cascade -label "Move to" \
- -menu .button3menu.moveto -state disabled
+ .button3menu add cascade -label "Move to" \
+ -menu .button3menu.moveto -state disabled
} else {
- .button3menu add cascade -label "Move to" \
- -menu .button3menu.moveto
+ .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
- }
+ 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"
+ [getNodeCanvas $mirror_node] == $curcanvas } {
+ .button3menu add command -label "Merge" \
+ -command "mergeGUINode $node"
} else {
- .button3menu add command -label "Merge" \
- -state disabled
+ .button3menu add command -label "Merge" -state disabled
}
#
# Delete selection
#
if { $oper_mode != "exec" } {
- .button3menu add command -label "Delete" -command deleteSelection
+ .button3menu add command -label "Delete" -command deleteSelection
} else {
- .button3menu add command -label "Delete" -state disabled
+ .button3menu add command -label "Delete" -state disabled
}
#
#
.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 != "" } {
- .button3menu.shell add command -label "$cmd" \
- -command "spawnShell $node $cmd"
- }
- .button3menu.shell add command -label "/bin/sh" \
- -command "spawnShell $node /bin/sh"
+ .button3menu add cascade -label "Shell window" \
+ -menu .button3menu.shell
+ set cmd [[typemodel $node].shellcmd $node]
+ if { $cmd != "/bin/sh" && $cmd != "" } {
+ .button3menu.shell add command -label "$cmd" \
+ -command "spawnShell $node $cmd"
+ }
+ .button3menu.shell add command -label "/bin/sh" \
+ -command "spawnShell $node /bin/sh"
} else {
- .button3menu add cascade -label "Shell window" \
- -menu .button3menu.shell -state disabled
+ .button3menu add cascade -label "Shell window" \
+ -menu .button3menu.shell -state disabled
}
#
#
.button3menu.ethereal delete 0 end
if { $oper_mode == "exec" && [[typemodel $node].layer] == "NETWORK" } {
- .button3menu add cascade -label "Ethereal" \
- -menu .button3menu.ethereal
- foreach ifc [ifcList $node] {
- set label "$ifc"
- if { [getIfcIPv4addr $node $ifc] != "" } {
- set label "$label ([getIfcIPv4addr $node $ifc])"
- }
- if { [getIfcIPv6addr $node $ifc] != "" } {
- set label "$label ([getIfcIPv6addr $node $ifc])"
- }
- .button3menu.ethereal add command -label $label \
- -command "startethereal $node $ifc"
- }
- .button3menu add command -label Start \
- -command "[typemodel $node].start $eid $node"
- .button3menu add command -label Stop \
- -command "[typemodel $node].shutdown $eid $node"
+ .button3menu add cascade -label "Ethereal" \
+ -menu .button3menu.ethereal
+ foreach ifc [ifcList $node] {
+ set label "$ifc"
+ if { [getIfcIPv4addr $node $ifc] != "" } {
+ set label "$label ([getIfcIPv4addr $node $ifc])"
+ }
+ if { [getIfcIPv6addr $node $ifc] != "" } {
+ set label "$label ([getIfcIPv6addr $node $ifc])"
+ }
+ .button3menu.ethereal add command -label $label \
+ -command "startethereal $node $ifc"
+ }
+ .button3menu add command -label Start \
+ -command "[typemodel $node].start $eid $node"
+ .button3menu add command -label Stop \
+ -command "[typemodel $node].shutdown $eid $node"
} else {
- .button3menu add cascade -label "Ethereal" \
- -menu .button3menu.ethereal -state disabled
- .button3menu add command -label start \
- -command "[typemodel $node].start $eid $node" -state disabled
- .button3menu add command -label stop \
- -command "[typemodel $node].stop $eid $node" -state disabled
+ .button3menu add cascade -label "Ethereal" \
+ -menu .button3menu.ethereal -state disabled
+ .button3menu add command -label start \
+ -command "[typemodel $node].start $eid $node" -state disabled
+ .button3menu add command -label stop \
+ -command "[typemodel $node].stop $eid $node" -state disabled
}
#
set x [winfo pointerx .]
set y [winfo pointery .]
tk_popup .button3menu $x $y
-
- return
}
nexec vimageShellServer.sh $node_id 1234 $cmd &
if { $gui_unix } {
exec xterm -sb -rightbar \
- -T "IMUNES: [getNodeName $node] (console)" \
- -e "nc $exec_host 1234" &
+ -T "IMUNES: [getNodeName $node] (console)" \
+ -e "nc $exec_host 1234" &
} else {
exec cmd /c nc $exec_host 1234 &
}
} else {
- nexec xterm -sb -rightbar \
- -T "IMUNES: [getNodeName $node] (console)" \
- -e "vimage $node_id $cmd" &
+ nexec xterm -sb -rightbar \
+ -T "IMUNES: [getNodeName $node] (console)" \
+ -e "vimage $node_id $cmd" &
}
}
set interface "$iface@$eid\_$node"
nexec ethereal -i $interface &
- return
}
# * button -- the keyboard button that is pressed.
#****
proc button1 { c x y button } {
- global node_list curcanvas
+ global node_list curcanvas zoom
global activetool newlink curobj changed def_router_model
global router pc host lanswitch frswitch rj45 hub
global lastX lastY
- global defLinkColor defLinkWidth background selectbox
+ global background selectbox
+ global defLinkColor defLinkWidth
set x [$c canvasx $x]
set y [$c canvasy $y]
set curobj [$c find withtag current]
set curtype [lindex [$c gettags current] 0]
if { $curtype == "node" || ( $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
- }
+ [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 { $button != "ctrl" || $activetool != "select" } {
- $c dtag node selected
- $c delete -withtags selectmark
- }
- if { $curobj == $background } {
- if { [lsearch {select link} $activetool] < 0 } {
- set node [newNode $activetool]
- setNodeCanvas $node $curcanvas
- setNodeCoords $node "$x $y"
- set dy 32
- if { [lsearch {router hub lanswitch rj45} $activetool] >= 0 } {
- set dy 24
- }
- setNodeLabelCoords $node "$x [expr $y + $dy]"
- drawNode $node
- selectNode $c [$c find withtag "node && $node"]
- set changed 1
- } 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 ""
- }
- }
+ $c dtag node selected
+ $c delete -withtags selectmark
+ }
+ if { [lsearch [.c gettags $curobj] background] != -1 } {
+ if { [lsearch {select link} $activetool] < 0 } {
+ set node [newNode $activetool]
+ setNodeCanvas $node $curcanvas
+ setNodeCoords $node "[expr {$x / $zoom}] [expr {$y / $zoom}]"
+ set dy 32
+ if { [lsearch {router hub lanswitch rj45} $activetool] >= 0 } {
+ set dy 24
+ }
+ setNodeLabelCoords $node "[expr {$x / $zoom}] \
+ [expr {$y / $zoom + $dy}]"
+ drawNode $node
+ selectNode $c [$c find withtag "node && $node"]
+ set changed 1
+ } 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 ""
+ }
+ }
} 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"]
- }
+ 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"]
+ }
}
$c raise link background
$c raise linklabel "link || background"
$c raise interface "linklabel || link || background"
$c raise node "interface || linklabel || link || background"
$c raise nodelabel "node || interface || linklabel || link || background"
- return
}
# * y -- y coordinate
#****
proc button1-motion { c x y } {
- global activetool newlink changed grid
+ global activetool newlink changed
global lastX lastY sizex sizey selectbox background
set x [$c canvasx $x]
set curobj [$c find withtag current]
set curtype [lindex [$c gettags current] 0]
if {$activetool == "link" && $newlink != ""} {
- $c coords $newlink $lastX $lastY $x $y
+ $c coords $newlink $lastX $lastY $x $y
} elseif { $activetool == "select" && \
- ( $curobj == $selectbox || $curobj == $background )} {
- 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
- }
+ ( $curobj == $selectbox || $curtype == "background" )} {
+ 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
+ }
} elseif { $activetool == "select" && $curtype == "nodelabel" \
&& [nodeType [lindex [$c gettags $curobj] 1]] != "pseudo" } {
- $c move $curobj [expr $x-$lastX] [expr $y-$lastY]
+ $c move $curobj [expr {$x - $lastX}] [expr {$y - $lastY}]
set changed 1
set lastX $x
set lastY $y
} else {
- foreach img [$c find withtag "selected"] {
- set node [lindex [$c gettags $img] 1]
- set img [$c find withtag "selectmark && $node"]
- $c move $img [expr $x-$lastX] [expr $y-$lastY]
+ foreach img [$c find withtag "selected"] {
+ set node [lindex [$c gettags $img] 1]
+ set img [$c find withtag "selectmark && $node"]
+ $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]
- $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
- set changed 1
- set lastX $x
- set lastY $y
+ $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}]
+ $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
+ set changed 1
+ set lastX $x
+ set lastY $y
}
- return
}
set link [newLink $lnode1 $lnode2]
if { $link == "" } {
- return
+ 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
+ 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
- return
}
# * y -- y coordinate
#****
proc button1-release { c x y } {
- global node_list
- global activetool newlink curobj grid
+ global node_list activetool newlink curobj grid
global changed undolog undolevel redolevel selectbox selected
- global lastX lastY sizex sizey
+ global lastX lastY sizex sizey zoom
global autorearrange_enabled
set x [$c canvasx $x]
$c config -cursor left_ptr
if {$activetool == "link" && $newlink != ""} {
- $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
- }
- }
- }
+ $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
+ }
+ }
+ }
}
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 [lindex $coords 0]
- set y [lindex $coords 1]
- if { $autorearrange_enabled } {
- set dx 0
- set dy 0
- } else {
- set dx [expr int($x / $grid + 0.5) * $grid - $x]
- set dy [expr int($y / $grid + 0.5) * $grid - $y]
- }
- $c move $img $dx $dy
- set coords [$c coords $img]
- set x [lindex $coords 0]
- set y [lindex $coords 1]
- setNodeCoords $node "$x $y"
- if {$x < 0 || $y < 0 || $x > $sizex || $y > $sizey} {
- set regular false
- }
- $c move "nodelabel && $node" $dx $dy
- set coords [$c coords "nodelabel && $node"]
- set x [lindex $coords 0]
- set y [lindex $coords 1]
- 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"
- }
- if {$regular == "true"} {
- foreach link [$c find withtag "link && need_redraw"] {
- redrawLink [lindex [$c gettags $link] 1]
- }
- } else {
- loadCfg $undolog($undolevel)
- redrawAll
- foreach node $selected {
- selectNode $c [$c find withtag "node && $node"]
- }
- set changed 0
- }
- $c dtag link need_redraw
+ 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} {
+ 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
+ }
+ setNodeCoords $node "$x $y"
+ if {$x < 0 || $y < 0 || $x > $sizex || $y > $sizey} {
+ set regular false
+ }
+ $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"
+ }
+ if {$regular == "true"} {
+ foreach link [$c find withtag "link && need_redraw"] {
+ redrawLink [lindex [$c gettags $link] 1]
+ }
+ } else {
+ .c config -cursor watch
+ loadCfg $undolog($undolevel)
+ redrawAll
+ if {$activetool == "select" } {
+ selectNodes $selected
+ }
+ set changed 0
+ }
+ $c dtag link need_redraw
} elseif {$activetool == "select" } {
- if {$selectbox == ""} {
- set x1 $x
- set y1 $y
- set autorearrange_enabled 0
- } 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 ""
- }
- set enclosed {}
- 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
- }
- }
- foreach obj $enclosed {
- selectNode $c $obj
- }
+ if {$selectbox == ""} {
+ set x1 $x
+ set y1 $y
+ set autorearrange_enabled 0
+ } 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 ""
+ }
+ set enclosed {}
+ 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
+ }
+ }
+ foreach obj $enclosed {
+ selectNode $c $obj
+ }
}
$c raise link background
$c raise linklabel "link || background"
$c raise nodelabel "node || interface || linklabel || link || background"
update
updateUndoLog
- return
}
set name [getNodeName $node]
set model [getNodeModel $node]
if { $model != "" } {
- set line "{$node} $name ($model):"
+ set line "{$node} $name ($model):"
} else {
- set line "{$node} $name:"
+ set line "{$node} $name:"
}
if { $type != "rj45" } {
- foreach ifc [ifcList $node] {
- set line "$line $ifc:[getIfcIPv4addr $node $ifc]"
- }
+ foreach ifc [ifcList $node] {
+ set line "$line $ifc:[getIfcIPv4addr $node $ifc]"
+ }
}
.bottom.textbox config -text "$line"
- return
}
set link [lindex [$c gettags current] 1]
if { [lsearch $link_list $link] == -1 } {
- return
+ return
}
set line "$link: [getLinkBandwidthString $link] [getLinkDelayString $link]"
.bottom.textbox config -text "$line"
- return
}
global activetool
.bottom.textbox config -text ""
- return
}
#****
proc checkIntRange { str low high } {
if { $str == "" } {
- return 1
+ return 1
}
set str [string trimleft $str 0]
if { $str == "" } {
- set str 0
+ set str 0
}
if { ![string is integer $str] } {
- return 0
+ return 0
}
if { $str < $low || $str > $high } {
- return 0
+ return 0
}
return 1
}
set bg white
if { $badentry == -1 } {
- return
+ return
} else {
- set badentry 1
+ 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
+ $W configure -foreground $fg -background $bg
+ set badentry 0
} else {
- $W configure -foreground $fg -background $bg
- }
- after 200 [list focusAndFlash $W [expr {$count-1}]]
+ if {$count%2} {
+ $W configure -foreground $bg -background $fg
+ } else {
+ $W configure -foreground $fg -background $bg
+ }
+ after 200 [list focusAndFlash $W [expr {$count - 1}]]
}
- return
}
# * c -- canvas id
#****
proc popupConfigDialog { c } {
- global activetool router_model supp_router_models oper_mode
+ global activetool router_model link_color supp_router_models oper_mode
global badentry curcanvas
set wi .popup
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
+ set object_type node
}
if { [lsearch {link linklabel} $tk_type] > -1 } {
- set object_type link
+ set object_type link
}
if { "$object_type" == ""} {
- destroy $wi
- return
+ destroy $wi
+ return
}
if { $object_type == "link" } {
- set n0 [lindex [linkPeers $target] 0]
- set n1 [lindex [linkPeers $target] 1]
- if { [nodeType $n0] == "rj45" || [nodeType $n1] == "rj45" } {
- destroy $wi
- return
- }
+ set n0 [lindex [linkPeers $target] 0]
+ set n1 [lindex [linkPeers $target] 1]
+ if { [nodeType $n0] == "rj45" || [nodeType $n1] == "rj45" } {
+ destroy $wi
+ return
+ }
}
$c dtag node selected
$c delete -withtags selectmark
node {
set type [nodeType $target]
if { $type == "pseudo" } {
- #
- # Hyperlink to another canvas
- #
- destroy $wi
- set curcanvas [getNodeCanvas [getNodeMirror $target]]
- switchCanvas none
- return
+ #
+ # 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"
frame $wi.ftop -borderwidth 4
if { $type == "rj45" } {
- label $wi.ftop.name_label -text "Physical interface:"
+ label $wi.ftop.name_label -text "Physical interface:"
} else {
- label $wi.ftop.name_label -text "Node name:"
+ label $wi.ftop.name_label -text "Node name:"
}
entry $wi.ftop.name -bg white -width 16 \
- -validate focus -invcmd "focusAndFlash %W"
+ -validate focus -invcmd "focusAndFlash %W"
$wi.ftop.name insert 0 [getNodeName $target]
pack $wi.ftop.name $wi.ftop.name_label -side right -padx 4 -pady 4
pack $wi.ftop -side top
if { $type == "router" } {
- frame $wi.model -borderwidth 4
- label $wi.model.label -text "Model:"
- if { $oper_mode == "edit" } {
- eval tk_optionMenu $wi.model.menu router_model \
- $supp_router_models
- } else {
- tk_optionMenu $wi.model.menu router_model $model
- }
- pack $wi.model.menu $wi.model.label -side right -padx 0 -pady 0
- pack $wi.model -side top
+ frame $wi.model -borderwidth 4
+ label $wi.model.label -text "Model:"
+ if { $oper_mode == "edit" } {
+ eval tk_optionMenu $wi.model.menu router_model \
+ $supp_router_models
+ } else {
+ tk_optionMenu $wi.model.menu router_model $model
+ }
+ pack $wi.model.menu $wi.model.label -side right -padx 0 -pady 0
+ pack $wi.model -side top
}
if { $type != "rj45" } {
- foreach ifc [lsort -ascii [ifcList $target]] {
- labelframe $wi.if$ifc -padx 4 -pady 4
- frame $wi.if$ifc.label
- label $wi.if$ifc.label.txt -text "Interface $ifc:"
- pack $wi.if$ifc.label.txt -side left -anchor w
- if {[[typemodel $target].layer] == "NETWORK"} {
- global ifoper$ifc
- set ifoper$ifc [getIfcOperState $target $ifc]
- radiobutton $wi.if$ifc.label.up -text "up" \
- -variable ifoper$ifc -value up
- radiobutton $wi.if$ifc.label.down -text "down" \
- -variable ifoper$ifc -value down
- label $wi.if$ifc.label.mtul -text "MTU" \
- -anchor e -width 5
- spinbox $wi.if$ifc.label.mtuv -bg white -width 4 \
- -validate focus -invcmd "focusAndFlash %W"
- $wi.if$ifc.label.mtuv insert 0 \
- [getIfcMTU $target $ifc]
- if {![string first eth $ifc]} {
- $wi.if$ifc.label.mtuv configure \
- -from 256 -to 1500 -increment 2 \
- -vcmd {checkIntRange %P 256 1500}
- } else {
- $wi.if$ifc.label.mtuv configure \
- -from 256 -to 2044 -increment 2 \
- -vcmd {checkIntRange %P 256 2044}
- }
- pack $wi.if$ifc.label.up $wi.if$ifc.label.down \
- $wi.if$ifc.label.mtul $wi.if$ifc.label.mtuv \
- -side left -anchor w
- }
- pack $wi.if$ifc.label -side top -anchor w
- frame $wi.if$ifc.tab -width 10
- frame $wi.if$ifc.cfg
-
- #
- # Queue config
- #
- global ifqdisc$ifc ifqdrop$ifc
- set ifqdisc$ifc [getIfcQDisc $target $ifc]
- set ifqdrop$ifc [getIfcQDrop $target $ifc]
- frame $wi.if$ifc.cfg.q
- label $wi.if$ifc.cfg.q.l1 -text "Queue" \
- -anchor w
- tk_optionMenu $wi.if$ifc.cfg.q.disc ifqdisc$ifc \
- FIFO DRR WFQ
- tk_optionMenu $wi.if$ifc.cfg.q.drop ifqdrop$ifc \
- drop-tail drop-head
- label $wi.if$ifc.cfg.q.l2 -text "len" \
- -anchor e -width 3
- spinbox $wi.if$ifc.cfg.q.len -bg white -width 4 \
- -validate focus -invcmd "focusAndFlash %W"
- $wi.if$ifc.cfg.q.len insert 0 [getIfcQLen $target $ifc]
- $wi.if$ifc.cfg.q.len configure \
- -from 5 -to 4096 -increment 1 \
- -vcmd {checkIntRange %P 5 4096}
- pack $wi.if$ifc.cfg.q.l1 $wi.if$ifc.cfg.q.disc \
- $wi.if$ifc.cfg.q.drop -side left -anchor w
- pack $wi.if$ifc.cfg.q.l2 $wi.if$ifc.cfg.q.len \
- -side left -anchor e
- pack $wi.if$ifc.cfg.q -side top -anchor w
-
- if {[lsearch {router pc host} $type] >= 0} {
- #
- # IPv4 address
- #
- frame $wi.if$ifc.cfg.ipv4
- label $wi.if$ifc.cfg.ipv4.addrl -text "IPv4 address" \
- -anchor w
- entry $wi.if$ifc.cfg.ipv4.addrv -bg white -width 30 \
- -validate focus -invcmd "focusAndFlash %W"
- $wi.if$ifc.cfg.ipv4.addrv insert 0 \
- [getIfcIPv4addr $target $ifc]
- $wi.if$ifc.cfg.ipv4.addrv configure \
- -vcmd {checkIPv4Net %P}
- pack $wi.if$ifc.cfg.ipv4.addrl \
- $wi.if$ifc.cfg.ipv4.addrv -side left
- pack $wi.if$ifc.cfg.ipv4 -side top -anchor w
-
- #
- # IPv6 address
- #
- frame $wi.if$ifc.cfg.ipv6
- label $wi.if$ifc.cfg.ipv6.addrl -text "IPv6 address" \
- -anchor w
- entry $wi.if$ifc.cfg.ipv6.addrv -bg white -width 30 \
- -validate focus -invcmd "focusAndFlash %W"
- $wi.if$ifc.cfg.ipv6.addrv insert 0 \
- [getIfcIPv6addr $target $ifc]
- $wi.if$ifc.cfg.ipv6.addrv configure \
- -vcmd {checkIPv6Net %P}
- pack $wi.if$ifc.cfg.ipv6.addrl \
- $wi.if$ifc.cfg.ipv6.addrv -side left
- pack $wi.if$ifc.cfg.ipv6 -side top -anchor w
- }
- pack $wi.if$ifc.tab $wi.if$ifc.cfg -side left
- pack $wi.if$ifc -side top -anchor w -fill both
- }
+ foreach ifc [lsort -ascii [ifcList $target]] {
+ labelframe $wi.if$ifc -padx 4 -pady 4
+ frame $wi.if$ifc.label
+ label $wi.if$ifc.label.txt -text "Interface $ifc:"
+ pack $wi.if$ifc.label.txt -side left -anchor w
+ if {[[typemodel $target].layer] == "NETWORK"} {
+ global ifoper$ifc
+ set ifoper$ifc [getIfcOperState $target $ifc]
+ radiobutton $wi.if$ifc.label.up -text "up" \
+ -variable ifoper$ifc -value up
+ radiobutton $wi.if$ifc.label.down -text "down" \
+ -variable ifoper$ifc -value down
+ label $wi.if$ifc.label.mtul -text "MTU" \
+ -anchor e -width 5
+ spinbox $wi.if$ifc.label.mtuv -bg white -width 4 \
+ -validate focus -invcmd "focusAndFlash %W"
+ $wi.if$ifc.label.mtuv insert 0 \
+ [getIfcMTU $target $ifc]
+ if {![string first eth $ifc]} {
+ $wi.if$ifc.label.mtuv configure \
+ -from 256 -to 1500 -increment 2 \
+ -vcmd {checkIntRange %P 256 1500}
+ } else {
+ $wi.if$ifc.label.mtuv configure \
+ -from 256 -to 2044 -increment 2 \
+ -vcmd {checkIntRange %P 256 2044}
+ }
+ pack $wi.if$ifc.label.up $wi.if$ifc.label.down \
+ $wi.if$ifc.label.mtul $wi.if$ifc.label.mtuv \
+ -side left -anchor w
+ }
+ pack $wi.if$ifc.label -side top -anchor w
+ frame $wi.if$ifc.tab -width 10
+ frame $wi.if$ifc.cfg
+
+ #
+ # Queue config
+ #
+ global ifqdisc$ifc ifqdrop$ifc
+ set ifqdisc$ifc [getIfcQDisc $target $ifc]
+ set ifqdrop$ifc [getIfcQDrop $target $ifc]
+ frame $wi.if$ifc.cfg.q
+ label $wi.if$ifc.cfg.q.l1 -text "Queue" -anchor w
+ tk_optionMenu $wi.if$ifc.cfg.q.disc ifqdisc$ifc \
+ FIFO DRR WFQ
+ tk_optionMenu $wi.if$ifc.cfg.q.drop ifqdrop$ifc \
+ drop-tail drop-head
+ label $wi.if$ifc.cfg.q.l2 -text "len" \
+ -anchor e -width 3
+ spinbox $wi.if$ifc.cfg.q.len -bg white -width 4 \
+ -validate focus -invcmd "focusAndFlash %W"
+ $wi.if$ifc.cfg.q.len insert 0 [getIfcQLen $target $ifc]
+ $wi.if$ifc.cfg.q.len configure \
+ -from 5 -to 4096 -increment 1 \
+ -vcmd {checkIntRange %P 5 4096}
+ pack $wi.if$ifc.cfg.q.l1 $wi.if$ifc.cfg.q.disc \
+ $wi.if$ifc.cfg.q.drop -side left -anchor w
+ pack $wi.if$ifc.cfg.q.l2 $wi.if$ifc.cfg.q.len \
+ -side left -anchor e
+ pack $wi.if$ifc.cfg.q -side top -anchor w
+
+ if {[lsearch {router pc host} $type] >= 0} {
+ #
+ # IPv4 address
+ #
+ frame $wi.if$ifc.cfg.ipv4
+ label $wi.if$ifc.cfg.ipv4.addrl -text "IPv4 address" \
+ -anchor w
+ entry $wi.if$ifc.cfg.ipv4.addrv -bg white -width 30 \
+ -validate focus -invcmd "focusAndFlash %W"
+ $wi.if$ifc.cfg.ipv4.addrv insert 0 \
+ [getIfcIPv4addr $target $ifc]
+ $wi.if$ifc.cfg.ipv4.addrv configure \
+ -vcmd {checkIPv4Net %P}
+ pack $wi.if$ifc.cfg.ipv4.addrl \
+ $wi.if$ifc.cfg.ipv4.addrv -side left
+ pack $wi.if$ifc.cfg.ipv4 -side top -anchor w
+
+ #
+ # IPv6 address
+ #
+ frame $wi.if$ifc.cfg.ipv6
+ label $wi.if$ifc.cfg.ipv6.addrl -text "IPv6 address" \
+ -anchor w
+ entry $wi.if$ifc.cfg.ipv6.addrv -bg white -width 30 \
+ -validate focus -invcmd "focusAndFlash %W"
+ $wi.if$ifc.cfg.ipv6.addrv insert 0 \
+ [getIfcIPv6addr $target $ifc]
+ $wi.if$ifc.cfg.ipv6.addrv configure -vcmd {checkIPv6Net %P}
+ pack $wi.if$ifc.cfg.ipv6.addrl \
+ $wi.if$ifc.cfg.ipv6.addrv -side left
+ pack $wi.if$ifc.cfg.ipv6 -side top -anchor w
+ }
+ pack $wi.if$ifc.tab $wi.if$ifc.cfg -side left
+ pack $wi.if$ifc -side top -anchor w -fill both
+ }
}
if {[lsearch {router pc host} $type] >= 0} {
- #
- # Static routes
- #
- set routes [concat [getStatIPv4routes $target] \
- [getStatIPv6routes $target]]
- labelframe $wi.statrt -padx 4 -pady 4
- label $wi.statrt.label -text "Static routes:"
- pack $wi.statrt.label -side top -anchor w
- frame $wi.statrt.tab -width 10
- frame $wi.statrt.tab1 -width 10
- frame $wi.statrt.cfg
- set h [expr [llength $routes] + 1]
- if { $h < 2 } {
- set h 2
- }
- text $wi.statrt.cfg.text -font arial -bg white \
- -width 42 -height $h -takefocus 0
- foreach route $routes {
- $wi.statrt.cfg.text insert end "$route\r"
- }
- pack $wi.statrt.cfg.text -expand yes
- pack $wi.statrt.tab $wi.statrt.cfg $wi.statrt.tab1 -side left
- pack $wi.statrt -side top -anchor w -fill both
+ #
+ # Static routes
+ #
+ set routes [concat [getStatIPv4routes $target] \
+ [getStatIPv6routes $target]]
+ labelframe $wi.statrt -padx 4 -pady 4
+ label $wi.statrt.label -text "Static routes:"
+ pack $wi.statrt.label -side top -anchor w
+ frame $wi.statrt.tab -width 10
+ frame $wi.statrt.tab1 -width 10
+ frame $wi.statrt.cfg
+ set h [expr {[llength $routes] + 1}]
+ if { $h < 2 } {
+ set h 2
+ }
+ text $wi.statrt.cfg.text -font arial -bg white \
+ -width 42 -height $h -takefocus 0
+ foreach route $routes {
+ $wi.statrt.cfg.text insert end "$route\r"
+ }
+ pack $wi.statrt.cfg.text -expand yes
+ pack $wi.statrt.tab $wi.statrt.cfg $wi.statrt.tab1 -side left
+ pack $wi.statrt -side top -anchor w -fill both
}
if {[lsearch {router pc host} $type] >= 0} {
- #
- # Custom startup config
- #
- global customEnabled
- labelframe $wi.custom -padx 4 -pady 4
- frame $wi.custom.label
- label $wi.custom.label.txt -text "Custom startup config:"
- pack $wi.custom.label.txt -side left -anchor w
- set customEnabled [getCustomEnabled $target]
- radiobutton $wi.custom.label.enabled -text "enabled" \
- -variable customEnabled -value true
- radiobutton $wi.custom.label.disabled -text "disabled" \
- -variable customEnabled -value false
- pack $wi.custom.label.enabled $wi.custom.label.disabled \
- -side left -anchor w
- pack $wi.custom.label -side top -anchor w
- frame $wi.custom.cfg
- button $wi.custom.cfg.generate -text "Generate" \
- -command "cfgGenerate $target"
- button $wi.custom.cfg.edit -text "Edit" \
- -command "editStartupCfg $target 0"
- button $wi.custom.cfg.clear -text "Clear" \
- -command "setCustomConfig $target {} {} {} 0"
- pack $wi.custom.cfg.generate $wi.custom.cfg.edit \
- $wi.custom.cfg.clear -side left
-
- pack $wi.custom.label -side top -anchor w
- pack $wi.custom.cfg -side top
- pack $wi.custom -side top -anchor w -fill both
-
- #
- # IPsec configuration:
- #
- global ipsecEnabled
- global showIPsecConfig
- if { $showIPsecConfig == 1 } {
+ #
+ # Custom startup config
+ #
+ global customEnabled
+ labelframe $wi.custom -padx 4 -pady 4
+ frame $wi.custom.label
+ label $wi.custom.label.txt -text "Custom startup config:"
+ pack $wi.custom.label.txt -side left -anchor w
+ set customEnabled [getCustomEnabled $target]
+ radiobutton $wi.custom.label.enabled -text "enabled" \
+ -variable customEnabled -value true
+ radiobutton $wi.custom.label.disabled -text "disabled" \
+ -variable customEnabled -value false
+ pack $wi.custom.label.enabled $wi.custom.label.disabled \
+ -side left -anchor w
+ pack $wi.custom.label -side top -anchor w
+ frame $wi.custom.cfg
+ button $wi.custom.cfg.generate -text "Generate" \
+ -command "cfgGenerate $target"
+ button $wi.custom.cfg.edit -text "Edit" \
+ -command "editStartupCfg $target 0"
+ button $wi.custom.cfg.clear -text "Clear" \
+ -command "setCustomConfig $target {} {} {} 0"
+ pack $wi.custom.cfg.generate $wi.custom.cfg.edit \
+ $wi.custom.cfg.clear -side left
+
+ pack $wi.custom.label -side top -anchor w
+ pack $wi.custom.cfg -side top
+ pack $wi.custom -side top -anchor w -fill both
+
+ #
+ # IPsec configuration:
+ #
+ global ipsecEnabled
+ global showIPsecConfig
+ if { $showIPsecConfig == 1 } {
labelframe $wi.ipsec -padx 4 -pady 4
- frame $wi.ipsec.label
- label $wi.ipsec.label.txt -text "Manual IPsec configuration:"
- pack $wi.ipsec.label.txt -side left -anchor w
- set ipsecEnabled [getIpsecEnabled $target]
- radiobutton $wi.ipsec.label.enabled -text "enabled" \
- -variable ipsecEnabled -value true
- radiobutton $wi.ipsec.label.disabled -text "disabled" \
- -variable ipsecEnabled -value false
- pack $wi.ipsec.label.enabled $wi.ipsec.label.disabled \
- -side left -anchor w
- pack $wi.ipsec.label -side top -anchor w
- frame $wi.ipsec.cfg
- set delete "0"
- set view "0"
- button $wi.ipsec.cfg.add -text "Add SA/SP" \
- -command "viewIpsecCfg $target $delete $view"
- set delete "0"
- set view "1"
- button $wi.ipsec.cfg.view -text "Edit SAs/SPs" \
- -command "viewIpsecCfg $target $delete $view"
- pack $wi.ipsec.cfg.add \
- $wi.ipsec.cfg.view -side left
- pack $wi.ipsec.label -side top -anchor w
- pack $wi.ipsec.cfg -side top
- pack $wi.ipsec -side top -anchor w -fill both
- }
+ frame $wi.ipsec.label
+ label $wi.ipsec.label.txt -text "Manual IPsec configuration:"
+ pack $wi.ipsec.label.txt -side left -anchor w
+ set ipsecEnabled [getIpsecEnabled $target]
+ radiobutton $wi.ipsec.label.enabled -text "enabled" \
+ -variable ipsecEnabled -value true
+ radiobutton $wi.ipsec.label.disabled -text "disabled" \
+ -variable ipsecEnabled -value false
+ pack $wi.ipsec.label.enabled $wi.ipsec.label.disabled \
+ -side left -anchor w
+ pack $wi.ipsec.label -side top -anchor w
+ frame $wi.ipsec.cfg
+ set delete "0"
+ set view "0"
+ button $wi.ipsec.cfg.add -text "Add SA/SP" \
+ -command "viewIpsecCfg $target $delete $view"
+ set delete "0"
+ set view "1"
+ button $wi.ipsec.cfg.view -text "Edit SAs/SPs" \
+ -command "viewIpsecCfg $target $delete $view"
+ pack $wi.ipsec.cfg.add $wi.ipsec.cfg.view -side left
+ pack $wi.ipsec.label -side top -anchor w
+ pack $wi.ipsec.cfg -side top
+ pack $wi.ipsec -side top -anchor w -fill both
+ }
- #
- # CPU scheduling parameters
- #
- labelframe $wi.cpu -padx 4 -pady 4
- label $wi.cpu.minl -text "CPU min%" -anchor w
- spinbox $wi.cpu.mine -bg white -width 3 \
- -validate focus -invcmd "focusAndFlash %W"
- $wi.cpu.mine insert 0 [lindex \
- [lsearch -inline [getNodeCPUConf $target] {min *}] 1]
- $wi.cpu.mine configure \
- -vcmd {checkIntRange %P 1 90} \
- -from 0 -to 90 -increment 1
- label $wi.cpu.maxl -text " max%" -anchor w
- spinbox $wi.cpu.maxe -bg white -width 3 \
- -validate focus -invcmd "focusAndFlash %W"
- set cpumax [lindex \
- [lsearch -inline [getNodeCPUConf $target] {max *}] 1]
- if { $cpumax == "" } {
- set cpumax 100
- }
- $wi.cpu.maxe insert 0 $cpumax
- $wi.cpu.maxe configure \
- -vcmd {checkIntRange %P 1 100} \
- -from 1 -to 100 -increment 1
- label $wi.cpu.weightl -text " weight" -anchor w
- spinbox $wi.cpu.weighte -bg white -width 2 \
- -validate focus -invcmd "focusAndFlash %W"
- $wi.cpu.weighte insert 0 [lindex \
- [lsearch -inline [getNodeCPUConf $target] {weight *}] 1]
- $wi.cpu.weighte configure \
- -vcmd {checkIntRange %P 1 10} \
- -from 1 -to 10 -increment 1
- pack $wi.cpu.minl $wi.cpu.mine \
- $wi.cpu.maxl $wi.cpu.maxe \
- $wi.cpu.weightl $wi.cpu.weighte -side left
- pack $wi.cpu -side top -anchor w -fill both
+ #
+ # CPU scheduling parameters
+ #
+ labelframe $wi.cpu -padx 4 -pady 4
+ label $wi.cpu.minl -text "CPU min%" -anchor w
+ spinbox $wi.cpu.mine -bg white -width 3 \
+ -validate focus -invcmd "focusAndFlash %W"
+ $wi.cpu.mine insert 0 [lindex \
+ [lsearch -inline [getNodeCPUConf $target] {min *}] 1]
+ $wi.cpu.mine configure \
+ -vcmd {checkIntRange %P 1 90} \
+ -from 0 -to 90 -increment 1
+ label $wi.cpu.maxl -text " max%" -anchor w
+ spinbox $wi.cpu.maxe -bg white -width 3 \
+ -validate focus -invcmd "focusAndFlash %W"
+ set cpumax [lindex \
+ [lsearch -inline [getNodeCPUConf $target] {max *}] 1]
+ if { $cpumax == "" } {
+ set cpumax 100
+ }
+ $wi.cpu.maxe insert 0 $cpumax
+ $wi.cpu.maxe configure \
+ -vcmd {checkIntRange %P 1 100} \
+ -from 1 -to 100 -increment 1
+ label $wi.cpu.weightl -text " weight" -anchor w
+ spinbox $wi.cpu.weighte -bg white -width 2 \
+ -validate focus -invcmd "focusAndFlash %W"
+ $wi.cpu.weighte insert 0 [lindex \
+ [lsearch -inline [getNodeCPUConf $target] {weight *}] 1]
+ $wi.cpu.weighte configure \
+ -vcmd {checkIntRange %P 1 10} \
+ -from 1 -to 10 -increment 1
+ pack $wi.cpu.minl $wi.cpu.mine \
+ $wi.cpu.maxl $wi.cpu.maxe \
+ $wi.cpu.weightl $wi.cpu.weighte -side left
+ pack $wi.cpu -side top -anchor w -fill both
}
}
link {
-from 0 -to 50 -increment 1
pack $wi.dup.value $wi.dup.label -side right
pack $wi.dup -side top -anchor e
+
+ frame $wi.color -borderwidth 4
+ 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
+ pack $wi.color.value $wi.color.label -side right
+ pack $wi.color -side top -anchor e
+
+ frame $wi.width -borderwidth 4
+ label $wi.width.label -anchor e -text "Width:"
+ spinbox $wi.width.value -bg white -justify right -width 10 \
+ -validate focus -invcmd "focusAndFlash %W"
+ $wi.width.value insert 0 [getLinkWidth $target]
+ $wi.width.value configure \
+ -vcmd {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
}
}
pack $wi.butt.cancel $wi.butt.apply -side right
pack $wi.butt -side bottom
after 100 {
- grab .popup
+ grab .popup
}
- return
}
# * node_id -- node id
#****
proc cfgGenerate { node } {
- set id "generic"
- set cmd [[typemodel $node].bootcmd $node]
- set cfg [[typemodel $node].cfggen $node]
+ set id "generic"
+ set cmd [[typemodel $node].bootcmd $node]
+ set cfg [[typemodel $node].cfggen $node]
setCustomConfig $node $id $cmd $cfg 0
}
# Creates an edit startup configuration dialog box.
# INPUTS
# * node_id -- node id
-# * deleted -- if deleted is set to 1, editStartupCfg
-# has been invoked after deleting custom-config
-# with specified custom-config-id.
+# * deleted -- if deleted is set to 1, editStartupCfg
+# has been invoked after deleting custom-config
+# with specified custom-config-id.
#****
proc editStartupCfg { node deleted } {
+ global viewcustomid
- set customCfgList ""
- set customCfgList [getCustomConfig $node]
- set customidlist {}
- foreach customCfg $customCfgList {
- set customid [lindex [lsearch -inline $customCfg \
- "custom-config-id *"] 1]
- lappend customidlist $customid
- }
+ set customCfgList ""
+ set customCfgList [getCustomConfig $node]
+ set customidlist {}
+ foreach customCfg $customCfgList {
+ set customid [lindex [lsearch -inline $customCfg \
+ "custom-config-id *"] 1]
+ lappend customidlist $customid
+ }
- global viewcustomid
- set edit 1
+ set edit 1
if { $deleted == "1" } {
set viewcustomid [lindex $customidlist 0]
}
- if { $customidlist == "" } {
- set warning "Custom config list is empty."
+ if { $customidlist == "" } {
+ set warning "Custom config list is empty."
tk_messageBox -message $warning -type ok -icon warning \
- -title "Custom configuration warning"
- } else {
-
- set w .cfgeditor
- catch {destroy $w}
- toplevel $w -takefocus 1
- #wm transient $w .
- grab $w
- wm title $w "Custom config $node"
- wm iconname $w "$node"
-
+ -title "Custom configuration warning"
+ } else {
+ set w .cfgeditor
+ catch {destroy $w}
+ toplevel $w -takefocus 1
+ grab $w
+ wm title $w "Custom config $node"
+ wm iconname $w "$node"
labelframe $w.custom -padx 4 -pady 4
- if { $edit == "1" } {
- frame $w.custom.viewid -borderwidth 4
- label $w.custom.viewid.label -text "View custom-config:"
- pack $w.custom.viewid.label -side left -anchor w
- eval {tk_optionMenu $w.custom.viewid.optmenu viewcustomid} $customidlist
- pack $w.custom.viewid.label $w.custom.viewid.optmenu \
- -side left -anchor w
- pack $w.custom.viewid -side top -anchor w
- button $w.custom.viewid.button -text View \
- -command "editStartupCfg $node 0"
- pack $w.custom.viewid.button -side right
-
- foreach element $customCfgList {
- set cid [lindex [lsearch -inline $element "custom-config-id *"] 1]
+ if { $edit == "1" } {
+ frame $w.custom.viewid -borderwidth 4
+ label $w.custom.viewid.label -text "View custom-config:"
+ pack $w.custom.viewid.label -side left -anchor w
+ eval {tk_optionMenu $w.custom.viewid.optmenu viewcustomid} \
+ $customidlist
+ pack $w.custom.viewid.label $w.custom.viewid.optmenu \
+ -side left -anchor w
+ pack $w.custom.viewid -side top -anchor w
+ button $w.custom.viewid.button -text View \
+ -command "editStartupCfg $node 0"
+ pack $w.custom.viewid.button -side right
+
+ foreach element $customCfgList {
+ set cid \
+ [lindex [lsearch -inline $element "custom-config-id *"] 1]
if { $viewcustomid == $cid } {
- set customCfg $element
- }
- }
- }
+ set customCfg $element
+ }
+ }
+ }
frame $w.custom.id -borderwidth 4
label $w.custom.id.label -text "Custom config id:"
entry $w.custom.id.text -bg white -width 30
if { $customCfg != {} } {
- set ccfg [getConfig $customCfg "custom-config-id"]
+ set ccfg [getConfig $customCfg "custom-config-id"]
} else {
- set ccfg ""
+ set ccfg ""
}
$w.custom.id.text insert 0 $ccfg
pack $w.custom.id.text $w.custom.id.label -side right -padx 4 -pady 4
pack $w.custom.id -side top -anchor w
pack $w.custom -side top -anchor w -fill both
- frame $w.ftop -borderwidth 4
- label $w.ftop.label -text "Startup command:"
- entry $w.ftop.cmd -bg white -width 64
+ frame $w.ftop -borderwidth 4
+ label $w.ftop.label -text "Startup command:"
+ entry $w.ftop.cmd -bg white -width 64
if { $customCfg != {} } {
- set ccmd [getConfig $customCfg "custom-command"]
+ set ccmd [getConfig $customCfg "custom-command"]
} else {
- set ccmd ""
+ set ccmd ""
}
$w.ftop.cmd insert 0 $ccmd
pack $w.ftop.cmd $w.ftop.label -side right -padx 4 -pady 4
- pack $w.ftop -side top -anchor w
-
- text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" \
- -setgrid 1 -height 20 -undo 1 -autosep 1 -background white
- focus $w.text
- scrollbar $w.scroll -command "$w.text yview"
-
- frame $w.buttons
- pack $w.buttons -side bottom
- button $w.buttons.apply -text "Apply" \
- -command "customConfigApply $w $node"
- button $w.buttons.close -text Close -command "destroy $w"
+ pack $w.ftop -side top -anchor w
+
+ text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" \
+ -setgrid 1 -height 20 -undo 1 -autosep 1 -background white
+ focus $w.text
+ scrollbar $w.scroll -command "$w.text yview"
+
+ frame $w.buttons
+ pack $w.buttons -side bottom
+ button $w.buttons.apply -text "Apply" \
+ -command "customConfigApply $w $node"
+ button $w.buttons.close -text Close -command "destroy $w"
button $w.buttons.delete -text Delete -command \
- "deleteCustomConfig $w $node $viewcustomid {} {} 1"
- pack $w.buttons.apply $w.buttons.close $w.buttons.delete -side left
+ "deleteCustomConfig $w $node $viewcustomid {} {} 1"
+ pack $w.buttons.apply $w.buttons.close $w.buttons.delete -side left
- pack $w.scroll -side right -fill y
- pack $w.text -expand yes -fill both
+ pack $w.scroll -side right -fill y
+ pack $w.text -expand yes -fill both
if { $customCfg != {} } {
- set ccfg [getConfig $customCfg "config"]
+ set ccfg [getConfig $customCfg "config"]
} else {
- set ccfg ""
+ set ccfg ""
}
- foreach line $ccfg {
- $w.text insert end "$line\n"
- }
- $w.text mark set insert 0.0
+ foreach line $ccfg {
+ $w.text insert end "$line\n"
}
- return
+ $w.text mark set insert 0.0
+ }
}
#****f* editor.tcl/customConfigApply
global changed
set newcmd [$w.ftop.cmd get]
- set newid [$w.custom.id.text get]
+ set newid [$w.custom.id.text get]
set newconf [split [$w.text get 0.0 end] "\n"]
- while { [lindex $newconf end] == {} && $newconf != {} } {
- set newconf [lreplace $newconf end end]
+ while { [lindex $newconf end] == {} && $newconf != {} } {
+ set newconf [lreplace $newconf end end]
}
- # TODO:
if { [getCustomCmd $node] != $newcmd || \
- [getCustomConfig $node] != $newconf } {
- set changed 1
+ [getCustomConfig $node] != $newconf } {
+ set changed 1
}
setCustomConfig $node $newid $newcmd $newconf 0
destroy $w
- editStartupCfg $node 0
- return
+ editStartupCfg $node 0
}
#****f* editor.tcl/popupConfigApply
# set to 0.
#****
proc popupConfigApply { wi object_type target phase } {
- global changed oper_mode router_model badentry
+ global changed oper_mode router_model link_color badentry
global customEnabled ipsecEnabled
global eid
- global showIPsecConfig
+ global showIPsecConfig
$wi config -cursor watch
update
if { $phase == 0 } {
- set badentry 0
- focus .
- after 100 "popupConfigApply $wi $object_type $target 1"
- return
+ set badentry 0
+ focus .
+ after 100 "popupConfigApply $wi $object_type $target 1"
+ return
} elseif { $badentry } {
- $wi config -cursor left_ptr
- return
+ $wi config -cursor left_ptr
+ return
}
switch -exact -- $object_type {
#
set model [getNodeModel $target]
set name [string trim [$wi.ftop.name get]]
if { $name != [getNodeName $target] } {
- setNodeName $target $name
- set changed 1
+ setNodeName $target $name
+ set changed 1
}
if { $oper_mode == "edit" && $type == "router" && \
- $router_model != $model } {
- setNodeModel $target $router_model
- set changed 1
+ $router_model != $model } {
+ setNodeModel $target $router_model
+ set changed 1
}
#
# Queue config
#
foreach ifc [ifcList $target] {
- if { [nodeType [peerByIfc $target $ifc]] != "rj45" && \
- [nodeType $target] != "rj45" } {
- global ifqdisc$ifc ifqdrop$ifc
- set qdisc [subst $[subst ifqdisc$ifc]]
- set oldqdisc [getIfcQDisc $target $ifc]
- if { $qdisc != $oldqdisc } {
- setIfcQDisc $target $ifc $qdisc
- set changed 1
- }
- set qdrop [subst $[subst ifqdrop$ifc]]
- set oldqdrop [getIfcQDrop $target $ifc]
- if { $qdrop != $oldqdrop } {
- setIfcQDrop $target $ifc $qdrop
- set changed 1
- }
- set len [$wi.if$ifc.cfg.q.len get]
- set oldlen [getIfcQLen $target $ifc]
- if { $len != $oldlen } {
- setIfcQLen $target $ifc $len
- set changed 1
- }
- }
- }
+ if { [nodeType [peerByIfc $target $ifc]] != "rj45" && \
+ [nodeType $target] != "rj45" } {
+ global ifqdisc$ifc ifqdrop$ifc
+ set qdisc [subst $[subst ifqdisc$ifc]]
+ set oldqdisc [getIfcQDisc $target $ifc]
+ if { $qdisc != $oldqdisc } {
+ setIfcQDisc $target $ifc $qdisc
+ set changed 1
+ }
+ set qdrop [subst $[subst ifqdrop$ifc]]
+ set oldqdrop [getIfcQDrop $target $ifc]
+ if { $qdrop != $oldqdrop } {
+ setIfcQDrop $target $ifc $qdrop
+ set changed 1
+ }
+ set len [$wi.if$ifc.cfg.q.len get]
+ set oldlen [getIfcQLen $target $ifc]
+ if { $len != $oldlen } {
+ setIfcQLen $target $ifc $len
+ set changed 1
+ }
+ }
+ }
if {[[typemodel $target].layer] == "NETWORK"} {
- foreach ifc [ifcList $target] {
+ foreach ifc [ifcList $target] {
#
# Operational state
#
set mirror [getLinkMirror $target]
set bw [$wi.bandwidth.value get]
if { $bw != [getLinkBandwidth $target] } {
- setLinkBandwidth $target [$wi.bandwidth.value get]
- if { $mirror != "" } {
- setLinkBandwidth $mirror [$wi.bandwidth.value get]
- }
- set changed 1
+ setLinkBandwidth $target [$wi.bandwidth.value get]
+ if { $mirror != "" } {
+ setLinkBandwidth $mirror [$wi.bandwidth.value get]
+ }
+ set changed 1
}
set dly [$wi.delay.value get]
if { $dly != [getLinkDelay $target] } {
- setLinkDelay $target [$wi.delay.value get]
- if { $mirror != "" } {
- setLinkDelay $mirror [$wi.delay.value get]
- }
- set changed 1
+ setLinkDelay $target [$wi.delay.value get]
+ if { $mirror != "" } {
+ setLinkDelay $mirror [$wi.delay.value get]
+ }
+ set changed 1
}
set ber [$wi.ber.value get]
if { $ber != [getLinkBER $target] } {
- setLinkBER $target [$wi.ber.value get]
- if { $mirror != "" } {
- setLinkBER $mirror [$wi.ber.value get]
- }
- set changed 1
+ setLinkBER $target [$wi.ber.value get]
+ if { $mirror != "" } {
+ setLinkBER $mirror [$wi.ber.value get]
+ }
+ set changed 1
}
set dup [$wi.dup.value get]
if { $dup != [getLinkDup $target] } {
- setLinkDup $target [$wi.dup.value get]
- if { $mirror != "" } {
- setLinkDup $mirror [$wi.dup.value get]
- }
- set changed 1
- }
- if { $changed == 1 && $oper_mode == "exec" } {
- execSetLinkParams $eid $target
- }
+ setLinkDup $target [$wi.dup.value get]
+ if { $mirror != "" } {
+ setLinkDup $mirror [$wi.dup.value get]
+ }
+ 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 [$wi.width.value get]
+ if { $mirror != "" } {
+ setLinkWidth $mirror [$wi.width.value get]
+ }
+ set changed 1
+ }
+ if { $changed == 1 && $oper_mode == "exec" } {
+ execSetLinkParams $eid $target
+ }
}
}
if { $changed == 1 } {
- redrawAll
+ redrawAll
updateUndoLog
}
destroy $wi
proc deleteSelection { } {
global changed
global background
- global viewid
- catch {unset viewid}
-
+ global viewid
+ catch {unset viewid}
+ .c config -cursor watch; update
+
foreach obj [.c find withtag "node && selected"] {
- set lnode [lindex [.c gettags $obj] 1]
- if { $lnode != "" } {
- removeGUINode $lnode
- }
- set changed 1
+ set lnode [lindex [.c gettags $obj] 1]
+ if { $lnode != "" } {
+ removeGUINode $lnode
+ }
+ set changed 1
}
.c raise link background
.c raise linklabel "link || background"
.c raise node "interface || linklabel || link || background"
.c raise nodelabel "node || interface || linklabel || link || background"
updateUndoLog
+ .c config -cursor left_ptr
+ .bottom.textbox config -text ""
+}
+
+
+proc align2grid {} {
+ global sizex sizey grid zoom
+
+ 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"
+ set dy 32
+ if { [lsearch {router hub lanswitch rj45} \
+ [nodeType $node]] >= 0 } {
+ set dy 24
+ }
+ setNodeLabelCoords $node "$x [expr {$y + $dy}]"
+ }
+ }
}
# rearranged.
#****
proc rearrange { mode } {
- global link_list autorearrange_enabled sizex sizey curcanvas
+ global link_list autorearrange_enabled sizex sizey curcanvas zoom
set autorearrange_enabled 1
- .menubar.tools entryconfigure "Rearrange all" -state disabled
- .menubar.tools entryconfigure "Rearrange selected" -state disabled
+ .menubar.tools entryconfigure "Auto rearrange all" -state disabled
+ .menubar.tools entryconfigure "Auto rearrange selected" -state disabled
.bottom.mbuf config -text "autorearrange"
if { $mode == "selected" } {
- set tagmatch "node && selected"
+ set tagmatch "node && selected"
} else {
- set tagmatch "node"
+ 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 [lindex $coords 0]
- set y [lindex $coords 1]
- 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]
- }
+ 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
+ }
- 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]
- }
+ 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 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]
+ 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"
- .c move $obj $dx $dy
- set img [.c find withtag "selectmark && $node"]
- .c move $img $dx $dy
- set img [.c find withtag "nodelabel && $node"]
- .c move $img $dx $dy
- setNodeLabelCoords $node [.c coords $img]
- .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
+ 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
}
- .menubar.tools entryconfigure "Rearrange all" -state normal
- .menubar.tools entryconfigure "Rearrange selected" -state normal
+ .menubar.tools entryconfigure "Auto rearrange all" -state normal
+ .menubar.tools entryconfigure "Auto rearrange selected" -state normal
.bottom.mbuf config -text ""
- return
}
#****
proc switchCanvas { direction } {
global canvas_list curcanvas
+ global sizex sizey
set i [lsearch $canvas_list $curcanvas]
switch -exact -- $direction {
-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 \
+ 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 \
+ 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 coords $text [expr {$x + $ox + 12}] [expr {$oy + 2}]
.hframe.t raise $text
- incr x [expr 2 * $ox + 17]
+ incr x [expr {2 * $ox + 17}]
}
incr x 7
.hframe.t raise "$curcanvas"
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]
+ 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]
+ .hframe.t xview moveto [expr {1.0 * ($lborder - 10) / $x}]
}
if { $rborder > $rmargin } {
- .hframe.t xview moveto [expr 1.0 * ($rborder - $width + 10) / $x]
+ .hframe.t xview moveto [expr {1.0 * ($rborder - $width + 10) / $x}]
}
+ set sizex [lindex [getCanvasSize $curcanvas] 0]
+ set sizey [lindex [getCanvasSize $curcanvas] 1]
+
redrawAll
- return
}
pack $w.e1 -side top -pady 5 -padx 10 -fill x
}
+proc resizeCanvasPopup {} {
+ global curcanvas
+
+ set w .entry1
+ catch {destroy $w}
+ toplevel $w -takefocus 1
+ update
+ grab $w
+ wm title $w "Canvas resize"
+ wm iconname $w "Canvas resize"
+
+ label $w.msg -wraplength 5i -justify left -text "Canvas size:"
+ pack $w.msg -side top
+
+ 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
+
+ frame $w.size
+ pack $w.size -side top -fill x -pady 2m
+ spinbox $w.size.x -bg white -width 4 \
+ -validate focus -invcmd "focusAndFlash %W"
+ $w.size.x insert 0 [lindex [getCanvasSize $curcanvas] 0]
+ $w.size.x configure -from 800 -to 4096 -increment 2 \
+ -vcmd {checkIntRange %P 800 4096}
+ label $w.size.label -text "*"
+ spinbox $w.size.y -bg white -width 4 \
+ -validate focus -invcmd "focusAndFlash %W"
+ $w.size.y insert 0 [lindex [getCanvasSize $curcanvas] 1]
+ $w.size.y configure -from 600 -to 4096 -increment 2 \
+ -vcmd {checkIntRange %P 600 4096}
+
+ pack $w.size.x $w.size.label $w.size.y -side left -pady 5 -padx 2 -fill x
+}
#****f* editor.tcl/renameCanvasApply
# NAME
set newname [$w.e1 get]
destroy $w
if { $newname != [getCanvasName $curcanvas] } {
- set changed 1
+ set changed 1
}
setCanvasName $curcanvas $newname
switchCanvas none
updateUndoLog
}
+proc resizeCanvasApply { w } {
+ global curcanvas changed
+
+ set x [$w.size.x get]
+ set y [$w.size.y get]
+ destroy $w
+ if { "$x $y" != [getCanvasSize $curcanvas] } {
+ set changed 1
+ }
+ setCanvasSize $curcanvas $x $y
+ switchCanvas none
+ updateUndoLog
+}
#****f* editor.tcl/animate
# NAME
.c itemconfigure "selectmark || selectbox" -dashoffset $animatephase
incr animatephase 2
if { $animatephase == 100 } {
- set animatephase 0
+ set animatephase 0
}
if { $oper_mode == "edit" } {
- after 250 animate
+ after 250 animate
} else {
- after 1500 animate
+ after 1500 animate
}
- return
}
enable_disable $wi
after 100 {
- grab .popup
+ grab .popup
}
;# Apply and Cancel explicitly destroy $wi
vwait forever
}
}
+
+proc zoom { dir } {
+ global zoom
+
+ set stops ".25 .5 .75 1.0 1.5 2.0 4.0"
+ set i [lsearch $stops $zoom]
+ switch -exact -- $dir {
+ "down" {
+ if { $i >0 } {
+ set zoom [lindex $stops [expr $i - 1]]
+ redrawAll
+ }
+ }
+ "up" {
+ if { $i < [expr [llength $stops] - 1] } {
+ set zoom [lindex $stops [expr $i + 1]]
+ redrawAll
+ }
+ }
+ }
+}
projects / imunes.git / commitdiff