2023 lines
54 KiB
Tcl
Executable file
2023 lines
54 KiB
Tcl
Executable file
#
|
|
# Copyright 2005-2013 the Boeing Company.
|
|
# See the LICENSE file included in this distribution.
|
|
#
|
|
|
|
#
|
|
# Copyright 2004-2008 University of Zagreb, Croatia.
|
|
#
|
|
# Redistribution and use in source and binary forms, with or without
|
|
# modification, are permitted provided that the following conditions
|
|
# are met:
|
|
# 1. Redistributions of source code must retain the above copyright
|
|
# notice, this list of conditions and the following disclaimer.
|
|
# 2. Redistributions in binary form must reproduce the above copyright
|
|
# notice, this list of conditions and the following disclaimer in the
|
|
# documentation and/or other materials provided with the distribution.
|
|
#
|
|
# THIS SOFTWARE IS PROVIDED BY AUTHOR AND CONTRIBUTORS ``AS IS'' AND
|
|
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
|
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
|
# ARE DISCLAIMED. IN NO EVENT SHALL AUTHOR OR CONTRIBUTORS BE LIABLE
|
|
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
|
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
|
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
|
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
|
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
|
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
|
# SUCH DAMAGE.
|
|
#
|
|
# This work was supported in part by Croatian Ministry of Science
|
|
# and Technology through the research contract #IP-2003-143.
|
|
#
|
|
|
|
|
|
#****h* imunes/nodecfg.tcl
|
|
# NAME
|
|
# nodecfg.tcl -- file used for manipultaion with nodes in IMUNES
|
|
# FUNCTION
|
|
# This module is used to define all the actions used for configuring
|
|
# nodes in IMUNES. The definition of nodes is presented in NOTES
|
|
# section.
|
|
#
|
|
# NOTES
|
|
# The IMUNES configuration file contains declarations of IMUNES objects.
|
|
# Each object declaration contains exactly the following three fields:
|
|
#
|
|
# object_class object_id class_specific_config_string
|
|
#
|
|
# Currently only two object classes are supported: node and link. In the
|
|
# future we plan to implement a canvas object, which should allow placing
|
|
# other objects into multiple visual maps.
|
|
#
|
|
# "node" objects are further divided by their type, which can be one of
|
|
# the following:
|
|
# * router
|
|
# * host
|
|
# * pc
|
|
# * lanswitch
|
|
# * hub
|
|
# * rj45
|
|
# * pseudo
|
|
#
|
|
# The following node types are to be implemented in the future:
|
|
# * text
|
|
# * image
|
|
#
|
|
#
|
|
# Routines for manipulation of per-node network configuration files
|
|
# IMUNES keeps per-node network configuration in an IOS / Zebra / Quagga
|
|
# style format.
|
|
#
|
|
# Network configuration is embedded in each node's config section via the
|
|
# "network-config" statement. The following functions can be used to
|
|
# manipulate the per-node network config:
|
|
#
|
|
# netconfFetchSection { node_id sectionhead }
|
|
# Returns a section of a config file starting with the $sectionhead
|
|
# line, and ending with the first occurence of the "!" sign.
|
|
#
|
|
# netconfClearSection { node_id sectionhead }
|
|
# Removes the appropriate section from the config.
|
|
#
|
|
# netconfInsertSection { node_id section }
|
|
# Inserts a section in the config file. Sections beginning with the
|
|
# "interface" keyword are inserted at the head of the config, and
|
|
# all other sequences are simply appended to the config tail.
|
|
#
|
|
# getIfcOperState { node_id ifc }
|
|
# Returns "up" or "down".
|
|
#
|
|
# setIfcOperState { node_id ifc state }
|
|
# Sets the new interface state. Implicit default is "up".
|
|
#
|
|
#Boeing:
|
|
# getIfcDumpState { node_id ifc }
|
|
# Returns "tcpdump on" or "tcpdump off".
|
|
#
|
|
#Boeing:
|
|
# setIfcDumpState { node_id ifc state }
|
|
# Sets the tcpdump state for the interface
|
|
#
|
|
# getIfcQDisc { node_id ifc }
|
|
# getIfcQDisc { node_id ifc }
|
|
# Returns "FIFO", "WFQ" or "DRR".
|
|
#
|
|
# setIfcQDisc { node_id ifc qdisc }
|
|
# Sets the new queuing discipline. Implicit default is FIFO.
|
|
#
|
|
# getIfcQDrop { node_id ifc }
|
|
# Returns "drop-tail" or "drop-head".
|
|
#
|
|
# setIfcQDrop { node_id ifc qdrop }
|
|
# Sets the new queuing discipline. Implicit default is "drop-tail".
|
|
#
|
|
# getIfcQLen { node_id ifc }
|
|
# Returns the queue length limit in packets.
|
|
#
|
|
# setIfcQLen { node_id ifc len }
|
|
# Sets the new queue length limit.
|
|
#
|
|
# getIfcMTU { node_id ifc }
|
|
# Returns the configured MTU, or an empty string if default MTU is used.
|
|
#
|
|
# setIfcMTU { node_id ifc mtu }
|
|
# Sets the new MTU. Zero MTU value denotes the default MTU.
|
|
#
|
|
# getIfcIPv4addr { node_id ifc }
|
|
# Returns a list of all IPv4 addresses assigned to an interface.
|
|
#
|
|
# setIfcIPv4addr { node_id ifc addr }
|
|
# Sets a new IPv4 address(es) on an interface. The correctness of the
|
|
# IP address format is not checked / enforced.
|
|
#
|
|
# getIfcIPv6addr { node_id ifc }
|
|
# Returns a list of all IPv6 addresses assigned to an interface.
|
|
#
|
|
# setIfcIPv6addr { node_id ifc addr }
|
|
# Sets a new IPv6 address(es) on an interface. The correctness of the
|
|
# IP address format is not checked / enforced.
|
|
#
|
|
# getStatIPv4routes { node_id }
|
|
# Returns a list of all static IPv4 routes as a list of
|
|
# {destination gateway {metric}} pairs.
|
|
#
|
|
# setStatIPv4routes { node_id route_list }
|
|
# Replace all current static route entries with a new one, in form of
|
|
# a list, as described above.
|
|
#
|
|
# getStatIPv6routes { node_id }
|
|
# Returns a list of all static IPv6 routes as a list of
|
|
# {destination gateway {metric}} pairs.
|
|
#
|
|
# setStatIPv6routes { node_id route_list }
|
|
# Replace all current static route entries with a new one, in form of
|
|
# a list, as described above.
|
|
#
|
|
# getNodeName { node_id }
|
|
# Returns node's logical name.
|
|
#
|
|
# setNodeName { node_id name }
|
|
# Sets a new node's logical name.
|
|
#
|
|
# nodeType { node_id }
|
|
# Returns node's type.
|
|
#
|
|
# getNodeModel { node_id }
|
|
# Returns node's optional model identifier.
|
|
#
|
|
# setNodeModel { node_id model }
|
|
# Sets the node's optional model identifier.
|
|
#
|
|
# getNodeCanvas { node_id }
|
|
# Returns node's canvas affinity.
|
|
#
|
|
# setNodeCanvas { node_id canvas_id }
|
|
# Sets the node's canvas affinity.
|
|
#
|
|
# getNodeCoords { node_id }
|
|
# Return icon coords.
|
|
#
|
|
# setNodeCoords { node_id coords }
|
|
# Sets the coordinates.
|
|
#
|
|
# getNodeLabelCoords { node_id }
|
|
# Return node label coordinates.
|
|
#
|
|
# setNodeLabelCoords { node_id coords }
|
|
# Sets the label coordinates.
|
|
#
|
|
# getNodeCPUConf { node_id }
|
|
# Returns node's CPU scheduling parameters { minp maxp weight }.
|
|
#
|
|
# setNodeCPUConf { node_id param_list }
|
|
# Sets the node's CPU scheduling parameters.
|
|
#
|
|
# ifcList { node_id }
|
|
# Returns a list of all interfaces present in a node.
|
|
#
|
|
# peerByIfc { node_id ifc }
|
|
# Returns id of the node on the other side of the interface
|
|
#
|
|
# logicalPeerByIfc { node_id ifc }
|
|
# Returns id of the logical node on the other side of the interface.
|
|
#
|
|
# ifcByPeer { local_node_id peer_node_id }
|
|
# Returns the name of the interface connected to the specified peer
|
|
# if the peer is on the same canvas, otherwise returns an empty string.
|
|
#
|
|
# ifcByLogicalPeer { local_node_id peer_node_id }
|
|
# Returns the name of the interface connected to the specified peer.
|
|
# Returns the right interface even if the peer node is on the other
|
|
# canvas.
|
|
#
|
|
# hasIPv4Addr { node_id }
|
|
# hasIPv6Addr { node_id }
|
|
# Returns true if at least one interface has an IPv{4|6} address
|
|
# configured, otherwise returns false.
|
|
#
|
|
# removeNode { node_id }
|
|
# Removes the specified node as well as all the links that bind
|
|
# that node to any other node.
|
|
#
|
|
# newIfc { ifc_type node_id }
|
|
# Returns the first available name for a new interface of the
|
|
# specified type.
|
|
#
|
|
# All of the above functions are independent to any Tk objects. This means
|
|
# they can be used for implementing tasks external to GUI, so inside the
|
|
# GUI any updating of related Tk objects (such as text labels etc.) will
|
|
# have to be implemented by additional Tk code.
|
|
#
|
|
# Additionally, an alternative configuration can be specified in
|
|
# "custom-config" section.
|
|
#
|
|
# getCustomConfig { node_id }
|
|
#
|
|
# setCustomConfig { node_id cfg }
|
|
#
|
|
# getCustomEnabled { node_id }
|
|
#
|
|
# setCustomEnabled { node_id state }
|
|
#****
|
|
|
|
#****f* nodecfg.tcl/typemodel
|
|
# NAME
|
|
# typemodel -- find node's type and routing model
|
|
# SYNOPSIS
|
|
# set typemod [typemodel $node_id]
|
|
# FUNCTION
|
|
# For input node this procedure returns the node's
|
|
# type and routing model (if exists)
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * typemod -- returns node's type and routing model in form type.model
|
|
#****
|
|
|
|
proc typemodel { node } {
|
|
return [nodeType $node]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getNodeLocation
|
|
# NAME
|
|
# getNodeLocation -- get location of the node
|
|
# SYNOPSIS
|
|
# set location [getNodeLocation $node_id]
|
|
# FUNCTION
|
|
# For input node this procedure returns the name of the CORE box
|
|
# controlling the node.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * location -- returns the location of the node
|
|
#****
|
|
|
|
proc getNodeLocation { node } {
|
|
global $node
|
|
|
|
set loc_tmp [lindex [lsearch -inline [set $node] "location *"] 1]
|
|
return $loc_tmp
|
|
}
|
|
|
|
|
|
|
|
#****f* nodecfg.tcl/setNodeLocation
|
|
# NAME
|
|
# setNodeLocation -- set location of the node
|
|
# SYNOPSIS
|
|
# setNodeLocation $node_id $location
|
|
# FUNCTION
|
|
# For input node this procedure sets the name of the CORE box
|
|
# controlling the node.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * location -- the name of the CORE box controlling the node
|
|
#****
|
|
|
|
proc setNodeLocation { node location } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "location *"]
|
|
if { $i >= 0 } {
|
|
set $node [lreplace [set $node] $i $i]
|
|
}
|
|
|
|
if { $location == "" } { return }
|
|
|
|
lappend $node [list location $location]
|
|
|
|
return
|
|
}
|
|
|
|
# returns true if any connected peer has the specified location
|
|
proc nodePeerHasLocation { node location } {
|
|
foreach ifc [ifcList $node] {
|
|
set peer [peerByIfc $node $ifc]
|
|
if { [getNodeLocation $peer] == $location } {
|
|
return 1
|
|
}
|
|
}
|
|
return 0
|
|
}
|
|
|
|
|
|
#****f* nodecfg.tcl/setConfig
|
|
# NAME
|
|
# setConfig -- add an element to the *-config
|
|
# structure
|
|
# SYNOPSIS
|
|
# setConfig $strlist $str
|
|
# FUNCTION
|
|
# Procedure returns requested element that belongs
|
|
# to *-config structure.
|
|
# INPUTS
|
|
# * strlist -- *-config structure
|
|
# * cfg -- current *-config that will be extended
|
|
# with new elements
|
|
# * str -- new element
|
|
# RESULT
|
|
# * strlist -- new *-config sructure
|
|
#****
|
|
|
|
proc setConfig { strlist cfg str } {
|
|
|
|
set i [lsearch $strlist "$str *"]
|
|
|
|
if { $i < 0 } {
|
|
if { $cfg != {} } {
|
|
set newcfg [list $str $cfg]
|
|
lappend strlist $newcfg
|
|
}
|
|
} else {
|
|
set oldval [lindex [lsearch -inline $strlist "$str *"] 1]
|
|
if { $oldval != $cfg } {
|
|
set strlist [lreplace $strlist $i $i [list $str $cfg]]
|
|
}
|
|
}
|
|
|
|
return $strlist
|
|
}
|
|
|
|
|
|
#****f* nodecfg.tcl/getConfig
|
|
# NAME
|
|
# getConfig -- get an element of the *-config
|
|
# SYNOPSIS
|
|
# getConfig $strlist $str
|
|
# FUNCTION
|
|
# Procedure returns requested element that belongs
|
|
# to *-config structure.
|
|
# INPUTS
|
|
# * strlist -- *-config structure
|
|
# * str -- an element of the *-config structure
|
|
#****
|
|
|
|
proc getConfig { strlist str } {
|
|
|
|
return [lindex [lsearch -inline $strlist "$str *"] 1]
|
|
}
|
|
|
|
|
|
#****f* nodecfg.tcl/getCustomEnabled
|
|
# NAME
|
|
# getCustomEnabled -- get custom configuration enabled state
|
|
# SYNOPSIS
|
|
# set enabled [getCustomEnabled $node_id]
|
|
# FUNCTION
|
|
# For input node this procedure returns true if custom configuration
|
|
# is enabled for the specified node.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * enabled -- returns true if custom configuration is enabled
|
|
#****
|
|
|
|
proc getCustomEnabled { node } {
|
|
global $node
|
|
|
|
if { [lindex [lsearch -inline [set $node] "custom-enabled *"] 1] == true } {
|
|
return true
|
|
} else {
|
|
return false
|
|
}
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setCustomEnabled
|
|
# NAME
|
|
# setCustomEnabled -- set custom configuration enabled state
|
|
# SYNOPSIS
|
|
# setCustomEnabled $node_id $enabled
|
|
# FUNCTION
|
|
# For input node this procedure enables or disables custom configuration.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * enabled -- true if enabling custom configuration, false if disabling
|
|
#****
|
|
|
|
proc setCustomEnabled { node enabled } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "custom-enabled *"]
|
|
if { $i >= 0 } {
|
|
set $node [lreplace [set $node] $i $i]
|
|
}
|
|
if { $enabled == true } {
|
|
lappend $node [list custom-enabled $enabled]
|
|
}
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getCustomCmd
|
|
# NAME
|
|
# getCustomCmd -- get custom configuration command
|
|
# SYNOPSIS
|
|
# set command [getCustomCmd $node_id]
|
|
# FUNCTION
|
|
# For input node this procedure returns custom command.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * command -- custom configuration command
|
|
#****
|
|
|
|
proc getCustomCmd { node } {
|
|
global $node
|
|
|
|
return [lindex [lsearch -inline [set $node] "custom-command *"] 1]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setCustomCmd
|
|
# NAME
|
|
# setCustomEnabled -- set custom configuration command
|
|
# SYNOPSIS
|
|
# setCustomCmd $node_id $command
|
|
# FUNCTION
|
|
# For input node this procedure sets custom command.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * command -- custom configuration command
|
|
#****
|
|
|
|
proc setCustomCmd { node cmd } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "custom-command *"]
|
|
if { $i >= 0 } {
|
|
set $node [lreplace [set $node] $i $i]
|
|
}
|
|
|
|
lappend $node [list custom-command $cmd]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getCustomConfig
|
|
# NAME
|
|
# getCustomConfig -- get custom configuration section
|
|
# SYNOPSIS
|
|
# set cfg [getCustomConfig $node_id]
|
|
# FUNCTION
|
|
# For input node this procedure returns custom configuration section.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * cfg -- returns custom configuration section
|
|
#****
|
|
|
|
proc getCustomConfig { node } {
|
|
global $node
|
|
set customCfgList {}
|
|
|
|
set customcmd ""
|
|
set customcfg ""
|
|
set customcmd [lsearch -inline [set $node] "custom-command *"]
|
|
set customcmdval [lindex $customcmd 1]
|
|
set customcfg [lsearch -inline [set $node] "custom-config *"]
|
|
set customcfgval [lindex $customcfg 1]
|
|
if { $customcmd != "" } {
|
|
set customid [list custom-config-id generic]
|
|
set customcmd [list custom-command $customcmdval]
|
|
set customcfg [list config $customcfgval]
|
|
set customCfgList [list [list $customid $customcmd $customcfg]]
|
|
} else {
|
|
set values [lsearch -all -inline [set $node] "custom-config *"]
|
|
foreach val $values {
|
|
lappend customCfgList [lindex $val 1]
|
|
}
|
|
}
|
|
|
|
return $customCfgList
|
|
}
|
|
|
|
|
|
proc getCustomConfigByID { node id } {
|
|
set customCfgList [getCustomConfig $node]
|
|
foreach element $customCfgList {
|
|
if { $id == [getConfig $element "custom-config-id"] } {
|
|
return [getConfig $element "config"]
|
|
}
|
|
}
|
|
return ""
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setCustomConfig
|
|
# NAME
|
|
# setCustomConfig -- set custom configuration command
|
|
# SYNOPSIS
|
|
# setCustomConfig $node_id $cfg
|
|
# FUNCTION
|
|
# For input node this procedure sets custom configuration section.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * id -- custom-config id
|
|
# * cmd -- custom command
|
|
# * cfg -- custom configuration section
|
|
# * delete -- if delete is set to 1, setCustomConfig is invoked
|
|
# to delete custom-config with custom-config-id $id
|
|
# *
|
|
#****
|
|
|
|
proc setCustomConfig { node id cmd cfg delete } {
|
|
global viewcustomid
|
|
global $node
|
|
|
|
# removes first occurrence of custom-command and custom-config
|
|
set i [lsearch [set $node] "custom-command *"]
|
|
if { $i != "-1" } {
|
|
# remove custom-command
|
|
set $node [lreplace [set $node] $i $i]
|
|
# remove custom-config
|
|
set j [lsearch [set $node] "custom-config *"]
|
|
set $node [lreplace [set $node] $j $j]
|
|
}
|
|
|
|
# removes existing custom-config if custom-config-id matches
|
|
set cnt 0
|
|
set indices [lsearch -all [set $node] "custom-config *"]
|
|
foreach i $indices {
|
|
set tmp [lindex [set $node] $i]
|
|
set customCfg [lindex $tmp 1]
|
|
set cid [lindex [lsearch -inline $customCfg "custom-config-id *"] 1]
|
|
|
|
if { $cid == $id } {
|
|
set $node [lreplace [set $node] $i $i]
|
|
}
|
|
}
|
|
|
|
# adds the new config specified in the dialog box
|
|
if { $delete == 0 } {
|
|
if { $cfg != {} && $cmd != {} && $id != {} } {
|
|
set newid [list custom-config-id $id]
|
|
set viewcustomid [lindex $newid 1]
|
|
set newcmd [list custom-command $cmd]
|
|
set newcfg [list config $cfg]
|
|
# Boeing: insert the new custom config so it's the first (active)
|
|
# custom config in the list, or just add it to the end
|
|
set first [lindex $indices 0]
|
|
if { $first < 0 } {
|
|
set first end
|
|
}
|
|
set $node [linsert [set $node] $first \
|
|
[ list custom-config [list $newid $newcmd $newcfg] ]]
|
|
#lappend $node [ list custom-config [list $newid $newcmd $newcfg] ]
|
|
}
|
|
}
|
|
}
|
|
|
|
#****f* nodecfg.tcl/netconfFetchSection
|
|
# NAME
|
|
# netconfFetchSection -- fetch the network configuration section
|
|
# SYNOPSIS
|
|
# set section [netconfFetchSection $node_id $sectionhead]
|
|
# FUNCTION
|
|
# Returns a section of a network part of a configuration file starting with the $sectionhead
|
|
# line, and ending with the first occurrence of the "!" sign.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * sectionhead -- represents the first line of the section in network-config part of
|
|
# the configuration file
|
|
# RESULT
|
|
# * section -- returns a part of the configuration file between sectionhead and "!"
|
|
#****
|
|
|
|
proc netconfFetchSection { node sectionhead } {
|
|
global $node
|
|
|
|
set cfgmode global
|
|
set section {}
|
|
# Boeing: read custom config if enabled
|
|
if { [lindex [lsearch -inline [set $node] "custom-enabled *"] 1] == true } {
|
|
# this will match the first custom-config encountered
|
|
set netconf [lindex [lsearch -inline [set $node] "custom-config *"] 1]
|
|
set tmp [lindex [lsearch -inline $netconf "config *"] 1]
|
|
if {$tmp != "" } { set netconf $tmp }
|
|
} else {
|
|
set netconf [lindex [lsearch -inline [set $node] "network-config *"] 1]
|
|
}
|
|
# if 'nocustom' keyword is passed in sectionhead, don't use custom-config
|
|
if { [lsearch $sectionhead "nocustom"] > -1 } {
|
|
# remove "nocustom" from sectionhead
|
|
set sectionhead [lsearch -all -inline -not $sectionhead "nocustom"]
|
|
# do not read custom config
|
|
set netconf [lindex [lsearch -inline [set $node] "network-config *"] 1]
|
|
}
|
|
# end Boeing
|
|
foreach line $netconf {
|
|
if { $cfgmode == "section" } {
|
|
if { "$line" == "!" } {
|
|
return $section
|
|
}
|
|
lappend section "$line"
|
|
continue
|
|
}
|
|
if { "$line" == "$sectionhead" } {
|
|
set cfgmode section
|
|
# Boeing: search the first part of $line for $sectionhead
|
|
} elseif { "router bgp" == "$sectionhead" } {
|
|
if { [string first $sectionhead $line 0] == 0 } {
|
|
set cfgmode section
|
|
lappend section "$line"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
#****f* nodecfg.tcl/netconfClearSection
|
|
# NAME
|
|
# netconfClearSection -- clear the section from a network-config part
|
|
# SYNOPSIS
|
|
# netconfClearSection $node_id $sectionhead
|
|
# FUNCTION
|
|
# Removes the appropriate section from the network part of the configuration.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * sectionhead -- represents the first line of the section that is to be removed from network-config
|
|
# part of the configuration.
|
|
#****
|
|
|
|
proc netconfClearSection { node sectionhead } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "network-config *"]
|
|
set netconf [lindex [lindex [set $node] $i] 1]
|
|
set lnum_beg -1
|
|
set lnum_end 0
|
|
foreach line $netconf {
|
|
if { $lnum_beg == -1 && "$line" == "$sectionhead" } {
|
|
set lnum_beg $lnum_end
|
|
}
|
|
if { $lnum_beg > -1 && "$line" == "!" } {
|
|
set netconf [lreplace $netconf $lnum_beg $lnum_end]
|
|
set $node [lreplace [set $node] $i $i \
|
|
[list network-config $netconf]]
|
|
return
|
|
}
|
|
incr lnum_end
|
|
}
|
|
}
|
|
|
|
#****f* nodecfg.tcl/netconfInsertSection
|
|
# NAME
|
|
# netconfInsertSection -- Insert the section to a network-config part of configuration
|
|
# SYNOPSIS
|
|
# netconfInsertSection $node_id $section
|
|
# FUNCTION
|
|
# Inserts a section in the configuration. Sections beginning with the
|
|
# "interface" keyword are inserted at the head of the configuration, and
|
|
# all other sequences are simply appended to the configuration tail.
|
|
# INPUTS
|
|
# * node_id -- the node id of the node whose config section is inserted
|
|
# * section -- represents the section that is being inserted. If there
|
|
# was a section in network config with the same section head, it is lost.
|
|
#****
|
|
|
|
proc netconfInsertSection { node section } {
|
|
global $node
|
|
|
|
set sectionhead [lindex $section 0]
|
|
netconfClearSection $node $sectionhead
|
|
set i [lsearch [set $node] "network-config *"]
|
|
set netconf [lindex [lindex [set $node] $i] 1]
|
|
set lnum_beg end
|
|
if { "[lindex $sectionhead 0]" == "interface" } {
|
|
set lnum [lsearch $netconf "hostname *"]
|
|
if { $lnum >= 0 } {
|
|
set lnum_beg [expr $lnum + 2]
|
|
}
|
|
} elseif { "[lindex $sectionhead 0]" == "hostname" } {
|
|
set lnum_beg 0
|
|
}
|
|
if { "[lindex $section end]" != "!" } {
|
|
lappend section "!"
|
|
}
|
|
foreach line $section {
|
|
set netconf [linsert $netconf $lnum_beg $line]
|
|
if { $lnum_beg != "end" } {
|
|
incr lnum_beg
|
|
}
|
|
}
|
|
set $node [lreplace [set $node] $i $i [list network-config $netconf]]
|
|
}
|
|
|
|
|
|
#Boeing: proc to find out whether tcpdump should be on for an interface
|
|
proc getIfcDumpState { node ifc } {
|
|
foreach line [netconfFetchSection $node "nocustom interface $ifc"] {
|
|
if { [lindex $line 0] == "tcpdump" } {
|
|
return "tcpdump on"
|
|
}
|
|
}
|
|
return "tcpdump off"
|
|
}
|
|
|
|
#Boeing: proc to set tcpdump for an interface
|
|
proc setIfcDumpState { node ifc state } {
|
|
set ifcfg [list "interface $ifc"]
|
|
if { $state == "tcpdump on" } {
|
|
lappend ifcfg " tcpdump"
|
|
}
|
|
foreach line [netconfFetchSection $node "interface $ifc"] {
|
|
if { [lindex $line 0] != "tcpdump" && \
|
|
[lrange $line 0 1] != "no tcpdump" } {
|
|
lappend ifcfg $line
|
|
}
|
|
}
|
|
netconfInsertSection $node $ifcfg
|
|
}
|
|
|
|
|
|
#****f* nodecfg.tcl/getIfcOperState
|
|
# NAME
|
|
# getIfcOperState -- get interface operating state
|
|
# SYNOPSIS
|
|
# set state [getIfcOperState $node_id $ifc]
|
|
# FUNCTION
|
|
# Returns the operating state of the specified interface. It can be "up" or "down".
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * ifc -- The interface that is up or down
|
|
# RESULT
|
|
# * state -- the operating state of the interface, can either "up" or "down".
|
|
#****
|
|
|
|
proc getIfcOperState { node ifc } {
|
|
foreach line [netconfFetchSection $node "nocustom interface $ifc"] {
|
|
if { [lindex $line 0] == "shutdown" } {
|
|
return "down"
|
|
}
|
|
}
|
|
return "up"
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setIfcOperState
|
|
# NAME
|
|
# setIfcOperState -- set interface operating state
|
|
# SYNOPSIS
|
|
# setIfcOperState $node_id $ifc
|
|
# FUNCTION
|
|
# Sets the operating state of the specified interface. It can be set to "up" or "down".
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * ifc -- interface
|
|
# * state -- new operating state of the interface, can be either "up" or "down"
|
|
#****
|
|
|
|
proc setIfcOperState { node ifc state } {
|
|
set ifcfg [list "interface $ifc"]
|
|
if { $state == "down" } {
|
|
lappend ifcfg " shutdown"
|
|
}
|
|
foreach line [netconfFetchSection $node "interface $ifc"] {
|
|
if { [lindex $line 0] != "shutdown" && \
|
|
[lrange $line 0 1] != "no shutdown" } {
|
|
lappend ifcfg $line
|
|
}
|
|
}
|
|
netconfInsertSection $node $ifcfg
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getIfcQDisc
|
|
# NAME
|
|
# getIfcQDisc -- get interface queuing discipline
|
|
# SYNOPSIS
|
|
# set qdisc [getIfcQDisc $node_id $ifc]
|
|
# FUNCTION
|
|
# Returns one of the supported queuing discipline ("FIFO", "WFQ" or "DRR") that is activ
|
|
# for the specified interface.
|
|
# INPUTS
|
|
# * node_id -- represents the node id of the node whose interface's queuing discipline is checked.
|
|
# * ifc -- The interface name.
|
|
# RESULT
|
|
# * qdisc -- returns queuing discipline of the interface, can be "FIFO", "WFQ" or "DRR".
|
|
#****
|
|
|
|
proc getIfcQDisc { node ifc } {
|
|
foreach line [netconfFetchSection $node "nocustom interface $ifc"] {
|
|
if { [lindex $line 0] == "fair-queue" } {
|
|
return WFQ
|
|
}
|
|
if { [lindex $line 0] == "drr-queue" } {
|
|
return DRR
|
|
}
|
|
}
|
|
return FIFO
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setIfcQDisc
|
|
# NAME
|
|
# setIfcQDisc -- set interface queueing discipline
|
|
# SYNOPSIS
|
|
# setIfcQDisc $node_id $ifc $qdisc
|
|
# FUNCTION
|
|
# Sets the new queuing discipline for the interface. Implicit default is FIFO.
|
|
# INPUTS
|
|
# * node_id -- represents the node id of the node whose interface's queuing discipline is set.
|
|
# * ifc -- interface name.
|
|
# * qdisc -- queuing discipline of the interface, can be "FIFO", "WFQ" or "DRR".
|
|
#****
|
|
|
|
proc setIfcQDisc { node ifc qdisc } {
|
|
set ifcfg [list "interface $ifc"]
|
|
if { $qdisc == "WFQ" } {
|
|
lappend ifcfg " fair-queue"
|
|
}
|
|
if { $qdisc == "DRR" } {
|
|
lappend ifcfg " drr-queue"
|
|
}
|
|
foreach line [netconfFetchSection $node "interface $ifc"] {
|
|
if { [lindex $line 0] != "fair-queue" && \
|
|
[lindex $line 0] != "drr-queue" } {
|
|
lappend ifcfg $line
|
|
}
|
|
}
|
|
netconfInsertSection $node $ifcfg
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getIfcQDrop
|
|
# NAME
|
|
# getIfcQDrop -- get interface queue dropping policy
|
|
# SYNOPSIS
|
|
# set qdrop [getIfcQDrop $node_id $ifc]
|
|
# FUNCTION
|
|
# Returns one of the supported queue dropping policies ("drop-tail" or "drop-head") that is active
|
|
# for the specified interface.
|
|
# INPUTS
|
|
# * node_id -- represents the node id of the node whose interface's queue dropping policy is checked.
|
|
# * ifc -- The interface name.
|
|
# RESULT
|
|
# * qdrop -- returns queue dropping policy of the interface, can be "drop-tail" or "drop-head".
|
|
#****
|
|
|
|
proc getIfcQDrop { node ifc } {
|
|
foreach line [netconfFetchSection $node "nocustom interface $ifc"] {
|
|
if { [lindex $line 0] == "drop-head" } {
|
|
return drop-head
|
|
}
|
|
}
|
|
return drop-tail
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setIfcQDrop
|
|
# NAME
|
|
# setIfcQDrop -- set interface queue dropping policy
|
|
|
|
# SYNOPSIS
|
|
# setIfcQDrop $node_id $ifc $qdrop
|
|
# FUNCTION
|
|
# Sets the new queuing discipline. Implicit default is "drop-tail".
|
|
# INPUTS
|
|
# * node_id -- represents the node id of the node whose interface's queue droping policie is set.
|
|
# * ifc -- interface name.
|
|
# * qdrop -- new queue dropping policy of the interface, can be "drop-tail" or "drop-head".
|
|
#****
|
|
|
|
proc setIfcQDrop { node ifc qdrop } {
|
|
set ifcfg [list "interface $ifc"]
|
|
if { $qdrop == "drop-head" } {
|
|
lappend ifcfg " drop-head"
|
|
|
|
}
|
|
foreach line [netconfFetchSection $node "interface $ifc"] {
|
|
if { [lindex $line 0] != "drop-head" && \
|
|
[lindex $line 0] != "drop-tail" } {
|
|
lappend ifcfg $line
|
|
}
|
|
}
|
|
netconfInsertSection $node $ifcfg
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getIfcQLen
|
|
# NAME
|
|
# getIfcQLen -- get interface queue length
|
|
# SYNOPSIS
|
|
# set qlen [getIfcQLen $node_id $ifc]
|
|
# FUNCTION
|
|
# Returns the queue length limit in number of packets.
|
|
# INPUTS
|
|
# * node_id -- represents the node id of the node whose interface's queue length is checked.
|
|
# * ifc -- interface name.
|
|
# RESULT
|
|
# * qlen -- queue length limit represented in number of packets.
|
|
#****
|
|
|
|
proc getIfcQLen { node ifc } {
|
|
foreach line [netconfFetchSection $node "nocustom interface $ifc"] {
|
|
if { [lindex $line 0] == "queue-len" } {
|
|
return [lindex $line 1]
|
|
}
|
|
}
|
|
return 50
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setIfcQLen
|
|
# NAME
|
|
# setIfcQLen -- set interface queue length
|
|
# SYNOPSIS
|
|
# setIfcQLen $node_id $ifc $len
|
|
# FUNCTION
|
|
# Sets the queue length limit.
|
|
# INPUTS
|
|
# * node_id -- represents the node id of the node whose interface's queue length is set.
|
|
# * ifc -- interface name.
|
|
# * qlen -- queue length limit represented in number of packets.
|
|
#****
|
|
|
|
proc setIfcQLen { node ifc len } {
|
|
set ifcfg [list "interface $ifc"]
|
|
foreach line [netconfFetchSection $node "interface $ifc"] {
|
|
if { [lindex $line 0] != "queue-len" } {
|
|
lappend ifcfg $line
|
|
}
|
|
}
|
|
if { $len > 5 && $len != 50 } {
|
|
lappend ifcfg " queue-len $len"
|
|
}
|
|
netconfInsertSection $node $ifcfg
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getIfcMTU
|
|
# NAME
|
|
# getIfcMTU -- get interface MTU size.
|
|
# SYNOPSIS
|
|
# set mtu [getIfcMTU $node_id $ifc]
|
|
# FUNCTION
|
|
# Returns the configured MTU, or a default MTU.
|
|
# INPUTS
|
|
# * node_id -- represents the node id of the node whose interface's MTU is checked.
|
|
# * ifc -- interface name.
|
|
# RESULT
|
|
# * mtu -- maximum transmission unit of the packet, represented in bytes.
|
|
#****
|
|
|
|
proc getIfcMTU { node ifc } {
|
|
foreach line [netconfFetchSection $node "nocustom interface $ifc"] {
|
|
if { [lindex $line 0] == "mtu" } {
|
|
return [lindex $line 1]
|
|
}
|
|
}
|
|
# Return defaults
|
|
switch -exact [string range $ifc 0 2] {
|
|
eth { return 1500 }
|
|
ser { return 2044 }
|
|
}
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setIfcMTU
|
|
# NAME
|
|
# setIfcMTU -- set interface MTU size.
|
|
# SYNOPSIS
|
|
# setIfcMTU $node_id $ifc $mtu
|
|
# FUNCTION
|
|
# Sets the new MTU. Zero MTU value denotes the default MTU.
|
|
# INPUTS
|
|
# * node_id -- represents the node id of the node whose interface's MTU is set.
|
|
# * ifc -- interface name.
|
|
# * mtu -- maximum transmission unit of a packet, represented in bytes.
|
|
#****
|
|
|
|
proc setIfcMTU { node ifc mtu } {
|
|
set ifcfg [list "interface $ifc"]
|
|
foreach line [netconfFetchSection $node "interface $ifc"] {
|
|
if { [lindex $line 0] != "mtu" } {
|
|
lappend ifcfg $line
|
|
}
|
|
}
|
|
switch -exact [string range $ifc 0 2] {
|
|
eth { set limit 1500 }
|
|
ser { set limit 2044 }
|
|
}
|
|
if { $mtu >= 256 && $mtu < $limit } {
|
|
lappend ifcfg " mtu $mtu"
|
|
}
|
|
netconfInsertSection $node $ifcfg
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getIfcIPv4addr
|
|
# NAME
|
|
# getIfcIPv4addr -- get interface IPv4 address.
|
|
# SYNOPSIS
|
|
# set addr [getIfcIPv4addr $node_id $ifc]
|
|
# FUNCTION
|
|
# Returns the list of IPv4 addresses assigned to the specified interface.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * ifc -- interface name.
|
|
# RESULT
|
|
# * addr -- A list of all the IPv4 addresses assigned to the specified interface.
|
|
#****
|
|
|
|
proc getIfcIPv4addr { node ifc } {
|
|
set addrlist {}
|
|
foreach line [netconfFetchSection $node "interface $ifc"] {
|
|
if { [lrange $line 0 1] == "ip address" } {
|
|
lappend addrlist [lindex $line 2]
|
|
}
|
|
}
|
|
# XXX remove this extra check if special OpenVZ case is removed
|
|
# this forces a search of network-config when no IP address has been found
|
|
if { [llength $addrlist] == 0 } {
|
|
foreach line [netconfFetchSection $node "nocustom interface $ifc"] {
|
|
if { [lrange $line 0 1] == "ip address" } {
|
|
lappend addrlist [lindex $line 2]
|
|
}
|
|
}
|
|
}
|
|
return $addrlist
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setIfcIPv4addr
|
|
# NAME
|
|
# setIfcIPv4addr -- set interface IPv4 address.
|
|
# SYNOPSIS
|
|
# setIfcIPv4addr $node_id $ifc $addr
|
|
# FUNCTION
|
|
# Sets a new IPv4 address(es) on an interface. The correctness of the
|
|
# IP address format is not checked / enforced.
|
|
# INPUTS
|
|
# * node_id -- the node id of the node whose interface's IPv4 address is set.
|
|
# * ifc -- interface name.
|
|
# * addr -- new IPv4 address.
|
|
#****
|
|
|
|
proc setIfcIPv4addr { node ifc addr } {
|
|
set ifcfg [list "interface $ifc"]
|
|
foreach line [netconfFetchSection $node "interface $ifc"] {
|
|
if { [lrange $line 0 1] != "ip address" } {
|
|
lappend ifcfg $line
|
|
}
|
|
}
|
|
if { $addr != "" } {
|
|
lappend ifcfg " ip address $addr"
|
|
}
|
|
netconfInsertSection $node $ifcfg
|
|
return
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getIfcIPv6addr
|
|
# NAME
|
|
# getIfcIPv6addr -- get interface IPv6 address.
|
|
# SYNOPSIS
|
|
# set addr [getIfcIPv6addr $node_id $ifc]
|
|
# FUNCTION
|
|
# Returns the list of IPv6 addresses assigned to the specified interface.
|
|
# INPUTS
|
|
# * node_id -- the node id of the node whose interface's IPv6 addresses are returned.
|
|
# * ifc -- interface name.
|
|
# RESULT
|
|
# * addr -- A list of all the IPv6 addresses assigned to the specified interface.
|
|
#****
|
|
|
|
proc getIfcIPv6addr { node ifc } {
|
|
set addrlist {}
|
|
foreach line [netconfFetchSection $node "interface $ifc"] {
|
|
if { [lrange $line 0 1] == "ipv6 address" } {
|
|
lappend addrlist [lindex $line 2]
|
|
}
|
|
}
|
|
return $addrlist
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setIfcIPv6addr
|
|
# NAME
|
|
# setIfcIPv6addr -- set interface IPv6 address.
|
|
# SYNOPSIS
|
|
# setIfcIPv6addr $node_id $ifc $addr
|
|
# FUNCTION
|
|
# Sets a new IPv6 address(es) on an interface. The correctness of the
|
|
# IP address format is not checked / enforced.
|
|
# INPUTS
|
|
# * node_id -- the node id of the node whose interface's IPv4 address is set.
|
|
# * ifc -- interface name.
|
|
# * addr -- new IPv6 address.
|
|
#****
|
|
|
|
proc setIfcIPv6addr { node ifc addr } {
|
|
set ifcfg [list "interface $ifc"]
|
|
foreach line [netconfFetchSection $node "interface $ifc"] {
|
|
if { [lrange $line 0 1] != "ipv6 address" } {
|
|
lappend ifcfg $line
|
|
}
|
|
}
|
|
if { $addr != "" } {
|
|
lappend ifcfg " ipv6 address $addr"
|
|
}
|
|
netconfInsertSection $node $ifcfg
|
|
}
|
|
|
|
proc getIfcMacaddr { node ifc } {
|
|
set addrlist {}
|
|
foreach line [netconfFetchSection $node "interface $ifc"] {
|
|
if { [lrange $line 0 1] == "mac address" } {
|
|
lappend addrlist [lindex $line 2]
|
|
}
|
|
}
|
|
return $addrlist
|
|
}
|
|
|
|
proc setIfcMacaddr { node ifc macaddr} {
|
|
set ifcfg [list "interface $ifc"]
|
|
foreach line [netconfFetchSection $node "interface $ifc"] {
|
|
if { [lrange $line 0 1] != "mac address" } {
|
|
lappend ifcfg $line
|
|
}
|
|
}
|
|
if { $macaddr != "" } {
|
|
lappend ifcfg " mac address $macaddr"
|
|
}
|
|
netconfInsertSection $node $ifcfg
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getStatIPv4routes
|
|
# NAME
|
|
# getStatIPv4routes -- get static IPv4 routes.
|
|
# SYNOPSIS
|
|
# set routes [getStatIPv4routes $node_id]
|
|
# FUNCTION
|
|
# Returns a list of all static IPv4 routes as a list of
|
|
# {destination gateway {metric}} pairs.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * routes -- the list of all static routes defined for the specified node
|
|
#****
|
|
|
|
proc getStatIPv4routes { node } {
|
|
global $node
|
|
|
|
set routes {}
|
|
set netconf [lindex [lsearch -inline [set $node] "network-config *"] 1]
|
|
foreach entry [lsearch -all -inline $netconf "ip route *"] {
|
|
lappend routes [lrange $entry 2 end]
|
|
}
|
|
return $routes
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setStatIPv4routes
|
|
# NAME
|
|
# setStatIPv4routes -- set static IPv4 routes.
|
|
# SYNOPSIS
|
|
# setStatIPv4routes $node_id $routes
|
|
# FUNCTION
|
|
# Replace all current static route entries with a new one, in form of
|
|
# a list of {destination gateway {metric}} pairs.
|
|
# INPUTS
|
|
# * node_id -- the node id of the node whose static routes are set.
|
|
# * routes -- the list of all static routes defined for the specified node
|
|
#****
|
|
|
|
proc setStatIPv4routes { node routes } {
|
|
netconfClearSection $node "ip route [lindex [getStatIPv4routes $node] 0]"
|
|
set section {}
|
|
foreach route $routes {
|
|
lappend section "ip route $route"
|
|
}
|
|
netconfInsertSection $node $section
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getStatIPv6routes
|
|
# NAME
|
|
# getStatIPv6routes -- get static IPv6 routes.
|
|
# SYNOPSIS
|
|
# set routes [getStatIPv6routes $node_id]
|
|
# FUNCTION
|
|
# Returns a list of all static IPv6 routes as a list of
|
|
# {destination gateway {metric}} pairs.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * routes -- the list of all static routes defined for the specified node
|
|
#****
|
|
|
|
proc getStatIPv6routes { node } {
|
|
global $node
|
|
|
|
set routes {}
|
|
set netconf [lindex [lsearch -inline [set $node] "network-config *"] 1]
|
|
foreach entry [lsearch -all -inline $netconf "ipv6 route *"] {
|
|
lappend routes [lrange $entry 2 end]
|
|
}
|
|
return $routes
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setStatIPv6routes
|
|
# NAME
|
|
# setStatIPv4routes -- set static IPv6 routes.
|
|
# SYNOPSIS
|
|
# setStatIPv6routes $node_id $routes
|
|
# FUNCTION
|
|
# Replace all current static route entries with a new one, in form of
|
|
# a list of {destination gateway {metric}} pairs.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * routes -- the list of all static routes defined for the specified node
|
|
#****
|
|
|
|
proc setStatIPv6routes { node routes } {
|
|
netconfClearSection $node "ipv6 route [lindex [getStatIPv6routes $node] 0]"
|
|
set section {}
|
|
foreach route $routes {
|
|
lappend section "ipv6 route $route"
|
|
|
|
}
|
|
netconfInsertSection $node $section
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getNodeName
|
|
# NAME
|
|
# getNodeName -- get node name.
|
|
# SYNOPSIS
|
|
# set name [getNodeName $node_id]
|
|
# FUNCTION
|
|
# Returns node's logical name.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * name -- logical name of the node
|
|
#****
|
|
|
|
proc getNodeName { node } {
|
|
global $node
|
|
|
|
set netconf [lindex [lsearch -inline [set $node] "network-config *"] 1]
|
|
return [lrange [lsearch -inline $netconf "hostname *"] 1 end]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setNodeName
|
|
# NAME
|
|
# setNodeName -- set node name.
|
|
# SYNOPSIS
|
|
# setNodeName $node_id $name
|
|
# FUNCTION
|
|
# Sets node's logical name.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * name -- logical name of the node
|
|
#****
|
|
|
|
proc setNodeName { node name } {
|
|
netconfClearSection $node "hostname [getNodeName $node]"
|
|
netconfInsertSection $node [list "hostname $name"]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getNodeType
|
|
# NAME
|
|
# getNodeType -- get node type.
|
|
# SYNOPSIS
|
|
# set type [getNodeType $node_id]
|
|
# FUNCTION
|
|
# Returns node's type.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * type -- type of the node
|
|
#****
|
|
|
|
proc nodeType { node } {
|
|
global $node
|
|
|
|
return [lindex [lsearch -inline [set $node] "type *"] 1]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getNodeModel
|
|
# NAME
|
|
# getNodeModel -- get node routing model.
|
|
# SYNOPSIS
|
|
# set model [getNodeModel $node_id]
|
|
# FUNCTION
|
|
#
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * model -- routing model of the specified node
|
|
#****
|
|
|
|
proc getNodeModel { node } {
|
|
global $node
|
|
|
|
return [lindex [lsearch -inline [set $node] "model *"] 1]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setNodeModel
|
|
# NAME
|
|
# setNodeModel -- set node routing model.
|
|
# SYNOPSIS
|
|
# setNodeModel $node_id $model
|
|
# FUNCTION
|
|
#
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * model -- routing model of the specified node
|
|
#****
|
|
|
|
proc setNodeModel { node model } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "model *"]
|
|
if { $i >= 0 } {
|
|
set $node [lreplace [set $node] $i $i "model $model"]
|
|
} else {
|
|
set $node [linsert [set $node] 1 "model $model"]
|
|
}
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getNodeCoords
|
|
# NAME
|
|
# getNodeCoords -- get node icon coordinates.
|
|
# SYNOPSIS
|
|
# set coords [getNodeCoords $node_id]
|
|
# FUNCTION
|
|
# Returns node's icon coordinates.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * coords -- coordinates of the node's icon a list in form of {Xcoord Ycoord}
|
|
#****
|
|
|
|
proc getNodeCoords { node } {
|
|
global $node
|
|
|
|
return [lindex [lsearch -inline [set $node] "iconcoords *"] 1]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setNodeCoords
|
|
# NAME
|
|
# setNodeCoords -- set node's icon coordinates.
|
|
# SYNOPSIS
|
|
|
|
# setNodeCoords $node_id $coords
|
|
# FUNCTION
|
|
# Sets node's icon coordinates.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * coords -- coordinates of the node's icon in form of Xcoord Ycoord
|
|
#****
|
|
|
|
proc setNodeCoords { node coords } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "iconcoords *"]
|
|
if { $i >= 0 } {
|
|
set $node [lreplace [set $node] $i $i "iconcoords {$coords}"]
|
|
} else {
|
|
set $node [linsert [set $node] end "iconcoords {$coords}"]
|
|
}
|
|
writeNodeCoords $node $coords
|
|
}
|
|
|
|
# this saves each node's current X,Y position to a /tmp/pycore.nnnnn/nX.xy
|
|
proc writeNodeCoords { node coords } {
|
|
global oper_mode g_current_session
|
|
|
|
if { [info exists oper_mode] && $oper_mode != "exec" } { return }
|
|
if { $g_current_session == 0 } { return }
|
|
if { [nodeType $node] != "router" } { return }
|
|
|
|
set fn "/tmp/pycore.$g_current_session/$node.xy"
|
|
catch {
|
|
set f [open $fn w]
|
|
puts $f $coords
|
|
close $f
|
|
}
|
|
}
|
|
|
|
# cleanup the /tmp/pycore.nnnnn/nX.xy file
|
|
proc deleteNodeCoords { node } {
|
|
global g_current_session
|
|
|
|
if { $g_current_session == 0 } { return }
|
|
if { [nodeType $node] != "router" } { return }
|
|
|
|
set fn "/tmp/pycore.$g_current_session/$node.xy"
|
|
if { [file exists $fn] } { file delete $fn }
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getNodeLabelCoords
|
|
# NAME
|
|
# getNodeLabelCoords -- get node's label coordinates.
|
|
# SYNOPSIS
|
|
# set coords [getNodeLabelCoords $node_id]
|
|
# FUNCTION
|
|
# Returns node's label coordinates.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * coords -- coordinates of the node's label a list in form of {Xcoord Ycoord}
|
|
#****
|
|
|
|
proc getNodeLabelCoords { node } {
|
|
global $node
|
|
|
|
return [lindex [lsearch -inline [set $node] "labelcoords *"] 1]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setNodeLabelCoords
|
|
# NAME
|
|
# setNodeLabelCoords -- set node's label coordinates.
|
|
# SYNOPSIS
|
|
# setNodeLabelCoords $node_id $coords
|
|
# FUNCTION
|
|
# Sets node's label coordinates.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * coords -- coordinates of the node's label in form of Xcoord Ycoord
|
|
#****
|
|
|
|
proc setNodeLabelCoords { node coords } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "labelcoords *"]
|
|
if { $i >= 0 } {
|
|
set $node [lreplace [set $node] $i $i "labelcoords {$coords}"]
|
|
} else {
|
|
set $node [linsert [set $node] end "labelcoords {$coords}"]
|
|
}
|
|
}
|
|
|
|
# return [dx, dy] offset for a node label, which may depend on its type
|
|
proc getDefaultLabelOffsets { nodetype } {
|
|
set dx 0
|
|
set dy 32
|
|
if { [lsearch {hub lanswitch} $nodetype] >= 0 } {
|
|
set dy 24
|
|
}
|
|
return [list $dx $dy]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/ifcList
|
|
# NAME
|
|
# ifcList -- get list of all interfaces
|
|
# SYNOPSIS
|
|
# set ifcs [ifcList $node_id]
|
|
# FUNCTION
|
|
# Returns a list of all interfaces present in a node.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * ifcs -- list of all node's interfaces.
|
|
#****
|
|
|
|
proc ifcList { node } {
|
|
global $node
|
|
if { ![info exists $node] } { return "" }
|
|
set interfaces ""
|
|
foreach entry [lsearch -all -inline [set $node] "interface-peer *"] {
|
|
lappend interfaces [lindex [lindex $entry 1] 0]
|
|
}
|
|
return $interfaces
|
|
}
|
|
|
|
#****f* nodecfg.tcl/peerByIfc
|
|
# NAME
|
|
# peerByIfc -- get node's peer by interface.
|
|
# SYNOPSIS
|
|
# set peer [peerByIfc $node_id $ifc]
|
|
# FUNCTION
|
|
# Returns id of the node on the other side of the interface. If the node
|
|
# on the other side of the interface is situated on the other canvas or connected
|
|
# via split link, this function returns a pseudo node.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * ifc -- interface name
|
|
# RESULT
|
|
# * peer -- node id of the node on the other side of the interface
|
|
#****
|
|
|
|
proc peerByIfc { node ifc } {
|
|
global $node
|
|
|
|
set entry [lsearch -inline [set $node] "interface-peer {$ifc *}"]
|
|
return [lindex [lindex $entry 1] 1]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/logicalPeerByIfc
|
|
# NAME
|
|
# logicalPeerByIfc -- get node's peer by interface.
|
|
# SYNOPSIS
|
|
# set peer [logicalPeerByIfc $node_id $ifc]
|
|
# FUNCTION
|
|
# Returns id of the node on the other side of the interface. If the node on the other
|
|
# side of the interface is connected via normal link (not split) this function acts the same
|
|
# as the function peerByIfc, but if the nodes are connected via split links or situated on different
|
|
# canvases this function returns the logical peer node.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * ifc -- interface name
|
|
# RESULT
|
|
# * peer -- node id of the node on the other side of the interface
|
|
#****
|
|
|
|
proc logicalPeerByIfc { node ifc } {
|
|
global $node
|
|
|
|
set peer [peerByIfc $node $ifc]
|
|
if { $peer == "" } { return "" }; # Boeing
|
|
if { [nodeType $peer] != "pseudo" } {
|
|
return $peer
|
|
|
|
} else {
|
|
set mirror_node [getNodeMirror $peer]
|
|
set mirror_ifc [ifcList $mirror_node]
|
|
return [peerByIfc $mirror_node $mirror_ifc]
|
|
}
|
|
}
|
|
|
|
#****f* nodecfg.tcl/ifcByPeer
|
|
# NAME
|
|
# ifcByPeer -- get node interface by peer.
|
|
# SYNOPSIS
|
|
# set ifc [peerByIfc $node_id $peer_id]
|
|
# FUNCTION
|
|
# Returns the name of the interface connected to the specified peer.
|
|
# If the peer node is on different canvas or connected via split link
|
|
# to the specified node this function returns an empty string.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * peer_id -- id of the peer node
|
|
# RESULT
|
|
# * ifc -- interface name
|
|
#****
|
|
|
|
proc ifcByPeer { node peer } {
|
|
global $node
|
|
|
|
set entry [lsearch -inline [set $node] "interface-peer {* $peer}"]
|
|
return [lindex [lindex $entry 1] 0]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/ifcByLogicalPeer
|
|
# NAME
|
|
# ifcByPeer -- get node interface by peer.
|
|
# SYNOPSIS
|
|
# set ifc [peerByIfc $node_id $peer_id]
|
|
# FUNCTION
|
|
# Returns the name of the interface connected to the specified peer.
|
|
# Returns the right interface even if the peer node is on the other
|
|
# canvas or connected via split link.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * peer_id -- id of the peer node
|
|
# RESULT
|
|
# * ifc -- interface name
|
|
#****
|
|
|
|
proc ifcByLogicalPeer { node peer } {
|
|
global $node
|
|
|
|
set ifc [ifcByPeer $node $peer]
|
|
if { $ifc == "" } {
|
|
#
|
|
# Must search through pseudo peers
|
|
#
|
|
foreach ifc [ifcList $node] {
|
|
set t_peer [peerByIfc $node $ifc]
|
|
if { [nodeType $t_peer] == "pseudo" } {
|
|
set mirror [getNodeMirror $t_peer]
|
|
if { [peerByIfc $mirror [ifcList $mirror]] == $peer } {
|
|
return $ifc
|
|
}
|
|
}
|
|
}
|
|
return ""
|
|
} else {
|
|
return $ifc
|
|
}
|
|
}
|
|
|
|
#****f* nodecfg.tcl/hasIPv4Addr
|
|
# NAME
|
|
# hasIPv4Addr -- has IPv4 address.
|
|
# SYNOPSIS
|
|
# set check [hasIPv4Addr $node_id]
|
|
# FUNCTION
|
|
# Returns true if at least one interface has an IPv4 address
|
|
# configured, otherwise returns false.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * check -- true if at least one interface has IPv4 address, otherwise false.
|
|
#****
|
|
|
|
proc hasIPv4Addr { node } {
|
|
foreach ifc [ifcList $node] {
|
|
if { [getIfcIPv4addr $node $ifc] != "" } {
|
|
return true
|
|
}
|
|
}
|
|
return false
|
|
}
|
|
|
|
#****f* nodecfg.tcl/hasIPv6Addr
|
|
# NAME
|
|
# hasIPv4Addr -- has IPv6 address.
|
|
# SYNOPSIS
|
|
# set check [hasIPv6Addr $node_id]
|
|
# FUNCTION
|
|
# Retruns true if at least one interface has an IPv6 address
|
|
# configured, otherwise returns false.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * check -- true if at least one interface has IPv6 address, otherwise false.
|
|
#****
|
|
|
|
proc hasIPv6Addr { node } {
|
|
foreach ifc [ifcList $node] {
|
|
if { [getIfcIPv6addr $node $ifc] != "" } {
|
|
return true
|
|
}
|
|
}
|
|
return false
|
|
}
|
|
|
|
#****f* nodecfg.tcl/removeNode
|
|
# NAME
|
|
# removeNode -- removes the node
|
|
# SYNOPSIS
|
|
# removeNode $node_id
|
|
# FUNCTION
|
|
# Removes the specified node as well as all the links binding that node to
|
|
# the other nodes.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
#****
|
|
|
|
proc removeNode { node } {
|
|
global node_list $node
|
|
|
|
foreach ifc [ifcList $node] {
|
|
set peer [peerByIfc $node $ifc]
|
|
set link [linkByPeers $node $peer]
|
|
removeLink $link
|
|
}
|
|
set i [lsearch -exact $node_list $node]
|
|
set node_list [lreplace $node_list $i $i]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getNodeCanvas
|
|
# NAME
|
|
# getNodeCanvas -- get node canvas id
|
|
# SYNOPSIS
|
|
# set canvas [getNodeCanvas $node_id]
|
|
# FUNCTION
|
|
# Returns node's canvas affinity.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * canvas -- canvas id
|
|
#****
|
|
|
|
proc getNodeCanvas { node } {
|
|
global $node
|
|
|
|
return [lindex [lsearch -inline [set $node] "canvas *"] 1]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setNodeCanvas
|
|
# NAME
|
|
# setNodeCanvas -- set node canvas
|
|
# SYNOPSIS
|
|
# setNodeCanvas $node_id $canvas
|
|
# FUNCTION
|
|
# Sets node's canvas affinity.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * canvas -- canvas id
|
|
#****
|
|
|
|
proc setNodeCanvas { node canvas } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "canvas *"]
|
|
if { $i >= 0 } {
|
|
set $node [lreplace [set $node] $i $i "canvas $canvas"]
|
|
} else {
|
|
set $node [linsert [set $node] end "canvas $canvas"]
|
|
}
|
|
}
|
|
|
|
proc getNodeHidden { node } {
|
|
global $node
|
|
|
|
set h [lindex [lsearch -inline [set $node] "hidden *"] 1]
|
|
if { $h == "" } { return 0 }
|
|
return $h
|
|
}
|
|
|
|
proc setNodeHidden { node value } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "hidden *"]
|
|
if { $value == 0 } {
|
|
if { $i >= 0 } {
|
|
set $node [lreplace [set $node] $i $i]
|
|
}
|
|
return
|
|
}
|
|
if { $i >= 0 } {
|
|
set $node [lreplace [set $node] $i $i "hidden $value"]
|
|
} else {
|
|
set $node [linsert [set $node] end "hidden $value"]
|
|
}
|
|
}
|
|
|
|
#****f* nodecfg.tcl/newIfc
|
|
# NAME
|
|
# newIfc -- new interface
|
|
# SYNOPSIS
|
|
# set ifc [newIfc $type $node_id]
|
|
# FUNCTION
|
|
# Returns the first available name for a new interface of the specified type.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * type -- type
|
|
# RESULT
|
|
# * ifc -- the first available name for a interface of the specified type
|
|
#****
|
|
|
|
proc newIfc { type node } {
|
|
set interfaces [ifcList $node]
|
|
set firstinterface 0
|
|
for { set id $firstinterface } { [lsearch -exact $interfaces $type$id] >= 0 } {incr id} {}
|
|
return $type$id
|
|
}
|
|
|
|
#****f* nodecfg.tcl/newNode
|
|
# NAME
|
|
# newNode -- new node
|
|
# SYNOPSIS
|
|
# set node_id [newNode $type]
|
|
# FUNCTION
|
|
# Returns the node id of a new node of the specified type.
|
|
# INPUTS
|
|
# * type -- node type
|
|
# RESULT
|
|
# * node_id -- node id of a new node of the specified type
|
|
#****
|
|
|
|
proc newNode { type } {
|
|
global node_list def_router_model
|
|
global viewid
|
|
catch {unset viewid}
|
|
|
|
# overload the passed in parameter - allow specifing new node num
|
|
if { [llength $type] > 1 } {
|
|
set node [lindex $type 1]
|
|
set type [lindex $type 0]
|
|
} else {
|
|
set node [newObjectId node]
|
|
}
|
|
|
|
global $node
|
|
set $node {}
|
|
lappend $node "type $type"
|
|
if { $type == "router" } {
|
|
lappend $node "model $def_router_model"
|
|
set nconfig [list \
|
|
"hostname $node" \
|
|
! ]
|
|
# tunnel
|
|
} elseif {$type == "rj45" || $type == "tunnel" || $type == "ktunnel" } {
|
|
set nconfig [list \
|
|
"hostname UNASSIGNED" \
|
|
! ]
|
|
# set wlan default parameters upon creation
|
|
} elseif { $type == "wlan" } {
|
|
global DEFAULT_WLAN_MODEL DEFAULT_WLAN_MODEL_TYPES
|
|
global DEFAULT_WLAN_MODEL_VALS
|
|
set nconfig [list \
|
|
"hostname $type[string range $node 1 end]" \
|
|
! \
|
|
"mobmodel" \
|
|
"coreapi" \
|
|
"$DEFAULT_WLAN_MODEL" \
|
|
! ]
|
|
lappend $node "network-config [list $nconfig]"
|
|
setCustomConfig $node $DEFAULT_WLAN_MODEL $DEFAULT_WLAN_MODEL_TYPES \
|
|
$DEFAULT_WLAN_MODEL_VALS 0
|
|
} else {
|
|
set nconfig [list \
|
|
"hostname $node" \
|
|
! ]
|
|
}
|
|
|
|
# wlan has already changed node global above
|
|
if { $type != "wlan" } {
|
|
lappend $node "network-config [list $nconfig]"
|
|
}
|
|
lappend node_list $node
|
|
return $node
|
|
}
|
|
|
|
#****f* nodecfg.tcl/getNodeMirror
|
|
# NAME
|
|
# getNodeMirror -- get node mirror
|
|
# SYNOPSIS
|
|
# set mirror_node_id [getNodeMirror $node_id]
|
|
# FUNCTION
|
|
# Returns the node id of a mirror pseudo node of the node. Mirror node is the
|
|
# corresponding pseudo node. The pair of pseudo nodes, node and his mirror node, are
|
|
# introduced to form a split in a link. This split can be used for avoiding crossed
|
|
# links or for displaying a link between the nodes on a different canvas.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# RESULT
|
|
# * mirror_node_id -- node id of a mirror node
|
|
#****
|
|
|
|
proc getNodeMirror { node } {
|
|
global $node
|
|
|
|
return [lindex [lsearch -inline [set $node] "mirror *"] 1]
|
|
}
|
|
|
|
#****f* nodecfg.tcl/setNodeMirror
|
|
# NAME
|
|
# setNodeMirror -- set node mirror
|
|
# SYNOPSIS
|
|
# setNodeMirror $node_id $mirror_node_id
|
|
# FUNCTION
|
|
# Sets the node id of a mirror pseudo node of the specified node. Mirror node is the
|
|
# corresponding pseudo node. The pair of pseudo nodes, node and his mirror node, are
|
|
# introduced to form a split in a link. This split can be used for avoiding crossed
|
|
# links or for displaying a link between the nodes on a different canvas.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * mirror_node_id -- node id of a mirror node
|
|
#****
|
|
|
|
proc setNodeMirror { node value } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "mirror *"]
|
|
if { $value == "" } {
|
|
set $node [lreplace [set $node] $i $i]
|
|
} else {
|
|
set $node [linsert [set $node] end "mirror $value"]
|
|
}
|
|
}
|
|
|
|
|
|
#****f* nodecfg.tcl/setType
|
|
# NAME
|
|
# setType -- set node's type.
|
|
# SYNOPSIS
|
|
# setType $node_id $type
|
|
# FUNCTION
|
|
# Sets node's type.
|
|
# INPUTS
|
|
# * node_id -- node id
|
|
# * type -- type of node
|
|
#****
|
|
|
|
proc setType { node type } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "type *"]
|
|
if { $i >= 0 } {
|
|
set $node [lreplace [set $node] $i $i "type $type"]
|
|
} else {
|
|
set $node [linsert [set $node] 1 "type $type"]
|
|
}
|
|
}
|
|
|
|
# begin Boeing: node commands specific to wlan
|
|
proc getNodeRange { node } {
|
|
global $node
|
|
|
|
return [lindex [lsearch -inline [set $node] "range *"] 1]
|
|
}
|
|
|
|
proc setNodeRange { node value } {
|
|
global $node
|
|
set i [lsearch [set $node] "range *"]
|
|
if { $value == "" } {
|
|
if { $i > 0 } {
|
|
set $node [lreplace [set $node] $i $i]
|
|
}
|
|
return
|
|
}
|
|
if { $i > 0 } {
|
|
set $node [lreplace [set $node] $i $i "range $value"]
|
|
} else {
|
|
set $node [linsert [set $node] end "range $value"]
|
|
}
|
|
return
|
|
}
|
|
# end Boeing
|
|
|
|
# Boeing - custom post config commands
|
|
proc getCustomPostConfigCommands { node } {
|
|
global $node
|
|
return [lindex [lsearch -inline [set $node] "custom-post-config-commands *"] 1]
|
|
}
|
|
|
|
#Boeing custom pre config commands
|
|
proc getCustomPreConfigCommands { node } {
|
|
global $node
|
|
return [lindex [lsearch -inline [set $node] "custom-pre-config-commands *"] 1]
|
|
}
|
|
|
|
#Boeing custom post config commands
|
|
proc setCustomPostConfigCommands { node cfg } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "custom-post-config-commands *"]
|
|
if { $i >= 0 } {
|
|
set $node [lreplace [set $node] $i $i]
|
|
}
|
|
if { $cfg != {} } {
|
|
lappend $node [list custom-post-config-commands $cfg]
|
|
}
|
|
return
|
|
}
|
|
|
|
# get the services saved for this node; if want_defaults is true and no services
|
|
# have been configured, return the default services for this node type
|
|
proc getNodeServices { node want_defaults } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "services *"]
|
|
set s [lindex [lindex [set $node] $i] 1]
|
|
if { $want_defaults && $i < 0 } {
|
|
set s [getNodeTypeServices [getNodeModel $node]]
|
|
}
|
|
return $s
|
|
}
|
|
|
|
# save the list of services configured for this node
|
|
proc setNodeServices { node services } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "services *"]
|
|
if { $i >= 0 } {
|
|
set $node [lreplace [set $node] $i $i "services {$services}"]
|
|
} else {
|
|
set $node [linsert [set $node] end "services {$services}"]
|
|
}
|
|
}
|
|
|
|
# Boeing - custom image
|
|
proc getCustomImage { node } {
|
|
global $node
|
|
return [lindex [lsearch -inline [set $node] "custom-image *"] 1]
|
|
}
|
|
|
|
# Boeing - custom image
|
|
proc setCustomImage { node image } {
|
|
global $node
|
|
|
|
set i [lsearch [set $node] "custom-image *"]
|
|
if { $i >= 0 } {
|
|
set $node [lreplace [set $node] $i $i]
|
|
}
|
|
if { $image != "" } {
|
|
lappend $node [list custom-image $image]
|
|
}
|
|
return
|
|
}
|
|
|
|
# if cmd=save save all node positions, otherwise reset them with cmd=reset
|
|
proc resetAllNodeCoords { cmd } {
|
|
global node_list g_saved_node_coords zoom
|
|
|
|
# save the node coordinates to a global array
|
|
if { $cmd == "save" } {
|
|
array unset g_saved_node_coords
|
|
foreach node $node_list {
|
|
set coords [getNodeCoords $node]
|
|
if { $coords == "" } { continue }
|
|
array set g_saved_node_coords [list $node $coords]
|
|
}
|
|
# restore the node coordinates from the global array
|
|
} elseif { $cmd == "reset" } {
|
|
if { ![array exists g_saved_node_coords] } { return }
|
|
foreach node $node_list {
|
|
if { ![info exists g_saved_node_coords($node)] } { continue }
|
|
set coords $g_saved_node_coords($node)
|
|
if { [llength $coords] != 2 } { continue }
|
|
set x [expr {$zoom * [lindex $coords 0]}]
|
|
set y [expr {$zoom * [lindex $coords 1]}]
|
|
moveNodeAbs .c $node $x $y
|
|
}
|
|
}
|
|
|
|
}
|
|
|