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