afonso/core-extra
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge branch 'rel/5.1'

Browse source
This commit is contained in:
bharnden 2018-05-22 20:44:26 -07:00
commit c3d0b01b7f
293 changed files with 6907 additions and 34130 deletions
Download patch file Download diff file Expand all files Collapse all files

60
gui/Makefile.am
View file

@ -10,66 +10,32 @@
SUBDIRS = icons
TCL_FILES = annotations.tcl api.tcl canvas.tcl cfgparse.tcl \
core.tcl debug.tcl editor.tcl exec.tcl \
filemgmt.tcl gpgui.tcl \
graph_partitioning.tcl help.tcl \
initgui.tcl ipv4.tcl ipv6.tcl \
linkcfg.tcl mobility.tcl nodecfg.tcl \
nodes.tcl services.tcl ns2imunes.tcl plugins.tcl \
tooltips.tcl topogen.tcl traffic.tcl util.tcl \
version.tcl widget.tcl wlan.tcl wlanscript.tcl \
exceptions.tcl
TCL_FILES := $(wildcard *.tcl)
ADDONS_FILES := $(wildcard addons/*)
CONFIG_FILES := $(wildcard configs/*)
ADDONS_FILES = addons/ipsecservice.tcl
CONFIG_FILES = configs/sample1.imn configs/sample1.scen \
configs/sample1-bg.gif configs/sample2-ssh.imn \
configs/sample3-bgp.imn configs/sample4-nrlsmf.imn \
configs/sample4.scen configs/sample4-bg.jpg \
configs/sample5-mgen.imn configs/sample6-emane-rfpipe.imn \
configs/sample7-emane-ieee80211abg.imn \
configs/sample8-ipsec-service.imn \
configs/sample9-vpn.imn \
configs/sample10-kitchen-sink.imn
OTHER_FILES = core-bsd-cleanup.sh
#
# CORE GUI script (/usr/local/bin/core-gui)
#
dist_bin_SCRIPTS = core-gui
#
# Tcl/Tk scripts (/usr/local/lib/core)
#
coredir = $(CORE_LIB_DIR)
dist_core_DATA = $(TCL_FILES)
dist_core_SCRIPTS = $(OTHER_FILES)
coredir = $(CORE_LIB_DIR)
dist_core_DATA = $(TCL_FILES)
dist_core_SCRIPTS = $(OTHER_FILES)
#
# Addon files
#
coreaddonsdir = $(coredir)/addons
coreaddonsdir = $(coredir)/addons
dist_coreaddons_DATA = $(ADDONS_FILES)
#
# Sample configs (/usr/local/share/core/examples/configs)
#
coreconfigsdir = $(datadir)/core/examples/configs
dist_coreconfigs_DATA = $(CONFIG_FILES)
coreconfigsdir = $(datadir)/core/examples/configs
dist_coreconfigs_DATA = $(CONFIG_FILES)
# remove generated file from dist
dist-hook:
rm -rf $(distdir)/addons/.svn
uninstall-hook:
rmdir -p $(coreconfigsdir) || true
rmdir -p $(coreaddonsdir) || true
rmdir -p $(coredir) || true
-rm -f $(distdir)/version.tcl
# extra cruft to remove
DISTCLEANFILES = Makefile.in
DISTCLEANFILES = Makefile.in
# files to include in source tarball not included elsewhere
EXTRA_DIST = addons
EXTRA_DIST = core-gui.in

5
gui/addons/ipsecservice.tcl
View file

@ -1,9 +1,4 @@
#
# Copyright 2012 the Boeing Company.
# See the LICENSE file included in this distribution.
#
# author: Jeff Ahrenholz <jeffrey.m.ahrenholz@boeing.com>
#
# This is a separate "addons" file because it is closely tied to Python
# service definition for the IPsec service.
#

5
gui/annotations.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2007-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2007-2008 University of Zagreb, Croatia.
#

111
gui/api.tcl
View file

@ -1,11 +1,3 @@
#
# CORE API
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
# author: Jeff Ahrenholz <jeffrey.m.ahrenholz@boeing.com>
#
# version of the API document that is used
set CORE_API_VERSION 1.23
@ -30,7 +22,7 @@ array set g_execRequests { shell "" observer "" }
# for a simulator, uncomment this line or cut/paste into debugger:
# set XSCALE 4.0; set YSCALE 4.0; set XOFFSET 1800; set YOFFSET 300
array set nodetypes { 0 def 1 phys 2 xen 3 tbd 4 lanswitch 5 hub \
array set nodetypes { 0 def 1 phys 2 tbd 3 tbd 4 lanswitch 5 hub \
6 wlan 7 rj45 8 tunnel 9 ktunnel 10 emane }
array set regtypes { wl 1 mob 2 util 3 exec 4 gui 5 emul 6 }
@ -135,7 +127,7 @@ proc receiveMessage { channel } {
#
# Open an API socket to the specified server:port, prompt user for retry
# if specified; set the readable file event and parameters;
# if specified; set the readable file event and parameters;
# returns the channel name or -1 on error.
#
proc openAPIChannel { server port retry } {
@ -186,7 +178,7 @@ proc openAPIChannel { server port retry } {
# now we have a valid socket, set up encoding and receive event
fconfigure $s -blocking 0 -encoding binary -translation { binary binary } \
-buffering full -buffersize 4096
-buffering full -buffersize 4096
fileevent $s readable [list receiveMessage $s]
return $s
}
@ -299,7 +291,7 @@ proc parseNodeMessage { data len flags } {
# verbose debugging
#puts "tlv type=$type length=$length pad=$pad current=$current"
incr current 2
if {![info exists typenames($type)] } { ;# unknown TLV type
if { $prmsg } { puts -nonewline "unknown=$type," }
incr current $length
@ -352,11 +344,11 @@ proc parseNodeMessage { data len flags } {
} else {
set exists true
}
if { $vals(name) == "" } {; # make sure there is a node name
set name $node
if { $exists } { set name [getNodeName $node] }
array set vals [list name $name]
array set vals [list name $name]
}
if { $exists } {
if { $flags == 1 } {
@ -384,9 +376,7 @@ proc parseNodeMessage { data len flags } {
set wlans_needing_update { }
if { $vals(emuid) != -1 } {
# For Linux (FreeBSD populates ngnodeidmap in l3node.instantiate/
# buildInterface when the netgraph ID is known)
# populate ngnodeidmap for later use with wireless; it is treated as
# For Linux populate ngnodeidmap for later use with wireless; it is treated as
# a hex value string (without the leading "0x")
global ngnodeidmap
foreach wlan [findWlanNodes $node] {
@ -472,7 +462,7 @@ proc apiNodeCreate { node vals_ref } {
set nodetype $nodetypes($vals(type))
set nodename $vals(name)
if { $nodetype == "emane" } { set nodetype "wlan" } ;# special case - EMANE
if { $nodetype == "def" || $nodetype == "xen" } { set nodetype "router" }
if { $nodetype == "def" } { set nodetype "router" }
newNode [list $nodetype $node] ;# use node number supplied from API message
setNodeName $node $nodename
if { $vals(canv) == "" } {
@ -484,7 +474,7 @@ proc apiNodeCreate { node vals_ref } {
return
}
set canv "c$canv"
if { [lsearch $canvas_list $canv] < 0 && $canv == "c0" } {
if { [lsearch $canvas_list $canv] < 0 && $canv == "c0" } {
# special case -- support old imn files with Canvas0
global $canv
lappend canvas_list $canv
@ -511,7 +501,7 @@ proc apiNodeCreate { node vals_ref } {
set model $vals(model)
if { $model != "" && $vals(type) < 4} {
# set model only for (0 def 1 phys 2 xen 3 tbd) 4 lanswitch
# set model only for (0 def 1 phys 2 tbd 3 tbd) 4 lanswitch
setNodeModel $node $model
if { [lsearch -exact [getNodeTypeNames] $model] == -1 } {
puts "warning: unknown node type '$model' in Node message!"
@ -787,12 +777,12 @@ proc apiLinkAddModify { node1 node2 vals_ref add } {
updateLinkGuiAttr $wired_link $vals(guiattr)
return
# if add flag is set and a wired link already exists, assume wlan linkage
# special case: rj45 model=1 means link via wireless
# special case: rj45 model=1 means link via wireless
} elseif {[nodeType $node1] == "rj45" || [nodeType $node2] == "rj45"} {
if { [nodeType $node1] == "rj45" } {
set rj45node $node1; set othernode $node2;
} else { set rj45node $node2; set othernode $node1; }
if { [netconfFetchSection $rj45node model] == 1 } {
if { [netconfFetchSection $rj45node model] == 1 } {
set wlan [findWlanNodes $othernode]
if {$wlan != ""} {newGUILink $wlan $rj45node};# link rj4node to wlan
}
@ -1034,7 +1024,7 @@ proc parseRegMessage { data len flags channel } {
# TLV header
if { [binary scan $data @${current}cc type length] != 2 } {
puts "TLV header error"
break
break
}
set length [expr {$length & 0xFF}]; # convert signed to unsigned
if { $length == 0 } {
@ -1078,9 +1068,9 @@ proc parseRegMessage { data len flags channel } {
if { $session != "" } {
# The channel passed to here is soon after discarded for
# sessions that are started from XML or Python scripts. This causes
# an exception in the GUI when responding back to daemon if the
# response is sent after the channel has been destroyed. Setting
# the channel to -1 basically disables the GUI response to the daemon,
# an exception in the GUI when responding back to daemon if the
# response is sent after the channel has been destroyed. Setting
# the channel to -1 basically disables the GUI response to the daemon,
# but it turns out the daemon does not need the response anyway.
set channel -1
# assume session string only contains one session number
@ -1432,7 +1422,7 @@ proc parseEventMessage { data len flags channel } {
2 {
incr current $pad
binary scan $data @${current}I eventtype
if { $prmsg == 1} {
if { $prmsg == 1} {
set typestr ""
foreach t [array names eventtypes] {
if { $eventtypes($t) == $eventtype } {
@ -1493,7 +1483,7 @@ proc parseEventMessage { data len flags channel } {
set name [lindex [getEmulPlugin "*"] 0]
if { [getAssignedRemoteServers] == "" } {
# start a new session if not distributed
# otherwise we need to allow time for node delete messages
# otherwise we need to allow time for node delete messages
# from other servers
pluginConnect $name disconnect 1
pluginConnect $name connect 1
@ -1529,7 +1519,7 @@ proc parseSessionMessage { data len flags channel } {
set typelength [parseTLVHeader $data current]
set type [lindex $typelength 0]
set length [lindex $typelength 1]
if { $length == 0 || $length == "" } {
if { $length == 0 || $length == "" } {
puts "warning: zero-length TLV, discarding remainder of message!"
break
}
@ -1737,7 +1727,7 @@ proc sendNodePosMessage { channel node nodeid x y wlanid force } {
if {$wlanid > -1} { incr len 8 }
if {$force == 1 } { set crit 0x4 } else { set crit 0x0 }
#puts "sending [expr $len+4] bytes: $nodeid $x $y $wlanid"
if { $prmsg == 1 } {
if { $prmsg == 1 } {
puts -nonewline ">NODE(flags=$crit,$node,x=$x,y=$y" }
set msg [binary format ccSc2sIc2Sc2S \
1 $crit $len \
@ -1805,8 +1795,8 @@ proc sendNodeAddMessage { channel node } {
} else {
set canv ""
}
# services
# services
set svc [getNodeServices $node false]
set svc [join $svc "|"]
set svc_len [string length $svc]
@ -1854,7 +1844,7 @@ proc sendNodeAddMessage { channel node } {
set mac [join [split $macstr ":"] ""]
puts -nonewline $channel [binary format c2x2W {0x5 8} 0x$mac]
}
# IPv6 address
if { $ipv6 != 0 } {
if { $prmsg == 1 } { puts -nonewline "$ipv6str," }
@ -1943,7 +1933,7 @@ proc sendNodeDelMessage { channel node } {
proc sendLinkMessage { channel link type {sendboth true} } {
global showAPI
set prmsg $showAPI
set node1 [lindex [linkPeers $link] 0]
set node2 [lindex [linkPeers $link] 1]
set if1 [ifcByPeer $node1 $node2]; set if2 [ifcByPeer $node2 $node1]
@ -2207,7 +2197,7 @@ proc getIfcAddrs { node ifc ipv4p ipv6p macp ipv4maskp ipv6maskp lenp } {
# IPv4 address
set ipv4str [getIfcIPv4addr $node $ifc]
if {$ipv4str != ""} {
if {$ipv4str != ""} {
set ipv4 [lindex [split $ipv4str /] 0]
if { [info exists ipv4mask ] } {
set ipv4mask [lindex [split $ipv4str / ] 1]
@ -2222,7 +2212,7 @@ proc getIfcAddrs { node ifc ipv4p ipv6p macp ipv4maskp ipv6maskp lenp } {
# IPv6 address
set ipv6str [getIfcIPv6addr $node $ifc]
if {$ipv6str != ""} {
if {$ipv6str != ""} {
set ipv6 [lindex [split $ipv6str /] 0]
if { [info exists ipv6mask ] } {
set ipv6mask [lindex [split $ipv6str / ] 1]
@ -2248,7 +2238,7 @@ proc getIfcAddrs { node ifc ipv4p ipv6p macp ipv4maskp ipv6maskp lenp } {
#
# Register Message: (registration types)
# This is a simple Register Message, types is an array of
# This is a simple Register Message, types is an array of
# <module TLV, string> tuples.
proc sendRegMessage { channel flags types_list } {
global showAPI regtypes
@ -2361,7 +2351,7 @@ proc sendConfRequestMessage { channel node model flags netid opaque } {
set msg4 [binary format c2sI {0x23 4} 0 0x$netid ]
}
#catch {puts -nonewline $channel $msg1$model$model_pad$msg2$msg3$msg4$msg5}
#catch {puts -nonewline $channel $msg1$model$model_pad$msg2$msg3$msg4$msg5}
puts -nonewline $channel $msg1$msg1b$msg1c$model$model_pad$msg2$msg3$msg4
if { $opaque_len > 0 } { puts -nonewline $channel $msgop }
@ -2436,7 +2426,7 @@ proc sendConfReplyMessage { channel node model types values opaque } {
# session number
set msg3 ""
if { $session != "" } {
incr len [expr {2 + $session_len + $session_pad_len }]
incr len [expr {2 + $session_len + $session_pad_len }]
set msg3 [binary format cc 0x0A $session_len]
set msg3 $msg3$session$session_pad
}
@ -2472,7 +2462,7 @@ proc sendEventMessage { channel type nodenum name data flags } {
set data_pad_len [pad_32bit $data_len]
if { $data_len > 0 } { incr len [expr {2 + $data_len + $data_pad_len}] }
if { $prmsg == 1 } {
if { $prmsg == 1 } {
puts -nonewline ">EVENT(flags=$flags," }
set msg [binary format ccS 8 $flags $len ] ;# message header
@ -2481,7 +2471,7 @@ proc sendEventMessage { channel type nodenum name data flags } {
if { $prmsg == 1 } { puts -nonewline "node=$nodenum," }
set msg2 [binary format c2sI {0x01 4} 0 $nodenum]
}
if { $prmsg == 1} {
if { $prmsg == 1} {
set typestr ""
foreach t [array names eventtypes] {
if { $eventtypes($t) == $type } { set typestr "-$t"; break }
@ -2513,7 +2503,7 @@ proc sendEventMessage { channel type nodenum name data flags } {
# deploy working configuration using CORE API
# Deploys a current working configuration. It creates all the
# Deploys a current working configuration. It creates all the
# nodes and link as defined in configuration file.
proc deployCfgAPI { sock } {
global eid
@ -2546,13 +2536,13 @@ proc deployCfgAPI { sock } {
sendSessionProperties $sock
# this tells the CORE services that we are starting to send
# this tells the CORE services that we are starting to send
# configuration data
# clear any existing config
sendEventMessage $sock $eventtypes(definition_state) -1 "" "" 0
# inform CORE services about emulation servers, hook scripts, canvas info,
# and services
sendEventMessage $sock $eventtypes(configuration_state) -1 "" "" 0
sendEventMessage $sock $eventtypes(configuration_state) -1 "" "" 0
sendEmulationServerInfo $sock 0
sendSessionOptions $sock
sendHooks $sock
@ -2567,7 +2557,7 @@ proc deployCfgAPI { sock } {
set type [nodeType $node]
set name [getNodeName $node]
if { $type == "pseudo" } { continue }
statgraph inc 1
statline "Creating node $name"
if { [[typemodel $node].layer] == "NETWORK" } {
@ -2611,7 +2601,7 @@ proc deployCfgAPI { sock } {
# status bar graph
statgraph off 0
statline "Network topology instantiated in [expr [clock seconds] - $t_start] seconds ([llength $node_list] nodes and [llength $link_list] links)."
# TODO: turn on tcpdump if enabled; customPostConfigCommands;
# addons 4 deployCfgHook
@ -2628,8 +2618,8 @@ proc deployCfgAPI { sock } {
sendTrafficScripts $sock
# tell the CORE services that we are ready to instantiate
sendEventMessage $sock $eventtypes(instantiation_state) -1 "" "" 0
sendEventMessage $sock $eventtypes(instantiation_state) -1 "" "" 0
set deployCfgAPI_lock 0 ;# unlock
statline "Network topology instantiated in [expr [clock seconds] - $t_start] seconds ([llength $node_list] nodes and [llength $link_list] links)."
@ -2651,7 +2641,7 @@ proc shutdownSession {} {
set plugin [lindex [getEmulPlugin "*"] 0]
set sock [pluginConnect $plugin connect true]
sendEventMessage $sock $eventtypes(datacollect_state) -1 "" "" 0
sendEventMessage $sock $eventtypes(datacollect_state) -1 "" "" 0
# shut down all links
foreach link $link_list {
@ -2712,7 +2702,7 @@ proc sendNodeTypeInfo { sock reset } {
sendConfRequestMessage $sock -1 "all" 0x3 -1 ""
return
}
# build a list of node types in use
# build a list of node types in use
set typesinuse ""
foreach node $node_list {
set type [nodeType $node]
@ -2922,7 +2912,6 @@ proc getNodeTypeAPI { node } {
jail { return 0x0 }
OVS { return 0x0 }
physical { return 0x1 }
xen { return 0x2 }
tbd { return 0x3 }
lanswitch { return 0x4 }
hub { return 0x5 }
@ -2974,7 +2963,7 @@ proc sendFileMessage { channel node type f sf data data_len } {
set prmsg $showAPI
set node_num [string range $node 1 end]
set f_len [string length $f]
set f_pad_len [pad_32bit $f_len]
set f_pad [binary format x$f_pad_len]
@ -3013,7 +3002,7 @@ proc sendFileMessage { channel node type f sf data data_len } {
if { $prmsg == 1 } {
puts -nonewline ">FILE(flags=$flags,$node,f=$f,"
if { $type != "" } { puts -nonewline "type=$type," }
if { $sf != "" } { puts "src=$sf)"
if { $sf != "" } { puts "src=$sf)"
} else { puts "data=($data_len))" }
}
@ -3077,7 +3066,7 @@ proc sendSessionMessage { channel flags num name sfile nodecount tf user } {
set user_pad_len [pad_32bit $user_len]
if { $user_len > 0 } { incr len [expr { 2 + $user_len + $user_pad_len }] }
if { $prmsg == 1 } {
if { $prmsg == 1 } {
puts -nonewline ">SESSION(flags=$flags" }
set msgh [binary format ccS 0x09 $flags $len ] ;# message header
@ -3089,7 +3078,7 @@ proc sendSessionMessage { channel flags num name sfile nodecount tf user } {
set msg2 ""
if { $name_len > 0 } {
if { $prmsg == 1 } { puts -nonewline ",name=$name" }
# TODO: name_len > 255
# TODO: name_len > 255
set name_hdr [binary format cc 0x02 $name_len]
set name_pad [binary format x$name_pad_len]
set msg2 "$name_hdr$name$name_pad"
@ -3097,7 +3086,7 @@ proc sendSessionMessage { channel flags num name sfile nodecount tf user } {
set msg3 ""
if { $sfile_len > 0 } {
if { $prmsg == 1 } { puts -nonewline ",file=$sfile" }
# TODO: sfile_len > 255
# TODO: sfile_len > 255
set sfile_hdr [binary format cc 0x03 $sfile_len]
set sfile_pad [binary format x$sfile_pad_len]
set msg3 "$sfile_hdr$sfile$sfile_pad"
@ -3150,11 +3139,11 @@ proc xmlFileLoadSave { cmd name } {
# inform daemon about nodes and links when saving in edit mode
if { $cmd == "save" && $oper_mode != "exec" } {
sendSessionProperties $sock
# this tells the CORE services that we are starting to send
# this tells the CORE services that we are starting to send
# configuration data
# clear any existing config
sendEventMessage $sock $eventtypes(definition_state) -1 "" "" 0
sendEventMessage $sock $eventtypes(configuration_state) -1 "" "" 0
sendEventMessage $sock $eventtypes(configuration_state) -1 "" "" 0
sendEmulationServerInfo $sock 0
sendSessionOptions $sock
sendHooks $sock
@ -3246,7 +3235,7 @@ proc buildStringTLV { type data len_ref } {
}
if { $data_len > 255 } {
set hdr [binary format ccS $type 0 $data_len]
set hdr [binary format ccS $type 0 $data_len]
set hdr_len 4
} else {
set hdr [binary format cc $type $data_len]
@ -3274,7 +3263,7 @@ proc pad_32bit { len } {
proc macToString { mac_num } {
set mac_bytes ""
# convert 64-bit integer into 12-digit hex string
# convert 64-bit integer into 12-digit hex string
set mac_num 0x[format "%.12lx" $mac_num]
while { $mac_num > 0 } {
# append 8-bit hex number to list
@ -3295,7 +3284,7 @@ proc macToString { mac_num } {
set r {}
set i [llength $mac_bytes]
while { $i > 0 } { lappend r [lindex $mac_bytes [incr i -1]] }
return [join $r :]
}

5
gui/canvas.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2005-2008 University of Zagreb, Croatia.
#

95
gui/cfgparse.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2005-2008 University of Zagreb, Croatia.
#
@ -35,24 +30,24 @@
# NAME
# cfgparse.tcl -- file used for parsing the configuration
# FUNCTION
# This module is used for parsing the configuration, i.e. reading the
# configuration from a file or a string and writing the configuration
# to a file or a string. This module also contains a function for returning
# This module is used for parsing the configuration, i.e. reading the
# configuration from a file or a string and writing the configuration
# to a file or a string. This module also contains a function for returning
# a new ID for nodes, links and canvases.
#****
#****f* nodecfg.tcl/dumpputs
# NAME
# dumpputs -- puts a string to a file or a string configuration
# dumpputs -- puts a string to a file or a string configuration
# SYNOPSIS
# dumpputs $method $destination $string
# FUNCTION
# Puts a sting to the file or appends the string configuration (used for
# Puts a sting to the file or appends the string configuration (used for
# undo functions), the choice depends on the value of method parameter.
# INPUTS
# * method -- method used. Possiable values are file (if saving the string
# * method -- method used. Possiable values are file (if saving the string
# to the file) and string (if appending the string configuration)
# * dest -- destination used. File_id for files, and string name for string
# * dest -- destination used. File_id for files, and string name for string
# configuration
# * string -- the string that is inserted to a file or appended to the string
# configuartion
@ -73,7 +68,7 @@ proc dumpputs {method dest string} {
#****f* nodecfg.tcl/dumpCfg
# NAME
# dumpCfg -- puts the current configuraton to a file or a string
# dumpCfg -- puts the current configuraton to a file or a string
# SYNOPSIS
# dumpCfg $method $destination
# FUNCTION
@ -81,7 +76,7 @@ proc dumpputs {method dest string} {
# INPUTS
# * method -- used method. Possiable values are file (saving current congif
# to the file) and string (saving current config in a string)
# * dest -- destination used. File_id for files, and string name for string
# * dest -- destination used. File_id for files, and string name for string
# configurations
#****
@ -95,7 +90,7 @@ proc dumpCfg {method dest} {
dumpputs $method $dest "\}"
dumpputs $method $dest ""
}
foreach node $node_list {
global $node
upvar 0 $node lnode
@ -129,7 +124,7 @@ proc dumpCfg {method dest} {
}
}
dumpputs $method $dest " \}"
} elseif { "[lindex $element 0]" == "ipsec-config" } {
} elseif { "[lindex $element 0]" == "ipsec-config" } {
dumpputs $method $dest " ipsec-config \{"
foreach line [lindex $element 1] {
if { $line != {} } {
@ -228,24 +223,24 @@ proc dumpGlobalOptions { method dest } {
global mac_addr_start
dumpputs $method $dest "option global \{"
if {$showIfNames == 0} {
dumpputs $method $dest " interface_names no"
if {$showIfNames == 0} {
dumpputs $method $dest " interface_names no"
} else {
dumpputs $method $dest " interface_names yes" }
if {$showIfIPaddrs == 0} {
dumpputs $method $dest " ip_addresses no"
if {$showIfIPaddrs == 0} {
dumpputs $method $dest " ip_addresses no"
} else {
dumpputs $method $dest " ip_addresses yes" }
if {$showIfIPv6addrs == 0} {
dumpputs $method $dest " ipv6_addresses no"
if {$showIfIPv6addrs == 0} {
dumpputs $method $dest " ipv6_addresses no"
} else {
dumpputs $method $dest " ipv6_addresses yes" }
if {$showNodeLabels == 0} {
dumpputs $method $dest " node_labels no"
if {$showNodeLabels == 0} {
dumpputs $method $dest " node_labels no"
} else {
dumpputs $method $dest " node_labels yes" }
if {$showLinkLabels == 0} {
dumpputs $method $dest " link_labels no"
if {$showLinkLabels == 0} {
dumpputs $method $dest " link_labels no"
} else {
dumpputs $method $dest " link_labels yes" }
if {$showAPI == 0} {
@ -290,7 +285,7 @@ proc setGlobalOption { field value } {
global showIfIPaddrs showIfIPv6addrs
global showBkgImage showGrid showAnnotations
global showAPI
global mac_addr_start
global mac_addr_start
global g_traffic_start_opt
global g_view_locked
@ -400,8 +395,8 @@ proc cleanupGUIState {} {
# SYNOPSIS
# loadCfg $cfg
# FUNCTION
# Loads the configuration written in the cfg string to a current
# configuration.
# Loads the configuration written in the cfg string to a current
# configuration.
# INPUTS
# * cfg -- string containing the new working configuration.
#****
@ -489,7 +484,7 @@ proc loadCfg { cfg } {
# consume first two list elements from line
set value [lindex $line 1]
set line [lreplace $line 0 1]
if {"$class" == "node"} {
switch -exact -- $field {
type {
@ -561,7 +556,7 @@ proc loadCfg { cfg } {
}
ipsec-config {
set cfg ""
foreach zline [split $value {
}] {
if { [string index "$zline" 0] == " " } {
@ -600,7 +595,8 @@ proc loadCfg { cfg } {
custom-pre-config-commands {
# Boeing - custom pre config commands
set cfg ""
foreach zline [split $value { }] {
foreach zline [split $value {
}] {
if { [string index "$zline" 0] == " " } {
set zline [string replace "$zline" 0 0]
}
@ -612,7 +608,8 @@ proc loadCfg { cfg } {
custom-post-config-commands {
# Boeing - custom post config commands
set cfg ""
foreach zline [split $value { }] {
foreach zline [split $value {
}] {
if { [string index "$zline" 0] == " " } {
set zline [string replace "$zline" 0 0]
}
@ -628,7 +625,8 @@ proc loadCfg { cfg } {
ine-config {
# Boeing - INE
set cfg ""
foreach zline [split $value { }] {
foreach zline [split $value {
}] {
if { [string index "$zline" 0] == " " } {
set zline [string replace "$zline" 0 0]
}
@ -682,7 +680,7 @@ proc loadCfg { cfg } {
switch -exact -- $field {
name {
lappend $object "name $value"
}
}
height {
lappend $object "height $value"
}
@ -695,10 +693,10 @@ proc loadCfg { cfg } {
y {
lappend $object "y $value"
}
color {
color {
lappend $object "color $value"
}
}
}
}
} elseif {"$class" == "link"} {
switch -exact -- $field {
nodes {
@ -863,20 +861,20 @@ proc loadCfg { cfg } {
#****f* nodecfg.tcl/newObjectId
# NAME
# newObjectId -- new object Id
# newObjectId -- new object Id
# SYNOPSIS
# set obj_id [newObjectId $type]
# FUNCTION
# Returns the Id for a new object of the defined type. Supported types
# are node, link and canvas. The Id is in the form $mark$number. $mark is the
# are node, link and canvas. The Id is in the form $mark$number. $mark is the
# first letter of the given type and $number is the first available number to
# that can be used for id.
# that can be used for id.
# INPUTS
# * type -- the type of the new object. Can be node, link or canvas.
# RESULT
# * obj_id -- object Id in the form $mark$number. $mark is the
# * obj_id -- object Id in the form $mark$number. $mark is the
# first letter of the given type and $number is the first available number to
# that can be used for id.
# that can be used for id.
#****
proc newObjectId { type } {
@ -950,7 +948,7 @@ proc loadServersConf { } {
global CONFDIR exec_servers DEFAULT_API_PORT
set confname "$CONFDIR/servers.conf"
if { [catch { set f [open "$confname" r] } ] } {
puts "Creating a default $confname"
puts "Creating a default $confname"
if { [catch { set f [open "$confname" w+] } ] } {
puts "***Warning: could not create a default $confname file."
return
@ -1035,7 +1033,7 @@ proc popupPrefs {} {
-command "addFileToMrulist \"\""
pack $wi.dirs.mru.label $wi.dirs.mru.num $wi.dirs.mru.clear -side left
pack $wi.dirs.mru -side top -anchor w -padx 4 -pady 4
pack $wi.dirs -side top -fill x
#
@ -1049,7 +1047,7 @@ proc popupPrefs {} {
-variable g_prefs(gui_save_size)
pack $wi.win.win.savepos $wi.win.win.savesiz -side left -anchor w -padx 4
pack $wi.win.win -side top -anchor w -padx 4 -pady 4
frame $wi.win.a
checkbutton $wi.win.a.snaptogrid -text "snap to grid" \
-variable g_prefs(gui_snap_grid)
@ -1123,9 +1121,8 @@ proc initDefaultPrefs {} {
# variable expansions must be done here
array set g_prefs [list default_conf_path "$CONFDIR/configs"]
array set g_prefs [list gui_canvas_refpt "$DEFAULT_REFPT"]
if { $tcl_platform(os) == "FreeBSD" } { set shell "/usr/local/bin/bash"
} else { set shell "bash" }
array set g_prefs [list shell $shell]
set shell "bash"
array set g_prefs [list shell $shell]
array set g_prefs [list gui_text_editor [get_text_editor true]]
array set g_prefs [list gui_term_prog [get_term_prog true]]
setDefaultAddrs ipv4

2
gui/configs/sample10-kitchen-sink.imn
View file

@ -2,7 +2,7 @@ comments {
Kitchen Sink
============
Contains every type of node available in CORE, except for the Xen and physical (prouter)
Contains every type of node available in CORE, except for physical (prouter)
machine types, and nodes distributed on other emulation servers.
To get the RJ45 node to work, a test0 interface should first be created like this:

6
gui/configs/sample5-mgen.imn
View file

@ -86,11 +86,7 @@ node n2 {
HN=`hostname`
SCRIPTDIR=$SESSION_DIR
LOGDIR=/var/log
if [ `uname` = "FreeBSD" ]; then
SCRIPTDIR=/tmp/e0_$HN
LOGDIR=$SCRIPTDIR
fi
cd $SCRIPTDIR
(
cat << 'EOF'

60
gui/core-bsd-cleanup.sh
View file

@ -1,60 +0,0 @@
#!/bin/sh
#
# cleanup.sh
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
# Removes leftover netgraph nodes and vimages from an emulation that
# did not exit properly.
#
ngnodes="pipe eiface hub switch wlan"
vimages=`vimage -l | fgrep -v " " | cut -d: -f 1 | sed s/\"//g`
# shutdown netgraph nodes
for ngn in $ngnodes
do
nodes=`ngctl list | grep $ngn | awk '{print $2}'`
for n in $nodes
do
echo ngctl shutdown $n:
ngctl shutdown $n:
done
done
# kills processes and remove vimages
for vimage in $vimages
do
procs=`vimage $vimage ps x | awk '{print $1}'`
for proc in $procs
do
if [ $proc != "PID" ]
then
echo vimage $vimage kill $proc
vimage $vimage kill $proc
fi
done
loopback=`vimage $vimage ifconfig -a | head -n 1 | awk '{split($1,a,":"); print a[1]}'`
if [ "$loopback" != "" ]
then
addrs=`ifconfig $loopback | grep inet | awk '{print $2}'`
for addr in $addrs
do
echo vimage $vimage ifconfig $loopback $addr -alias
vimage $vimage ifconfig $loopback $addr -alias
if [ $? != 0 ]
then
vimage $vimage ifconfig $loopback inet6 $addr -alias
fi
done
echo vimage $vimage ifconfig $loopback down
vimage $vimage ifconfig $loopback down
fi
vimage $vimage kill -9 -1 2> /dev/null
echo vimage -d $vimage
vimage -d $vimage
done
# clean up temporary area
rm -rf /tmp/pycore.*

15
gui/core-gui.in
View file

@ -1,9 +1,4 @@
#!/bin/sh
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2004-2008 University of Zagreb, Croatia.
#
@ -54,7 +49,7 @@ case $1 in
exit 0
;;
-v | --version)
exec echo "`basename $0` version @CORE_VERSION@ (@CORE_VERSION_DATE@)"
exec echo "`basename $0` version @PACKAGE_VERSION@ (@PACKAGE_DATE@)"
exit 0
;;
esac
@ -63,7 +58,7 @@ SHELL=/bin/sh
export SHELL
export LIBDIR="@CORE_LIB_DIR@"
export SBINDIR="@SBINDIR@"
export SBINDIR="@sbindir@"
# eval is used here to expand "~" to user's home dir
if [ x$CONFDIR = x ]; then export CONFDIR=`eval "echo @CORE_GUI_CONF_DIR@"` ; fi
export CORE_STATE_DIR="@CORE_STATE_DIR@"
@ -88,6 +83,12 @@ init_conf_dir() {
else
cp -a $CORE_DATA_DIR/examples/myservices/* $CONFDIR/myservices/
fi
mkdir -p $CONFDIR/myemane
if [ $? != 0 ]; then
echo "error making directory $CONFDIR/myemane!";
else
cp -a $CORE_DATA_DIR/examples/myemane/* $CONFDIR/myemane/
fi
}
cd $LIBDIR

5
gui/core.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2004-2008 University of Zagreb, Croatia.
#

8
gui/debug.tcl
View file

@ -1,11 +1,3 @@
#
# CORE Debugger
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
# author: Jeff Ahrenholz <jeffrey.m.ahrenholz@boeing.com>
#
.menubar.tools add command -label "Debugger..." -command popupDebugger
set g_last_debug_cmd "puts \"Hello world\""

281
gui/editor.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2004-2008 University of Zagreb, Croatia.
#
@ -34,7 +29,7 @@
#****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
# 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
@ -71,8 +66,8 @@ proc animateCursor {} {
# 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
# * atomic -- defines if the remove was atomic action or a part
# of a composed, non-atomic action (relevant for updating log
# for undo).
#****
@ -137,7 +132,7 @@ proc removeGUINode { node } {
# SYNOPSIS
# updateUndoLog
# FUNCTION
# Updates the undo log. Writes the current configuration to the
# Updates the undo log. Writes the current configuration to the
# undolog array and updates the undolevel variable.
#****
@ -161,7 +156,7 @@ proc updateUndoLog {} {
# NAME
# undo -- undo function
# SYNOPSIS
# undo
# undo
# FUNCTION
# Undo the change. Reads the undolog and updates the current
# configuration. Reduces the value of undolevel.
@ -185,10 +180,10 @@ proc undo {} {
# SYNOPSIS
# redo
# FUNCTION
# Redo the change if possible (redolevel is greater than
# 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.
# updates the current configuration. Increases the value
# of undolevel.
#****
proc redo {} {
@ -244,7 +239,7 @@ proc redrawAll {} {
"-$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 \
@ -264,7 +259,7 @@ proc redrawAll {} {
if { [getNodeCanvas $obj] == $curcanvas } {
drawAnnotation $obj
}
}
}
}
# Grid
@ -303,7 +298,7 @@ proc redrawAll {} {
}
}
redrawAllThruplots
redrawAllThruplots
foreach link $link_list {
set nodes [linkPeers $link]
if { [getNodeCanvas [lindex $nodes 0]] != $curcanvas ||
@ -330,7 +325,7 @@ proc redrawAll {} {
# 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
# variable for all types of nodes and on invisible variable
# for pseudo nodes.
# INPUTS
# * node_id -- node id
@ -342,7 +337,7 @@ proc drawNode { c node } {
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}]
@ -361,7 +356,7 @@ proc drawNode { c 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]
set img [file tail $cimg]
# create the variable if the image hasn't been loaded before
global [set img]
if { ![info exists $img] } {
@ -433,9 +428,9 @@ proc drawNode { c node } {
# SYNOPSIS
# drawLink link_id
# FUNCTION
# Draws the specified link. An arrow is displayed for links
# 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.
# is specified link connecting a pseudo node stays hidden.
# INPUTS
# * link_id -- link id
#****
@ -486,7 +481,7 @@ proc drawLink { link } {
}
foreach n [list $lnode1 $lnode2] {
if { [getNodeHidden $n] } {
hideNode $n
hideNode $n
statline "Hidden node(s) exist."
}
}
@ -535,7 +530,7 @@ proc drawWlanLink { node1 node2 wlan } {
# set ifcName [chooseIfName $lnode1 $lnode2]
# FUNCTION
# Choose intreface name. The name can be:
# * eth -- for interface connecting pc, host and router
# * eth -- for interface connecting pc, host and router
# * e -- for interface connecting hub and lanswitch
# INPUTS
# * link_id -- link id
@ -564,7 +559,7 @@ proc chooseIfName { lnode1 lnode2 } {
return eth
}
rj45 {
return
return
}
tunnel {
return e
@ -589,8 +584,8 @@ proc chooseIfName { lnode1 lnode2 } {
# 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
# 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
@ -622,7 +617,7 @@ proc listLANnodes { l2node l2peers } {
# FUNCTION
# Calculates dx and dy variables of the calling function.
# INPUTS
# * lnode -- node id of a node whose dx and dy coordinates are
# * lnode -- node id of a node whose dx and dy coordinates are
# calculated
#****
@ -680,8 +675,8 @@ proc calcDxDy { lnode } {
# 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.
# * lnode2 -- node id of the node that is connected by this
# interface.
#****
proc updateIfcLabel { lnode1 lnode2 } {
global showIfNames showIfIPaddrs showIfIPv6addrs
@ -715,7 +710,7 @@ proc updateIfcLabel { lnode1 lnode2 } {
.c itemconfigure "interface && $lnode1 && $link" \
-text "$labelstr"
# Boeing: hide ifc label on wlans
if { [nodeType $lnode1] == "wlan" } {
if { [nodeType $lnode1] == "wlan" } {
.c itemconfigure "interface && $lnode1 && $link" -state hidden
}
}
@ -876,11 +871,11 @@ proc redrawWlanLink { link } {
#****f* editor.tcl/splitGUILink
# NAME
# splitGUILink -- splits a links
# splitGUILink -- splits a links
# SYNOPSIS
# splitGUILink $link
# FUNCTION
# Splits the link and draws new links and new pseudo nodes
# Splits the link and draws new links and new pseudo nodes
# on the canvas.
# INPUTS
# * link -- link id
@ -925,7 +920,7 @@ proc splitGUILink { link } {
#****f* editor.tcl/selectNode
# NAME
# selectNode -- select node
# selectNode -- select node
# SYNOPSIS
# selectNode $c $obj
# FUNCTION
@ -1019,11 +1014,11 @@ proc selectAdjacent {} {
#****f* editor.tcl/button3link
# NAME
# button3link
# button3link
# SYNOPSIS
# button3link $c $x $y
# FUNCTION
# This procedure is called when a right mouse button is
# 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:
@ -1099,7 +1094,7 @@ proc button3link { c x y } {
#****f* editor.tcl/movetoCanvas
# NAME
# movetoCanvas -- move to canvas
# movetoCanvas -- move to canvas
# SYNOPSIS
# movetoCanvas $canvas
# FUNCTION
@ -1176,7 +1171,7 @@ proc mergeGUINode { node } {
# SYNOPSIS
# button3node $c $x $y
# FUNCTION
# This procedure is called when a right mouse button is
# 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
@ -1190,18 +1185,18 @@ proc mergeGUINode { node } {
# 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
# * 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
# * 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 }
#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
@ -1242,7 +1237,7 @@ proc button3node { c x y button } {
if { $button == "shift" } { ;# normal bash shell
spawnShell $node $shell
} else { ;# right-click vtysh shell
set cmd [[typemodel $node].shellcmd $node]
set cmd [[typemodel $node].shellcmd $node]
if { $cmd != "/bin/sh" && $cmd != "" } { spawnShell $node $cmd }
}
return ;# open shell, don't post a menu
@ -1437,7 +1432,7 @@ proc button3node { c x y button } {
addInterfaceCommand $node .button3menu "Wireshark" "wireshark -k -i" \
$execstate 0
# wireshark on host veth pair -- need veth pair name
#wireshark -k -i
#wireshark -k -i
if { [lindex $systype 0] == "Linux" } {
set name [getNodeName $node]
.button3menu add command -label "View log..." -state $execstate \
@ -1464,7 +1459,7 @@ proc button3node { c x y button } {
# 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
# * node -- node id of the node for which the shell
# is spawned.
# * cmd -- the path to the shell.
#****
@ -1527,9 +1522,9 @@ proc raiseAll {c} {
# SYNOPSIS
# button1 $c $x $y $button
# FUNCTION
# This procedure is called when a left mouse button is
# 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
# node or creates a new node, depending on the selected
# tool.
# INPUTS
# * c -- tk canvas
@ -1563,7 +1558,7 @@ proc button1 { c x y button } {
set curobj [$c find withtag current]
set curtype [lindex [$c gettags current] 0]
if { $curtype == "node" || \
$curtype == "oval" || $curtype == "rectangle" || $curtype == "text" \
|| ( $curtype == "nodelabel" && \
@ -1613,7 +1608,7 @@ proc button1 { c x y button } {
if { $g_view_locked == 1 } { return }
if { $activetoolp == "routers" } {
if {$activetool != "OVS"} {
set node [newNode router]
set node [newNode router]
} else {
set node [newNode OVS]}
setNodeModel $node $activetool
@ -1666,7 +1661,7 @@ proc button1 { c x y button } {
set newlink [$c create line $lastX $lastY $x $y \
-fill $defLinkColor -width $defLinkWidth \
-tags "link"]
# twonode tool support
# twonode tool support
} elseif {$g_twoNodeSelect != "" && $curtype == "node"} {
set curnode [lindex [$c gettags $curobj] 1]
selectTwoNode $curnode
@ -1683,14 +1678,14 @@ proc setResizeMode { c x y } {
set isThruplot false
set type1 notset
if {$c == ".c"} {
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
set isThruplot true
}
#DYL
#puts "RESIZE NODETYPE = $type1"
@ -1743,11 +1738,11 @@ proc setResizeMode { c x y } {
# NAME
# button1-motion
# SYNOPSIS
# button1-motion $c $x $y
# 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
# 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
@ -1767,8 +1762,8 @@ proc button1-motion { c x y } {
if {$thruPlotDragStart == "dragging"} {
#puts "active tool is $activetool"
thruPlotDrag $c $thruPlotCur $x $y null true
return
thruPlotDrag $c $thruPlotCur $x $y null true
return
}
# fix occasional error
@ -1800,7 +1795,7 @@ proc button1-motion { c x y } {
set dx [expr {$x-$lastX} ]
set dy [expr {$y-$lastY} ]
# this provides smoother drawing
if { $dx > $markersize || $dy > $markersize } {
if { $dx > $markersize || $dy > $markersize } {
set mark [$c create line $lastX $lastY $x $y \
-width $markersize -fill $markercolor -tags "marker"]
$c raise $mark \
@ -1886,7 +1881,7 @@ proc button1-motion { c x y } {
}
# resizing an annotation
} elseif { $curtype == "selectmark" } {
foreach o [$c find withtag "selected"] {
foreach o [$c find withtag "selected"] {
set node [lindex [$c gettags $o] 1]
set tagovi [$c gettags $o]
set koord [getNodeCoords $node]
@ -1992,12 +1987,12 @@ proc button1-motion { c x y } {
#****f* editor.tcl/pseudo.layer
# NAME
# pseudo.layer
# pseudo.layer
# SYNOPSIS
# set layer [pseudo.layer]
# FUNCTION
# Returns the layer on which the pseudo node operates
# i.e. returns no layer.
# i.e. returns no layer.
# RESULT
# * layer -- returns an empty string
#****
@ -2011,8 +2006,8 @@ proc pseudo.layer {} {
# 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
# 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
@ -2052,10 +2047,10 @@ proc newGUILink { lnode1 lnode2 } {
# NAME
# button1-release
# SYNOPSIS
# button1-release $c $x $y
# button1-release $c $x $y
# FUNCTION
# This procedure is called when a left mouse button is
# released.
# 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
@ -2202,7 +2197,7 @@ proc button1-release { c x y } {
nodeEnter $c
# $changed!=1
} elseif {$activetool == "select" } {
} elseif {$activetool == "select" } {
if {$selectbox == ""} {
set x1 $x
set y1 $y
@ -2243,10 +2238,10 @@ proc button1-release { c x y } {
} 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 } {
# fixes a bug where the object dissappears
if { $x != $x1 || $y != $y1 } {
setNodeCoords $resizeobj "$x $y $x1 $y1"
}
}
set redrawNeeded 1
set resizemode false
}
@ -2269,11 +2264,11 @@ proc button1-release { c x y } {
# SYNOPSIS
# nodeEnter $c
# FUNCTION
# This procedure prints the node id, node name and
# 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.
# of the node in the status line.
# Information is presented for the node above which is
# the mouse pointer.
# the mouse pointer.
# INPUTS
# * c -- tk canvas
#****
@ -2314,7 +2309,7 @@ proc nodeEnter { c } {
# 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.
# the mouse pointer.
# INPUTS
# * c -- tk canvas
#****
@ -2351,13 +2346,13 @@ proc anyLeave {c} {
}
#****f* editor.tcl/checkIntRange
#****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
# This procedure checks the input string to see if it is
# an integer between the low and high value.
# INPUTS
# str -- string to check
@ -2407,14 +2402,14 @@ proc checkHostname { str } {
}
#****f* editor.tcl/focusAndFlash
#****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
# and on this filed it provides an effect of flashing
# for approximately 1 second.
# INPUTS
# * W -- textbox field that caused the bed entry
@ -2454,7 +2449,7 @@ proc focusAndFlash {W {count 9}} {
# SYNOPSIS
# popupConfigDialog $c
# FUNCTION
# Dynamically creates a popup dialog box for configuring
# Dynamically creates a popup dialog box for configuring
# links or nodes in IMUNES.
# INPUTS
# * c -- canvas id
@ -2540,10 +2535,10 @@ proc popupConfigDialog { c } {
$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]
@ -2556,7 +2551,7 @@ proc popupConfigDialog { c } {
# end Boeing
pack $wi.ftop -side top
if { $type == "router" || $type == "OVS"} {
ttk::frame $wi.model -borderwidth 4
ttk::label $wi.model.label -text "Type:"
set runstate "disabled"
@ -2618,7 +2613,7 @@ proc popupConfigDialog { c } {
global conntype
set conntype [netconfFetchSection $target "tunnel-type"]
if { $conntype == "" } { set conntype "UDP" }
# TODO: clean this up
ttk::frame $wi.linfo
@ -2804,7 +2799,7 @@ proc popupConfigDialog { c } {
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
pack $wi.unilabel -side top -anchor w
ttk::frame $wi.bandwidth -borderwidth 4
ttk::label $wi.bandwidth.label -anchor e -text "Bandwidth (bps):"
@ -2932,11 +2927,11 @@ proc popupConfigDialog { c } {
"popupConfigApply $wi $object_type $target 0"
focus $wi.butt.apply
# Boeing: remove range circles upon cancel
if {$type == "wlan"} {
if {$type == "wlan"} {
set cancelcmd "set badentry -1 ; destroy $wi;"
set cancelcmd "$cancelcmd updateRangeCircles $target 0"
set cancelcmd "$cancelcmd updateRangeCircles $target 0"
} else {
set cancelcmd "set badentry -1 ; destroy $wi"
set cancelcmd "set badentry -1 ; destroy $wi"
}
ttk::button $wi.butt.cancel -text "Cancel" -command $cancelcmd
#end Boeing
@ -3072,18 +3067,18 @@ proc macEntryHelper { wi ifc } {
# SYNOPSIS
# popupConfigApply $w $object_type $target $phase
# FUNCTION
# This procedure is called when the button apply is pressed in
# 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
# * 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
# * 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 } {
@ -3131,12 +3126,12 @@ proc popupConfigApply { wi object_type target phase } {
# Boeing - added wlan, remote, tunnel, ktunnel items
if { $type == "wlan" } {
wlanConfigDialogHelper $wi $target 1
wlanConfigDialogHelper $wi $target 1
} elseif { $type == "tunnel" } {
#
# apply tunnel items
#
set ipaddr "$name/24" ;# tunnel name == IP address of peer
set ipaddr "$name/24" ;# tunnel name == IP address of peer
set oldipaddr [getIfcIPv4addr $target e0]
if { $ipaddr != $oldipaddr } {
setIfcIPv4addr $target e0 $ipaddr
@ -3176,7 +3171,7 @@ proc popupConfigApply { wi object_type target phase } {
if { $oldlocal != $local } {
netconfInsertSection $target [list "local-hook" $local]
}
# Boeing changing to interface name for RJ45
# Boeing changing to interface name for RJ45
# } elseif { $type == "rj45" } {
# #
# # apply rj45 items
@ -3240,7 +3235,7 @@ proc popupConfigApply { wi object_type target phase } {
link {
global g_link_config_uni_state
set mirror [getLinkMirror $target]
if { [setIfChanged $target $mirror $wi "bandwidth" "LinkBandwidth"] } {
set changed 1
}
@ -3314,7 +3309,7 @@ proc setIfChanged { target mirror wi ctl procname } {
# printCanvas $w
# FUNCTION
# This procedure is called when the print button in
# print dialog box is pressed.
# print dialog box is pressed.
# INPUTS
# * w -- print dialog widget
#****
@ -3335,12 +3330,12 @@ proc printCanvas { w } {
# SYNOPSIS
# deleteSelection
# FUNCTION
# By calling this procedure all the selected nodes in imunes will
# By calling this procedure all the selected nodes in imunes will
# be deleted.
#****
proc deleteSelection { } {
global changed
global background
global background
global viewid
catch {unset viewid}
.c config -cursor watch; update
@ -3412,7 +3407,7 @@ proc align2grid {} {
# FUNCTION
# This procedure rearranges the position of nodes in imunes.
# It can be used to rearrange all the nodes or only the selected
# nodes.
# nodes.
# INPUTS
# * mode -- when set to "selected" only the selected nodes will be
# rearranged.
@ -3594,16 +3589,16 @@ proc rearrange_off { } {
}
#****f* editor.tcl/switchCanvas
#****f* editor.tcl/switchCanvas
# NAME
# switchCanvas -- switch canvas
# SYNOPSIS
# switchCanvas $direction
# FUNCTION
# This procedure switches the canvas in one of the defined
# 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 --
# * direction -- the direction of switching canvas. Can be: prev --
# previus, next -- next, first -- first, last -- last.
#****
proc switchCanvas { direction } {
@ -3706,7 +3701,7 @@ proc resizeCanvasPopup {} {
labelframe $w.size -text "Size"
frame $w.size.pixels
pack $w.size $w.size.pixels -side top -padx 4 -pady 4 -fill x
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
@ -3717,10 +3712,10 @@ proc resizeCanvasPopup {} {
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
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
@ -3789,7 +3784,7 @@ proc resizeCanvasPopup {} {
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
pack $w.default -side bottom -fill x
# update the size in meters based on pixels
syncSizeScale $w xp
@ -3884,7 +3879,7 @@ proc resizeCanvasApply { w } {
# SYNOPSIS
# animate
# FUNCTION
# This function animates the selectbox. The animation looks
# This function animates the selectbox. The animation looks
# different for edit and exec mode.
#****
proc animate {} {
@ -3929,7 +3924,7 @@ proc zoom { dir } {
set newzoom $z
}
}
set zoom $newzoom
set zoom $newzoom
}
redrawAll
}
@ -3945,7 +3940,7 @@ proc zoom { dir } {
break
}
}
set zoom $newzoom
set zoom $newzoom
}
redrawAll
}
@ -3965,7 +3960,7 @@ proc zoom { dir } {
# SYNOPSIS
# double1onGrid $c %x %y
# FUNCTION
# As grid is layered above annotations this procedure is used to find
# As grid is layered above annotations this procedure is used to find
# annotation object closest to cursor
#****
@ -3977,7 +3972,7 @@ proc double1onGrid { c x y } {
return
}
# Is this really necessary?
set coords [getNodeCoords $node]
set coords [getNodeCoords $node]
set x1 [lindex $coords 0]
set y1 [lindex $coords 1]
set x2 [lindex $coords 2]
@ -4065,7 +4060,7 @@ proc configRemoteServers {} {
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"
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
@ -4095,9 +4090,9 @@ proc configRemoteServers {} {
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"
-command "configRemoteServersHelper $wi 2"
button $wi.c.c.del -image $plugin_img_del \
-command "configRemoteServersHelper $wi 3"
-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
@ -4134,7 +4129,7 @@ proc configRemoteServers {} {
# apply/cancel buttons
frame $wi.b -borderwidth 4
button $wi.b.apply -text "Apply" -command \
"writeServersConf; redrawAll; destroy $wi"
"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
@ -4169,7 +4164,7 @@ proc configRemoteServersHelper { wi action } {
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]]
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
@ -4183,7 +4178,7 @@ proc selectRemoteServer { wi } {
# clear entries
$wi.c.c.name delete 0 end; $wi.c.c.ip delete 0 end;
$wi.c.c.port delete 0 end
$wi.c.c.port delete 0 end
set server [$wi.s.servers get $selected]
if { ![info exists exec_servers($server)] } { return }
@ -4215,7 +4210,7 @@ proc popupCustomImage { node } {
set wi .customimagedialog
catch {destroy $wi}
toplevel $wi -takefocus 1
wm transient $wi .popup
wm transient $wi .popup
wm resizable $wi 0 0
wm title $wi "[getNodeName $node] ($node) image"
grab $wi
@ -4228,11 +4223,11 @@ proc popupCustomImage { node } {
global configwin
set configwin $wi
button $wi.ftop.filebtn -text "..." -command {
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 != "" } {
if { $f != "" } {
set node [string trim [lindex [wm title $configwin] 1] "()"]
$configwin.ftop.filename delete 0 end
$configwin.ftop.filename insert 0 $f
@ -4271,7 +4266,7 @@ proc popupCustomImagePreview { wi node } {
setNodeCoords $node "150 50"
setNodeLabelCoords $node "150 78"
if { $img_save != $img_new } { setCustomImage $node $img_new }
if { $img_save != $img_new } { setCustomImage $node $img_new }
$wi.fmid.c delete all
drawNode $wi.fmid.c $node
@ -4363,9 +4358,9 @@ proc markerOptions { show } {
# 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}
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
@ -4393,18 +4388,18 @@ proc markerSize { x y } {
drawMarkerSizes .left.markeropt.sizes $sel
}
# Boeing: set canvas wallpaper
# 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
@ -4421,7 +4416,7 @@ proc wallpaperPopup {} {
# file browse button
global configwin
set configwin $w
button $w.f.filebtn -text "..." -command {
button $w.f.filebtn -text "..." -command {
global configwin showGrid adjustCanvas fileDialogBox_initial
global g_imageFileTypes
# use default conf file path upon first run
@ -4443,7 +4438,7 @@ proc wallpaperPopup {} {
}
# clear wallpaper button
button $w.f.clear -text "clear" -command {
button $w.f.clear -text "clear" -command {
global configwin wallpaperStyle
$configwin.f.file delete 0 end
$configwin.preview delete "wallpaper"
@ -4493,11 +4488,11 @@ proc wallpaperPopup {} {
# buttons
frame $w.btns
button $w.btns.apply -text "Apply" -command {
button $w.btns.apply -text "Apply" -command {
global configwin wallpaperStyle curcanvas adjustCanvas
set f [$configwin.f.file get]
if {$adjustCanvas} {
wallpaperAdjustCanvas $curcanvas $f $wallpaperStyle
if {$adjustCanvas} {
wallpaperAdjustCanvas $curcanvas $f $wallpaperStyle
}
setCanvasWallpaper $curcanvas $f $wallpaperStyle
redrawAll
@ -4536,7 +4531,7 @@ proc wallpaperAdjustCanvas { c f style } {
#puts -nonewline "wallpaperAdjustCanvas img($imgx, $imgy) $cx, $cy -> "
# For scaled and tiled styles, expand canvas x and y to a multiple of
# 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"} {
@ -4605,13 +4600,13 @@ proc drawWallpaper { c f style } {
# grow image
if { $cx >= $imgx || $cy > $imgy } {
set x [expr 1+($cx / $imgx)]
set y [expr 1+($cy / $imgy)]
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) }]
[expr { int($imgy / $cy) }]
}
$c create image [expr 1+$cx/2] [expr 1+$cy/2] -image $img2 \
-tags "background wallpaper"
@ -4635,7 +4630,7 @@ proc drawWallpaper { c f style } {
}
raiseAll $c
}
# helper for close/cancel buttons
@ -4665,11 +4660,11 @@ proc rj45ifclist { wi node wasclicked } {
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"
-command "$wi.ftop.ifc.ifc_list yview"
set ifname ""
set ifip ""
# this handles differences between Linux and FreeBSD ifconfig
# this handles differences between ifconfig
foreach line [split [nexec localnode ifconfig -a] "\n"] {
set char [string index $line 0]
if { $char != " " && $char != " " } {
@ -4924,7 +4919,7 @@ proc popupHookScript { name } {
"genericOpenSaveButtonPress $c $wi.mid.script $wi.n.name"
}
ttk::combobox $wi.n.state -width 15 -state readonly -exportselection 0 \
-values $CORE_STATES
-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
@ -5081,7 +5076,7 @@ proc popupFileView { pathname } {
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.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

5
gui/exceptions.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2011-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
array set g_exceptions {}
global execMode
if { $execMode == "interactive" } {

118
gui/exec.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2004-2008 University of Zagreb, Croatia.
#
@ -38,10 +33,10 @@
# SYNOPSIS
# set result [nexec $args]
# FUNCTION
# Executes the sting given in args variable. The sting is not executed
# Executes the sting given in args variable. The sting is not executed
# if IMUNES is running in editor only mode. Execution of a string can
# be local or remote. If socket can not be opened in try of a remote
# execution, mode is switched to editor only mode.
# execution, mode is switched to editor only mode.
# INPUTS
# * args -- the string that should be executed localy or remotely.
# RESULT
@ -80,7 +75,7 @@ proc acquireOperModeLock { mode } {
if { $mode == "exec" } {
set choice [tk_messageBox -type yesno -default no -icon warning \
-message "You have selected to start the session while the previous one is still shutting down. Are you sure you want to interrupt the shutdown? (not recommended)"]
if { $choice == "no" } {
if { $choice == "no" } {
set activetool select
return; # return and allow previous setOperMode to finish...
}
@ -88,7 +83,7 @@ proc acquireOperModeLock { mode } {
} elseif { $setOperMode_lock } { ;# mode == "edit"
set choice [tk_messageBox -type yesno -default no -icon warning \
-message "You are trying to stop the session while it is still starting. Are you sure you want to interrupt the startup? (not recommeded)"]
if { $choice == "no" } {
if { $choice == "no" } {
set activetool select
return; # return and allow previous setOperMode to finish...
}
@ -155,7 +150,7 @@ proc drawToolbar { mode } {
# add buttons when in edit mode
set imgf "$CORE_DATA_DIR/icons/tiny/$b.gif"
set image [image create photo -file $imgf]
catch {
catch {
radiobutton .left.$b -indicatoron 0 \
-variable activetool -value $b -selectcolor $defSelectionColor \
-width 32 -height 32 -image $image \
@ -163,7 +158,7 @@ proc drawToolbar { mode } {
leftToolTip $b .left
pack .left.$b -side top
}
}
}
}
# popup toolbar buttons have submenus
set buttons {routers hubs bgobjs}
@ -192,7 +187,7 @@ proc drawToolbar { mode } {
-borderwidth 1 -tearoff 0]
# create the child menutbuttons
drawToolbarSubmenu $b $menubuttons
# tooltips for parent and submenu items
# tooltips for parent and submenu items
leftToolTip $b .left
bind $buttonmenu <<MenuSelect>> {leftToolTipSubMenu %W}
bind $buttonmenu <Leave> {
@ -206,7 +201,7 @@ proc drawToolbar { mode } {
}
}
#
#
# Exec mode button bar
#
if { "$mode" == "edit" } {
@ -267,7 +262,7 @@ proc drawToolbarSubmenu { b menubuttons } {
$buttonmenu add command -image $img -columnbreak 1 \
-command "popupMenuChoose $b $menubutton $imgf"
}
# add an edit button to the end of the row
# add an edit button to the end of the row
if { $b == "routers" } {
set imgf "$CORE_DATA_DIR/icons/normal/document-properties.gif"
set img [createImageButton $imgf 0]
@ -279,7 +274,7 @@ proc drawToolbarSubmenu { b menubuttons } {
proc setSessionStartStopMenu { mode } {
if { $mode == "exec" } {
catch {.menubar.session entryconfigure "Start" \
-label "Stop" -command "startStopButton edit"}
-label "Stop" -command "startStopButton edit"}
} else {
catch {.menubar.session entryconfigure "Stop" \
-label "Start" -command "startStopButton exec"}
@ -339,8 +334,8 @@ proc startStopButton { mode } {
# Sets imunes operating mode to the value of the parameter mode.
# The mode can be set only to edit or exec.
# When changing the mode to exec all the emulation interfaces are
# checked (if they are nonexistent the message is displayed, and
# mode is not changed), all the required buttons are disabled
# checked (if they are nonexistent the message is displayed, and
# mode is not changed), all the required buttons are disabled
# (except the simulation/Terminate button, that is enabled) and
# procedure deployCfg is called.
# When changing the mode to edit, all required buttons are enabled
@ -387,7 +382,7 @@ proc setOperMode { mode { type "" } } {
#
# Start/stop the emulation
#
#
### start button is pressed
if { "$mode" == "exec" } {
rearrange_off
@ -395,11 +390,11 @@ proc setOperMode { mode { type "" } } {
resetAllNodeCoords save
clearExceptions "" ""
throwCEL true
# Bind left mouse click to displaying the CPU usage in
# Bind left mouse click to displaying the CPU usage in
# a graph format
bind .bottom.cpu_load <1> {manageCPUwindow %X %Y 1}
monitor_loop
set plugin [lindex [getEmulPlugin "*"] 0]
set emul_sock [pluginConnect $plugin connect false]
@ -422,7 +417,7 @@ proc setOperMode { mode { type "" } } {
clearWlanLinks ""
widgets_stop
set oper_mode edit
# Bind left mouse click to clearing the CPU graph
bind .bottom.cpu_load <1> {manageCPUwindow %X %Y 0}
manageCPUwindow %X %Y 0
@ -438,7 +433,7 @@ proc setOperMode { mode { type "" } } {
# SYNOPSIS
# statline $line
# FUNCTION
# Sets the string of the status line. If the execution mode is
# Sets the string of the status line. If the execution mode is
# set to batch the line is just printed on the standard output.
# INPUTS
# * line -- line to be displayed
@ -475,15 +470,15 @@ proc getNextMac {} {
# monitor_loop
# FUNCTION
# Calculates the usage of cpu, mbuffers and mbuf clusters.
# The results are displayed in status line and updated
# The results are displayed in status line and updated
# every two seconds.
#****
proc monitor_loop {} {
global oper_mode systype
global server_cpuusage
global exec_servers
global exec_servers
if {$oper_mode != "exec"} {
.bottom.cpu_load config -text ""
.bottom.mbuf config -text ""
@ -492,7 +487,7 @@ proc monitor_loop {} {
if { [lindex $systype 0] == "Linux" } {
set cpuusage [getCPUUsage]
#TODO: get the cpu usage on all the assigned server
# store usage history for each server stored in an array list
set assigned_servers [getAssignedRemoteServers]
@ -509,22 +504,22 @@ proc monitor_loop {} {
# TODO: receive CPU usage from other servers
set cpuusageforserver 0
}
# append the latest cpu value to the end of list and
# only keep and display the last 20 values for each server
set server_cpuusage($ip) [lappend server_cpuusage($ip) $cpuusageforserver]
set server_cpuusage($ip) [lappend server_cpuusage($ip) $cpuusageforserver]
if { [llength $server_cpuusage($ip)] > 20 } {
set server_cpuusage($ip) [lreplace $server_cpuusage($ip) 0 0]
}
}
}
#plot the usage data if cpu windows already opened
# for all servers
if { [winfo exists .cpu]} {
plotCPUusage
}
set cputxt "CPU [lindex $cpuusage 0]% ("
set cpuusage [lreplace $cpuusage 0 0]
for { set n 0 } { $n < [llength $cpuusage] } { incr n } {
@ -544,13 +539,8 @@ proc monitor_loop {} {
return
}
if { $systype == "FreeBSD 4.11-RELEASE" } {
set defaultname "default"
set cpun 3
} else {
set defaultname "."
set defaultname "."
set cpun 4
}
# CPU usage from `vimage -l`
set vimagetext [nexec localnode vimage -l $defaultname | xargs]
@ -578,7 +568,7 @@ proc monitor_loop {} {
# SYNOPSIS
# execSetLinkParams $eid $link
# FUNCTION
# Sets the link parameters during execution.
# Sets the link parameters during execution.
# All the parameters are set at the same time.
# INPUTS
# eid -- experiment id
@ -649,7 +639,7 @@ proc createImageButton { imgf style } {
}
}
return $img
}
# Boeing: status bar graph
@ -689,7 +679,7 @@ proc statgraph { cmd n } {
}
}
}
proc popupConnectMessage { dst } {
global CORE_DATA_DIR execMode
@ -751,21 +741,21 @@ proc manageCPUwindow {xpos ypos start} {
global exec_servers
global server_cpuusage
if {$start == 1} {
if { ![winfo exists .cpu]} {
if { ![winfo exists .cpu]} {
toplevel .cpu
wm geometry .cpu 200x210+$xpos+$ypos
wm resizable .cpu 0 0
wm title .cpu "CPU Usage"
canvas .cpu.graph -width 200 -height 210
wm title .cpu "CPU Usage"
canvas .cpu.graph -width 200 -height 210
pack .cpu.graph
}
}
} else {
if { [winfo exists .cpu]} {
destroy .cpu
set assigned_servers [getAssignedRemoteServers]
for {set i 0} {$i <= [llength $assigned_servers]} {incr i} {
if {$i == [llength $assigned_servers]} {
set ip [getMyIP]
@ -774,7 +764,7 @@ proc manageCPUwindow {xpos ypos start} {
set srv [array get exec_servers $server]
if { $srv == "" } { continue }
set ip [lindex $srv 0]
}
}
set server_cpuusage($ip) [lreplace $server_cpuusage($ip) 0 end]
}
}
@ -800,24 +790,24 @@ proc plotCPUusage { } {
global cpu_palettes
global exec_servers
global server_cpuusage
.cpu.graph delete "all"
.cpu.graph delete "all"
.cpu.graph create line 0 100 200 100 -width 2
.cpu.graph create line 0 80 200 80 -width 1
.cpu.graph create line 0 60 200 60 -width 1
.cpu.graph create line 0 40 200 40 -width 1
.cpu.graph create line 0 20 200 20 -width 1
.cpu.graph create line 0 0 200 0 -width 1
.cpu.graph create line 40 0 40 100 -width 1
.cpu.graph create line 80 0 80 100 -width 1
.cpu.graph create line 120 0 120 100 -width 1
.cpu.graph create line 160 0 160 100 -width 1
.cpu.graph create line 200 0 200 100 -width 1
# for each server create a plot of cpu usage
set assigned_servers [getAssignedRemoteServers]
for {set i 0} {$i <= [llength $assigned_servers]} {incr i} {
# for each server create a plot of cpu usage
set assigned_servers [getAssignedRemoteServers]
for {set i 0} {$i <= [llength $assigned_servers]} {incr i} {
if {$i == [llength $assigned_servers]} {
set ip [getMyIP]
} else {
@ -826,9 +816,9 @@ proc plotCPUusage { } {
if { $srv == "" } { continue }
set ip [lindex $srv 0]
}
#need to add multiple cpuusgaehistory (array)
for { set n 1 } { $n < [llength $server_cpuusage($ip)] } { incr n } {
for { set n 1 } { $n < [llength $server_cpuusage($ip)] } { incr n } {
set prevn [expr {$n - 1}]
set x1 [expr {$prevn * 10}]
set y1 [expr {100 - [lindex $server_cpuusage($ip) $prevn]}]
@ -840,15 +830,15 @@ proc plotCPUusage { } {
.cpu.graph create line $x1 $y1 $x2 $y2 -fill [lindex $cpu_palettes end]
}
#debug
#puts " cpu $x1 $y1 $x2 $y2"
#debug
#puts " cpu $x1 $y1 $x2 $y2"
}
#for each server create a legend (limited to 8)
set legendtext $ip
append legendtext " " [lindex $server_cpuusage($ip) end] "%"
set legendy [expr {($i * 10) + 120}]
set legendy [expr {($i * 10) + 120}]
set legendx 10
if {$i < [llength $cpu_palettes]} {
.cpu.graph create rectangle $legendx $legendy \
@ -864,9 +854,9 @@ proc plotCPUusage { } {
.cpu.graph create text [expr {$legendx + 15}] [expr {$legendy + 4}]\
-text $legendtext -fill [lindex $cpu_palettes end] \
-anchor w -justify left
}
}
}

59
gui/filemgmt.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2014 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2004-2008 University of Zagreb, Croatia.
#
@ -36,41 +31,41 @@
# NAME
# filemgmt.tcl -- file used for manipulation with files
# FUNCTION
# This module is used for all file manipulations. In this file
# This module is used for all file manipulations. In this file
# a file is read, a new file opened or existing file saved.
# NOTES
# variables:
#
#
# currentFile
# relative or absolute path to the current configuration file
#
#
# fileTypes
# types that will be displayed when opening new file
# types that will be displayed when opening new file
#
# procedures used for loading and storing the configuration file:
#
# newFile
# newFile
# - creates an empty project
#
# openFile {filename}
# - loads configuration from filename
#
# saveFile {selectedFile}
# - saves current configuration to a file named selectedFile
# saveFile {selectedFile}
# - saves current configuration to a file named selectedFile
# unless the file name is an empty string
#
# fileOpenStartUp
# - opens the file named as command line argument
#
#
# fileNewDialogBox
# - opens message box to optionally save the changes
# - opens message box to optionally save the changes
#
# fileOpenDialogBox
# - opens dialog box for selecting a file to open
#
# fileSaveDialogBox
# - opens dialog box for saving a file under new name if there is no
# current file
# current file
#****
set currentFile ""
@ -103,11 +98,6 @@ proc newFile {} {
set g_view_locked 0
# flush daemon configuration
if { [llength [findWlanNodes ""]] > 0 } {
if { [lindex $systype 0] == "FreeBSD" } {
catch { exec ngctl config wlan_ctl: flush=all }
}
}
loadCfg ""
resetGlobalVars newfile
set curcanvas [lindex $canvas_list 0]
@ -143,7 +133,7 @@ proc newFile {} {
# Loads the configuration from the file named $filename.
#****
proc openFile { filename } {
global currentFile
global currentFile
global undolog activetool
global canvas_list curcanvas systype
global changed
@ -190,11 +180,6 @@ proc openFile { filename } {
}
# flush daemon configuration
if { [llength [findWlanNodes ""]] > 0 } {
if { [lindex $systype 0] == "FreeBSD" } {
catch { exec ngctl config wlan_ctl: flush=all }
}
}
set cfg ""
if { [catch { set fileId [open $currentFile r] } err] } {
puts "error opening file $currentFile: $err"
@ -209,7 +194,7 @@ proc openFile { filename } {
loadCfg $cfg
switchCanvas none
set undolog(0) $cfg
set undolog(0) $cfg
set activetool select
# remember opened files
@ -236,11 +221,11 @@ proc resetGlobalVars { reason } {
# FUNCTION
# Loads the current configuration into the selectedFile file.
# INPUTS
# * selectedFile -- the name of the file where current
# * selectedFile -- the name of the file where current
# configuration is saved.
#****
proc saveFile { selectedFile } {
global currentFile
global currentFile
global changed
if { $selectedFile == ""} {
@ -275,7 +260,7 @@ proc saveFile { selectedFile } {
# SYNOPSIS
# fileOpenStartUp
# FUNCTION
# Loads configuration from batch input file to the current
# Loads configuration from batch input file to the current
# configuration.
#****
proc fileOpenStartUp {} {
@ -310,7 +295,7 @@ proc fileNewDialogBox {} {
if {$changed != 0 } {
set choice [promptForSave]
}
if { $choice != "cancel"} {
newFile
}
@ -370,7 +355,7 @@ proc fileSaveDialogBox { prompt } {
set ft [lreplace $ft 0 0]
set ft [linsert $ft 1 $imn]
}
set dir ""
# use default conf file path upon first run
if { $fileDialogBox_initial == 0} {
@ -450,7 +435,7 @@ proc loadDotFile {} {
set isfile 0
if {[catch {set dotfile [open "$CONFDIR/prefs.conf" r]} ]} return
close $dotfile
if {[catch { source "$CONFDIR/prefs.conf" }]} {
puts "The $CONFDIR/prefs.conf preferences file is invalid, ignoring it."
#file delete "~/.core"
@ -468,7 +453,7 @@ proc savePrefsFile { } {
# header
puts $dotfile "# CORE ${CORE_VERSION} GUI preference file"
# save the most-recently-used file list
puts $dotfile "set g_mrulist \"$g_mrulist\""
@ -550,10 +535,6 @@ proc exit {} {
if { [popupStopSessionPrompt]=="cancel" } {
return
}
# Flush daemon configuration
if { [lindex $systype 0] == "FreeBSD" } {
catch { exec ngctl config wlan_ctl: flush=all }
}
# Prompt for save if file was changed
if { $changed != 0 && [promptForSave] == "cancel" } {
return
@ -579,7 +560,7 @@ proc exit {} {
# save user preferences
savePrefsFile
exit.real
}

5
gui/gpgui.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2007-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2007 Petra Schilhard.
#

5
gui/graph_partitioning.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2007-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2007 Petra Schilhard.
#

7
gui/help.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2004-2008 University of Zagreb, Croatia.
#
@ -86,7 +81,7 @@ proc popupAbout {} {
# version info
label .about.text1 -text "CORE version $CORE_VERSION ($CORE_VERSION_DATE)" \
-foreground #500000 -padx 5 -pady 10
label .about.text2 -text "Copyright (c)2005-2013\
label .about.text2 -text "Copyright \
the Boeing Company. See the LICENSE file included in this\
distribution."
pack .about.text1 -side top -anchor n -padx 4 -pady 4

98
gui/icons/Makefile.am
View file

@ -5,97 +5,25 @@
# author: Jeff Ahrenholz <jeffrey.m.ahrenholz@boeing.com>
#
TINY_ICONS = tiny/button.play.gif \
tiny/select.gif tiny/marker.gif \
tiny/rj45.gif tiny/text.gif \
tiny/edit-delete.gif tiny/stop.gif \
tiny/blank.gif tiny/mobility.gif \
tiny/script_play.gif tiny/arrow.gif \
tiny/lanswitch.gif tiny/script_pause.gif \
tiny/pc.gif tiny/rectangle.gif \
tiny/observe.gif tiny/document-new.gif \
tiny/document-save.gif \
tiny/view-refresh.gif tiny/moboff.gif \
tiny/document-properties.gif tiny/arrow.up.gif \
tiny/host.gif tiny/hub.gif \
tiny/twonode.gif tiny/router.gif \
tiny/eraser.gif \
tiny/stock_connect.gif tiny/stock_disconnect.gif \
tiny/ping.gif tiny/link.gif \
tiny/start.gif \
tiny/trace.gif tiny/button.stop.gif \
tiny/arrow.down.gif tiny/oval.gif \
tiny/wlan.gif tiny/delete.gif \
tiny/run.gif tiny/tunnel.gif \
tiny/script_stop.gif \
tiny/router_black.gif tiny/router_green.gif \
tiny/router_red.gif tiny/router_yellow.gif \
tiny/router_purple.gif \
tiny/ap.gif tiny/mdr.gif \
tiny/folder.gif \
tiny/cel.gif \
tiny/fileopen.gif \
tiny/xen.gif \
tiny/plot.gif
TINY_ICONS := $(wildcard tiny/*)
NORM_ICONS := $(wildcard normal/*)
SVG_ICONS := $(wildcard svg/*)
NORM_ICONS = normal/gps-diagram.xbm \
normal/router_black.gif normal/host.gif \
normal/hub.gif \
normal/router.gif \
normal/rj45.gif normal/antenna.gif \
normal/text.gif \
normal/lanswitch.gif normal/core-icon.png \
normal/core-icon.xbm normal/oval.gif \
normal/wlan.gif normal/pc.gif \
normal/tunnel.gif normal/core-logo-275x75.gif \
normal/router_red.gif normal/router_green.gif \
normal/simple.xbm \
normal/document-properties.gif \
normal/thumb-unknown.gif \
normal/router_purple.gif normal/router_yellow.gif \
normal/ap.gif normal/mdr.gif \
normal/xen.gif
SVG_ICONS = svg/ap.svg \
svg/cel.svg \
svg/hub.svg \
svg/lanswitch.svg \
svg/mdr.svg \
svg/otr.svg \
svg/rj45.svg \
svg/router_black.svg \
svg/router_green.svg \
svg/router_purple.svg \
svg/router_red.svg \
svg/router.svg \
svg/router_yellow.svg \
svg/start.svg \
svg/tunnel.svg \
svg/vlan.svg \
svg/xen.svg
#
# Icon files (/usr/local/share/core/icons/[tiny,normal,svg])
#
coreiconnormaldir = $(CORE_DATA_DIR)/icons/normal
coreiconnormaldir = $(CORE_DATA_DIR)/icons/normal
dist_coreiconnormal_DATA = $(NORM_ICONS)
coreicontinydir = $(CORE_DATA_DIR)/icons/tiny
dist_coreicontiny_DATA = $(TINY_ICONS)
coreiconsvgdir = $(CORE_DATA_DIR)/icons/svg
dist_coreiconsvg_DATA = $(SVG_ICONS)
iconpixmapdir = $(datarootdir)/pixmaps
dist_iconpixmap_DATA = core-gui.xpm
coreicontinydir = $(CORE_DATA_DIR)/icons/tiny
dist_coreicontiny_DATA = $(TINY_ICONS)
icondesktopdir = $(datarootdir)/applications
dist_icondesktop_DATA = core-gui.desktop
coreiconsvgdir = $(CORE_DATA_DIR)/icons/svg
dist_coreiconsvg_DATA = $(SVG_ICONS)
uninstall-hook:
rmdir -p $(icondesktopdir) || true
rmdir -p $(iconpixmapdir) || true
rmdir -p $(coreiconsvgdir) || true
rmdir -p $(coreicontinydir) || true
rmdir -p $(coreiconnormaldir) || true
iconpixmapdir = $(datarootdir)/pixmaps
dist_iconpixmap_DATA = core-gui.xpm
icondesktopdir = $(datarootdir)/applications
dist_icondesktop_DATA = core-gui.desktop
# extra cruft to remove
DISTCLEANFILES = Makefile.in

BIN
gui/icons/normal/xen.gif
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 1.6 KiB

181
gui/icons/svg/xen.svg
View file

@ -1,181 +0,0 @@
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<!-- Created with Inkscape (http://www.inkscape.org/) -->
<svg
xmlns:dc="http://purl.org/dc/elements/1.1/"
xmlns:cc="http://creativecommons.org/ns#"
xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
xmlns:svg="http://www.w3.org/2000/svg"
xmlns="http://www.w3.org/2000/svg"
xmlns:xlink="http://www.w3.org/1999/xlink"
xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
width="146"
height="100"
id="svg13653"
sodipodi:version="0.32"
inkscape:version="0.48.0 r9654"
sodipodi:docname="xen.svg"
version="1.0"
inkscape:export-filename="xen.png"
inkscape:export-xdpi="30.464558"
inkscape:export-ydpi="30.464558">
<defs
id="defs13655">
<inkscape:perspective
sodipodi:type="inkscape:persp3d"
inkscape:vp_x="0 : 99.931252 : 1"
inkscape:vp_y="0 : 1000 : 0"
inkscape:vp_z="199.10001 : 99.931252 : 1"
inkscape:persp3d-origin="99.550003 : 66.620834 : 1"
id="perspective3835" />
<linearGradient
id="linearGradient12828">
<stop
id="stop12830"
offset="0"
style="stop-color:#484849;stop-opacity:1;" />
<stop
style="stop-color:#434344;stop-opacity:1;"
offset="0"
id="stop12862" />
<stop
id="stop12832"
offset="1.0000000"
style="stop-color:#8f8f90;stop-opacity:0.0000000;" />
</linearGradient>
<radialGradient
inkscape:collect="always"
xlink:href="#linearGradient12828"
id="radialGradient13651"
cx="328.57144"
cy="602.7193"
fx="328.57144"
fy="602.7193"
r="147.14285"
gradientTransform="matrix(1,0,0,0.177184,0,495.9268)"
gradientUnits="userSpaceOnUse" />
<linearGradient
id="linearGradient12001">
<stop
style="stop-color:#1b4a78;stop-opacity:1;"
offset="0"
id="stop12003" />
<stop
style="stop-color:#5dacd1;stop-opacity:1;"
offset="1"
id="stop12005" />
</linearGradient>
<linearGradient
inkscape:collect="always"
xlink:href="#linearGradient12001"
id="linearGradient13633"
gradientUnits="userSpaceOnUse"
gradientTransform="matrix(0.471308,0,0,0.471308,118.8781,123.5182)"
x1="175.71875"
y1="737.01562"
x2="470.00089"
y2="737.01562" />
<linearGradient
inkscape:collect="always"
xlink:href="#linearGradient12001"
id="linearGradient3844"
gradientUnits="userSpaceOnUse"
gradientTransform="matrix(0.471308,0,0,0.471308,-45.6934,-239.9103)"
x1="175.71875"
y1="737.01562"
x2="470.00089"
y2="737.01562" />
</defs>
<sodipodi:namedview
id="base"
pagecolor="#ffffff"
bordercolor="#666666"
borderopacity="1.0"
inkscape:pageopacity="0.0"
inkscape:pageshadow="2"
inkscape:zoom="1"
inkscape:cx="118.57814"
inkscape:cy="50.488033"
inkscape:document-units="px"
inkscape:current-layer="layer1"
inkscape:window-width="1280"
inkscape:window-height="949"
inkscape:window-x="1631"
inkscape:window-y="29"
showgrid="false"
inkscape:window-maximized="0" />
<metadata
id="metadata13658">
<rdf:RDF>
<cc:Work
rdf:about="">
<dc:format>image/svg+xml</dc:format>
<dc:type
rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
<dc:title></dc:title>
</cc:Work>
</rdf:RDF>
</metadata>
<g
inkscape:label="Capa 1"
inkscape:groupmode="layer"
id="layer1"
transform="translate(-33.124945,-44.636248)">
<path
style="fill:url(#linearGradient3844);fill-opacity:1;stroke:none"
d="m 37.14136,72.27878 0,0.29457 c 0.006,-0.0975 0.0206,-0.19729 0.0295,-0.29457 l -0.0295,0 z m 138.62351,0 c 0.0302,0.33044 0.0589,0.66821 0.0589,1.00153 l 0,-1.00153 -0.0589,0 z m 0.0589,1.00153 c -1e-5,15.05224 -31.07495,27.26223 -69.35594,27.26223 -37.68286,1e-5 -68.3765,-11.82771 -69.32649,-26.55527 l 0,40.67979 c -0.0151,0.23376 -0.0147,0.45704 -0.0147,0.69223 0,0.22546 8.7e-4,0.45335 0.0147,0.67751 0.91151,14.74102 31.61889,26.59945 69.32649,26.59945 37.7076,0 68.41498,-11.85843 69.32648,-26.59945 l 0.0295,0 0,-0.50077 c 9.5e-4,-0.0587 0,-0.11794 0,-0.17674 0,-0.0588 9.4e-4,-0.11803 0,-0.17674 l 0,-41.90224 z"
id="path13626" />
<path
sodipodi:type="arc"
style="fill:#3a78a0;fill-opacity:1;stroke:none"
id="path11090"
sodipodi:cx="328.57144"
sodipodi:cy="602.7193"
sodipodi:rx="147.14285"
sodipodi:ry="26.071428"
d="m 475.71429,602.7193 c 0,14.39885 -65.87809,26.07143 -147.14285,26.07143 -81.26475,0 -147.14285,-11.67258 -147.14285,-26.07143 0,-14.39885 65.8781,-26.07143 147.14285,-26.07143 81.26476,0 147.14285,11.67258 147.14285,26.07143 z"
transform="matrix(0.471308,0,0,1.045917,-48.3838,-554.9944)" />
<g
id="g13565"
style="fill:#f2fdff;fill-opacity:0.71171169"
transform="matrix(0.84958,0.276715,-0.703617,0.334119,278.6313,-230.2001)">
<path
id="path13507"
d="m 328.66945,592.8253 -5.97867,10.35298 -5.97867,10.35297 6.18436,0 0,21.24074 11.53226,0 0,-21.24074 6.18435,0 -5.97867,-10.35297 -5.96496,-10.35298 z"
style="fill:#f2fdff;fill-opacity:0.71171169;stroke:none" />
<path
id="path13509"
d="m 328.66945,687.10951 -5.97867,-10.35298 -5.97867,-10.35297 6.18436,0 0,-21.24074 11.53226,0 0,21.24074 6.18435,0 -5.97867,10.35297 -5.96496,10.35298 z"
style="fill:#f2fdff;fill-opacity:0.71171169;stroke:none" />
<path
id="path13511"
d="m 333.74751,639.82449 10.35297,-5.97867 10.35297,-5.97867 0,6.18436 21.24074,0 0,11.53225 -21.24074,0 0,6.18436 -10.35297,-5.97867 -10.35297,-5.96496 z"
style="fill:#f2fdff;fill-opacity:0.71171169;stroke:none" />
<path
id="path13513"
d="m 323.35667,639.82449 -10.35297,-5.97867 -10.35298,-5.97867 0,6.18436 -21.24073,0 0,11.53225 21.24073,0 0,6.18436 10.35298,-5.97867 10.35297,-5.96496 z"
style="fill:#f2fdff;fill-opacity:0.71171169;stroke:none" />
</g>
<rect
style="fill:#f2fdff;fill-opacity:0.70980394;stroke:#000000;stroke-opacity:1"
id="rect6161"
width="91.923882"
height="37.476658"
x="52.679455"
y="60.048466"
transform="translate(33.124945,44.636248)"
rx="5.454824"
ry="5.454824" />
<text
xml:space="preserve"
style="font-size:32px;font-style:normal;font-variant:normal;font-weight:bold;font-stretch:normal;fill:#000000;fill-opacity:1;stroke:none;font-family:DejaVu Sans;-inkscape-font-specification:Bitstream Charter Bold"
x="91.107697"
y="135.0903"
id="text6673"><tspan
sodipodi:role="line"
id="tspan6675"
x="91.107697"
y="135.0903">Xen</tspan></text>
</g>
</svg>
Side by side

Before

Width:  |  Height:  |  Size: 6.9 KiB

BIN
gui/icons/tiny/xen.gif
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 905 B

9
gui/initgui.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2014 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2004-2008 University of Zagreb, Croatia.
#
@ -600,9 +595,9 @@ menu .menubar.session -tearoff 1
#
menu .menubar.help -tearoff 0
.menubar.help add command -label "Online manual (www)" -command \
"_launchBrowser http://downloads.pf.itd.nrl.navy.mil/docs/core/core-html/"
"_launchBrowser https://downloads.pf.itd.nrl.navy.mil/docs/core/core-html/"
.menubar.help add command -label "CORE website (www)" -command \
"_launchBrowser http://www.nrl.navy.mil/itd/ncs/products/core"
"_launchBrowser https://www.nrl.navy.mil/itd/ncs/products/core"
.menubar.help add command -label "Mailing list (www)" -command \
"_launchBrowser https://publists.nrl.navy.mil/mailman/listinfo/core-users"
.menubar.help add command -label "About" -command popupAbout

5
gui/ipv4.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2005-2008 University of Zagreb, Croatia.
#

5
gui/ipv6.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2005-2008 University of Zagreb, Croatia.
#

65
gui/linkcfg.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2004-2008 University of Zagreb, Croatia.
#
@ -35,11 +30,11 @@
# NAME
# linkcfg.tcl -- file used for manipultaion with links in IMUNES
# FUNCTION
# This module is used to define all the actions used for configuring
# links in IMUNES.
# This module is used to define all the actions used for configuring
# links in IMUNES.
#
# NOTES
#
#
# linkPeers { link_id }
# Returns node_ids of link endpoints
#
@ -53,7 +48,7 @@
# ... in bits per second
#
# getLinkBandwidthString { link_id }
# ... as string
# ... as string
#
# getLinkDelay { link_id }
# ... in microseconds
@ -83,7 +78,7 @@
# INPUTS
# * link_id -- link id
# RESULT
# * link_peers -- returns nodes_ids of a link endpoints
# * link_peers -- returns nodes_ids of a link endpoints
# in a list {node1_id node2_id}
#****
@ -100,14 +95,14 @@ proc linkPeers { link } {
# SYNOPSIS
# set link_id [linkByPeers $node1_id $node2_id]
# FUNCTION
# Returns link_id whose peers are node1 and node2.
# Returns link_id whose peers are node1 and node2.
# The order of input nodes is irrelevant.
# INPUTS
# * node1_id -- node id of the first node
# * node2_id -- node id of the second node
# RESULT
# * link_id -- returns id of a link connecting endpoints
# node1_id node2_id.
# * link_id -- returns id of a link connecting endpoints
# node1_id node2_id.
#****
proc linkByPeers { node1 node2 } {
@ -144,7 +139,7 @@ proc linkByPeersMirror { node1 node2 } {
# removeLink $link_id
# FUNCTION
# Removes the link and related entries in peering node's configs.
# Updates the default route for peer nodes.
# Updates the default route for peer nodes.
# INPUTS
# * link_id -- link id
#****
@ -199,7 +194,7 @@ proc getLinkBandwidth { link {dir "down"} } {
# INPUTS
# * link_id -- link id
# RESULT
# * bandwidth_str -- The value of link bandwidth formated in a sting
# * bandwidth_str -- The value of link bandwidth formated in a sting
# containing a measure unit.
#****
@ -332,7 +327,7 @@ proc getLinkDelay { link {dir "down"} } {
# INPUTS
# * link_id -- link id
# RESULT
# * delay -- The value of link delay formated in a string
# * delay -- The value of link delay formated in a string
# containing a measure unit.
#****
@ -437,7 +432,7 @@ proc getLinkBERString { link } {
if { $ber != "" } {
set berstr "$berstr$ber%"
}
if { $berup != "" } {
if { $berup != "" } {
set berstr "$berstr / $berup%"
}
return $berstr
@ -472,7 +467,7 @@ proc setLinkBER { link value } {
#****f* linkcfg.tcl/getLinkDup
# NAME
# getLinkDup -- get link packet duplicate value
# getLinkDup -- get link packet duplicate value
# SYNOPSIS
# set duplicate [getLinkDup $link_id]
# FUNCTION
@ -508,7 +503,7 @@ proc getLinkDupString { link } {
#****f* linkcfg.tcl/setLinkDup
# NAME
# setLinkDup -- set link packet duplicate value
# setLinkDup -- set link packet duplicate value
# SYNOPSIS
# setLinkDup $link_id $value
# FUNCTION
@ -547,7 +542,7 @@ proc isLinkUni { link } {
#****f* linkcfg.tcl/getLinkMirror
# NAME
# getLinkMirror -- get link's mirror link
# getLinkMirror -- get link's mirror link
# SYNOPSIS
# set mirror_link_id [getLinkMirror $link_id]
# FUNCTION
@ -569,7 +564,7 @@ proc getLinkMirror { link } {
#****f* linkcfg.tcl/setLinkMirror
# NAME
# setLinkMirror -- set link's mirror link
# setLinkMirror -- set link's mirror link
# SYNOPSIS
# setLinkMirror $link_id $mirror_link_id
# FUNCTION
@ -599,7 +594,7 @@ proc setLinkMirror { link value } {
# SYNOPSIS
# set nodes [splitLink $link_id $nodetype]
# FUNCTION
# Splits the link in two parts. Each part of the split link is one
# Splits the link in two parts. Each part of the split link is one
# pseudo link.
# INPUTS
# * link_id -- link id
@ -674,7 +669,7 @@ proc splitLink { link nodetype } {
# SYNOPSIS
# set new_link_id [mergeLink $link_id]
# FUNCTION
# Rebuilts a link from two pseudo link.
# Rebuilts a link from two pseudo link.
# INPUTS
# * link_id -- pseudo link id
# RESULT
@ -754,11 +749,11 @@ proc newLink { lnode1 lnode2 } {
global systype
if { ([nodeType $lnode1] == "lanswitch" ||[nodeType $lnode1] == "OVS") && \
[nodeType $lnode2] != "router" && \
([nodeType $lnode2] != "lanswitch" || [nodeType $lnode2] != "OVS") } {
([nodeType $lnode2] != "lanswitch" || [nodeType $lnode2] != "OVS") } {
set regular no }
if { ([nodeType $lnode2] == "lanswitch" || [nodeType $lnode2] == "OVS") && \
[nodeType $lnode1] != "router" && \
([nodeType $lnode1] != "lanswitch" || [nodeType $lnode1] != "OVS" )} {
([nodeType $lnode1] != "lanswitch" || [nodeType $lnode1] != "OVS" )} {
#Khaled: puts "connecting '$lnode1' (type: '[nodeType $lnode1]') to '$lnode2' (type: '[nodeType $lnode2]') "
set regular no }
if { [nodeType $lnode1] == "hub" && \
@ -839,15 +834,11 @@ proc newLink { lnode1 lnode2 } {
if { [string range $model 0 6] == "coreapi" } {
set delay 0; # delay controlled by wireless module
} elseif {$delay != ""} {
if { [lindex $systype 0] == "FreeBSD" } {
lappend $link "delay [expr $delay/2]"
} else {
lappend $link "delay $delay"
}
}
}
# Exclude OVS from network layer nodes IP address asignments
if { ([[typemodel $lnode2].layer] == "NETWORK") && ([nodeType $lnode2] != "OVS") } {
#Khaled: puts "Assigning '$lnode2' (type: '[nodeType $lnode2]') an automatic IP address"
if { $ipv4_addr2 == "" } { autoIPv4addr $lnode2 $ifname2 }
@ -872,7 +863,7 @@ proc newLink { lnode1 lnode2 } {
if { [nodeType $lnode2] != "pseudo" &&
[nodeType $lnode1] != "wlan" &&
([[typemodel $lnode1].layer] == "NETWORK" && [nodeType $lnode1] != "OVS") } {
if { $ipv4_addr1 == "" && $do_auto_addressing } {
autoIPv4addr $lnode1 $ifname1
}
@ -884,16 +875,16 @@ proc newLink { lnode1 lnode2 } {
if { [nodeType $lnode1] != "pseudo" &&
[nodeType $lnode1] != "wlan" &&
([[typemodel $lnode2].layer] == "NETWORK" && [nodeType $lnode2] != "OVS") } {
if { $ipv4_addr2 == "" && $do_auto_addressing } {
autoIPv4addr $lnode2 $ifname2
autoIPv4addr $lnode2 $ifname2
}
if { $ipv6_addr2 == "" && $do_auto_addressing } {
autoIPv6addr $lnode2 $ifname2
}
}
# tunnel address based on its name
# tunnel address based on its name
if { [nodeType $lnode1] == "tunnel" } {
set ipaddr "[getNodeName $lnode1]/24"
setIfcIPv4addr $lnode1 e0 $ipaddr
@ -914,7 +905,7 @@ proc newLink { lnode1 lnode2 } {
# FUNCTION
# Returns the link id of the link connecting the node's interface
# INPUTS
# * node_id -- node id
# * node_id -- node id
# * ifc -- interface
# RESULT
# * link_id -- link id.
@ -1021,7 +1012,7 @@ proc updateLinkGuiAttr { link attr } {
}
color {
setLinkColor $link $value
.c itemconfigure "link && $link" -fill [getLinkColor $link]
.c itemconfigure "link && $link" -fill [getLinkColor $link]
}
dash {
.c itemconfigure "link && $link" -dash $value

33
gui/mobility.tcl
View file

@ -1,12 +1,7 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
# shows the Two-node Tool
proc popupTwoNodeDialog { } {
global twonodePID lastTwoNodeHop g_twoNodeSelect g_twoNodeSelectCallback
markerOptions off
set wi .twonodetool
catch {destroy $wi}
@ -61,7 +56,7 @@ proc popupTwoNodeDialog { } {
# buttons on the bottom
frame $wi.butt -borderwidth 6
button $wi.butt.run -text "Run" -command "runTwoNodeCommand $wi"
button $wi.butt.run -text "Run" -command "runTwoNodeCommand $wi"
button $wi.butt.cancel -text "Clear" -command "clearTwoNodeDialog $wi 0"
button $wi.butt.close -text "Close" -command "clearTwoNodeDialog $wi 1"
pack $wi.butt.run $wi.butt.cancel $wi.butt.close -side left
@ -83,11 +78,7 @@ proc clearTwoNodeDialog { wi done} {
set emul [getEmulPlugin $node]
set emulation_type [lindex $emul 1]
catch {
if { $os == "FreeBSD" } {
exec sudo kill -9 $twonodePID 2> /dev/null
} else {
exec kill -9 $twonodePID 2> /dev/null
}
exec kill -9 $twonodePID 2> /dev/null
}
set twonodePID 0
}
@ -318,11 +309,11 @@ proc drawTwoNodeLine { node line type } {
# search for hops matching this nexthop address
set hops [findNextHops $lastTwoNodeHop $nexthop ""]
if {[llength $hops] == 0} {
puts "Couldn't highlight next hop: $nexthop";
puts "Couldn't highlight next hop: $nexthop";
return
}
# highlight the path
# highlight the path
set a $lastTwoNodeHop
foreach b $hops {
highlightLink $a $b
@ -372,7 +363,7 @@ proc nodeHasAddr { node addr } {
if { $nodeaddr == $addr } {
return 1
}
}
}
return 0
}
@ -429,7 +420,7 @@ proc clearLinkHighlights { } {
# Boeing: shows the Two-node Tool
proc popupRunDialog { } {
global node_list activetool systype
set activetool select
markerOptions off
set wi .runtool
@ -489,7 +480,7 @@ proc popupRunDialog { } {
# buttons on the bottom
frame $wi.butt -borderwidth 6
button $wi.butt.run -text "Run" -command "runToolCommand $wi \"\""
button $wi.butt.run -text "Run" -command "runToolCommand $wi \"\""
button $wi.butt.close -text "Close" -command "destroy $wi"
pack $wi.butt.run $wi.butt.close -side left
pack $wi.butt -side bottom
@ -504,7 +495,7 @@ proc runToolCommand { wi node } {
if { ![winfo exists $wi] } { return }; # user has closed window
# start running commands
if { $node == "" } {
if { $node == "" } {
$wi.results.text delete 1.0 end
set selected [$wi.n.nodes.nodes curselection]
if { [llength $selected] == 0 } {
@ -518,8 +509,8 @@ proc runToolCommand { wi node } {
set next ""
set getnext 0
foreach i [$wi.n.nodes.nodes curselection] { ;# find the next node
set n [lindex $node_list $i]
foreach i [$wi.n.nodes.nodes curselection] { ;# find the next node
set n [lindex $node_list $i]
if {$n == $node } {
set getnext 1
} elseif { $getnext == 1 } {
@ -553,7 +544,7 @@ proc runToolCommand { wi node } {
# callback after receiving exec message response
proc exec_runtool_callback { node execnum cmd result status } {
set wi .runtool
if { ![winfo exists $wi] } { return }; # user has closed window
$wi.results.text insert end "> $node > $cmd:\n"

5
gui/nodecfg.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2004-2008 University of Zagreb, Croatia.
#

53
gui/nodes.tcl
View file

@ -1,9 +1,4 @@
#
# Copyright 2010-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
# author: Jeff Ahrenholz <jeffrey.m.ahrenholz@boeing.com>
#
# GUI support for node types and profiles.
#
@ -26,14 +21,12 @@ array set g_node_types_default {
5 {prouter router_green.gif router_green.gif \
{zebra OSPFv2 OSPFv3 IPForward} \
physical {built-in type for physical nodes}}
6 {xen xen.gif xen.gif {zebra OSPFv2 OSPFv3 IPForward} \
xen {built-in type for Xen PVM domU router}}
7 {OVS lanswitch.gif lanswitch.gif {DefaultRoute SSH OvsService} OVS {} }
6 {OVS lanswitch.gif lanswitch.gif {DefaultRoute SSH OvsService} OVS {} }
}
# possible machine types for nodes
set MACHINE_TYPES "netns physical xen OVS"
set MACHINE_TYPES "netns physical OVS"
# array populated from nodes.conf file
array set g_node_types { }
@ -65,7 +58,7 @@ proc loadNodesConf { } {
set line [list $idx $data]
}
}
# load into array of nodes
if { [catch {array set g_node_types $line} e] } {
puts "Error reading $confname line '$node': $e"
@ -86,13 +79,13 @@ proc checkNodeTypes { fatal } {
puts "error: missing built-in node type '$name'!"
puts "move your ~/.core/nodes.conf file to re-create the defaults"
if { $fatal } {
exit
exit
} else {
return $name
}
}
}
return ""
}
@ -187,7 +180,7 @@ proc getNodeTypeServices { type } {
return ""
}
# return the machine type (e.g. netns, physical, xen) of the currently selected
# return the machine type (e.g. netns, physical) of the currently selected
# node type from the toolbar
proc getNodeTypeMachineType { type } {
global MACHINE_TYPES g_node_types
@ -211,7 +204,7 @@ proc getNodeTypeProfile { type } {
return ""
}
# return the machine type (e.g. netns, physical, xen) of the currently selected
# return the machine type (e.g. netns, physical) of the currently selected
# node type from the toolbar
proc getNodeTypeMachineType { type } {
global MACHINE_TYPES g_node_types
@ -269,7 +262,7 @@ proc popupNodeProfileConfig { channel node model types values captions bitmap po
global g_node_types
set opaque_items [split $opaque :]
if { [llength $opaque_items] != 2 } {
if { [llength $opaque_items] != 2 } {
puts "warning: received unexpected opaque data in conf message!"
return
}
@ -334,7 +327,7 @@ proc popupNodesConfig {} {
labelframe $wi.s -borderwidth 0 -text "Node Types"
listbox $wi.s.nodes -selectmode single -height 5 -width 15 \
-yscrollcommand "$wi.s.nodes_scroll set" -exportselection 0
scrollbar $wi.s.nodes_scroll -command "$wi.s.nodes yview"
scrollbar $wi.s.nodes_scroll -command "$wi.s.nodes yview"
pack $wi.s.nodes $wi.s.nodes_scroll -fill y -side left
pack $wi.s -padx 4 -pady 4 -fill both -side top -expand true
@ -365,9 +358,9 @@ proc popupNodesConfig {} {
frame $wi.s.edit -borderwidth 4
frame $wi.s.edit.0
label $wi.s.edit.0.namelab -text "Name"
entry $wi.s.edit.0.name -bg white -width 20
entry $wi.s.edit.0.name -bg white -width 20
pack $wi.s.edit.0.namelab $wi.s.edit.0.name -side left
frame $wi.s.edit.1
label $wi.s.edit.1.iconlab -text "Icon"
entry $wi.s.edit.1.icon -bg white -width 25
@ -422,7 +415,7 @@ proc popupNodesConfig {} {
nodesConfigSelect $wi ""
# close button
# close button
frame $wi.b -borderwidth 0
button $wi.b.close -text "Close" -command "nodesConfigClose $wi"
pack $wi.b.close -side right
@ -461,7 +454,7 @@ proc nodesConfigSelect { wi cmd } {
set selected_idx [$wi.s.nodes curselection]
if { $selected_idx == "" } { return }
set idx [expr {$selected_idx + 1}]
if { ![info exists g_node_types($idx)] } { return }
@ -522,7 +515,7 @@ proc nodesConfigImgDialog { wi ctl size } {
if { [string first $dir $f] == 0 } {
# chop off default path of $dir
set f [string range $f [string length $dir] end]
}
}
if { $f != "" } {
$ctl delete 0 end
$ctl insert 0 $f
@ -581,7 +574,7 @@ proc nodesConfigHelper { wi cmd } {
set newdata [lreplace $newdata 0 0 $newname]
set newdata [lreplace $newdata 5 5 ""] ;# zero the meta-data
array set g_node_types [list $arridx $newdata]
set newsel [expr {$arridx - 1}]
set newsel [expr {$arridx - 1}]
}
save {
nodesConfigSelect $wi save
@ -591,26 +584,26 @@ proc nodesConfigHelper { wi cmd } {
}
up -
down {
if {$cmd == "up" } {
if {$cmd == "up" } {
if { $arridx < 2 } { return }
set newidx [expr {$arridx - 1}]
set newsel [expr {$idx - 1}]
set newidx [expr {$arridx - 1}]
set newsel [expr {$idx - 1}]
} else {
if { $idx >= [expr {[$ctl size] - 1}]} { return }
set newidx [expr {$arridx + 1}]
set newsel [expr {$idx + 1}]
set newsel [expr {$idx + 1}]
}
set newentry [lindex [array get g_node_types $arridx] 1]
set oldentry [lindex [array get g_node_types $newidx] 1]
if {$oldentry != ""} {
array set g_node_types [list $arridx $oldentry]
array set g_node_types [list $arridx $oldentry]
}
array set g_node_types [list $newidx $newentry]
}
}
nodesConfigRefreshList $wi
if { $newsel != "" } {
if { $newsel != "" } {
$ctl selection clear 0 end
$ctl selection set $newsel
}
@ -628,12 +621,12 @@ proc nodesConfigServices { wi services_or_profile } {
set sock [lindex [getEmulPlugin "*"] 2]
# node number 0 is sent, but these services are not associated with a node
if { $services_or_profile == "profile" } {
set services_or_profile $g_machine_type ;# address the e.g. "xen" model
set services_or_profile $g_machine_type ;# address the model
set opaque "$g_machine_type:$g_node_type_services_hint"
} else {
set opaque ""
}
sendConfRequestMessage $sock -1 $services_or_profile 0x1 -1 $opaque
sendConfRequestMessage $sock -1 $services_or_profile 0x1 -1 $opaque
}
# helper for when close button is pressed

5
gui/ns2imunes.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2004-2008 University of Zagreb, Croatia.
#

113
gui/plugins.tcl
View file

@ -1,9 +1,4 @@
#
# Copyright 2010-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
# author: Jeff Ahrenholz <jeffrey.m.ahrenholz@boeing.com>
#
# Support for managing CORE plugins from the GUI.
#
@ -49,7 +44,7 @@ set plugin_img_folder [image create photo -file "$iconpath/folder.gif"]
array set g_plugin_button_tooltips {
add "add a new plugin"
edit "edit the selected plugin"
edit "edit the selected plugin"
del "remove the selected plugin"
conn "connect to this plugin"
disc "disconnect from this plugin"
@ -78,7 +73,7 @@ proc popupPluginsConfig {} {
labelframe $wi.s -borderwidth 0 -text "Plugins"
listbox $wi.s.plugins -selectmode single -height 5 -width 50 \
-yscrollcommand "$wi.s.plugins_scroll set" -exportselection 0
scrollbar $wi.s.plugins_scroll -command "$wi.s.plugins yview"
scrollbar $wi.s.plugins_scroll -command "$wi.s.plugins yview"
pack $wi.s.plugins $wi.s.plugins_scroll -fill y -side left
pack $wi.s -padx 4 -pady 4 -fill both -side top -expand true
@ -118,7 +113,7 @@ proc popupPluginsConfig {} {
bind $wi.s.plugins <<ListboxSelect>> "pluginsConfigSelect $wi"
pluginsConfigSelect $wi
# close button
# close button
frame $wi.b -borderwidth 0
button $wi.b.save -text "Save" -command "writePluginsConf; destroy $wi"
button $wi.b.cancel -text "Cancel" -command "destroy $wi"
@ -216,8 +211,8 @@ proc popupPluginsConfigEdit { parent action } {
#
proc popupPluginConfigEditApply { wi selected_idx selected_name } {
global g_plugins g_plugin_types plugin_config_type plugin_config_autoconn
# get values from the dialog
# get values from the dialog
set name "\"[string trim [$wi.c.a.name get]]\""
set ip [string trim [$wi.c.b.ip get]]
set port [string trim [$wi.c.b.port get]]
@ -243,8 +238,8 @@ proc popupPluginConfigEditApply { wi selected_idx selected_name } {
array unset g_plugins "\"$selected_name\""
}
}
# manipulate the g_plugins array
# manipulate the g_plugins array
set plugin_data [list $ip $port $typenum $ac $status $cap $sock]
array set g_plugins [list $name $plugin_data]
}
@ -335,7 +330,7 @@ proc pluginsConfigSelect { wi } {
set buttons_state normal
set name "\"[$wi.s.plugins get $selected_idx]\""
}
# enable or disable the editing/control buttons
if { $name == "\"GUI\"" } {
# this program is the GUI, you cannot change this connection
@ -420,7 +415,7 @@ proc popupPluginsCapConfig { wlan parent } {
set wi .pluginCapConfig
catch {destroy $wi}
toplevel $wi
wm transient $parent .
wm transient $parent .
wm title $wi "Available Plugins"
# update dialog
@ -435,7 +430,7 @@ proc popupPluginsCapConfig { wlan parent } {
listbox $wi.active.plugins -selectmode single -width 55 -height 5 \
-yscrollcommand "$wi.active.scroll set" -exportselection 0
scrollbar $wi.active.scroll -command "$wi.active.plugins yview"
pack $wi.active.plugins -fill both -side left
pack $wi.active.plugins -fill both -side left
pack $wi.active.scroll -fill y -side left
pack $wi.active -side top -fill both -expand true -padx 4 -pady 4
@ -462,7 +457,7 @@ proc popupPluginsCapConfig { wlan parent } {
listbox $wi.avail.plugins -selectmode single -width 55 -height 5 \
-yscrollcommand "$wi.avail.scroll set" -exportselection 0
scrollbar $wi.avail.scroll -command "$wi.avail.plugins yview"
pack $wi.avail.plugins -fill both -side left
pack $wi.avail.plugins -fill both -side left
pack $wi.avail.scroll -fill y -side left
pack $wi.avail -side top -fill both -expand true -padx 4 -pady 4
@ -472,7 +467,7 @@ proc popupPluginsCapConfig { wlan parent } {
"popupPluginsCapConfigHelper $wi up $wlan"
# this reads from the existing wlan config
if { $g_cap_in_use == "" } {
if { $g_cap_in_use == "" } {
set g_cap_in_use [getCapabilities $wlan "mobmodel"]
}
@ -525,25 +520,25 @@ proc popupPluginsCapConfigHelper { wi cmd wlan} {
set channel [pluginConnect $plugin connect 1]
if { $cap == "location" } {
# hack to map location capabilities with canvas size/scale dialog
resizeCanvasPopup
resizeCanvasPopup
return
}
if { $channel != -1 && $channel != "" } {
sendConfRequestMessage $channel $wlan $cap $flags $netid $opaque
sendConfRequestMessage $channel $wlan $cap $flags $netid $opaque
}
return
} else { ;# up/down enable/disable button preseed
set capstr [$l get $selected_idx]
$l delete $selected_idx $selected_idx
$l2 insert end $capstr
$l2 selection set end
$l2 selection set end
# put the capabilities from the active list into the g_cap_in_use list
# this list will be read in wlanConfigDialogHelper when Apply pressed
set g_cap_in_use {}
set g_cap_in_use_set 1
foreach capstr [$wi.active.plugins get 0 end] {
set cap [string trim [lindex [split $capstr -] 1]]
lappend g_cap_in_use $cap
lappend g_cap_in_use $cap
}
}
}
@ -560,7 +555,7 @@ proc configCap { node models } {
set opaque "" ;# unused
set channel [pluginConnect $plugin connect 1]
if { $channel != -1 && $channel != "" } {
sendConfRequestMessage $channel $node $models $flags $netid $opaque
sendConfRequestMessage $channel $node $models $flags $netid $opaque
}
}
@ -612,15 +607,17 @@ proc capTitle { cap } {
# Session options
# EMANE options
# EMANE model options, per-WLAN/per-interface
# node profile (Xen machine type)
#
proc popupCapabilityConfig { channel wlan model types values captions bmp possible_values groups } {
global node_list g_node_type_services_hint g_popupcap_keys g_prefs
set wi .popupCapabilityConfig
catch {destroy $wi}
toplevel $wi
set modelname [capTitle $model]
wm transient $wi .
wm maxsize $wi 710 600
wm minsize $wi 710 600
wm transient $wi .
wm title $wi "$modelname configuration"
array unset g_popupcap_keys ;# hint for supporting key=value w/apply button
@ -656,16 +653,33 @@ proc popupCapabilityConfig { channel wlan model types values captions bmp possib
if { $customcfg != "" } {
set cfg [lindex [lindex $customcfg 2] 1]
} else {
} else {
set cfg ""
}
# session options stored in array, not custom-config
if { $model == "session" } { set cfg [getSessionOptionsList] }
frame $wi.frame
set windowFrame $wi.frame
ttk::notebook $wi.vals
pack $wi.vals -fill both -expand true -padx 4 -pady 4
ttk::notebook::enableTraversal $wi.vals
canvas $windowFrame.c -width 700 -height 600
set windowCanvas $windowFrame.c
scrollbar $windowFrame.sb -orient vert -command "$windowCanvas yview"
set windowScroll $windowFrame.sb
$windowCanvas config -yscrollcommand "$windowScroll set"
pack $windowScroll -fill y -side right
pack $windowCanvas -expand yes -fill both -side top
frame $windowCanvas.notebookFrame -width 700 -height 1200
set notebookFrame $windowCanvas.notebookFrame
pack $notebookFrame -fill both -expand yes -padx 5 -pady 5
ttk::notebook $notebookFrame.vals -width 690 -height 1200
set configNotebook $notebookFrame.vals
ttk::notebook::enableTraversal $configNotebook
pack $configNotebook -fill both -expand yes
set n 0
set gn 0
@ -676,7 +690,7 @@ proc popupCapabilityConfig { channel wlan model types values captions bmp possib
set value [lindex $kv 1]
if { $cfg != "" } { ;# possibly use existing config value
if { $key == "" } { ;# support old "value" format
if { $key == "" } { ;# support old "value" format
set value [lindex $cfg $n]
} else {
set value [getKeyValue $key $cfg $value]
@ -694,12 +708,14 @@ proc popupCapabilityConfig { channel wlan model types values captions bmp possib
set gn [lindex $groupinfo 0]
set groupcaption [lindex $groupinfo 1]
if { $lastgn != $gn } {
ttk::frame $wi.vals.$gn
$wi.vals add $wi.vals.$gn -text $groupcaption -underline 0
ttk::frame $configNotebook.$gn
$configNotebook add $configNotebook.$gn -text $groupcaption -underline 0
set lastgn $gn
}
set fr $wi.vals.$gn.item$n
set fr $configNotebook.$gn.item$n
ttk::frame $fr
if {$type == 11} { ;# boolean value
global $fr.entval $fr.entvalhint
set optcmd [list tk_optionMenu $fr.ent \
@ -754,6 +770,7 @@ proc popupCapabilityConfig { channel wlan model types values captions bmp possib
} else {
pack $fr.ent $fr.lab -side right -padx 4 -pady 4
}
pack $fr -side top -anchor e
incr n
}; # end foreach
@ -784,6 +801,11 @@ proc popupCapabilityConfig { channel wlan model types values captions bmp possib
bind $wi <Key-Return> $apply_cmd
bind $wi <Key-Escape> $cancel_cmd
# pack notebook
$windowCanvas create window 0 0 -anchor nw -window $notebookFrame
$windowCanvas configure -scrollregion [$windowCanvas bbox all]
pack $windowFrame -fill both -expand yes -side top
after 100 {
grab .popupCapabilityConfig
raise .popupCapabilityConfig
@ -823,22 +845,23 @@ proc popupCapabilityConfigGroup { groups n } {
proc popupCapabilityConfigApply { wi channel wlan model types groups } {
global node_list MACHINE_TYPES g_popupcap_keys
set configNotebook $wi.frame.c.notebookFrame.vals
set n 0
set vals {}
foreach type $types {
set groupinfo [popupCapabilityConfigGroup $groups [expr {$n + 1}]]
set gn [lindex $groupinfo 0]
if { ![winfo exists $wi.vals.$gn.item$n.ent] } {
if { ![winfo exists $configNotebook.$gn.item$n.ent] } {
puts "warning: missing dialog value $n for $model"
continue
}
if { [catch { set val [$wi.vals.$gn.item$n.ent get] }] } {
if { [catch { set val [$configNotebook.$gn.item$n.ent get] }] } {
if { $type == 11 } {
# convert textual value from tk_optionMenu to boolean 0/1
# using hint
global $wi.vals.$gn.item$n.entval $wi.vals.$gn.item$n.entvalhint
if { [set $wi.vals.$gn.item$n.entval] == \
[set $wi.vals.$gn.item$n.entvalhint] } {
global $configNotebook.$gn.item$n.entval $configNotebook.$gn.item$n.entvalhint
if { [set $configNotebook.$gn.item$n.entval] == \
[set $configNotebook.$gn.item$n.entvalhint] } {
set val 1 ;# true
} else {
set val 0 ;# false
@ -846,8 +869,8 @@ proc popupCapabilityConfigApply { wi channel wlan model types groups } {
} else {
# convert textual dropdown value to numeric using first word
# e.g. "0 11 Mbps" has a value of 0
global $wi.vals.$gn.item$n.entval
set selectedopt [set $wi.vals.$gn.item$n.entval]
global $configNotebook.$gn.item$n.entval
set selectedopt [set $configNotebook.$gn.item$n.entval]
set val [lindex $selectedopt 0]
}
}
@ -889,7 +912,7 @@ proc popupSessionConfig { channel sessionids sessionnames sessionfiles nodecount
set wi .popupSessionConfig
catch {destroy $wi}
toplevel $wi
wm transient $wi .
wm transient $wi .
wm title $wi "CORE Sessions"
ttk::frame $wi.top
@ -965,7 +988,7 @@ proc popupSessionConfig { channel sessionids sessionnames sessionfiles nodecount
grid $wi.btn.new $wi.btn.conn $wi.btn.shut $wi.btn.cancel -padx 4 -pady 4
grid columnconfigure $wi 0 -weight 1
pack $wi.btn -side bottom -fill x
bind $wi <Key-Return> $conn_cmd
bind $wi <Key-Escape> $close_cmd
bind $wi.tree <<TreeviewSelect>> "sessionConfigSelect $wi {$thumbs}"
@ -1114,7 +1137,7 @@ proc setPluginCapList { plugin caps } {
return -1 ;# unknown plugin
}
set plugin_data $g_plugins($plugin)
set plugin_data [lreplace $plugin_data 5 5 $caps]
set plugin_data [lreplace $plugin_data 5 5 $caps]
array set g_plugins [list $plugin $plugin_data]
return 0
}
@ -1200,7 +1223,7 @@ proc autoConnectPlugins { } {
proc pluginConnect { name cmd retry } {
global g_plugins
if { $name == "" } { set name \"core-daemon\" }
if { ![info exists g_plugins($name)] } {
if { ![info exists g_plugins($name)] } {
puts "pluginConnect error: $name does not exist!"
return -1
}
@ -1223,7 +1246,7 @@ proc pluginConnect { name cmd retry } {
1 { ;# CORE API
if { $cmd == "toggle" } {
if { $snum == 0 } {
set cmd connect
set cmd connect
} elseif { $snum == 1 } {
set cmd disconnect
}
@ -1303,7 +1326,7 @@ proc pluginRefresh { plugin } {
#
proc pluginChannelClosed { sock } {
global g_plugins
set plugin [pluginByChannel $sock]
set plugin [pluginByChannel $sock]
if { $plugin == "" } { return } ;# channel not found
set plugin_data $g_plugins($plugin)
set plugin_data [lreplace $plugin_data 6 6 -1]; # sock = -1

5
gui/services.tcl
View file

@ -1,9 +1,4 @@
#
# Copyright 2010-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
# author: Jeff Ahrenholz <jeffrey.m.ahrenholz@boeing.com>
#
# GUI support for managing CORE node services.
#

5
gui/tooltips.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
array set left_tooltips {
select "selection tool"
start "start the session"

5
gui/topogen.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2007-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2007-2008 University of Zagreb, Croatia.
#

5
gui/traffic.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2011-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
set g_traffic_start_opt 0
set g_traffic_flows ""

56
gui/util.tcl
View file

@ -1,22 +1,16 @@
#
# Copyright 2005-2014 the Boeing Company.
# See the LICENSE file included in this distribution.
#
set g_imageFileTypes {{"images" {.gif}} {"images" {.jpg}} {"images" {.png}}
{"images" {.bmp}} {"images" {.pcx}} {"images" {.tga}}
{"images" {.tif}} {"images" {.ps}} {"images" {.ppm}}
{"images" {.xbm}} {"All files" {*} }}
global execMode
if { $execMode == "interactive"} {
if { $execMode == "interactive"} {
if { [catch { package require Img }] } {
puts "warning: Tcl/Tk Img package not found"
puts " Thumbnails and other image types (JPG, PNG, etc.) will not be supported."
puts " Please install it with:"
puts " yum install tkimg (RedHat/Fedora)"
puts " sudo apt-get install libtk-img (Debian/Ubuntu)"
puts " pkg_add -r libimg (FreeBSD)\n"
puts " sudo apt-get install libtk-img (Debian/Ubuntu)\n"
set g_imageFileTypes {{"images" {.gif}} {"All files" {*} }}
}
}
@ -51,7 +45,7 @@ proc checkOS {} {
set machine [exec uname -m]
set kernel [exec uname -v]
set x11 0
set x11 0
catch { set x11 [winfo server .c] }
set os_ident "$os_name $os_ver"
@ -203,7 +197,7 @@ proc upgradeNetworkConfigToServices { } {
puts "updating Quagga services on node $node"
} ;# end quagga services
#
# convert static model to router
# convert static model to router
#
if { [getNodeModel $node] == "static" } {
setNodeModel $node "router"
@ -223,7 +217,7 @@ proc upgradeNetworkConfigToServices { } {
setCustomConfig $node "service:UserDefined" "UserDefined" \
$statvals 0
setCustomConfig $node "service:UserDefined:$cfgname" $cfgname $cfg 0
set services [getNodeServices $node true]
set services [getNodeServices $node true]
lappend services "UserDefined"
setNodeServices $node $services
puts "adding user-defined static routing service on node $node"
@ -240,7 +234,7 @@ proc getCPUUsage { } {
}
array set cpu {}
while { [ gets $f line ] >= 0 } {
set cpun [lindex $line 0]
set user [lindex $line 1]; set nice [lindex $line 2]
@ -264,14 +258,14 @@ proc getCPUUsage { } {
set usage_time [expr {($u-$lu) + ($n-$ln) + ($s-$ls)}]
set total_time [expr {$usage_time + ($i-$li)}]
if { $total_time <= 0 } {
if { $total_time <= 0 } {
set cpuusage "" ;# avoid div by zero
} else {
set cpuusage [expr { 100 * $usage_time / $total_time }]
}
lappend cpuusages $cpuusage
}
return $cpuusages
return $cpuusages
}
# Node selection dialog display given message 'msg' with initial node selection
@ -294,7 +288,7 @@ proc popupSelectNodes { msg initsel callback } {
listbox $wi.nodes.fr.nodelist -width 40 \
-listvariable node_list -yscrollcommand "$wi.nodes.fr.scroll set" \
-activestyle dotbox -selectmode extended
scrollbar $wi.nodes.fr.scroll -command "$wi.nodes.fr.nodelist yview"
scrollbar $wi.nodes.fr.scroll -command "$wi.nodes.fr.nodelist yview"
pack $wi.nodes.fr.nodelist -fill both -expand true -side left
pack $wi.nodes.fr.scroll -fill y -expand true -side left
pack $wi.nodes.label $wi.nodes.fr -side top -padx 4 -pady 4 \
@ -352,7 +346,7 @@ proc popupRenumberNodes { } {
listbox $wi.nodes.left.fr.from -selectmode single -width 20 \
-listvariable node_list -yscrollcommand "$wi.nodes.left.fr.scroll set" \
-activestyle dotbox
scrollbar $wi.nodes.left.fr.scroll -command "$wi.nodes.left.fr.from yview"
scrollbar $wi.nodes.left.fr.scroll -command "$wi.nodes.left.fr.from yview"
pack $wi.nodes.left.fr.from $wi.nodes.left.fr.scroll -fill y -side left
pack $wi.nodes.left.label $wi.nodes.left.fr -side top -padx 4 -pady 4 \
-anchor w
@ -487,24 +481,16 @@ proc addStaticRoutesToConfig { node cfg_ref } {
upvar 1 $cfg_ref cfg
foreach statrte [getStatIPv4routes $node] {
if {[lindex $systype 0] == "Linux" } { ;# Linux
set net [lindex [split $statrte] 0]
set gw [lindex [split $statrte] 1]
lappend cfg "/sbin/ip -4 route add $net via $gw"
} else { ;# FreeBSD
lappend cfg "route -q add -inet $statrte"
}
}
foreach statrte [getStatIPv6routes $node] {
if { [lindex $systype 0] == "Linux" } { ;# Linux
set net [lindex [split $statrte] 0]
set gw [lindex [split $statrte] 1]
if { $net == "::/0" } { set net "default" }
lappend cfg "/sbin/ip -6 route add $net via $gw"
} else { ;# FreeBSD
lappend cfg "route -q add -inet6 $statrte"
}
}
}
@ -514,11 +500,7 @@ proc getServiceStartString { } {
setSystype
if { [lindex $systype 0] == "Linux" } { ;# Linux
return "/etc/init.d/core-daemon start"
} else { ;# FreeBSD
return "/usr/local/etc/rc.d/core onestart"
}
}
proc popupBuildHostsFile { } {
@ -540,7 +522,7 @@ proc popupBuildHostsFile { } {
pack $wi.top.help -side top -fill both -expand true
pack $wi.top -padx 4 -pady 4 -side top
# text box
# text box
frame $wi.mid
text $wi.mid.hosts -relief sunken -bd 2 \
-yscrollcommand "$wi.mid.scroll set" -setgrid 1 -height 30 -undo 1 \
@ -585,7 +567,7 @@ proc popupBuildHostsFile { } {
set wi .buildhostsdialog
set hosts [string trim [$wi.mid.hosts get 0.0 end]]
set filename [$wi.fil.filename get]
set fileId [open $filename a]
set fileId [open $filename a]
puts $fileId $hosts
close $fileId
destroy $wi
@ -707,7 +689,7 @@ proc addressConfigHelper { wi fam cmd } {
}
}
# set the default addresses for automatic allocation in the g_prefs array
# set the default addresses for automatic allocation in the g_prefs array
# for the given address family
proc setDefaultAddrs { fam } {
global g_prefs
@ -737,8 +719,8 @@ proc popupMacAddressConfig { } {
frame $wi.top
set helptext "MAC addresses are automatically assigned starting with\n"
set helptext "$helptext 00:00:00:aa:00:nn, where nn starts with the below"
set helptext "$helptext value.\n You should change this value when tunneling"
set helptext "$helptext between \nemulations to prevent MAC address conflicts."
set helptext "$helptext value.\n You should change this value when tunneling"
set helptext "$helptext between \nemulations to prevent MAC address conflicts."
label $wi.top.help -text $helptext
pack $wi.top.help -side top -fill both -expand true
@ -863,7 +845,7 @@ proc _launchBrowser url {
# helper for registering a callback with a tk_optionMenu variable, when a user
# clicks on the menu and changes the value; if the global variable var is
# cleared, this callback is cancelled
# cleared, this callback is cancelled
# NOTE: when closing the window that calls this, ensure that var is cleared
proc tkOptionMenuCallback { ctl var cb args } {
if { ![winfo exists $ctl] } { return }
@ -1094,7 +1076,7 @@ proc get_text_editor { want_default } {
if { $want_default } {
return "EDITOR"
} else {
return $ed
return $ed
}
}
# return the first installed editor from EDITORS global
@ -1203,7 +1185,7 @@ proc delAddrsFromNodes { fam nodes } {
# fix for Tcl/Tk 8.5.8 and lower which doesn't have ttk::spinbox
# set spinbox [getspinbox]
# $spinbox $var -justify right -width 10 ...
#
#
proc getspinbox {} {
if { [info command ttk::spinbox] == "" } {
return spinbox
@ -1308,7 +1290,7 @@ proc findButton { w } {
if { $first == "" } {
$tree insert {} end -id none -values [list "" "" "" "no results found"]
} else {
$tree selection set $first
$tree selection set $first
}
. config -cursor left_ptr

9
gui/version.tcl.in
View file

@ -1,10 +1,5 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# define the version number and release date here
#
set CORE_VERSION @CORE_VERSION@
set CORE_VERSION_DATE @CORE_VERSION_DATE@
set CORE_VERSION @PACKAGE_VERSION@
set CORE_VERSION_DATE @PACKAGE_DATE@

378
gui/widget.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
set vtysh_cmd vtysh
set vtysh_search_path {/usr/bin /usr/local/bin /usr/lib/quagga}
@ -22,19 +17,19 @@ if {$vtysh == ""} {
# widget array: name, {config, init, periodic, move}
#
array set widgets {
"Throughput"
{ widget_thru_config widget_thru_init widget_thru_periodic widget_thru_move }
"Throughput"
{ widget_thru_config widget_thru_init widget_thru_periodic widget_thru_move }
"Adjacency"
{ widget_adjacency_config widget_adjacency_init widget_adjacency_periodic widget_adjacency_move }
}
# TODO: fix CPU Widget; it is disabled because Linux network namespaces and
# FreeBSD jails do not have a CPU usage reporting mechanism right now
# "CPU"
# TODO: fix CPU Widget; it is disabled because Linux network namespaces
# do not have a CPU usage reporting mechanism right now
# "CPU"
# { widget_cpu_config widget_cpu_init widget_cpu_periodic widget_cpu_move }
# Common Observer Widget definitions
set widgets_obs_quagga [subst {
5
5
{{OSPFv2 neighbors} {$vtysh -c {show ip ospf neighbor}}}
6
@ -47,31 +42,6 @@ set widgets_obs_quagga [subst {
{{PIM neighbors} {$vtysh -c {show ip pim neighbor}}}
}]
# Observer Widget definitions for FreeBSD
array set widgets_obs_bsd $widgets_obs_quagga
array set widgets_obs_bsd {
1
{ "processes" "ps ax" }
2
{ "ifconfig" "ifconfig" }
3
{ "IPv4 routes" "netstat -f inet -rn" }
4
{ "IPv6 routes" "netstat -f inet6 -rn" }
7
{ "IPv4 listening sockets" "sockstat -4l" }
8
{ "IPv6 listening sockets" "sockstat -6l" }
9
{ "IPv4 MFC entries" "ifmcstat -f inet" }
10
{ "IPv6 MFC entries" "ifmcstat -f inet6" }
11
{ "firewall rules" "ipfw -a list" }
12
{ "IPsec policies" "setkey -DP" }
}
# Observer Widget definitions for Linux
array set widgets_obs_linux $widgets_obs_quagga
array set widgets_obs_linux {
@ -104,17 +74,13 @@ set widget_loop_ID -1
#
proc init_default_widgets_obs {} {
global systype widgets widgets_obs widget_obs last_widgetObserveNode
global widgets_obs_bsd widgets_obs_linux
global widgets_obs_linux
setSystype
array unset widgets_obs
if { [lindex $systype 0] == "Linux" } {
set arrayname widgets_obs_linux
# this works, but we will instead reset all indices:
#array set widgets_obs [array get widgets_obs_linux]
} else {
set arrayname widgets_obs_bsd
}
# this resets the array indices to be 1, 2, 3, etc.
set i 1
@ -142,7 +108,7 @@ proc init_widget_menu {} {
foreach w [array names widgets] {
global enable_$w
set enable_$w 0
# note that a more modular way to break out submenus would be nice here
# note that a more modular way to break out submenus would be nice here
if { $w == "Adjacency" } {
widget_adjacency_init_submenu .menubar.widgets
continue
@ -374,9 +340,9 @@ proc configObsWidgets {} {
button $wi.c.c3.add -text "new" \
-command "configObsWidgetsHelper $wi 1"
button $wi.c.c3.mod -text "modify" \
-command "configObsWidgetsHelper $wi 2"
-command "configObsWidgetsHelper $wi 2"
button $wi.c.c3.del -text "delete" \
-command "configObsWidgetsHelper $wi 3"
-command "configObsWidgetsHelper $wi 3"
pack $wi.c.c3.del $wi.c.c3.mod $wi.c.c3.add -side right
pack $wi.c.c3 -fill x -side top
@ -386,7 +352,7 @@ proc configObsWidgets {} {
frame $wi.s -borderwidth 4
listbox $wi.s.servers -selectmode single -width 50 \
-yscrollcommand "$wi.s.servers_scroll set" -exportselection 0
scrollbar $wi.s.servers_scroll -command "$wi.s.servers yview"
scrollbar $wi.s.servers_scroll -command "$wi.s.servers yview"
pack $wi.s.servers $wi.s.servers_scroll -fill y -side left
pack $wi.s -fill x -side top
bind $wi.s.servers <<ListboxSelect>> "selectObsWidgetConf $wi"
@ -531,7 +497,7 @@ proc selectObsWidgetConf { wi } {
set selected [$wi.s.servers curselection]
# clear entries
$wi.c.c.name delete 0 end
$wi.c.c.name delete 0 end
$wi.c.c2.cmd delete 0 end
set w [$wi.s.servers get $selected]
@ -602,23 +568,18 @@ proc widget_thru_config {} {
checkbutton $wi.tlab.up \
-text "Include receptions" -variable thruConfig(up)
pack $wi.tlab.show_thru $wi.tlab.avg $wi.tlab.down \
$wi.tlab.up -side top -anchor w -padx 4
$wi.tlab.up -side top -anchor w -padx 4
pack $wi.tlab -side top
frame $wi.msg -borderwidth 4
global systype
if { [lindex $systype 0] == "FreeBSD" } {
set lab1txt "Note: links with no impairments (bw, delay,\netc) "
set lab1txt "${lab1txt}will display 0.0 throughput"
} else {
set lab1txt ""
}
label $wi.msg.lab1 -text $lab1txt
pack $wi.msg.lab1 -side top -padx 4 -pady 4
pack $wi.msg -side top
labelframe $wi.hi -padx 4 -pady 4 -text "Link highlighting"
# Threshold (set to zero to disable)
label $wi.hi.lab1 -text \
"Highlight link if throuhgput exceeds this "
@ -632,7 +593,7 @@ proc widget_thru_config {} {
scale $wi.hi.threshscale -from 0.0 -to 1000.0 -orient horizontal \
-showvalue false -sliderrelief raised -variable thruConfig(thresh)
pack $wi.hi.threshscale -side top -fill x
frame $wi.hi.w
label $wi.hi.w.lab3 -text "Highlight link width:"
spinbox $wi.hi.w.width -bg white -width 8 -textvariable thruConfig(width) \
@ -649,7 +610,7 @@ proc widget_thru_config {} {
pack $wi.hi.co.colbtn $wi.hi.co.color $wi.hi.co.lab1 \
-side right -padx 4 -pady 4
pack $wi.hi.co -side top
pack $wi.hi -side top
# OK button at bottom
@ -748,7 +709,7 @@ proc ngctl_output_to_ifname { line } {
# Throughput widget periodic procedure
#
proc widget_thru_periodic { now } {
global systype eid link_list
global systype eid link_list
global link_thru_stats link_thru_avg_stats link_thru_last_time thruConfig
global throughput_cache
@ -759,7 +720,7 @@ proc widget_thru_periodic { now } {
set dt [expr { ($now - $link_thru_last_time)/1000.0 }]
set link_thru_last_time $now
if { $dt <= 0.0 } { return }
# keep wireless stats in an array
array set wireless_stats {}
@ -820,7 +781,7 @@ proc widget_thru_periodic { now } {
set kbps [expr {$kbps + $kbps_down}]
}
#set kbps [expr {$kbps_down + $kbps_up}]
if { $thruConfig(avg) } {
if { ![info exists link_thru_avg_stats($key)] } {
set link_thru_avg_stats($key) $kbps
@ -831,7 +792,7 @@ proc widget_thru_periodic { now } {
set kbps $s
}
}
set kbps_str [format "%.3f" $kbps]
set kbps_str [format "%.3f" $kbps]
# wireless link - keep total of wireless throughput for this node
# (supports membership to multiple wlans)
@ -855,14 +816,14 @@ proc widget_thru_periodic { now } {
}
.c itemconfigure "link && $link" -width $width -fill $color
}
thruPlotUpdate .c $link $kbps
thruPlotUpdate .c $link $kbps
}; # end foreach link
# after summing all wireless link bandwidths, go back and perform
# highlighting and label updating
foreach node [array names wireless_stats] {
set kbps_str [format "%.3f" $wireless_stats($node)]
# erase any existing circles (otherwise we get duplicates)
.c delete -withtag "$node && rangecircles"
# wireless circle if exceeding threshold
@ -897,13 +858,13 @@ proc widget_thru_periodic { now } {
# helper to convert ng_pipe stats into upstream/downstream bytes
proc getstats_bytes_netgraph { raw_input } {
# Rec'd response "getstats" (1) from "e0_n0-n1:":
# Args: { downstream={ FwdOctets=416 FwdFrames=6 }
# Args: { downstream={ FwdOctets=416 FwdFrames=6 }
# upstream={ FwdOctets=416 FwdFrames=6 } }
set tmp [split $raw_input ":"]
if { [llength $tmp] != 4 } {
return [list 0 0]
}
set statline [lindex [lindex $tmp 3] 0]
set down [lindex $statline 1]
set up [lindex $statline 5]
@ -952,8 +913,8 @@ proc getstats_bytes_proc { raw_input ifname } {
break
}
# match the ifname exactly
} elseif { [string range $statline 0 $ifname_len] == "$ifname:" } {
break
} elseif { [string range $statline 0 $ifname_len] == "$ifname:" } {
break
}
set statline ""
}
@ -964,8 +925,8 @@ proc getstats_bytes_proc { raw_input ifname } {
set stats [lindex $statline 1]
set down_bytes [lindex $stats 0]
set up_bytes [lindex $stats 8]
set up_bytes [lindex $stats 8]
if { $down_bytes == "" } { set down_bytes 0 }
if { $up_bytes == "" } { set up_bytes 0 }
@ -979,43 +940,43 @@ proc widget_thru_move { c node done } {
# Create a new throughput plot.
proc thruPlot { c link x y height width isresize} {
global widgets enable_Throughput thruPlotColor curPlotBgColor
global widgets enable_Throughput thruPlotColor curPlotBgColor
global plot_list
# if thruplot is called from resize, $link will hold full name
# if thruplot is called from resize, $link will hold full name
if { $isresize == true } {
set g $link
# extract linkname from full path
regexp {l(.*)thruplot} $g match sub1
set link "l$sub1"
} else {
# if new thruplot is created create full name
} else {
# if new thruplot is created create full name
set g "$c.${link}thruplot"
}
# update plot_list
# Plot info to be stored :
# Plot info to be stored :
# - canvas coords
# - size (height, width)
# - color scheme
# - linkname
# - size (height, width)
# - color scheme
# - linkname
# global plot variable that stores all plot info
global ${link}thruplot
# reset global variable
if {[info exists ${link}thruplot]} { unset ${link}thruplot}
# reset global variable
if {[info exists ${link}thruplot]} { unset ${link}thruplot}
set ${link}thruplot {}
lappend ${link}thruplot "name $g"
lappend ${link}thruplot "height $height"
lappend ${link}thruplot "width $width"
lappend ${link}thruplot "x $x"
lappend ${link}thruplot "y $y"
lappend ${link}thruplot "name $g"
lappend ${link}thruplot "height $height"
lappend ${link}thruplot "width $width"
lappend ${link}thruplot "x $x"
lappend ${link}thruplot "y $y"
# if not in color dict, add and set to default (blue)
# if not in color dict, add and set to default (blue)
if {[dict exists $thruPlotColor $g] == 0} {
dict set thruPlotColor $g blue
set curPlotBgColor "#EEEEFF"
@ -1025,11 +986,11 @@ proc thruPlot { c link x y height width isresize} {
thruPlotSetScheme $scheme
lappend ${link}thruplot "color $scheme"
}
# add plot to global plot_list
if {[lsearch $plot_list ${link}thruplot] eq -1} {
# add plot to global plot_list
if {[lsearch $plot_list ${link}thruplot] eq -1} {
lappend plot_list ${link}thruplot
}
}
# set global
global $g
@ -1040,7 +1001,7 @@ proc thruPlot { c link x y height width isresize} {
destroy $g # TODO: support multiple plots for the same link
}
canvas $g -height $height -width $width -bg $curPlotBgColor
canvas $g -height $height -width $width -bg $curPlotBgColor
$c create window $x $y -window $g -tags "thruplot $g"
# set link interface title
@ -1049,21 +1010,21 @@ proc thruPlot { c link x y height width isresize} {
set if1 [ifcByPeer $lnode1 $lnode2]
set if2 [ifcByPeer $lnode2 $lnode1]
# if too narrow, bring title down
# if too narrow, bring title down
if {$width < 220} {
$g create text $width 20 -anchor ne -text "$if1@$lnode1 - $if2@$lnode2"
} else {
$g create text $width 0 -anchor ne -text "$if1@$lnode1 - $if2@$lnode2"
}
}
# bind items
bind $g <1> "thruPlotClick $c $g %x %y none"
bind $g <B1-Motion> "thruPlotHandleB1Motion $c $g %x %y start"
bind $g <3> "thruPlotPopup $g %x %y"
bind $g <3> "thruPlotPopup $g %x %y"
#DYL trying to update cursor look
bind $g <Motion> "selectmarkEnter $g %x %y"
#DYL trying to update cursor look
bind $g <Motion> "selectmarkEnter $g %x %y"
bind $g <Any-Leave> "selectmarkLeave $c %x %y"
bind $g <B1-ButtonRelease> "thruPlotHandleRelease $c $g %x %y done"
#TODO when we are inside the thruplot, the graph hides the cursor
@ -1085,27 +1046,27 @@ proc thruPlotPopup {g xclick yclick } {
.button3menu delete 0 end
.button3menu.color delete 0 end
.button3menu.color delete 0 end
.button3menu add cascade -label "Set Color" -menu .button3menu.color
# color red
.button3menu.color add command -label "Red" -command "setThruPlotColor $g red"
# color blue
.button3menu.color add command -label "Green" -command "setThruPlotColor $g green"
# color green
# color red
.button3menu.color add command -label "Red" -command "setThruPlotColor $g red"
# color blue
.button3menu.color add command -label "Green" -command "setThruPlotColor $g green"
# color green
.button3menu.color add command -label "Blue" -command "setThruPlotColor $g blue"
# delete
.button3menu add command -label "Delete" -command "deletePlot $g"
set x [winfo pointerx .]
set y [winfo pointery .]
set y [winfo pointery .]
tk_popup .button3menu $x $y
}
# remove thruplot
# remove thruplot
proc deletePlot { g } {
global plot_list
regexp {.c.(.*thruplot)} $g match plotname
@ -1119,15 +1080,15 @@ proc deletePlot { g } {
# Mouse click on a throughput plot.
# check to see if resize
proc thruPlotClick { c g x y modifier } {
global thruplotResize cursorToResizemode resizemode resizeobj thruPlotDragStart thruPlotCur
set cursorMode [$c cget -cursor]
global thruplotResize cursorToResizemode resizemode resizeobj thruPlotDragStart thruPlotCur
set cursorMode [$c cget -cursor]
# check if resizeMode
if {$cursorMode != "left_ptr" && $cursorMode != "crosshair"} {
global oldX1 oldY1 oldX2 oldY2
global oldX1 oldY1 oldX2 oldY2
# save old top left and bottom right points
# save old top left and bottom right points
set bbox [$c bbox $g]
set oldX1 [lindex $bbox 0]
set oldY1 [lindex $bbox 1]
@ -1135,28 +1096,28 @@ proc thruPlotClick { c g x y modifier } {
set oldY2 [lindex $bbox 3]
# set resizeobj and resize mode
set resizeobj $g
set resizeobj $g
set resizemode [dict get $cursorToResizemode $cursorMode]
set thruplotResize true
} else {
# update cursor to drag (crosshair)
$c configure -cursor crosshair
set thruPlotDragStart true
set thruPlotCur $g
$c configure -cursor crosshair
set thruPlotDragStart true
set thruPlotCur $g
}
}
# Must handle either a resize or a drag
# Must handle either a resize or a drag
# The plot canvas gets the B1-Motion event, not the parent canvas
proc thruPlotHandleB1Motion {c g x y what} {
global thruplotResize resizemode resizeobj
global thruplotResize resizemode resizeobj
set cursorMode [$c cget -cursor]
# check if drag (center is clicked)
# check if drag (center is clicked)
if {($cursorMode == "left_ptr" || $cursorMode == "crosshair") && $thruplotResize == false} {
thruPlotDrag $c $g $x $y $what false
} else {
# resize was clicked
# resize was clicked
}
}
@ -1168,30 +1129,30 @@ proc thruPlotHandleRelease { c g x y what} {
thruPlotDrag $c $g $x $y $what false
} else {
thruPlotRescale $c $g $x $y
}
}
}
# redraw thruplot
# x y show coords relative to top left corner of thruplot
proc thruPlotRescale { c g x y } {
global thruplotResize resizemode oldX1 oldY1 oldX2 oldY2
global thruplotResize resizemode oldX1 oldY1 oldX2 oldY2
# resize based on resize mode
switch $resizemode {
ld {
# if the left bot corner is clicked just look at new x set new height
# if the left bot corner is clicked just look at new x set new height
lassign [calcDimensions [expr {$oldX1 + $x}] $oldY1 $oldX2 [expr {$oldY1 + $y}]] cx cy h w
thruPlot $c $g $cx $cy $h $w true
thruPlot $c $g $cx $cy $h $w true
}
ru {
# if the right top corner is clicked just look at new x set new heigth
lassign [calcDimensions $oldX1 [expr {$oldY1 + $y}] [expr {$oldX1 + $x}] $oldY2] cx cy h w
thruPlot $c $g $cx $cy $h $w true
thruPlot $c $g $cx $cy $h $w true
}
rd {
# if the right bottom corner clicked
# if the right bottom corner clicked
lassign [calcDimensions $oldX1 $oldY1 [expr {$oldX1 + $x}] [expr {$oldY1 + $y}]] cx cy h w
thruPlot $c $g $cx $cy $h $w true
thruPlot $c $g $cx $cy $h $w true
}
lu {
# if the left bottom corner clicked
@ -1205,44 +1166,44 @@ proc thruPlotRescale { c g x y } {
}
l {
# if the left side is clicked just look at new x
lassign [calcDimensions [expr {$oldX1 + $x}] $oldY1 $oldX2 $oldY2] cx cy h w
thruPlot $c $g $cx $cy $h $w true
lassign [calcDimensions [expr {$oldX1 + $x}] $oldY1 $oldX2 $oldY2] cx cy h w
thruPlot $c $g $cx $cy $h $w true
}
u {
# if the top side is click just look at new y
# if the top side is click just look at new y
lassign [calcDimensions $oldX1 [expr {$oldY1 + $y}] $oldX2 $oldY2] cx cy h w
thruPlot $c $g $cx $cy $h $w true
thruPlot $c $g $cx $cy $h $w true
}
d {
# if the top side is click just look at new y
lassign [calcDimensions $oldX1 $oldY1 $oldX2 [expr {$oldY1 + $y}]] cx cy h w
thruPlot $c $g $cx $cy $h $w true
thruPlot $c $g $cx $cy $h $w true
}
default {
puts "ERROR: should not come here. resize mode is invalid."
}
puts "ERROR: should not come here. resize mode is invalid."
}
}
# rescale is done reset rescale global variables
set cursor left_ptr
set thruplotResize false
set resizemode false
set resizemode false
}
# Calculate center, height, width based on top left and bot right corners
proc calcDimensions { x1 y1 x2 y2 } {
set h [expr {$y2 - $y1}]
set h [expr {$y2 - $y1}]
set w [expr {$x2 - $x1}]
# enforce min size
if {$h < 100} {
set h 100
set h 100
}
if {$w < 100} {
set w 100
}
list [expr {$x1 + ($w/2)}] [expr {$y1 + ($h/2)}] $h $w
list [expr {$x1 + ($w/2)}] [expr {$y1 + ($h/2)}] $h $w
}
# Mouse drag a throughput plot.
@ -1250,67 +1211,67 @@ proc thruPlotDrag { c g x y what fromCanvas} {
global thruPlotDragStart thruPlotCur
global plot_list
set pad 60
set maxjump 500
set maxjump 500
# this fixes a bug when thruplot is off screen
if {$fromCanvas == true} {
#puts "handling from canvas"
$c coords $thruPlotCur [expr {$x - $pad}] [expr {$y- $pad}]
return
$c coords $thruPlotCur [expr {$x - $pad}] [expr {$y- $pad}]
return
}
if {$thruPlotDragStart == false} {
if { [expr abs($x)] > $maxjump || [expr abs($y)] > $maxjump} {
puts "ERROR can not drag too far at one time"
return
}
} else {
return
}
} else {
set curx [lindex [$c coords $g] 0]
set cury [lindex [$c coords $g] 1]
# perform the actual drag
# perform the actual drag
set newx [expr {$x - $pad + $curx}]
set newy [expr {$y- $pad + $cury}]
$c coords $thruPlotCur $newx $newy
set newy [expr {$y- $pad + $cury}]
$c coords $thruPlotCur $newx $newy
# save new coords DYL
regexp {.c.(l.*thruplot)} $g match name
# global ${name}
regexp {.c.(l.*thruplot)} $g match name
# global ${name}
# find and replace x coord
updatePlotAttr ${name} "x" $newx
updatePlotAttr ${name} "y" $newy
updatePlotAttr ${name} "x" $newx
updatePlotAttr ${name} "y" $newy
set thruPlotDragStart dragging
}
}
}
proc redrawAllThruplots {} {
global plot_list
foreach tp $plot_list {
# extract the following properties from the thruplot :
# extract the following properties from the thruplot :
# full path
# height, width
# x,y coords,
# color scheme
set fp [getPlotAttr $tp name]
set height [getPlotAttr $tp height]
set width [getPlotAttr $tp width]
set width [getPlotAttr $tp width]
set x [getPlotAttr $tp x]
set y [getPlotAttr $tp y]
set color [getPlotAttr $tp color]
thruPlot .c $fp $x $y $height $width true
setThruPlotColor $fp $color
}
thruPlot .c $fp $x $y $height $width true
setThruPlotColor $fp $color
}
}
# this will update an attribute of the global thruplot variable
# this will update an attribute of the global thruplot variable
proc updatePlotAttr { plot attr val } {
# puts "updating $attr of ${plot} to $val"
global ${plot}
# find and replace attribute
# find and replace attribute
set i [lsearch [set ${plot}] "$attr *"]
# puts " found at $i"
if { $i >= 0 } {
@ -1320,7 +1281,7 @@ proc updatePlotAttr { plot attr val } {
}
}
# this will return an attribute from the plotlist
# this will return an attribute from the plotlist
proc getPlotAttr {plot attr} {
global ${plot}
@ -1345,7 +1306,7 @@ proc setThruPlotColor { g color} {
# set global variables that determine color scheme
thruPlotSetScheme $color
# update old data
# update old data
$g itemconfigure "filler" -fill $curPlotFillColor
$g itemconfigure "line" -fill $curPlotLineColor
$g configure -bg $curPlotBgColor
@ -1372,15 +1333,15 @@ proc thruPlotSetScheme { color } {
set curPlotBgColor "#eeffee"
}
default {
puts "ERROR: invalid plot color '$color'"
puts "ERROR: invalid plot color '$color'"
}
}
}
}
# update a throughput plot with a new data point
proc thruPlotUpdate { c link kbps } {
set g "$c.${link}thruplot"
global $g curPlotLineColor curPlotFillColor curPlotBgColor thruPlotColor thruPlotMaxKBPS
global $g curPlotLineColor curPlotFillColor curPlotBgColor thruPlotColor thruPlotMaxKBPS
# Check if window exists
if { ![winfo exists $g] } {
@ -1389,10 +1350,10 @@ proc thruPlotUpdate { c link kbps } {
# lookup scheme for thruplot and set scheme
set scheme [dict get $thruPlotColor $g]
thruPlotSetScheme $scheme
# set bg to scheme
$g configure -bg $curPlotBgColor
thruPlotSetScheme $scheme
# set bg to scheme
$g configure -bg $curPlotBgColor
set maxx [$g cget -width]
set maxy [$g cget -height]
set yscale [thruPlotAutoScale $g $kbps]
@ -1400,7 +1361,7 @@ proc thruPlotUpdate { c link kbps } {
# shift graph to the left by dt pixels
set dt 5.0
$g move "data" -$dt 0.0
thruPlotDeleteOldData $g $dt
set last [$g find withtag "data && last"]
@ -1416,8 +1377,8 @@ proc thruPlotUpdate { c link kbps } {
$g create polygon $x1 $y1 $x2 $y2 $x2 $maxy $x1 $maxy \
-tags "data filler" -fill $curPlotFillColor -width 2
$g create line $x1 $y1 $x2 $y2 -tags "data last line" -fill $curPlotLineColor
$g create line $x1 $y1 $x2 $y2 -tags "data last line" -fill $curPlotLineColor
}
# return the existing y-value scale; if the given value is off the scale,
@ -1426,21 +1387,21 @@ proc thruPlotAutoScale { g val } {
set yscale [lindex [$g itemcget "ticks && scalemax" -text] 0]
global thruPlotMaxKBPS
# update global max
# update global max
if { $val > $thruPlotMaxKBPS} {
set thruPlotMaxKBPS $val
} else {
} else {
set val $thruPlotMaxKBPS
}
# default
# default
if { $yscale == "" || $yscale < 1.0 } {
set yscale 10.0
}
}
if { $val < $yscale } {
return $yscale ;# value within bounds of existing scale
}
}
set maxy [$g cget -height]
set newyscale [expr {ceil($val) + 5.0}]
@ -1519,7 +1480,7 @@ proc thruPlotDrawScale { g max } {
proc thruPlotDeleteOldData { g dt } {
foreach i [$g find withtag "data"] {
if { [lindex [$g coords $i] 0] < [expr { -2.0 * $dt }] } {
$g delete $i
$g delete $i
}
}
}
@ -1571,7 +1532,7 @@ proc widget_cpu_config {} {
labelframe $wi.hi -padx 4 -pady 4 -text "Node highlighting"
# Threshold (set to zero to disable)
label $wi.hi.lab1 -text "Highlight node if CPU usage exceeds this "
pack $wi.hi.lab1 -side top -anchor w
@ -1581,7 +1542,7 @@ proc widget_cpu_config {} {
label $wi.hi.t.lab2 -text "% CPU"
pack $wi.hi.t.lab2 $wi.hi.t.thresh $wi.hi.t.lab1 -side right -padx 4 -pady 4
pack $wi.hi.lab1 $wi.hi.t -side top
# Highlight color/width
frame $wi.hi.w
label $wi.hi.w.lab3 -text "radius:"
@ -1597,7 +1558,7 @@ proc widget_cpu_config {} {
pack $wi.hi.w.colbtn $wi.hi.w.color $wi.hi.w.lab1 \
-side right -padx 4 -pady 4
pack $wi.hi.w -side top
pack $wi.hi -side top -fill x
# OK button at bottom
@ -1642,13 +1603,8 @@ proc widget_cpu_init {command} {
#
proc widget_cpu_periodic { now } {
global systype
if { [lindex $systype 0] == "FreeBSD" } {
widget_cpu_periodic_vimage $now
} else {
puts "warning: the CPU widget is not functional for this platform yet"
return
}
}
proc widget_cpu_periodic_vimage { now } {
@ -1664,10 +1620,10 @@ proc widget_cpu_periodic_vimage { now } {
set newtext [format "%.2f %%" $cpustats($eid\_$node)]
set coords [getCPUcoords $node]
set x [lindex $coords 0]
set y [lindex $coords 1]
set basex [lindex $coords 2]
set basey [lindex $coords 3]
set x [lindex $coords 0]
set y [lindex $coords 1]
set basex [lindex $coords 2]
set basey [lindex $coords 3]
set existing [.c find withtag "cpulabel && $node"]
if { [llength $existing] == 0 } { ;# create new label
@ -1678,7 +1634,7 @@ proc widget_cpu_periodic_vimage { now } {
.c itemconfigure $cpulabel -text $newtext
}
.c raise $cpulabel
# perform highlighting
# perform highlighting
set existing [.c find withtag "cpuhi && $node"]
if { $cpustats($eid\_$node) >= $cpuConfig(thresh) } {
if { [llength $existing] == 0 } {
@ -1692,7 +1648,7 @@ proc widget_cpu_periodic_vimage { now } {
#.c raise "link && $node"
.c raise "node && $node"
}
} elseif { [llength $existing] > 0 } {
.c delete $existing
}
@ -1726,7 +1682,7 @@ proc getstats_cpu_vimage { raw_input} {
if { $numlines <= 4 } {
return [list 0 0]
}
# add node_name/cpu to a list
set ret {}
set i 0
@ -1756,7 +1712,7 @@ proc getstats_cpu_vestat { } {
global cpu_vestat_history; # remember previous jiffies
set Hertz 100.0; # from <asm/param.h>, varies per architecture
# read /proc/vz/vestat
# read /proc/vz/vestat
if { [catch {set f [open "/proc/vz/vestat" r]} e] } {
puts "error opening /proc/vz/vestat: $e"
return
@ -1784,8 +1740,8 @@ proc getstats_cpu_vestat { } {
array set cpu_vestat_history [list uptime $uptime_now]
set elapsed [expr {$uptime_now - $uptime_old}]
if { $elapsed == 0.0 } { set elapsed 1.0 }; # don't divide by zero
# add node_name/cpu to a list
set ret {}
for { set i 0 } { $i < [llength $lines] } { incr i } {
@ -1943,7 +1899,7 @@ proc get_router_id {node} {
}
}
if {[lsearch [getNodeServices $node true] "OLSR"] != -1 } {
set sock [lindex [getEmulPlugin $node] 2]
set exec_num [newExecCallbackRequest adjacencyrouterid]
set name [getNodeName $node]
@ -2008,7 +1964,7 @@ proc widget_adjacency_init {command} {
set enable_Adjacency_OSPFv3 0
set enable_Adjacency_OLSR 0
set adjacency_config(proto) "OLSRv2_proto"
}
}
}
# Initialize
@ -2017,7 +1973,7 @@ proc widget_adjacency_init {command} {
foreach node $node_list { ;# save router-id node pairs for later lookup
if { [nodeType $node] != "router" } { continue }
if {[lsearch [getNodeServices $node true] "zebra"] < 0 &&
[lsearch [getNodeServices $node true] "OLSR"] < 0 &&
[lsearch [getNodeServices $node true] "OLSR"] < 0 &&
[lsearch [getNodeServices $node true] "OLSRv2"] < 0} {
continue
}
@ -2107,16 +2063,16 @@ proc exec_adjacency_callback { node execnum cmd result status } {
global g_api_exec_num
set changed 0
set c .c
set proto $adjacency_config(proto)
array set colors $adjacency_config(colors)
if { $adjacency_config(offset) } { set o 5 } else { set o 0 }
$c addtag adjdelete withtag "adjline && $node" ;# flag del all adjlines
$c addtag adjdelete withtag "adjline && $node" ;# flag del all adjlines
set adjs [getadj_from_neighbors $result $proto]
foreach adj $adjs {
set peer [lindex $adj 0]
set line [$c find withtag "adjline && $node && $peer"]
@ -2193,7 +2149,7 @@ proc getadj_from_neighbors { raw_input proto } {
"LOST" { set state "Down" }
"MPR" { set state "Full" }
"PENDING" { set state "Init" }
"INVALID" { set state "Down" }
"INVALID" { set state "Down" }
}
lappend ret [list $rtrid $state]
}
@ -2205,7 +2161,7 @@ proc getadj_from_neighbors { raw_input proto } {
#10.0.0.2 1 00:00:06 Init/PointToPoint 00:00:00 eth0[PointToP
#10.0.0.2 1 00:00:06 Twoway/PointToPoint 00:00:00 eth0[PointToP
#10.0.0.2 1 00:00:06 Full/PointToPoint 00:00:38 eth0[PointToP
#10.0.7.2 1 Full/Backup 37.240s 10.0.0.2 eth0:10.0.0.1
#10.0.7.2 1 Full/Backup 37.240s 10.0.0.2 eth0:10.0.0.1
foreach line [split $raw_input "\n"] {
set rtrid [string trim [string range $line 0 14]]
if { $rtrid == "Neighbor ID" } { continue }
@ -2284,17 +2240,17 @@ proc widget_adjacency_init_submenu { m } {
set enable_Adjacency_OSPFv2 0
$m.adj add checkbutton -label "OSPFv2" -variable enable_Adjacency_OSPFv2 \
-command "[lindex $widgets(Adjacency) 1] menu2"
global enable_Adjacency_OSPFv3
set enable_Adjacency_OSPFv3 0
$m.adj add checkbutton -label "OSPFv3" -variable enable_Adjacency_OSPFv3 \
-command "[lindex $widgets(Adjacency) 1] menu3"
global enable_Adjacency_OLSR
set enable_Adjacency_OLSR 0
$m.adj add checkbutton -label "OLSR" -variable enable_Adjacency_OLSR \
-command "[lindex $widgets(Adjacency) 1] menu4"
global enable_Adjacency_OLSRv2
set enable_Adjacency_OLSRv2 0
$m.adj add checkbutton -label "OLSRv2" -variable enable_Adjacency_OLSRv2 \

31
gui/wlan.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# Copyright 2005-2008 University of Zagreb, Croatia.
#
@ -73,7 +68,7 @@ proc findWlanNodes { peer } {
#
# Returns 1 if the given interface is wireless
proc isIfcWireless { node ifc } {
if { $ifc == "wireless" } {
if { $ifc == "wireless" } {
# wireless peudo-interface
return false
}
@ -107,7 +102,7 @@ proc clearWlanLinks { wlan } {
proc updateRangeCircles { wlan range } {
global .c zoom g_selected_model
set c .c
set radius [expr {$zoom * $range/2}]
$c delete -withtag rangecircles
if { $radius == 0 } {
@ -176,7 +171,7 @@ proc getWlanColor { wlan } {
if {[nodeType $node] != "wlan"} {
continue
}
if {$node == $wlan} {
if {$node == $wlan} {
return [lindex $wlanLinkColors $colornum]
}
incr colornum
@ -185,7 +180,7 @@ proc getWlanColor { wlan } {
# default color
return [lindex $wlanLinkColors 0]
}
# move a node given incremental coordinates
# dx dy should be adjusted for zoom
proc moveNodeIncr { c node dx dy } {
@ -394,7 +389,7 @@ proc wlanConfigDialogHelper { wi target apply } {
# use default model/values when none configured for this node
if { $mobmodel == "" } {
set mobmodel $DEFAULT_WLAN_MODEL
set mobmodel $DEFAULT_WLAN_MODEL
set vals $DEFAULT_WLAN_MODEL_VALS
# look for customized range/bw/jitter/delay/per
} else {
@ -478,7 +473,7 @@ proc wlanConfigDialogHelper { wi target apply } {
-side left -padx 4 -pady 4
pack $de -side top -anchor w -padx 4 -pady 4
# jitter frame
# jitter frame
set jt $wi.wl.note.basic.jt
ttk::frame $jt
ttk::label $jt.label1 -anchor w -text "Jitter (us):"
@ -496,7 +491,13 @@ proc wlanConfigDialogHelper { wi target apply } {
$wi.wl.note add $wi.wl.note.emane -text "EMANE" -underline 0
set txt "The EMANE emulation system provides more complex wireless radio"
set txt "$txt emulation\n using pluggable MAC and PHY modules."
set txt "$txt Refer to the wiki for configuration option details"
ttk::label $wi.wl.note.emane.tlab -text $txt
ttk::button $wi.wl.note.emane.wiki -text "EMANE Wiki" \
-image $plugin_img_edit -compound right \
-command \
"_launchBrowser https://github.com/adjacentlink/emane/wiki"
pack $wi.wl.note.emane.wiki -side top -anchor w -padx 4 -pady 4
pack $wi.wl.note.emane.tlab -side top -anchor w -padx 4 -pady 4
# models
@ -527,7 +528,7 @@ proc wlanConfigDialogHelper { wi target apply } {
}
if { ! $have_emane_models } {
# show connection dialog box to indicate why there are no EMANE models
$mod.none configure -text "none - connection to CORE daemon required!" \
$mod.none configure -text "Please install EMANE" \
-width "45"
after 500 {
update ;# allow dialog layout, otherwise strange results
@ -607,16 +608,16 @@ proc wlanConfigDialogHelper { wi target apply } {
set cmd "linkSelectedNodes $target"
button $wi.bottom.memb -text "Choose WLAN members" \
-command "popupSelectNodes \"$msg\" \"\" {$cmd}"
# layout items
pack $wi.bottom.ipv4.addrl $wi.bottom.ipv4.addrv -side left
pack $wi.bottom.ipv4 -side top -anchor w
pack $wi.bottom.ipv6.addrl $wi.bottom.ipv6.addrv -side left
pack $wi.bottom.ipv6 -side top -anchor w
pack $wi.bottom.script $wi.bottom.linkall $wi.bottom.memb \
-side left -anchor center
pack $wi.bottom -side top -anchor w
}

5
gui/wlanscript.tcl
View file

@ -1,8 +1,3 @@
#
# Copyright 2005-2013 the Boeing Company.
# See the LICENSE file included in this distribution.
#
#
# run a scengen mobility script
proc wlanRunMobilityScript { wlan } {