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

2018 lines
54 KiB
Tcl
Raw Blame History

#
# 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
}
}
}
Reference in a new issue View git blame Copy permalink