# # Copyright 2005-2013 the Boeing Company. # See the LICENSE file included in this distribution. # # # 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 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" } { 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 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"] $c raise $wlanlink "background || grid || oval || rectangle" 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 labelstr "" set delstr [getLinkDelayString $link] set ber [getLinkBER $link] set dup [getLinkDup $link] set labelstr "$labelstr[getLinkBandwidthString $link] " if { "$delstr" != "" } { set labelstr "$labelstr$delstr " } if { "$ber" != "" } { set berstr "loss=$ber%" set labelstr "$labelstr$berstr " } if { "$dup" != "" } { set dupstr "dup=$dup%" 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 localifc $node.$ifc.$ssid set icmd "exec $cmd $localifc &" } $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 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" } { set node [newNode router] 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 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" } { 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 # 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 "$wi.ifaces.c yview scroll -1 units" bind $ctl "$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] ttk::frame $wi.bandwidth -borderwidth 4 global link_preset_val set link_preset_val unlimited set linkpreMenu [tk_optionMenu $wi.bandwidth.linkpre link_preset_val a] pack $wi.bandwidth.linkpre -side top linkPresets $wi $linkpreMenu init 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] $wi.delay.value configure \ -validatecommand {checkIntRange %P 0 10000000} \ -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.ber -borderwidth 4 if { [lindex $systype 0] == "Linux" } { set bertext "Loss (%):" set berinc 1 set bermax 100 } 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 $bermax" \ -from 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 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 } } ;# 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 $cancelcmd # bind $wi "popupConfigApply $wi $object_type $target 0" } # 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 { 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 } 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 } 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 } 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 { $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 } } } popdownConfig $wi } #****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