3306 lines
101 KiB
Tcl
3306 lines
101 KiB
Tcl
#
|
|
# CORE API
|
|
# Copyright 2005-2013 the Boeing Company.
|
|
# See the LICENSE file included in this distribution.
|
|
#
|
|
# author: Jeff Ahrenholz <jeffrey.m.ahrenholz@boeing.com>
|
|
#
|
|
|
|
# version of the API document that is used
|
|
set CORE_API_VERSION 1.23
|
|
|
|
set DEFAULT_API_PORT 4038
|
|
set g_api_exec_num 100; # starting execution number
|
|
|
|
# set scale for X/Y coordinate translation
|
|
set XSCALE 1.0
|
|
set YSCALE 1.0
|
|
set XOFFSET 0
|
|
set YOFFSET 0
|
|
|
|
# current session; 0 is a new session
|
|
set g_current_session 0
|
|
set g_session_dialog_hint 1
|
|
|
|
# this is an array of lists, with one array entry for each widget or callback,
|
|
# and the entry is a list of execution numbers (for matching replies with
|
|
# requests)
|
|
array set g_execRequests { shell "" observer "" }
|
|
|
|
# for a simulator, uncomment this line or cut/paste into debugger:
|
|
# set XSCALE 4.0; set YSCALE 4.0; set XOFFSET 1800; set YOFFSET 300
|
|
|
|
array set nodetypes { 0 def 1 phys 2 xen 3 tbd 4 lanswitch 5 hub \
|
|
6 wlan 7 rj45 8 tunnel 9 ktunnel 10 emane }
|
|
|
|
array set regtypes { wl 1 mob 2 util 3 exec 4 gui 5 emul 6 }
|
|
array set regntypes { 1 wl 2 mob 3 util 4 exec 5 gui 6 emul 7 relay 10 session }
|
|
array set regtxttypes { wl "Wireless Module" mob "Mobility Module" \
|
|
util "Utility Module" exec "Execution Server" \
|
|
gui "Graphical User Interface" emul "Emulation Server" \
|
|
relay "Relay" }
|
|
set DEFAULT_GUI_REG "gui core_2d_gui"
|
|
array set eventtypes { definition_state 1 configuration_state 2 \
|
|
instantiation_state 3 runtime_state 4 \
|
|
datacollect_state 5 shutdown_state 6 \
|
|
event_start 7 event_stop 8 event_pause 9 \
|
|
event_restart 10 file_open 11 file_save 12 \
|
|
event_scheduled 31 }
|
|
|
|
set CORE_STATES \
|
|
"NONE DEFINITION CONFIGURATION INSTANTIATION RUNTIME DATACOLLECT SHUTDOWN"
|
|
|
|
set EXCEPTION_LEVELS \
|
|
"NONE FATAL ERROR WARNING NOTICE"
|
|
|
|
# Event handler invoked for each message received by peer
|
|
proc receiveMessage { channel } {
|
|
global curcanvas showAPI
|
|
set prmsg $showAPI
|
|
set type 0
|
|
set flags 0
|
|
set len 0
|
|
set seq 0
|
|
|
|
#puts "API receive data."
|
|
# disable the fileevent here, then reinstall the handler at the end
|
|
fileevent $channel readable ""
|
|
# channel closed
|
|
if { [eof $channel] } {
|
|
resetChannel channel 1
|
|
return
|
|
}
|
|
|
|
#
|
|
# read first four bytes of message header
|
|
set more_data 1
|
|
while { $more_data == 1 } {
|
|
if { [catch { set bytes [read $channel 4] } e] } {
|
|
# in tcl8.6 this occurs during shutdown
|
|
#puts "channel closed: $e"
|
|
break;
|
|
}
|
|
if { [fblocked $channel] == 1} {
|
|
# 4 bytes not available yet
|
|
break;
|
|
} elseif { [eof $channel] } {
|
|
resetChannel channel 1
|
|
break;
|
|
} elseif { [string bytelength $bytes] == 0 } {
|
|
# zero bytes read - parseMessageHeader would fail
|
|
break;
|
|
}
|
|
# parse type/flags/length
|
|
if { [parseMessageHeader $bytes type flags len] < 0 } {
|
|
# Message header error
|
|
break;
|
|
}
|
|
# read message data of specified length
|
|
set bytes [read $channel $len]
|
|
#if { $prmsg== 1} {
|
|
# puts "read $len bytes (type=$type, flags=$flags, len=$len)..."
|
|
#}
|
|
# handle each message type
|
|
switch -exact -- "$type" {
|
|
1 { parseNodeMessage $bytes $len $flags }
|
|
2 { parseLinkMessage $bytes $len $flags }
|
|
3 { parseExecMessage $bytes $len $flags $channel }
|
|
4 { parseRegMessage $bytes $len $flags $channel }
|
|
5 { parseConfMessage $bytes $len $flags $channel }
|
|
6 { parseFileMessage $bytes $len $flags $channel }
|
|
8 { parseEventMessage $bytes $len $flags $channel }
|
|
9 { parseSessionMessage $bytes $len $flags $channel }
|
|
10 { parseExceptionMessage $bytes $len $flags $channel;
|
|
#7 { parseIfaceMessage $bytes $len $flags $channel }
|
|
#
|
|
}
|
|
default { puts "Unknown Message = $type" }
|
|
}
|
|
# end switch
|
|
}
|
|
# end while
|
|
|
|
# update the canvas
|
|
catch {
|
|
# this messes up widgets
|
|
#raiseAll .c
|
|
.c config -cursor left_ptr ;# otherwise we have hourglass/pirate
|
|
update
|
|
}
|
|
|
|
if {$channel != -1 } {
|
|
resetChannel channel 0
|
|
}
|
|
}
|
|
|
|
#
|
|
# Open an API socket to the specified server:port, prompt user for retry
|
|
# if specified; set the readable file event and parameters;
|
|
# returns the channel name or -1 on error.
|
|
#
|
|
proc openAPIChannel { server port retry } {
|
|
# use default values (localhost:4038) when none specified
|
|
if { $server == "" || $server == 0 } {
|
|
set server "localhost"
|
|
}
|
|
if { $port == 0 } {
|
|
global DEFAULT_API_PORT
|
|
set port $DEFAULT_API_PORT
|
|
}
|
|
|
|
# loop when retry is true
|
|
set s -1
|
|
while { $s < 0 } {
|
|
# TODO: fix this to remove lengthy timeout periods...
|
|
# (need to convert all channel I/O to use async channel)
|
|
# vwait doesn't work here, blocks on socket call
|
|
#puts "Connecting to $server:$port..."; # verbose
|
|
set svcstart [getServiceStartString]
|
|
set e "This feature requires a connection to the CORE daemon.\n"
|
|
set e "$e\nFailed to connect to $server:$port!\n"
|
|
set e "$e\nHave you started the CORE daemon with"
|
|
set e "$e '$svcstart'?"
|
|
if { [catch {set s [socket $server $port]} ex] } {
|
|
puts "\n$e\n (Error: $ex)"
|
|
set s -1
|
|
if { ! $retry } { return $s; }; # error, don't retry
|
|
}
|
|
if { $s > 0 } { puts "connected." }; # verbose
|
|
if { $retry } {; # prompt user with retry dialog
|
|
if { $s < 0 } {
|
|
set choice [tk_dialog .connect "Error" $e \
|
|
error 0 Retry "Start daemon..." Cancel]
|
|
if { $choice == 2 } { return $s } ;# cancel
|
|
if { $choice == 1 } {
|
|
set sudocmd "gksudo"
|
|
set cmd "core-daemon -d"
|
|
if { [catch {exec $sudocmd $cmd & } e] } {
|
|
puts "Error running '$sudocmd $cmd'!"
|
|
}
|
|
after 300 ;# allow time for daemon to start
|
|
}
|
|
# fall through for retry...
|
|
}
|
|
}
|
|
}; # end while
|
|
|
|
# now we have a valid socket, set up encoding and receive event
|
|
fconfigure $s -blocking 0 -encoding binary -translation { binary binary } \
|
|
-buffering full -buffersize 4096
|
|
fileevent $s readable [list receiveMessage $s]
|
|
return $s
|
|
}
|
|
|
|
#
|
|
# Reinstall the receiveMessage event handler
|
|
#
|
|
proc resetChannel { channel_ptr close } {
|
|
upvar 1 $channel_ptr channel
|
|
if {$close == 1} {
|
|
close $channel
|
|
pluginChannelClosed $channel
|
|
set $channel -1
|
|
}
|
|
if { [catch { fileevent $channel readable \
|
|
[list receiveMessage $channel] } ] } {
|
|
# may print error here
|
|
}
|
|
}
|
|
|
|
#
|
|
# Catch errors when flushing sockets
|
|
#
|
|
proc flushChannel { channel_ptr msg } {
|
|
upvar 1 $channel_ptr channel
|
|
if { [catch { flush $channel } err] } {
|
|
puts "*** $msg: $err"
|
|
set channel -1
|
|
return -1
|
|
}
|
|
return 0
|
|
}
|
|
|
|
|
|
#
|
|
# CORE message header
|
|
#
|
|
proc parseMessageHeader { bytes type flags len } {
|
|
# variables are passed by reference
|
|
upvar 1 $type mytype
|
|
upvar 1 $flags myflags
|
|
upvar 1 $len mylen
|
|
|
|
#
|
|
# read the four-byte message header
|
|
#
|
|
if { [binary scan $bytes ccS mytype myflags mylen] != 3 } {
|
|
puts "*** warning: message header error"
|
|
return -1
|
|
} else {
|
|
set mytype [expr {$mytype & 0xFF}]; # convert signed to unsigned
|
|
set myflags [expr {$myflags & 0xFF}]
|
|
if { $mylen == 0 } {
|
|
puts "*** warning: zero length message header!"
|
|
# empty the channel
|
|
#set bytes [read $channel]
|
|
return -1
|
|
}
|
|
}
|
|
return 0
|
|
}
|
|
|
|
|
|
#
|
|
# CORE API Node message TLVs
|
|
#
|
|
proc parseNodeMessage { data len flags } {
|
|
global node_list curcanvas c router eid showAPI nodetypes CORE_DATA_DIR
|
|
global XSCALE YSCALE XOFFSET YOFFSET deployCfgAPI_lock
|
|
#puts "Parsing node message of length=$len, flags=$flags"
|
|
set prmsg $showAPI
|
|
set current 0
|
|
|
|
array set typenames { 1 num 2 type 3 name 4 ipv4_addr 5 mac_addr \
|
|
6 ipv6_addr 7 model 8 emulsrv 10 session \
|
|
32 xpos 33 ypos 34 canv \
|
|
35 emuid 36 netid 37 services \
|
|
48 lat 49 long 50 alt \
|
|
66 icon 80 opaque }
|
|
array set typesizes { num 4 type 4 name -1 ipv4_addr 4 ipv6_addr 16 \
|
|
mac_addr 8 model -1 emulsrv -1 session -1 \
|
|
xpos 2 ypos 2 canv 2 emuid 4 \
|
|
netid 4 services -1 lat 4 long 4 alt 4 \
|
|
icon -1 opaque -1 }
|
|
array set vals { num 0 type 0 name "" ipv4_addr -1 ipv6_addr -1 \
|
|
mac_addr -1 model "" emulsrv "" session "" \
|
|
xpos 0 ypos 0 canv "" \
|
|
emuid -1 netid -1 services "" \
|
|
lat 0 long 0 alt 0 \
|
|
icon "" opaque "" }
|
|
|
|
if { $prmsg==1 } { puts -nonewline "NODE(flags=$flags," }
|
|
|
|
#
|
|
# TLV parsing
|
|
#
|
|
while { $current < $len } {
|
|
# TLV header
|
|
if { [binary scan $data @${current}cc type length] != 2 } {
|
|
puts "TLV header error"
|
|
break
|
|
}
|
|
set length [expr {$length & 0xFF}]; # convert signed to unsigned
|
|
if { $length == 0 } {; # prevent endless looping
|
|
if { $type == 0 } { puts -nonewline "(extra padding)"; break
|
|
} else { puts "Found zero-length TLV for type=$type, dropping.";
|
|
break }
|
|
}
|
|
set pad [pad_32bit $length]
|
|
# verbose debugging
|
|
#puts "tlv type=$type length=$length pad=$pad current=$current"
|
|
incr current 2
|
|
|
|
if {![info exists typenames($type)] } { ;# unknown TLV type
|
|
if { $prmsg } { puts -nonewline "unknown=$type," }
|
|
incr current $length
|
|
continue
|
|
}
|
|
set typename $typenames($type)
|
|
set size $typesizes($typename)
|
|
# 32-bit and 64-bit vals pre-padded
|
|
if { $size == 4 || $size == 8 } { incr current $pad }
|
|
# read TLV data depending on size
|
|
switch -exact -- "$size" {
|
|
2 { binary scan $data @${current}S vals($typename) }
|
|
4 { binary scan $data @${current}I vals($typename) }
|
|
8 { binary scan $data @${current}W vals($typename) }
|
|
16 { binary scan $data @${current}c16 vals($typename) }
|
|
-1 { binary scan $data @${current}a${length} vals($typename) }
|
|
}
|
|
if { $size == -1 } { incr current $pad } ;# string vals post-padded
|
|
if { $type == 6 } { incr current $pad } ;# 128-bit vals post-padded
|
|
incr current $length
|
|
# special handling of data here
|
|
switch -exact -- "$typename" {
|
|
ipv4_addr { array set vals [list $typename \
|
|
[ipv4ToString $vals($typename)] ] }
|
|
mac_addr { array set vals [list $typename \
|
|
[macToString $vals($typename)] ] }
|
|
ipv6_addr { array set vals [list $typename \
|
|
[ipv6ToString $vals($typename)] ] }
|
|
xpos { array set vals [list $typename \
|
|
[expr { ($vals($typename) * $XSCALE) - $XOFFSET }] ] }
|
|
ypos { array set vals [list $typename \
|
|
[expr { ($vals($typename) * $YSCALE) - $YOFFSET }] ] }
|
|
}
|
|
if { $prmsg } { puts -nonewline "$typename=$vals($typename)," }
|
|
}
|
|
|
|
if { $prmsg } { puts ") "}
|
|
|
|
#
|
|
# Execution
|
|
#
|
|
# TODO: enforce message parameters here
|
|
if { ![info exists nodetypes($vals(type))] } {
|
|
puts "NODE: invalid node type ($vals(type)), dropping"; return
|
|
}
|
|
set node "n$vals(num)"
|
|
set node_id "$eid\_$node"
|
|
if { [lsearch $node_list $node] == -1 } {; # check for node existance
|
|
set exists false
|
|
} else {
|
|
set exists true
|
|
}
|
|
|
|
if { $vals(name) == "" } {; # make sure there is a node name
|
|
set name $node
|
|
if { $exists } { set name [getNodeName $node] }
|
|
array set vals [list name $name]
|
|
}
|
|
if { $exists } {
|
|
if { $flags == 1 } {
|
|
puts "Node add msg but node ($node) already exists, dropping."
|
|
return
|
|
}
|
|
} elseif { $flags != 1 } {
|
|
puts -nonewline "Node modify/delete message but node ($node) does "
|
|
puts "not exist dropping."
|
|
return
|
|
}
|
|
if { $vals(icon) != "" } {
|
|
set icon $vals(icon)
|
|
if { [file pathtype $icon] == "relative" } {
|
|
set icon "$CORE_DATA_DIR/icons/normal/$icon"
|
|
}
|
|
if { ![file exists $icon ] } {
|
|
puts "Node icon '$vals(icon)' does not exist."
|
|
array set vals [list icon ""]
|
|
} else {
|
|
array set vals [list icon $icon]
|
|
}
|
|
}
|
|
global $node
|
|
|
|
set wlans_needing_update { }
|
|
if { $vals(emuid) != -1 } {
|
|
# For Linux populate ngnodeidmap for later use with wireless; it is treated as
|
|
# a hex value string (without the leading "0x")
|
|
global ngnodeidmap
|
|
foreach wlan [findWlanNodes $node] {
|
|
if { ![info exists ngnodeidmap($eid\_$wlan)] } {
|
|
set netid [string range $wlan 1 end]
|
|
set emulation_type [lindex [getEmulPlugin $node] 1]
|
|
# TODO: verify that this incr 1000 is for OpenVZ
|
|
if { $emulation_type == "openvz" } { incr netid 1000 }
|
|
set ngnodeidmap($eid\_$wlan) [format "%x" $netid]
|
|
}
|
|
if { ![info exists ngnodeidmap($eid\_$wlan-$node)] } {
|
|
set ngnodeidmap($eid\_$wlan-$node) [format "%x" $vals(emuid)]
|
|
lappend wlans_needing_update $wlan
|
|
}
|
|
} ;# end foreach wlan
|
|
}
|
|
|
|
# local flags: informational message that node was added or deleted
|
|
if {[expr {$flags & 0x8}]} {
|
|
if { ![info exists c] } { return }
|
|
if {[expr {$flags & 0x1}] } { ;# add flag
|
|
nodeHighlights $c $node on green
|
|
after 3000 "nodeHighlights .c $node off green"
|
|
} elseif {[expr {$flags & 0x2}] } { ;# delete flag
|
|
nodeHighlights $c $node on black
|
|
after 3000 "nodeHighlights .c $node off black"
|
|
}
|
|
# note: we may want to save other data passed in this message here
|
|
# rather than just returning...
|
|
return
|
|
}
|
|
# now we have all the information about this node
|
|
switch -exact -- "$flags" {
|
|
0 { apiNodeModify $node vals }
|
|
1 { apiNodeCreate $node vals }
|
|
2 { apiNodeDelete $node }
|
|
default { puts "NODE: unsupported flags ($flags)"; return }
|
|
}
|
|
}
|
|
|
|
#
|
|
# modify a node
|
|
#
|
|
proc apiNodeModify { node vals_ref } {
|
|
global c eid zoom curcanvas
|
|
upvar $vals_ref vals
|
|
if { ![info exists c] } { return } ;# batch mode
|
|
set draw 0
|
|
if { $vals(icon) != "" } {
|
|
setCustomImage $node $vals(icon)
|
|
set draw 1
|
|
}
|
|
# move the node and its links
|
|
if {$vals(xpos) != 0 && $vals(ypos) != 0} {
|
|
moveNodeAbs $c $node [expr {$zoom * $vals(xpos)}] \
|
|
[expr {$zoom * $vals(ypos)}]
|
|
}
|
|
if { $vals(name) != "" } {
|
|
setNodeName $node $vals(name)
|
|
set draw 1
|
|
}
|
|
if { $vals(services) != "" } {
|
|
set services [split $vals(services) |]
|
|
setNodeServices $node $services
|
|
}
|
|
# TODO: handle other optional on-screen data
|
|
# lat, long, alt, heading, platform type, platform id
|
|
if { $draw && [getNodeCanvas $node] == $curcanvas } {
|
|
.c delete withtag "node && $node"
|
|
.c delete withtag "nodelabel && $node"
|
|
drawNode .c $node
|
|
}
|
|
}
|
|
|
|
#
|
|
# add a node
|
|
#
|
|
proc apiNodeCreate { node vals_ref } {
|
|
global $node nodetypes node_list canvas_list curcanvas eid
|
|
upvar $vals_ref vals
|
|
|
|
# create GUI object
|
|
set nodetype $nodetypes($vals(type))
|
|
set nodename $vals(name)
|
|
if { $nodetype == "emane" } { set nodetype "wlan" } ;# special case - EMANE
|
|
if { $nodetype == "def" || $nodetype == "xen" } { set nodetype "router" }
|
|
newNode [list $nodetype $node] ;# use node number supplied from API message
|
|
setNodeName $node $nodename
|
|
if { $vals(canv) == "" } {
|
|
setNodeCanvas $node $curcanvas
|
|
} else {
|
|
set canv $vals(canv)
|
|
if { ![string is integer $canv] || $canv < 0 || $canv > 100} {
|
|
puts "warning: invalid canvas '$canv' in Node message!"
|
|
return
|
|
}
|
|
set canv "c$canv"
|
|
if { [lsearch $canvas_list $canv] < 0 && $canv == "c0" } {
|
|
# special case -- support old imn files with Canvas0
|
|
global $canv
|
|
lappend canvas_list $canv
|
|
set $canv {}
|
|
setCanvasName $canv "Canvas0"
|
|
set curcanvas $canv
|
|
switchCanvas none
|
|
} else {
|
|
while { [lsearch $canvas_list $canv] < 0 } {
|
|
set canvnew [newCanvas ""]
|
|
switchCanvas none ;# redraw canvas tabs
|
|
}
|
|
}
|
|
setNodeCanvas $node $canv
|
|
}
|
|
setNodeCoords $node "$vals(xpos) $vals(ypos)"
|
|
lassign [getDefaultLabelOffsets [nodeType $node]] dx dy
|
|
setNodeLabelCoords $node "[expr $vals(xpos) + $dx] [expr $vals(ypos) + $dy]"
|
|
setNodeLocation $node $vals(emulsrv)
|
|
if { $vals(icon) != "" } {
|
|
setCustomImage $node $vals(icon)
|
|
}
|
|
drawNode .c $node
|
|
|
|
set model $vals(model)
|
|
if { $model != "" && $vals(type) < 4} {
|
|
# set model only for (0 def 1 phys 2 xen 3 tbd) 4 lanswitch
|
|
setNodeModel $node $model
|
|
if { [lsearch -exact [getNodeTypeNames] $model] == -1 } {
|
|
puts "warning: unknown node type '$model' in Node message!"
|
|
}
|
|
}
|
|
if { $vals(services) != "" } {
|
|
set services [split $vals(services) |]
|
|
setNodeServices $node $services
|
|
}
|
|
|
|
if { $vals(type) == 7 } { ;# RJ45 node - used later to control linking
|
|
netconfInsertSection $node [list model $vals(model)]
|
|
} elseif { $vals(type) == 10 } { ;# EMANE node
|
|
set section [list mobmodel coreapi ""]
|
|
netconfInsertSection $node $section
|
|
#set sock [lindex [getEmulPlugin $node] 2]
|
|
#sendConfRequestMessage $sock $node "all" 0x1 -1 ""
|
|
} elseif { $vals(type) == 6 } { ;# WLAN node
|
|
if { $vals(opaque) != "" } {
|
|
# treat opaque as a list to accomodate other data
|
|
set i [lsearch $vals(opaque) "range=*"]
|
|
if { $i != -1 } {
|
|
set range [lindex $vals(opaque) $i]
|
|
setNodeRange $node [lindex [split $range =] 1]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
#
|
|
# delete a node
|
|
#
|
|
proc apiNodeDelete { node } {
|
|
removeGUINode $node
|
|
}
|
|
|
|
#
|
|
# CORE API Link message TLVs
|
|
#
|
|
proc parseLinkMessage { data len flags } {
|
|
global router def_router_model eid
|
|
global link_list node_list ngnodeidmap ngnodeidrmap showAPI execMode
|
|
set prmsg $showAPI
|
|
set current 0
|
|
set c .c
|
|
#puts "Parsing link message of length=$len, flags=$flags"
|
|
|
|
array set typenames { 1 node1num 2 node2num 3 delay 4 bw 5 per \
|
|
6 dup 7 jitter 8 mer 9 burst 10 session \
|
|
16 mburst 32 ltype 33 guiattr 34 uni \
|
|
35 emuid1 36 netid 37 key \
|
|
48 if1num 49 if1ipv4 50 if1ipv4mask 51 if1mac \
|
|
52 if1ipv6 53 if1ipv6mask \
|
|
54 if2num 55 if2ipv4 56 if2ipv4mask 57 if2mac \
|
|
64 if2ipv6 65 if2ipv6mask }
|
|
array set typesizes { node1num 4 node2num 4 delay 8 bw 8 per -1 \
|
|
dup -1 jitter 8 mer 2 burst 2 session -1 \
|
|
mburst 2 ltype 4 guiattr -1 uni 2 \
|
|
emuid1 4 netid 4 key 4 \
|
|
if1num 2 if1ipv4 4 if1ipv4mask 2 if1mac 8 \
|
|
if1ipv6 16 if1ipv6mask 2 \
|
|
if2num 2 if2ipv4 4 if2ipv4mask 2 if2mac 8 \
|
|
if2ipv6 16 if2ipv6mask 2 }
|
|
array set vals { node1num -1 node2num -1 delay 0 bw 0 per "" \
|
|
dup "" jitter 0 mer 0 burst 0 session "" \
|
|
mburst 0 ltype 0 guiattr "" uni 0 \
|
|
emuid1 -1 netid -1 key -1 \
|
|
if1num -1 if1ipv4 -1 if1ipv4mask 24 if1mac -1 \
|
|
if1ipv6 -1 if1ipv6mask 64 \
|
|
if2num -1 if2ipv4 -1 if2ipv4mask 24 if2mac -1 \
|
|
if2ipv6 -1 if2ipv6mask 64 }
|
|
set emuid1 -1
|
|
|
|
if { $prmsg==1 } { puts -nonewline "LINK(flags=$flags," }
|
|
|
|
#
|
|
# TLV parsing
|
|
#
|
|
while { $current < $len } {
|
|
# TLV header
|
|
if { [binary scan $data @${current}cc type length] != 2 } {
|
|
puts "TLV header error"
|
|
break
|
|
}
|
|
set length [expr {$length & 0xFF}]; # convert signed to unsigned
|
|
if { $length == 0 } {; # prevent endless looping
|
|
if { $type == 0 } { puts -nonewline "(extra padding)"; break
|
|
} else { puts "Found zero-length TLV for type=$type, dropping.";
|
|
break }
|
|
}
|
|
set pad [pad_32bit $length]
|
|
# verbose debugging
|
|
#puts "tlv type=$type length=$length pad=$pad current=$current"
|
|
incr current 2
|
|
|
|
if {![info exists typenames($type)] } { ;# unknown TLV type
|
|
if { $prmsg } { puts -nonewline "unknown=$type," }
|
|
incr current $length
|
|
continue
|
|
}
|
|
set typename $typenames($type)
|
|
set size $typesizes($typename)
|
|
# 32-bit and 64-bit vals pre-padded
|
|
if { $size == 4 || $size == 8} { incr current $pad }
|
|
# read TLV data depending on size
|
|
switch -exact -- "$size" {
|
|
2 { binary scan $data @${current}S vals($typename) }
|
|
4 { binary scan $data @${current}I vals($typename) }
|
|
8 { binary scan $data @${current}W vals($typename) }
|
|
16 { binary scan $data @${current}c16 vals($typename) }
|
|
-1 { binary scan $data @${current}a${length} vals($typename) }
|
|
}
|
|
incr current $length
|
|
# special handling of data here
|
|
switch -exact -- "$typename" {
|
|
delay -
|
|
jitter { if { $vals($typename) > 2000000 } {
|
|
array set vals [list $typename 2000000] } }
|
|
bw { if { $vals($typename) > 1000000000 } {
|
|
array set vals [list $typename 0] } }
|
|
per { if { $vals($typename) > 100 } {
|
|
array set vals [list $typename 100] } }
|
|
dup { if { $vals($typename) > 50 } {
|
|
array set vals [list $typename 50] } }
|
|
emuid1 { if { $emuid1 == -1 } {
|
|
set emuid $vals($typename)
|
|
} else { ;# this sets emuid2 if we already have emuid1
|
|
array set vals [list emuid2 $vals($typename) ]
|
|
array set vals [list emuid1 $emuid1 ]
|
|
}
|
|
}
|
|
if1ipv4 -
|
|
if2ipv4 { array set vals [list $typename \
|
|
[ipv4ToString $vals($typename)] ] }
|
|
if1mac -
|
|
if2mac { array set vals [list $typename \
|
|
[macToString $vals($typename)] ] }
|
|
if1ipv6 -
|
|
if2ipv6 { array set vals [list $typename \
|
|
[ipv6ToString $vals($typename)] ] }
|
|
}
|
|
if { $prmsg } { puts -nonewline "$typename=$vals($typename)," }
|
|
if { $size == 16 } { incr current $pad } ;# 128-bit vals post-padded
|
|
if { $size == -1 } { incr current $pad } ;# string vals post-padded
|
|
}
|
|
|
|
if { $prmsg == 1 } { puts ") " }
|
|
|
|
# perform some sanity checking of the link message
|
|
if { $vals(node1num) == $vals(node2num) || \
|
|
$vals(node1num) < 0 || $vals(node2num) < 0 } {
|
|
puts -nonewline "link message error - node1=$vals(node1num), "
|
|
puts "node2=$vals(node2num)"
|
|
return
|
|
}
|
|
|
|
# convert node number to node and check for node existance
|
|
set node1 "n$vals(node1num)"
|
|
set node2 "n$vals(node2num)"
|
|
if { [lsearch $node_list $node1] == -1 || \
|
|
[lsearch $node_list $node2] == -1 } {
|
|
puts "Node ($node1/$node2) in link message not found, dropping"
|
|
return
|
|
}
|
|
|
|
# set IPv4 and IPv6 address if specified, otherwise may be automatic
|
|
set prefix1 [chooseIfName $node1 $node2]
|
|
set prefix2 [chooseIfName $node2 $node1]
|
|
foreach i "1 2" {
|
|
# set interface name/number
|
|
if { $vals(if${i}num) == -1 } {
|
|
set ifname [newIfc [set prefix${i}] [set node${i}]]
|
|
set prefixlen [string length [set prefix${i}]]
|
|
set if${i}num [string range $ifname $prefixlen end]
|
|
array set vals [list if${i}num [set if${i}num]]
|
|
}
|
|
set ifname [set prefix${i}]$vals(if${i}num)
|
|
array set vals [list if${i}name $ifname]
|
|
# record IPv4/IPv6 addresses for newGUILink
|
|
foreach j "4 6" {
|
|
if { $vals(if${i}ipv${j}) != -1 } {
|
|
setIfcIPv${j}addr [set node${i}] $ifname \
|
|
$vals(if${i}ipv${j})/$vals(if${i}ipv${j}mask)
|
|
}
|
|
}
|
|
if { $vals(if${i}mac) != -1 } {
|
|
setIfcMacaddr [set node${i}] $ifname $vals(if${i}mac)
|
|
}
|
|
}
|
|
# adopt network address for WLAN (WLAN must be node 1)
|
|
if { [nodeType $node1] == "wlan" } {
|
|
set v4addr $vals(if2ipv4)
|
|
if { $v4addr != -1 } {
|
|
set v4net [ipv4ToNet $v4addr $vals(if2ipv4mask)]
|
|
setIfcIPv4addr $node1 wireless "$v4net/$vals(if2ipv4mask)"
|
|
}
|
|
set v6addr $vals(if2ipv6)
|
|
if { $v6addr != -1 } {
|
|
set v6net [ipv6ToNet $v6addr $vals(if2ipv6mask)]
|
|
setIfcIPv6addr $node1 wireless "${v6net}::0/$vals(if2ipv6mask)"
|
|
}
|
|
}
|
|
|
|
if { $execMode == "batch" } {
|
|
return ;# no GUI to update in batch mode
|
|
}
|
|
# treat 100% loss as link delete
|
|
if { $flags == 0 && $vals(per) == 100 } {
|
|
apiLinkDelete $node1 $node2 vals
|
|
return
|
|
}
|
|
|
|
# now we have all the information about this node
|
|
switch -exact -- "$flags" {
|
|
0 { apiLinkAddModify $node1 $node2 vals 0 }
|
|
1 { apiLinkAddModify $node1 $node2 vals 1 }
|
|
2 { apiLinkDelete $node1 $node2 vals }
|
|
default { puts "LINK: unsupported flags ($flags)"; return }
|
|
}
|
|
}
|
|
|
|
#
|
|
# add or modify a link
|
|
# if add flag is set, check if two nodes are part of same wlan, and do wlan
|
|
# linkage, or add a wired link; otherwise modify wired/wireless link with
|
|
# supplied parameters
|
|
proc apiLinkAddModify { node1 node2 vals_ref add } {
|
|
global eid defLinkWidth
|
|
set c .c
|
|
upvar $vals_ref vals
|
|
|
|
if {$vals(key) > -1} {
|
|
if { [nodeType $node1] == "tunnel" } {
|
|
netconfInsertSection $node1 [list "tunnel-key" $vals(key)]
|
|
}
|
|
if { [nodeType $node2] == "tunnel" } {
|
|
netconfInsertSection $node2 [list "tunnel-key" $vals(key)]
|
|
}
|
|
}
|
|
|
|
# look for a wired link in the link list
|
|
set wired_link [linkByPeers $node1 $node2]
|
|
if { $wired_link != "" && $add == 0 } { ;# wired link exists, modify it
|
|
#puts "modify wired link"
|
|
if { $vals(uni) == 1 } { ;# unidirectional link effects message
|
|
set peers [linkPeers $wired_link]
|
|
if { $node1 == [lindex $peers 0] } { ;# downstream n1 <-- n2
|
|
set bw [list $vals(bw) [getLinkBandwidth $wired_link up]]
|
|
set delay [list $vals(delay) [getLinkDelay $wired_link up]]
|
|
set per [list $vals(per) [getLinkBER $wired_link up]]
|
|
set dup [list $vals(dup) [getLinkBER $wired_link up]]
|
|
set jitter [list $vals(jitter) [getLinkJitter $wired_link up]]
|
|
} else { ;# upstream n1 --> n2
|
|
set bw [list [getLinkBandwidth $wired_link] $vals(bw)]
|
|
set delay [list [getLinkDelay $wired_link] $vals(delay)]
|
|
set per [list [getLinkBER $wired_link] $vals(per)]
|
|
set dup [list [getLinkBER $wired_link] $vals(dup)]
|
|
set jitter [list $vals(jitter) [getLinkJitter $wired_link]]
|
|
}
|
|
setLinkBandwidth $wired_link $bw
|
|
setLinkDelay $wired_link $delay
|
|
setLinkBER $wired_link $per
|
|
setLinkDup $wired_link $dup
|
|
setLinkJitter $wired_link $jitter
|
|
} else {
|
|
setLinkBandwidth $wired_link $vals(bw)
|
|
setLinkDelay $wired_link $vals(delay)
|
|
setLinkBER $wired_link $vals(per)
|
|
setLinkDup $wired_link $vals(dup)
|
|
setLinkJitter $wired_link $vals(jitter)
|
|
}
|
|
updateLinkLabel $wired_link
|
|
updateLinkGuiAttr $wired_link $vals(guiattr)
|
|
return
|
|
# if add flag is set and a wired link already exists, assume wlan linkage
|
|
# special case: rj45 model=1 means link via wireless
|
|
} elseif {[nodeType $node1] == "rj45" || [nodeType $node2] == "rj45"} {
|
|
if { [nodeType $node1] == "rj45" } {
|
|
set rj45node $node1; set othernode $node2;
|
|
} else { set rj45node $node2; set othernode $node1; }
|
|
if { [netconfFetchSection $rj45node model] == 1 } {
|
|
set wlan [findWlanNodes $othernode]
|
|
if {$wlan != ""} {newGUILink $wlan $rj45node};# link rj4node to wlan
|
|
}
|
|
}
|
|
|
|
# no wired link; determine if both nodes belong to the same wlan, and
|
|
# link them; otherwise add a wired link if add flag is set
|
|
set wlan $vals(netid)
|
|
if { $wlan < 0 } {
|
|
# WLAN not specified with netid, search for common WLAN
|
|
set wlans1 [findWlanNodes $node1]
|
|
set wlans2 [findWlanNodes $node2]
|
|
foreach w $wlans1 {
|
|
if { [lsearch -exact $wlans2 $w] < 0 } { continue }
|
|
set wlan $w
|
|
break
|
|
}
|
|
}
|
|
|
|
if { $wlan < 0 } { ;# no common wlan
|
|
if {$add == 1} { ;# add flag was set - add a wired link
|
|
global g_newLink_ifhints
|
|
set g_newLink_ifhints [list $vals(if1name) $vals(if2name)]
|
|
newGUILink $node1 $node2
|
|
if { [getNodeCanvas $node1] != [getNodeCanvas $node2] } {
|
|
set wired_link [linkByPeersMirror $node1 $node2]
|
|
} else {
|
|
set wired_link [linkByPeers $node1 $node2]
|
|
}
|
|
setLinkBandwidth $wired_link $vals(bw)
|
|
setLinkDelay $wired_link $vals(delay)
|
|
setLinkBER $wired_link $vals(per)
|
|
setLinkDup $wired_link $vals(dup)
|
|
setLinkJitter $wired_link $vals(jitter)
|
|
updateLinkLabel $wired_link
|
|
updateLinkGuiAttr $wired_link $vals(guiattr)
|
|
# adopt link effects for WLAN (WLAN must be node 1)
|
|
if { [nodeType $node1] == "wlan" } {
|
|
setLinkBandwidth $node1 $vals(bw)
|
|
setLinkDelay $node1 $vals(delay)
|
|
setLinkBER $node1 $vals(per)
|
|
}
|
|
return
|
|
} else { ;# modify link, but no wired link or common wlan!
|
|
puts -nonewline "link modify message received, but no wired link"
|
|
puts " or wlan for nodes $node1-$node2, dropping"
|
|
return
|
|
}
|
|
}
|
|
|
|
set wlan "n$wlan"
|
|
drawWlanLink $node1 $node2 $wlan
|
|
}
|
|
|
|
#
|
|
# delete a link
|
|
#
|
|
proc apiLinkDelete { node1 node2 vals_ref } {
|
|
global eid
|
|
upvar $vals_ref vals
|
|
set c .c
|
|
|
|
# look for a wired link in the link list
|
|
set wired_link [linkByPeers $node1 $node2]
|
|
if { $wired_link != "" } {
|
|
removeGUILink $wired_link non-atomic
|
|
return
|
|
}
|
|
|
|
set wlan $vals(netid)
|
|
if { $wlan < 0 } {
|
|
# WLAN not specified with netid, search for common WLAN
|
|
set wlans1 [findWlanNodes $node1]
|
|
set wlans2 [findWlanNodes $node2]
|
|
foreach w $wlans1 {
|
|
if { [lsearch -exact $wlans2 $w] < 0 } { continue }
|
|
set wlan $w
|
|
break
|
|
}
|
|
}
|
|
if { $wlan < 0 } {
|
|
puts "apiLinkDelete: no common WLAN!"
|
|
return
|
|
}
|
|
set wlan "n$wlan"
|
|
|
|
# look for wireless link on the canvas, remove GUI object
|
|
$c delete -withtags "wlanlink && $node2 && $node1 && $wlan"
|
|
$c delete -withtags "linklabel && $node2 && $node1 && $wlan"
|
|
}
|
|
|
|
#
|
|
# CORE API Execute message TLVs
|
|
#
|
|
proc parseExecMessage { data len flags channel } {
|
|
global node_list curcanvas c router eid showAPI
|
|
global XSCALE YSCALE XOFFSET YOFFSET
|
|
set prmsg $showAPI
|
|
set current 0
|
|
|
|
# set default values
|
|
set nodenum 0
|
|
set execnum 0
|
|
set exectime 0
|
|
set execcmd ""
|
|
set execres ""
|
|
set execstatus 0
|
|
set session ""
|
|
|
|
if { $prmsg==1 } { puts -nonewline "EXEC(flags=$flags," }
|
|
|
|
# parse each TLV
|
|
while { $current < $len } {
|
|
# TLV header
|
|
set typelength [parseTLVHeader $data current]
|
|
set type [lindex $typelength 0]
|
|
set length [lindex $typelength 1]
|
|
if { $length == 0 || $length == "" } { break }
|
|
set pad [pad_32bit $length]
|
|
# verbose debugging
|
|
#puts "exec tlv type=$type length=$length pad=$pad current=$current"
|
|
if { [expr {$current + $length + $pad}] > $len } {
|
|
puts "error with EXEC message length (len=$len, TLV length=$length)"
|
|
break
|
|
}
|
|
# TLV data
|
|
switch -exact -- "$type" {
|
|
1 {
|
|
incr current $pad
|
|
binary scan $data @${current}I nodenum
|
|
if { $prmsg==1 } { puts -nonewline "node=$nodenum/" }
|
|
}
|
|
2 {
|
|
incr current $pad
|
|
binary scan $data @${current}I execnum
|
|
if { $prmsg == 1} { puts -nonewline "exec=$execnum," }
|
|
}
|
|
3 {
|
|
incr current $pad
|
|
binary scan $data @${current}I exectime
|
|
if { $prmsg == 1} { puts -nonewline "time=$exectime," }
|
|
}
|
|
4 {
|
|
binary scan $data @${current}a${length} execcmd
|
|
if { $prmsg == 1} { puts -nonewline "cmd=$execcmd," }
|
|
incr current $pad
|
|
}
|
|
5 {
|
|
binary scan $data @${current}a${length} execres
|
|
if { $prmsg == 1} { puts -nonewline "res=($length bytes)," }
|
|
incr current $pad
|
|
}
|
|
6 {
|
|
incr current $pad
|
|
binary scan $data @${current}I execstatus
|
|
if { $prmsg == 1} { puts -nonewline "status=$execstatus," }
|
|
}
|
|
10 {
|
|
binary scan $data @${current}a${length} session
|
|
if { $prmsg == 1} { puts -nonewline "session=$session," }
|
|
incr current $pad
|
|
}
|
|
default {
|
|
if { $prmsg == 1} { puts -nonewline "unknown=" }
|
|
if { $prmsg == 1} { puts -nonewline "$type," }
|
|
}
|
|
}
|
|
# end switch
|
|
|
|
# advance current pointer
|
|
incr current $length
|
|
}
|
|
if { $prmsg == 1 } { puts ") "}
|
|
|
|
set node "n$nodenum"
|
|
set node_id "$eid\_$node"
|
|
# check for node existance
|
|
if { [lsearch $node_list $node] == -1 } {
|
|
puts "Execute message but node ($node) does not exist, dropping."
|
|
return
|
|
}
|
|
global $node
|
|
|
|
# Callback support - match execnum from response with original request, and
|
|
# invoke type-specific callback
|
|
global g_execRequests
|
|
foreach type [array names g_execRequests] {
|
|
set idx [lsearch $g_execRequests($type) $execnum]
|
|
if { $idx > -1 } {
|
|
set g_execRequests($type) \
|
|
[lreplace $g_execRequests($type) $idx $idx]
|
|
exec_${type}_callback $node $execnum $execcmd $execres $execstatus
|
|
return
|
|
}
|
|
}
|
|
}
|
|
|
|
# spawn interactive terminal
|
|
proc exec_shell_callback { node execnum execcmd execres execstatus } {
|
|
#puts "opening terminal for $node by running '$execres'"
|
|
set title "CORE: [getNodeName $node] (console)"
|
|
set term [get_term_prog false]
|
|
set xi [string first "xterm -e" $execres]
|
|
|
|
# shell callback already has xterm command, launch it using user-defined
|
|
# term program (e.g. remote nodes 'ssh -X -f a.b.c.d xterm -e ...'
|
|
if { $xi > -1 } {
|
|
set execres [string replace $execres $xi [expr $xi+7] $term]
|
|
if { [catch {exec sh -c "$execres" & } ] } {
|
|
puts "Warning: failed to open terminal for $node"
|
|
}
|
|
return
|
|
# no xterm command; execute shell callback in a terminal (e.g. local nodes)
|
|
} elseif { \
|
|
[catch {eval exec $term "$execres" & } ] } {
|
|
puts "Warning: failed to open terminal for $node: ($term $execres)"
|
|
}
|
|
}
|
|
|
|
|
|
#
|
|
# CORE API Register message TLVs
|
|
# parse register message into plugin capabilities
|
|
#
|
|
proc parseRegMessage { data len flags channel } {
|
|
global regntypes showAPI
|
|
set prmsg $showAPI
|
|
set current 0
|
|
set str 0
|
|
set session ""
|
|
set fnhint ""
|
|
|
|
set plugin_cap_list {} ;# plugin capabilities list
|
|
|
|
if { $prmsg==1 } { puts -nonewline "REG(flags=$flags," }
|
|
|
|
# parse each TLV
|
|
while { $current < $len } {
|
|
# TLV header
|
|
if { [binary scan $data @${current}cc type length] != 2 } {
|
|
puts "TLV header error"
|
|
break
|
|
}
|
|
set length [expr {$length & 0xFF}]; # convert signed to unsigned
|
|
if { $length == 0 } {
|
|
# prevent endless looping
|
|
if { $type == 0 } {
|
|
puts -nonewline "(extra padding)"
|
|
break
|
|
} else {
|
|
puts "Found zero-length TLV for type=$type, dropping."
|
|
break
|
|
}
|
|
}
|
|
set pad [pad_32bit $length]
|
|
# verbose debugging
|
|
#puts "tlv type=$type length=$length pad=$pad current=$current"
|
|
incr current 2
|
|
# TLV data
|
|
if { [info exists regntypes($type)] } {
|
|
set plugin_type $regntypes($type)
|
|
binary scan $data @${current}a${length} str
|
|
if { $prmsg == 1} { puts -nonewline "$plugin_type=$str," }
|
|
if { $type == 10 } { ;# session number
|
|
set session $str
|
|
} else {
|
|
lappend plugin_cap_list "$plugin_type=$str"
|
|
if { $plugin_type == "exec" } { set fnhint $str }
|
|
}
|
|
} else {
|
|
if { $prmsg == 1} { puts -nonewline "unknown($type)," }
|
|
}
|
|
incr current $pad
|
|
# end switch
|
|
|
|
# advance current pointer
|
|
incr current $length
|
|
}
|
|
if { $prmsg == 1 } { puts ") "}
|
|
|
|
# reg message with session number indicates the sid of a session that
|
|
# was just started from XML or Python script (via reg exec=scriptfile.py)
|
|
if { $session != "" } {
|
|
# The channel passed to here is soon after discarded for
|
|
# sessions that are started from XML or Python scripts. This causes
|
|
# an exception in the GUI when responding back to daemon if the
|
|
# response is sent after the channel has been destroyed. Setting
|
|
# the channel to -1 basically disables the GUI response to the daemon,
|
|
# but it turns out the daemon does not need the response anyway.
|
|
set channel -1
|
|
# assume session string only contains one session number
|
|
connectShutdownSession connect $channel $session $fnhint
|
|
return
|
|
}
|
|
|
|
set plugin [pluginByChannel $channel]
|
|
if { [setPluginCapList $plugin $plugin_cap_list] < 0 } {
|
|
return
|
|
}
|
|
|
|
# callback to refresh any open dialogs this message may refresh
|
|
pluginsConfigRefreshCallback
|
|
}
|
|
|
|
proc parseConfMessage { data len flags channel } {
|
|
global showAPI node_list MACHINE_TYPES
|
|
set prmsg $showAPI
|
|
set current 0
|
|
set str 0
|
|
set nodenum -1
|
|
set obj ""
|
|
set tflags 0
|
|
set types {}
|
|
set values {}
|
|
set captions {}
|
|
set bitmap {}
|
|
set possible_values {}
|
|
set groups {}
|
|
set opaque {}
|
|
set session ""
|
|
set netid -1
|
|
|
|
if { $prmsg==1 } { puts -nonewline "CONF(flags=$flags," }
|
|
|
|
# parse each TLV
|
|
while { $current < $len } {
|
|
set typelength [parseTLVHeader $data current]
|
|
set type [lindex $typelength 0]
|
|
set length [lindex $typelength 1]
|
|
set pad [pad_32bit $length]
|
|
if { $length == 0 || $length == "" } {
|
|
# allow some zero-length string TLVs
|
|
if { $type < 5 || $type > 9 } { break }
|
|
}
|
|
# verbose debugging
|
|
#puts "tlv type=$type length=$length pad=$pad current=$current"
|
|
# TLV data
|
|
switch -exact -- "$type" {
|
|
1 {
|
|
incr current $pad
|
|
binary scan $data @${current}I nodenum
|
|
if { $prmsg == 1} { puts -nonewline "node=$nodenum/" }
|
|
}
|
|
2 {
|
|
binary scan $data @${current}a${length} obj
|
|
if { $prmsg == 1} { puts -nonewline "obj=$obj," }
|
|
incr current $pad
|
|
}
|
|
3 {
|
|
binary scan $data @${current}S tflags
|
|
if { $prmsg == 1} { puts -nonewline "cflags=$tflags," }
|
|
}
|
|
4 {
|
|
set type 0
|
|
set types {}
|
|
if { $prmsg == 1} { puts -nonewline "types=" }
|
|
# number of 16-bit values
|
|
set types_len $length
|
|
# get each 16-bit type value, add to list
|
|
while {$types_len > 0} {
|
|
binary scan $data @${current}S type
|
|
if {$type > 0 && $type < 12} {
|
|
lappend types $type
|
|
if { $prmsg == 1} { puts -nonewline "$type/" }
|
|
}
|
|
incr current 2
|
|
incr types_len -2
|
|
}
|
|
if { $prmsg == 1} { puts -nonewline "," }
|
|
incr current -$length; # length incremented below
|
|
incr current $pad
|
|
}
|
|
5 {
|
|
set values {}
|
|
binary scan $data @${current}a${length} vals
|
|
if { $prmsg == 1} { puts -nonewline "vals=$vals," }
|
|
set values [split $vals |]
|
|
incr current $pad
|
|
}
|
|
6 {
|
|
set captions {}
|
|
binary scan $data @${current}a${length} capt
|
|
if { $prmsg == 1} { puts -nonewline "capt=$capt," }
|
|
set captions [split $capt |]
|
|
incr current $pad
|
|
}
|
|
7 {
|
|
set bitmap {}
|
|
binary scan $data @${current}a${length} bitmap
|
|
if { $prmsg == 1} { puts -nonewline "bitmap," }
|
|
incr current $pad
|
|
}
|
|
8 {
|
|
set possible_values {}
|
|
binary scan $data @${current}a${length} pvals
|
|
if { $prmsg == 1} { puts -nonewline "pvals=$pvals," }
|
|
set possible_values [split $pvals |]
|
|
incr current $pad
|
|
}
|
|
9 {
|
|
set groups {}
|
|
binary scan $data @${current}a${length} groupsstr
|
|
if { $prmsg == 1} { puts -nonewline "groups=$groupsstr," }
|
|
set groups [split $groupsstr |]
|
|
incr current $pad
|
|
}
|
|
10 {
|
|
binary scan $data @${current}a${length} session
|
|
if { $prmsg == 1} { puts -nonewline "session=$session," }
|
|
incr current $pad
|
|
}
|
|
35 {
|
|
incr current $pad
|
|
binary scan $data @${current}I netid
|
|
if { $prmsg == 1} { puts -nonewline "netid=$netid/" }
|
|
}
|
|
80 {
|
|
set opaque {}
|
|
binary scan $data @${current}a${length} opaquestr
|
|
if { $prmsg == 1} { puts -nonewline "opaque=$opaquestr," }
|
|
set opaque [split $opaquestr |]
|
|
incr current $pad
|
|
}
|
|
default {
|
|
if { $prmsg == 1} { puts -nonewline "unknown=" }
|
|
if { $prmsg == 1} { puts -nonewline "$type," }
|
|
}
|
|
}
|
|
# end switch
|
|
|
|
# advance current pointer
|
|
incr current $length
|
|
}
|
|
|
|
if { $prmsg == 1 } { puts ") "}
|
|
|
|
set objs_ok [concat "services session metadata emane" $MACHINE_TYPES]
|
|
if { $nodenum > -1 } {
|
|
set node "n$nodenum"
|
|
} else {
|
|
set node ""
|
|
}
|
|
# check for node existance
|
|
if { [lsearch $node_list $node] == -1 } {
|
|
if { [lsearch $objs_ok $obj] < 0 } {
|
|
set msg "Configure message for $obj but node ($node) does"
|
|
set msg "$msg not exist, dropping."
|
|
puts $msg
|
|
return
|
|
}
|
|
} else {
|
|
global $node
|
|
}
|
|
|
|
# for handling node services
|
|
# this could be improved, instead of checking for the hard-coded object
|
|
# "services" and opaque data for service customization
|
|
if { $obj == "services" } {
|
|
if { $tflags & 0x2 } { ;# update flag
|
|
if { $opaque != "" } {
|
|
set services [lindex [split $opaque ":"] 1]
|
|
set services [split $services ","]
|
|
customizeServiceValues n$nodenum $values $services
|
|
}
|
|
# TODO: save services config with the node
|
|
} elseif { $tflags & 0x1 } { ;# request flag
|
|
# TODO: something else
|
|
} else {
|
|
popupServicesConfig $channel n$nodenum $types $values $captions \
|
|
$possible_values $groups $session
|
|
}
|
|
return
|
|
# metadata received upon XML file load
|
|
} elseif { $obj == "metadata" } {
|
|
parseMetaData $values
|
|
return
|
|
# session options received upon XML file load
|
|
} elseif { $obj == "session" && $tflags & 0x2 } {
|
|
setSessionOptions $types $values
|
|
return
|
|
}
|
|
# handle node machine-type profile
|
|
if { [lsearch $MACHINE_TYPES $obj] != -1 } {
|
|
if { $tflags == 0 } {
|
|
popupNodeProfileConfig $channel n$nodenum $obj $types $values \
|
|
$captions $bitmap $possible_values $groups $session \
|
|
$opaque
|
|
} else {
|
|
puts -nonewline "warning: received Configure message for profile "
|
|
puts "with unexpected flags!"
|
|
}
|
|
return
|
|
}
|
|
|
|
# update the configuration for a node without displaying dialog box
|
|
if { $tflags & 0x2 } {
|
|
if { $obj == "emane" && $node == "" } {
|
|
set node [lindex [findWlanNodes ""] 0]
|
|
}
|
|
if { $node == "" } {
|
|
puts "ignoring Configure message for $obj with no node"
|
|
return
|
|
}
|
|
# this is similar to popupCapabilityConfigApply
|
|
setCustomConfig $node $obj $types $values 0
|
|
if { $obj != "emane" && [nodeType $node] == "wlan"} {
|
|
set section [list mobmodel coreapi $obj]
|
|
netconfInsertSection $node $section
|
|
}
|
|
# configuration request - unhandled
|
|
} elseif { $tflags & 0x1 } {
|
|
# configuration response data from our request (from GUI plugin configure)
|
|
} else {
|
|
popupCapabilityConfig $channel n$nodenum $obj $types $values \
|
|
$captions $bitmap $possible_values $groups
|
|
}
|
|
}
|
|
|
|
# process metadata received from Conf Message when loading XML
|
|
proc parseMetaData { values } {
|
|
global canvas_list annotation_list execMode g_comments
|
|
|
|
foreach value $values {
|
|
# data looks like this: "annotation a1={iconcoords {514.0 132.0...}}"
|
|
lassign [splitKeyValue $value] key object_config
|
|
lassign $key class object
|
|
# metadata with no object name e.g. comments="Comment text"
|
|
if { "$class" == "comments" } {
|
|
set g_comments $object_config
|
|
continue
|
|
} elseif { "$class" == "global_options" } {
|
|
foreach opt $object_config {
|
|
lassign [split $opt =] key value
|
|
setGlobalOption $key $value
|
|
}
|
|
continue
|
|
}
|
|
# metadata having class and object name
|
|
if {"$class" == "" || $object == ""} {
|
|
puts "warning: invalid metadata value '$value'"
|
|
}
|
|
if { "$class" == "canvas" } {
|
|
if { [lsearch $canvas_list $object] < 0 } {
|
|
lappend canvas_list $object
|
|
}
|
|
} elseif { "$class" == "annotation" } {
|
|
if { [lsearch $annotation_list $object] < 0 } {
|
|
lappend annotation_list $object
|
|
}
|
|
} else {
|
|
puts "metadata parsing error: unknown object class $class"
|
|
}
|
|
global $object
|
|
set $object $object_config
|
|
}
|
|
|
|
if { $execMode == "batch" } { return }
|
|
switchCanvas none
|
|
redrawAll
|
|
}
|
|
|
|
proc parseFileMessage { data len flags channel } {
|
|
global showAPI node_list
|
|
set prmsg $showAPI
|
|
|
|
array set tlvnames { 1 num 2 name 3 mode 4 fno 5 type 6 sname \
|
|
10 session 16 data 17 cdata }
|
|
array set tlvsizes { num 4 name -1 mode -3 fno 2 type -1 sname -1 \
|
|
session -1 data -1 cdata -1 }
|
|
array set defvals { num -1 name "" mode -1 fno -1 type "" sname "" \
|
|
session "" data "" cdata "" }
|
|
|
|
if { $prmsg==1 } { puts -nonewline "FILE(flags=$flags," }
|
|
array set vals [parseMessage $data $len $flags [array get tlvnames] \
|
|
[array get tlvsizes] [array get defvals]]
|
|
if { $prmsg } { puts ") "}
|
|
|
|
# hook scripts received in File Message
|
|
if { [string range $vals(type) 0 4] == "hook:" } {
|
|
global g_hook_scripts
|
|
set state [string range $vals(type) 5 end]
|
|
lappend g_hook_scripts [list $vals(name) $state $vals(data)]
|
|
return
|
|
}
|
|
|
|
# required fields
|
|
foreach t "num name data" {
|
|
if { $vals($t) == $defvals($t) } {
|
|
puts "Received File Message without $t, dropping."; return;
|
|
}
|
|
}
|
|
|
|
# check for node existance
|
|
set node "n$vals(num)"
|
|
if { [lsearch $node_list $node] == -1 } {
|
|
puts "File message but node ($node) does not exist, dropping."
|
|
return
|
|
} else {
|
|
global $node
|
|
}
|
|
|
|
# service customization received in File Message
|
|
if { [string range $vals(type) 0 7] == "service:" } {
|
|
customizeServiceFile $node $vals(name) $vals(type) $vals(data) true
|
|
}
|
|
}
|
|
|
|
proc parseEventMessage { data len flags channel } {
|
|
global showAPI eventtypes g_traffic_start_opt execMode node_list
|
|
set prmsg $showAPI
|
|
set current 0
|
|
set nodenum -1
|
|
set eventtype -1
|
|
set eventname ""
|
|
set eventdata ""
|
|
set eventtime ""
|
|
set session ""
|
|
|
|
if { $prmsg==1 } { puts -nonewline "EVENT(flags=$flags," }
|
|
|
|
# parse each TLV
|
|
while { $current < $len } {
|
|
set typelength [parseTLVHeader $data current]
|
|
set type [lindex $typelength 0]
|
|
set length [lindex $typelength 1]
|
|
if { $length == 0 || $length == "" } { break }
|
|
set pad [pad_32bit $length]
|
|
# verbose debugging
|
|
#puts "tlv type=$type length=$length pad=$pad current=$current"
|
|
# TLV data
|
|
switch -exact -- "$type" {
|
|
1 {
|
|
incr current $pad
|
|
binary scan $data @${current}I nodenum
|
|
if { $prmsg == 1} { puts -nonewline "node=$nodenum," }
|
|
}
|
|
2 {
|
|
incr current $pad
|
|
binary scan $data @${current}I eventtype
|
|
if { $prmsg == 1} {
|
|
set typestr ""
|
|
foreach t [array names eventtypes] {
|
|
if { $eventtypes($t) == $eventtype } {
|
|
set typestr "-$t"
|
|
break
|
|
}
|
|
}
|
|
puts -nonewline "type=$eventtype$typestr,"
|
|
}
|
|
}
|
|
3 {
|
|
binary scan $data @${current}a${length} eventname
|
|
if { $prmsg == 1} { puts -nonewline "name=$eventname," }
|
|
incr current $pad
|
|
}
|
|
4 {
|
|
binary scan $data @${current}a${length} eventdata
|
|
if { $prmsg == 1} { puts -nonewline "data=$eventdata," }
|
|
incr current $pad
|
|
}
|
|
5 {
|
|
binary scan $data @${current}a${length} eventtime
|
|
if { $prmsg == 1} { puts -nonewline "time=$eventtime," }
|
|
incr current $pad
|
|
}
|
|
10 {
|
|
binary scan $data @${current}a${length} session
|
|
if { $prmsg == 1} { puts -nonewline "session=$session," }
|
|
incr current $pad
|
|
}
|
|
default {
|
|
if { $prmsg == 1} { puts -nonewline "unknown=" }
|
|
if { $prmsg == 1} { puts -nonewline "$type," }
|
|
}
|
|
}
|
|
# end switch
|
|
|
|
# advance current pointer
|
|
incr current $length
|
|
}
|
|
|
|
if { $prmsg == 1 } { puts ") "}
|
|
|
|
# TODO: take other actions here based on Event Message
|
|
if { $eventtype == 4 } { ;# entered the runtime state
|
|
if { $g_traffic_start_opt == 1 } { startTrafficScripts }
|
|
if { $execMode == "batch" } {
|
|
global g_current_session g_abort_session
|
|
if {$g_abort_session} {
|
|
puts "Current session ($g_current_session) aborted. Disconnecting."
|
|
shutdownSession
|
|
} else {
|
|
puts "Session running. Session id is $g_current_session. Disconnecting."
|
|
}
|
|
exit.real
|
|
}
|
|
} elseif { $eventtype == 6 } { ;# shutdown state
|
|
set name [lindex [getEmulPlugin "*"] 0]
|
|
if { [getAssignedRemoteServers] == "" } {
|
|
# start a new session if not distributed
|
|
# otherwise we need to allow time for node delete messages
|
|
# from other servers
|
|
pluginConnect $name disconnect 1
|
|
pluginConnect $name connect 1
|
|
}
|
|
} elseif { $eventtype >= 7 || $eventtype <= 10 } {
|
|
if { [string range $eventname 0 8] == "mobility:" } {
|
|
set node "n$nodenum"
|
|
if {[lsearch $node_list $node] == -1} {
|
|
puts "Event message with unknown node %nodenum."
|
|
return
|
|
}
|
|
handleMobilityScriptEvent $node $eventtype $eventdata $eventtime
|
|
}
|
|
}
|
|
}
|
|
|
|
proc parseSessionMessage { data len flags channel } {
|
|
global showAPI g_current_session g_session_dialog_hint execMode
|
|
set prmsg $showAPI
|
|
set current 0
|
|
set sessionids {}
|
|
set sessionnames {}
|
|
set sessionfiles {}
|
|
set nodecounts {}
|
|
set sessiondates {}
|
|
set thumbs {}
|
|
set sessionopaque {}
|
|
|
|
if { $prmsg==1 } { puts -nonewline "SESSION(flags=$flags," }
|
|
|
|
# parse each TLV
|
|
while { $current < $len } {
|
|
set typelength [parseTLVHeader $data current]
|
|
set type [lindex $typelength 0]
|
|
set length [lindex $typelength 1]
|
|
if { $length == 0 || $length == "" } {
|
|
puts "warning: zero-length TLV, discarding remainder of message!"
|
|
break
|
|
}
|
|
set pad [pad_32bit $length]
|
|
# verbose debugging
|
|
#puts "tlv type=$type length=$length pad=$pad current=$current"
|
|
# TLV data
|
|
switch -exact -- "$type" {
|
|
1 {
|
|
set sessionids {}
|
|
binary scan $data @${current}a${length} sids
|
|
if { $prmsg == 1} { puts -nonewline "sids=$sids," }
|
|
set sessionids [split $sids |]
|
|
incr current $pad
|
|
}
|
|
2 {
|
|
set sessionnames {}
|
|
binary scan $data @${current}a${length} snames
|
|
if { $prmsg == 1} { puts -nonewline "names=$snames," }
|
|
set sessionnames [split $snames |]
|
|
incr current $pad
|
|
}
|
|
3 {
|
|
set sessionfiles {}
|
|
binary scan $data @${current}a${length} sfiles
|
|
if { $prmsg == 1} { puts -nonewline "files=$sfiles," }
|
|
set sessionfiles [split $sfiles |]
|
|
incr current $pad
|
|
}
|
|
4 {
|
|
set nodecounts {}
|
|
binary scan $data @${current}a${length} ncs
|
|
if { $prmsg == 1} { puts -nonewline "ncs=$ncs," }
|
|
set nodecounts [split $ncs |]
|
|
incr current $pad
|
|
}
|
|
5 {
|
|
set sessiondates {}
|
|
binary scan $data @${current}a${length} sdates
|
|
if { $prmsg == 1} { puts -nonewline "dates=$sdates," }
|
|
set sessiondates [split $sdates |]
|
|
incr current $pad
|
|
}
|
|
6 {
|
|
set thumbs {}
|
|
binary scan $data @${current}a${length} th
|
|
if { $prmsg == 1} { puts -nonewline "thumbs=$th," }
|
|
set thumbs [split $th |]
|
|
incr current $pad
|
|
}
|
|
10 {
|
|
set sessionopaque {}
|
|
binary scan $data @${current}a${length} sessionopaque
|
|
if { $prmsg == 1} { puts -nonewline "$sessionopaque," }
|
|
incr current $pad
|
|
}
|
|
default {
|
|
if { $prmsg == 1} { puts -nonewline "unknown=" }
|
|
if { $prmsg == 1} { puts -nonewline "$type," }
|
|
}
|
|
}
|
|
# end switch
|
|
|
|
# advance current pointer
|
|
incr current $length
|
|
}
|
|
|
|
if { $prmsg == 1 } { puts ") "}
|
|
|
|
if {$g_current_session == 0} {
|
|
# set the current session to the channel port number
|
|
set current_session [lindex [fconfigure $channel -sockname] 2]
|
|
} else {
|
|
set current_session $g_current_session
|
|
}
|
|
|
|
if {[lsearch $sessionids $current_session] == -1} {
|
|
puts -nonewline "*** warning: current session ($g_current_session) "
|
|
puts "not found in session list: $sessionids"
|
|
}
|
|
|
|
set orig_session_choice $g_current_session
|
|
set g_current_session $current_session
|
|
setGuiTitle ""
|
|
|
|
if {$execMode == "closebatch"} {
|
|
# we're going to close some session, so this is expected
|
|
global g_session_choice
|
|
|
|
if {[lsearch $sessionids $g_session_choice] == -1} {
|
|
puts -nonewline "*** warning: current session ($g_session_choice) "
|
|
puts "not found in session list: $sessionids"
|
|
} else {
|
|
set flags 0x2 ;# delete flag
|
|
set sid $g_session_choice
|
|
set name ""
|
|
set f ""
|
|
set nodecount ""
|
|
set thumb ""
|
|
set user ""
|
|
sendSessionMessage $channel $flags $sid $name $f $nodecount $thumb $user
|
|
|
|
puts "Session shutdown message sent."
|
|
}
|
|
exit.real
|
|
}
|
|
|
|
if {$orig_session_choice == 0 && [llength $sessionids] == 1} {
|
|
# we just started up and only the current session exists
|
|
set g_session_dialog_hint 0
|
|
return
|
|
}
|
|
|
|
if {$execMode == "batch"} {
|
|
puts "Another session is active."
|
|
exit.real
|
|
}
|
|
|
|
if { $g_session_dialog_hint } {
|
|
popupSessionConfig $channel $sessionids $sessionnames $sessionfiles \
|
|
$nodecounts $sessiondates $thumbs $sessionopaque
|
|
}
|
|
set g_session_dialog_hint 0
|
|
}
|
|
|
|
# parse message TLVs given the possible TLV names and sizes
|
|
# default values are supplied in defaultvals, parsed values are returned
|
|
proc parseMessage { data len flags tlvnamesl tlvsizesl defaultvalsl } {
|
|
global showAPI
|
|
set prmsg $showAPI
|
|
|
|
array set tlvnames $tlvnamesl
|
|
array set tlvsizes $tlvsizesl
|
|
array set vals $defaultvalsl ;# this array is returned
|
|
|
|
set current 0
|
|
|
|
while { $current < $len } {
|
|
set typelength [parseTLVHeader $data current]
|
|
set type [lindex $typelength 0]
|
|
set length [lindex $typelength 1]
|
|
if { $length == 0 || $length == "" } { break }
|
|
set pad [pad_32bit $length]
|
|
|
|
if {![info exists tlvnames($type)] } { ;# unknown TLV type
|
|
if { $prmsg } { puts -nonewline "unknown=$type," }
|
|
incr current $length
|
|
continue
|
|
}
|
|
set tlvname $tlvnames($type)
|
|
set size $tlvsizes($tlvname)
|
|
# 32-bit and 64-bit vals pre-padded
|
|
if { $size == 4 || $size == 8 } { incr current $pad }
|
|
# read TLV data depending on size
|
|
switch -exact -- "$size" {
|
|
2 { binary scan $data @${current}S vals($tlvname) }
|
|
4 { binary scan $data @${current}I vals($tlvname) }
|
|
8 { binary scan $data @${current}W vals($tlvname) }
|
|
16 { binary scan $data @${current}c16 vals($tlvname) }
|
|
-1 { binary scan $data @${current}a${length} vals($tlvname) }
|
|
}
|
|
if { $size == -1 } { incr current $pad } ;# string vals post-padded
|
|
if { $type == 6 } { incr current $pad } ;# 128-bit vals post-padded
|
|
incr current $length
|
|
|
|
if { $prmsg } { puts -nonewline "$tlvname=$vals($tlvname)," }
|
|
}
|
|
return [array get vals]
|
|
}
|
|
|
|
proc parseExceptionMessage { data len flags channel } {
|
|
global showAPI
|
|
set prmsg $showAPI
|
|
|
|
array set typenames { 1 num 2 sess 3 level 4 src 5 date 6 txt 10 opaque }
|
|
array set typesizes { num 4 sess -1 level 2 src -1 date -1 txt -1 \
|
|
opaque -1 }
|
|
array set defvals { num -1 sess "" level -1 src "" date "" txt "" opaque ""}
|
|
|
|
if { $prmsg==1 } { puts -nonewline "EXCEPTION(flags=$flags," }
|
|
array set vals [parseMessage $data $len $flags [array get typenames] \
|
|
[array get typesizes] [array get defvals]]
|
|
if { $prmsg == 1 } { puts ") "}
|
|
|
|
if { $vals(level) == $defvals(level) } {
|
|
puts "Exception Message received without an exception level."; return;
|
|
}
|
|
|
|
receiveException [array get vals]
|
|
}
|
|
|
|
proc sendNodePosMessage { channel node nodeid x y wlanid force } {
|
|
global showAPI
|
|
set prmsg $showAPI
|
|
|
|
if { $channel == -1 } {
|
|
set channel [lindex [getEmulPlugin $node] 2]
|
|
if { $channel == -1 } { return }
|
|
}
|
|
set node_num [string range $node 1 end]
|
|
set x [format "%u" [expr int($x)]]
|
|
set y [format "%u" [expr int($y)]]
|
|
set len [expr 8+4+4] ;# node number, x, y
|
|
if {$nodeid > -1} { incr len 8 }
|
|
if {$wlanid > -1} { incr len 8 }
|
|
if {$force == 1 } { set crit 0x4 } else { set crit 0x0 }
|
|
#puts "sending [expr $len+4] bytes: $nodeid $x $y $wlanid"
|
|
if { $prmsg == 1 } {
|
|
puts -nonewline ">NODE(flags=$crit,$node,x=$x,y=$y" }
|
|
set msg [binary format ccSc2sIc2Sc2S \
|
|
1 $crit $len \
|
|
{1 4} 0 $node_num \
|
|
{0x20 2} $x \
|
|
{0x21 2} $y
|
|
]
|
|
|
|
set msg2 ""
|
|
set msg3 ""
|
|
if { $nodeid > -1 } {
|
|
if { $prmsg == 1 } { puts -nonewline ",emuid=$nodeid" }
|
|
set msg2 [binary format c2sI {0x23 4} 0 $nodeid]
|
|
}
|
|
if { $wlanid > -1 } {
|
|
if { $prmsg == 1 } { puts -nonewline ",netid=$wlanid" }
|
|
set msg3 [binary format c2sI {0x24 4} 0 $wlanid]
|
|
}
|
|
|
|
if { $prmsg == 1 } { puts ")" }
|
|
puts -nonewline $channel $msg$msg2$msg3
|
|
flushChannel channel "Error sending node position"
|
|
}
|
|
|
|
# build a new node
|
|
proc sendNodeAddMessage { channel node } {
|
|
global showAPI CORE_DATA_DIR
|
|
set prmsg $showAPI
|
|
set len [expr {8+8+4+4}]; # node number, type, x, y
|
|
set ipv4 0
|
|
set ipv6 0
|
|
set macstr ""
|
|
set wireless 0
|
|
|
|
# type, name
|
|
set type [getNodeTypeAPI $node]
|
|
set model [getNodeModel $node]
|
|
set model_len [string length $model]
|
|
set model_pad_len [pad_32bit $model_len]
|
|
set model_pad [binary format x$model_pad_len]
|
|
set name [getNodeName $node]
|
|
set name_len [string length $name]
|
|
set name_pad_len [pad_32bit $name_len]
|
|
set name_pad [binary format x$name_pad_len]
|
|
incr len [expr { 2+$name_len+$name_pad_len}]
|
|
if {$model_len > 0} { incr len [expr {2+$model_len+$model_pad_len }] }
|
|
set node_num [string range $node 1 end]
|
|
|
|
# fixup node type for EMANE-enabled WLAN nodes
|
|
set opaque ""
|
|
if { [isEmane $node] } { set type 0xA }
|
|
|
|
# emulation server (node location)
|
|
set emusrv [getNodeLocation $node]
|
|
set emusrv_len [string length $emusrv]
|
|
set emusrv_pad_len [pad_32bit $emusrv_len]
|
|
set emusrv_pad [binary format x$emusrv_pad_len]
|
|
if { $emusrv_len > 0 } { incr len [expr {2+$emusrv_len+$emusrv_pad_len } ] }
|
|
|
|
# canvas
|
|
set canv [getNodeCanvas $node]
|
|
if { $canv != "c1" } {
|
|
set canv [string range $canv 1 end] ;# convert "c2" to "2"
|
|
incr len 4
|
|
} else {
|
|
set canv ""
|
|
}
|
|
|
|
# services
|
|
set svc [getNodeServices $node false]
|
|
set svc [join $svc "|"]
|
|
set svc_len [string length $svc]
|
|
set svc_pad_len [pad_32bit $svc_len]
|
|
set svc_pad [binary format x$svc_pad_len]
|
|
if { $svc_len > 0 } { incr len [expr {2+$svc_len+$svc_pad_len } ] }
|
|
|
|
# icon
|
|
set icon [getCustomImage $node]
|
|
if { [file dirname $icon] == "$CORE_DATA_DIR/icons/normal" } {
|
|
set icon [file tail $icon] ;# don't include standard icon path
|
|
}
|
|
set icon_len [string length $icon]
|
|
set icon_pad_len [pad_32bit $icon_len]
|
|
set icon_pad [binary format x$icon_pad_len]
|
|
if { $icon_len > 0 } { incr len [expr {2+$icon_len+$icon_pad_len} ] }
|
|
|
|
# opaque data
|
|
set opaque_len [string length $opaque]
|
|
set opaque_pad_len [pad_32bit $opaque_len]
|
|
set opaque_pad [binary format x$opaque_pad_len]
|
|
if { $opaque_len > 0 } { incr len [expr {2+$opaque_len+$opaque_pad_len} ] }
|
|
|
|
# length must be calculated before this
|
|
if { $prmsg == 1 } {
|
|
puts -nonewline ">NODE(flags=add/str,$node,type=$type,$name,"
|
|
}
|
|
set msg [binary format c2Sc2sIc2sIcc \
|
|
{0x1 0x11} $len \
|
|
{0x1 4} 0 $node_num \
|
|
{0x2 4} 0 $type \
|
|
0x3 $name_len ]
|
|
puts -nonewline $channel $msg$name$name_pad
|
|
|
|
# IPv4 address
|
|
if { $ipv4 > 0 } {
|
|
if { $prmsg == 1 } { puts -nonewline "$ipv4str," }
|
|
set msg [binary format c2sI {0x4 4} 0 $ipv4]
|
|
puts -nonewline $channel $msg
|
|
}
|
|
|
|
# MAC address
|
|
if { $macstr != "" } {
|
|
if { $prmsg == 1 } { puts -nonewline "$macstr," }
|
|
set mac [join [split $macstr ":"] ""]
|
|
puts -nonewline $channel [binary format c2x2W {0x5 8} 0x$mac]
|
|
}
|
|
|
|
# IPv6 address
|
|
if { $ipv6 != 0 } {
|
|
if { $prmsg == 1 } { puts -nonewline "$ipv6str," }
|
|
set msg [binary format c2 {0x6 16} ]
|
|
puts -nonewline $channel $msg
|
|
foreach ipv6w [split $ipv6 ":"] {
|
|
set msg [binary format S 0x$ipv6w]
|
|
puts -nonewline $channel $msg
|
|
}
|
|
puts -nonewline $channel [binary format x2]; # 2 bytes padding
|
|
}
|
|
|
|
# model type
|
|
if { $model_len > 0 } {
|
|
set mh [binary format cc 0x7 $model_len]
|
|
puts -nonewline $channel $mh$model$model_pad
|
|
if { $prmsg == 1 } { puts -nonewline "m=$model," }
|
|
}
|
|
|
|
# emulation server
|
|
if { $emusrv_len > 0 } {
|
|
puts -nonewline $channel [binary format cc 0x8 $emusrv_len]
|
|
puts -nonewline $channel $emusrv$emusrv_pad
|
|
if { $prmsg == 1 } { puts -nonewline "srv=$emusrv," }
|
|
}
|
|
|
|
# X,Y coordinates
|
|
set coords [getNodeCoords $node]
|
|
set x [format "%u" [expr int([lindex $coords 0])]]
|
|
set y [format "%u" [expr int([lindex $coords 1])]]
|
|
set msg [binary format c2Sc2S {0x20 2} $x {0x21 2} $y]
|
|
puts -nonewline $channel $msg
|
|
|
|
# canvas
|
|
if { $canv != "" } {
|
|
if { $prmsg == 1 } { puts -nonewline "canvas=$canv," }
|
|
set msg [binary format c2S {0x22 2} $canv]
|
|
puts -nonewline $channel $msg
|
|
}
|
|
|
|
if { $prmsg == 1 } { puts -nonewline "x=$x,y=$y" }
|
|
|
|
# services
|
|
if { $svc_len > 0 } {
|
|
puts -nonewline $channel [binary format cc 0x25 $svc_len]
|
|
puts -nonewline $channel $svc$svc_pad
|
|
if { $prmsg == 1 } { puts -nonewline ",svc=$svc" }
|
|
}
|
|
|
|
# icon
|
|
if { $icon_len > 0 } {
|
|
puts -nonewline $channel [binary format cc 0x42 $icon_len]
|
|
puts -nonewline $channel $icon$icon_pad
|
|
if { $prmsg == 1 } { puts -nonewline ",icon=$icon" }
|
|
}
|
|
|
|
# opaque data
|
|
if { $opaque_len > 0 } {
|
|
puts -nonewline $channel [binary format cc 0x50 $opaque_len]
|
|
puts -nonewline $channel $opaque$opaque_pad
|
|
if { $prmsg == 1 } { puts -nonewline ",opaque=$opaque" }
|
|
}
|
|
|
|
if { $prmsg == 1 } { puts ")" }
|
|
|
|
flushChannel channel "Error sending node add"
|
|
}
|
|
|
|
# delete a node
|
|
proc sendNodeDelMessage { channel node } {
|
|
global showAPI
|
|
set prmsg $showAPI
|
|
set len 8; # node number
|
|
set node_num [string range $node 1 end]
|
|
|
|
if { $prmsg == 1 } { puts ">NODE(flags=del/str,$node_num)" }
|
|
set msg [binary format c2Sc2sI \
|
|
{0x1 0x12} $len \
|
|
{0x1 4} 0 $node_num ]
|
|
puts -nonewline $channel $msg
|
|
flushChannel channel "Error sending node delete"
|
|
}
|
|
|
|
# send a message to build, modify, or delete a link
|
|
# type should indicate add/delete/link/unlink
|
|
proc sendLinkMessage { channel link type {sendboth true} } {
|
|
global showAPI
|
|
set prmsg $showAPI
|
|
|
|
set node1 [lindex [linkPeers $link] 0]
|
|
set node2 [lindex [linkPeers $link] 1]
|
|
set if1 [ifcByPeer $node1 $node2]; set if2 [ifcByPeer $node2 $node1]
|
|
if { [nodeType $node1] == "pseudo" } { return } ;# never seems to occur
|
|
if { [nodeType $node2] == "pseudo" } {
|
|
set mirror2 [getLinkMirror $node2]
|
|
set node2 [getNodeName $node2]
|
|
if { [string range $node1 1 end] > [string range $node2 1 end] } {
|
|
return ;# only send one link message (for two pseudo-links)
|
|
}
|
|
set if2 [ifcByPeer $node2 $mirror2]
|
|
}
|
|
set node1_num [string range $node1 1 end]
|
|
set node2_num [string range $node2 1 end]
|
|
|
|
# flag for sending unidirectional link messages
|
|
set uni 0
|
|
if { $sendboth && [isLinkUni $link] } {
|
|
set uni 1
|
|
}
|
|
|
|
# set flags and link message type from supplied type parameter
|
|
set flags 0
|
|
set ltype 1 ;# add/delete a link (not wireless link/unlink)
|
|
set netid -1
|
|
if { $type == "add" || $type == "link" } {
|
|
set flags 1
|
|
} elseif { $type == "delete" || $type == "unlink" } {
|
|
set flags 2
|
|
}
|
|
if { $type == "link" || $type == "unlink" } {
|
|
set ltype 0 ;# a wireless link/unlink event
|
|
set tmp [getLinkOpaque $link net]
|
|
if { $tmp != "" } { set netid [string range $tmp 1 end] }
|
|
}
|
|
|
|
set key ""
|
|
if { [nodeType $node1] == "tunnel" } {
|
|
set key [netconfFetchSection $node1 "tunnel-key"]
|
|
if { $key == "" } { set key 1 }
|
|
}
|
|
if {[nodeType $node2] == "tunnel" } {
|
|
set key [netconfFetchSection $node2 "tunnel-key"]
|
|
if { $key == "" } { set key 1 }
|
|
}
|
|
|
|
if { $prmsg == 1 } {
|
|
puts -nonewline ">LINK(flags=$flags,$node1_num-$node2_num,"
|
|
}
|
|
|
|
# len = node1num, node2num, type
|
|
set len [expr {8+8+8}]
|
|
set delay [getLinkDelay $link]
|
|
if { $delay == "" } { set delay 0 }
|
|
set jitter [getLinkJitter $link]
|
|
if { $jitter == "" } { set jitter 0 }
|
|
set bw [getLinkBandwidth $link]
|
|
if { $bw == "" } { set bw 0 }
|
|
set per [getLinkBER $link]; # PER and BER
|
|
if { $per == "" } { set per 0 }
|
|
set per_len 0
|
|
set per_msg [buildStringTLV 0x5 $per per_len]
|
|
set dup [getLinkDup $link]
|
|
if { $dup == "" } { set dup 0 }
|
|
set dup_len 0
|
|
set dup_msg [buildStringTLV 0x6 $dup dup_len]
|
|
if { $type != "delete" } {
|
|
incr len [expr {12+12+$per_len+$dup_len+12}] ;# delay,bw,per,dup,jitter
|
|
if {$prmsg==1 } {
|
|
puts -nonewline "$delay,$bw,$per,$dup,$jitter,"
|
|
}
|
|
}
|
|
# TODO: mer, burst, mburst
|
|
if { $prmsg == 1 } { puts -nonewline "type=$ltype," }
|
|
if { $uni } {
|
|
incr len 4
|
|
if { $prmsg == 1 } { puts -nonewline "uni=$uni," }
|
|
}
|
|
if { $netid > -1 } {
|
|
incr len 8
|
|
if { $prmsg == 1 } { puts -nonewline "netid=$netid," }
|
|
}
|
|
if { $key != "" } {
|
|
incr len 8
|
|
if { $prmsg == 1 } { puts -nonewline "key=$key," }
|
|
}
|
|
|
|
set if1num [ifcNameToNum $if1]; set if2num [ifcNameToNum $if2]
|
|
set if1ipv4 0; set if2ipv4 0; set if1ipv6 ""; set if2ipv6 "";
|
|
set if1ipv4mask 0; set if2ipv4mask 0;
|
|
set if1ipv6mask ""; set if2ipv6mask ""; set if1mac ""; set if2mac "";
|
|
|
|
if { $if1num >= 0 && ([[typemodel $node1].layer] == "NETWORK" || \
|
|
[nodeType $node1] == "tunnel") } {
|
|
incr len 4
|
|
if { $prmsg == 1 } { puts -nonewline "if1n=$if1num," }
|
|
if { $type != "delete" } {
|
|
getIfcAddrs $node1 $if1 if1ipv4 if1ipv6 if1mac if1ipv4mask \
|
|
if1ipv6mask len
|
|
}
|
|
}
|
|
if { $if2num >= 0 && ([[typemodel $node2].layer] == "NETWORK" || \
|
|
[nodeType $node2] == "tunnel") } {
|
|
incr len 4
|
|
if { $prmsg == 1 } { puts -nonewline "if2n=$if2num," }
|
|
if { $type != "delete" } {
|
|
getIfcAddrs $node2 $if2 if2ipv4 if2ipv6 if2mac if2ipv4mask \
|
|
if2ipv6mask len
|
|
}
|
|
}
|
|
|
|
# start building the binary message on channel
|
|
# length must be calculated before this
|
|
set msg [binary format ccSc2sIc2sI \
|
|
{0x2} $flags $len \
|
|
{0x1 4} 0 $node1_num \
|
|
{0x2 4} 0 $node2_num ]
|
|
puts -nonewline $channel $msg
|
|
|
|
if { $type != "delete" } {
|
|
puts -nonewline $channel [binary format c2sW {0x3 8} 0 $delay]
|
|
puts -nonewline $channel [binary format c2sW {0x4 8} 0 $bw]
|
|
puts -nonewline $channel $per_msg
|
|
puts -nonewline $channel $dup_msg
|
|
puts -nonewline $channel [binary format c2sW {0x7 8} 0 $jitter]
|
|
}
|
|
# TODO: mer, burst, mburst
|
|
|
|
# link type
|
|
puts -nonewline $channel [binary format c2sI {0x20 4} 0 $ltype]
|
|
|
|
# unidirectional flag
|
|
if { $uni } {
|
|
puts -nonewline $channel [binary format c2S {0x22 2} $uni]
|
|
}
|
|
|
|
# network ID
|
|
if { $netid > -1 } {
|
|
puts -nonewline $channel [binary format c2sI {0x24 4} 0 $netid]
|
|
}
|
|
|
|
if { $key != "" } {
|
|
puts -nonewline $channel [binary format c2sI {0x25 4} 0 $key]
|
|
}
|
|
|
|
# interface 1 info
|
|
if { $if1num >= 0 && ([[typemodel $node1].layer] == "NETWORK" || \
|
|
[nodeType $node1] == "tunnel") } {
|
|
puts -nonewline $channel [ binary format c2S {0x30 2} $if1num ]
|
|
}
|
|
if { $if1ipv4 > 0 } { puts -nonewline $channel [binary format c2sIc2S \
|
|
{0x31 4} 0 $if1ipv4 {0x32 2} $if1ipv4mask ] }
|
|
if { $if1mac != "" } {
|
|
set if1mac [join [split $if1mac ":"] ""]
|
|
puts -nonewline $channel [binary format c2x2W {0x33 8} 0x$if1mac]
|
|
}
|
|
if {$if1ipv6 != ""} { puts -nonewline $channel [binary format c2 {0x34 16}]
|
|
foreach ipv6w [split $if1ipv6 ":"] { puts -nonewline $channel \
|
|
[binary format S 0x$ipv6w] }
|
|
puts -nonewline $channel [binary format x2c2S {0x35 2} $if1ipv6mask] }
|
|
|
|
# interface 2 info
|
|
if { $if2num >= 0 && ([[typemodel $node2].layer] == "NETWORK" || \
|
|
[nodeType $node2] == "tunnel") } {
|
|
puts -nonewline $channel [ binary format c2S {0x36 2} $if2num ]
|
|
}
|
|
if { $if2ipv4 > 0 } { puts -nonewline $channel [binary format c2sIc2S \
|
|
{0x37 4} 0 $if2ipv4 {0x38 2} $if2ipv4mask ] }
|
|
if { $if2mac != "" } {
|
|
set if2mac [join [split $if2mac ":"] ""]
|
|
puts -nonewline $channel [binary format c2x2W {0x39 8} 0x$if2mac]
|
|
}
|
|
if {$if2ipv6 != ""} { puts -nonewline $channel [binary format c2 {0x40 16}]
|
|
foreach ipv6w [split $if2ipv6 ":"] { puts -nonewline $channel \
|
|
[binary format S 0x$ipv6w] }
|
|
puts -nonewline $channel [binary format x2c2S {0x41 2} $if2ipv6mask] }
|
|
|
|
if { $prmsg==1 } { puts ")" }
|
|
flushChannel channel "Error sending link message"
|
|
|
|
##########################################################
|
|
# send a second Link Message for unidirectional link effects
|
|
if { $uni < 1 } {
|
|
return
|
|
}
|
|
# first calculate length and possibly print the message
|
|
set flags 0
|
|
if { $prmsg == 1 } {
|
|
puts -nonewline ">LINK(flags=$flags,$node2_num-$node1_num,"
|
|
}
|
|
set len [expr {8+8+8}] ;# len = node2num, node1num (swapped), type
|
|
set delay [getLinkDelay $link up]
|
|
if { $delay == "" } { set delay 0 }
|
|
set jitter [getLinkJitter $link up]
|
|
if { $jitter == "" } { set jitter 0 }
|
|
set bw [getLinkBandwidth $link up]
|
|
if { $bw == "" } { set bw 0 }
|
|
set per [getLinkBER $link up]; # PER and BER
|
|
if { $per == "" } { set per 0 }
|
|
set per_len 0
|
|
set per_msg [buildStringTLV 0x5 $per per_len]
|
|
set dup [getLinkDup $link up]
|
|
if { $dup == "" } { set dup 0 }
|
|
set dup_len 0
|
|
set dup_msg [buildStringTLV 0x6 $dup dup_len]
|
|
incr len [expr {12+12+$per_len+$dup_len+12}] ;# delay,bw,per,dup,jitter
|
|
if {$prmsg==1 } {
|
|
puts -nonewline "$delay,$bw,$per,$dup,$jitter,"
|
|
}
|
|
if { $prmsg == 1 } { puts -nonewline "type=$ltype," }
|
|
incr len 4 ;# unidirectional flag
|
|
if { $prmsg == 1 } { puts -nonewline "uni=$uni," }
|
|
# note that if1num / if2num are reversed here due to reversed node nums
|
|
if { $if2num >= 0 && ([[typemodel $node2].layer] == "NETWORK" || \
|
|
[nodeType $node2] == "tunnel") } {
|
|
incr len 4
|
|
if { $prmsg == 1 } { puts -nonewline "if1n=$if2num," }
|
|
}
|
|
if { $if1num >= 0 && ([[typemodel $node1].layer] == "NETWORK" || \
|
|
[nodeType $node1] == "tunnel") } {
|
|
incr len 4
|
|
if { $prmsg == 1 } { puts -nonewline "if2n=$if1num," }
|
|
}
|
|
# build and send the link message
|
|
set msg [binary format ccSc2sIc2sI \
|
|
{0x2} $flags $len \
|
|
{0x1 4} 0 $node2_num \
|
|
{0x2 4} 0 $node1_num ]
|
|
puts -nonewline $channel $msg
|
|
puts -nonewline $channel [binary format c2sW {0x3 8} 0 $delay]
|
|
puts -nonewline $channel [binary format c2sW {0x4 8} 0 $bw]
|
|
puts -nonewline $channel $per_msg
|
|
puts -nonewline $channel $dup_msg
|
|
puts -nonewline $channel [binary format c2sW {0x7 8} 0 $jitter]
|
|
puts -nonewline $channel [binary format c2sI {0x20 4} 0 $ltype]
|
|
puts -nonewline $channel [binary format c2S {0x22 2} $uni]
|
|
if { $if2num >= 0 && ([[typemodel $node2].layer] == "NETWORK" || \
|
|
[nodeType $node2] == "tunnel") } {
|
|
puts -nonewline $channel [ binary format c2S {0x30 2} $if2num ]
|
|
}
|
|
if { $if1num >= 0 && ([[typemodel $node1].layer] == "NETWORK" || \
|
|
[nodeType $node1] == "tunnel") } {
|
|
puts -nonewline $channel [ binary format c2S {0x36 2} $if1num ]
|
|
}
|
|
if { $prmsg==1 } { puts ")" }
|
|
flushChannel channel "Error sending link message"
|
|
}
|
|
|
|
# helper to get IPv4, IPv6, MAC address and increment length
|
|
# also prints TLV-style addresses if showAPI is true
|
|
proc getIfcAddrs { node ifc ipv4p ipv6p macp ipv4maskp ipv6maskp lenp } {
|
|
global showAPI
|
|
upvar $ipv4p ipv4
|
|
upvar $ipv6p ipv6
|
|
upvar $macp mac
|
|
upvar $ipv4maskp ipv4mask
|
|
upvar $ipv6maskp ipv6mask
|
|
upvar $lenp len
|
|
|
|
if { $ifc == "" || $node == "" } { return }
|
|
|
|
# IPv4 address
|
|
set ipv4str [getIfcIPv4addr $node $ifc]
|
|
if {$ipv4str != ""} {
|
|
set ipv4 [lindex [split $ipv4str /] 0]
|
|
if { [info exists ipv4mask ] } {
|
|
set ipv4mask [lindex [split $ipv4str / ] 1]
|
|
incr len 12; # 8 addr + 4 mask
|
|
if { $showAPI == 1 } { puts -nonewline "$ipv4str," }
|
|
} else {
|
|
incr len 8; # 8 addr
|
|
if { $showAPI == 1 } { puts -nonewline "$ipv4," }
|
|
}
|
|
set ipv4 [stringToIPv4 $ipv4]; # convert to integer
|
|
}
|
|
|
|
# IPv6 address
|
|
set ipv6str [getIfcIPv6addr $node $ifc]
|
|
if {$ipv6str != ""} {
|
|
set ipv6 [lindex [split $ipv6str /] 0]
|
|
if { [info exists ipv6mask ] } {
|
|
set ipv6mask [lindex [split $ipv6str / ] 1]
|
|
incr len 24; # 20 addr + 4 mask
|
|
if { $showAPI == 1 } { puts -nonewline "$ipv6str," }
|
|
} else {
|
|
incr len 20; # 20 addr
|
|
if { $showAPI == 1 } { puts -nonewline "$ipv6," }
|
|
}
|
|
set ipv6 [expandIPv6 $ipv6]; # convert to long string
|
|
}
|
|
|
|
# MAC address (from conf if there, otherwise generated)
|
|
if { [info exists mac] } {
|
|
set mac [lindex [getIfcMacaddr $node $ifc] 0]
|
|
if {$mac == ""} {
|
|
set mac [getNextMac]
|
|
}
|
|
if { $showAPI == 1 } { puts -nonewline "$mac," }
|
|
incr len 12;
|
|
}
|
|
}
|
|
|
|
#
|
|
# Register Message: (registration types)
|
|
# This is a simple Register Message, types is an array of
|
|
# <module TLV, string> tuples.
|
|
proc sendRegMessage { channel flags types_list } {
|
|
global showAPI regtypes
|
|
set prmsg $showAPI
|
|
|
|
if { $channel == -1 || $channel == "" } {
|
|
set plugin [lindex [getEmulPlugin "*"] 0]
|
|
set channel [pluginConnect $plugin connect true]
|
|
if { $channel == -1 } { return }
|
|
}
|
|
set len 0
|
|
array set types $types_list
|
|
|
|
# array names output is unreliable, sort it
|
|
set type_list [lsort -dict [array names types]]
|
|
foreach type $type_list {
|
|
if { ![info exists regtypes($type)] } {
|
|
puts "sendRegMessage: unknown registration type '$type'"
|
|
return -1
|
|
}
|
|
set str_$type $types($type)
|
|
set str_${type}_len [string length [set str_$type]]
|
|
set str_${type}_pad_len [pad_32bit [set str_${type}_len]]
|
|
set str_${type}_pad [binary format x[set str_${type}_pad_len]]
|
|
incr len [expr { 2 + [set str_${type}_len] + [set str_${type}_pad_len]}]
|
|
}
|
|
|
|
if { $prmsg == 1 } { puts ">REG($type_list)" }
|
|
# message header
|
|
set msg1 [binary format ccS 4 $flags $len]
|
|
puts -nonewline $channel $msg1
|
|
|
|
foreach type $type_list {
|
|
set type_num $regtypes($type)
|
|
set tlvh [binary format cc $type_num [set str_${type}_len]]
|
|
puts -nonewline $channel $tlvh[set str_${type}][set str_${type}_pad]
|
|
}
|
|
|
|
flushChannel channel "Error: API channel was closed"
|
|
}
|
|
|
|
#
|
|
# Configuration Message: (object, type flags, node)
|
|
# This is a simple Configuration Message containing flags
|
|
proc sendConfRequestMessage { channel node model flags netid opaque } {
|
|
global showAPI
|
|
set prmsg $showAPI
|
|
|
|
if { $channel == -1 || $channel == "" } {
|
|
set pname [lindex [getEmulPlugin $node] 0]
|
|
set channel [pluginConnect $pname connect true]
|
|
if { $channel == -1 } { return }
|
|
}
|
|
|
|
set model_len [string length $model]
|
|
set model_pad_len [pad_32bit $model_len]
|
|
set model_pad [binary format x$model_pad_len ]
|
|
set len [expr {4+2+$model_len+$model_pad_len}]
|
|
# optional network ID to provide Netgraph mapping
|
|
if { $netid != -1 } { incr len 8 }
|
|
# convert from node name to number
|
|
if { [string is alpha [string range $node 0 0]] } {
|
|
set node [string range $node 1 end]
|
|
}
|
|
|
|
if { $node > 0 } { incr len 8 }
|
|
# add a session number when configuring services
|
|
set session ""
|
|
set session_len 0
|
|
set session_pad_len 0
|
|
set session_pad ""
|
|
if { $node <= 0 && $model == "services" } {
|
|
global g_current_session
|
|
set session [format "0x%x" $g_current_session]
|
|
set session_len [string length $session]
|
|
set session_pad_len [pad_32bit $session_len]
|
|
set session_pad [binary format x$session_pad_len]
|
|
incr len [expr {2 + $session_len + $session_pad_len}]
|
|
}
|
|
# opaque data - used when custom configuring services
|
|
set opaque_len 0
|
|
set msgop [buildStringTLV 0x50 $opaque opaque_len]
|
|
if { $opaque_len > 0 } { incr len $opaque_len }
|
|
|
|
if { $prmsg == 1 } {
|
|
puts -nonewline ">CONF(flags=0,"
|
|
if { $node > 0 } { puts -nonewline "node=$node," }
|
|
puts -nonewline "obj=$model,cflags=$flags"
|
|
if { $session != "" } { puts -nonewline ",session=$session" }
|
|
if { $netid > -1 } { puts -nonewline ",netid=$netid" }
|
|
if { $opaque_len > 0 } { puts -nonewline ",opaque=$opaque" }
|
|
puts ") request"
|
|
}
|
|
# header, node node number, node model header
|
|
set msg1 [binary format c2S {5 0} $len ]
|
|
set msg1b ""
|
|
if { $node > 0 } { set msg1b [binary format c2sI {1 4} 0 $node] }
|
|
set msg1c [binary format cc 2 $model_len]
|
|
# request flag
|
|
set msg2 [binary format c2S {3 2} $flags ]
|
|
# session number
|
|
set msg3 ""
|
|
if { $session != "" } {
|
|
set msg3 [binary format cc 0x0A $session_len]
|
|
set msg3 $msg3$session$session_pad
|
|
}
|
|
# network ID
|
|
set msg4 ""
|
|
if { $netid != -1 } {
|
|
set msg4 [binary format c2sI {0x23 4} 0 0x$netid ]
|
|
}
|
|
|
|
#catch {puts -nonewline $channel $msg1$model$model_pad$msg2$msg3$msg4$msg5}
|
|
puts -nonewline $channel $msg1$msg1b$msg1c$model$model_pad$msg2$msg3$msg4
|
|
if { $opaque_len > 0 } { puts -nonewline $channel $msgop }
|
|
|
|
flushChannel channel "Error: API channel was closed"
|
|
}
|
|
|
|
#
|
|
# Configuration Message: (object, type flags, node, types, values)
|
|
# This message is more complicated to build because of the list of
|
|
# data types and values.
|
|
proc sendConfReplyMessage { channel node model types values opaque } {
|
|
global showAPI
|
|
set prmsg $showAPI
|
|
# convert from node name to number
|
|
if { [string is alpha [string range $node 0 0]] } {
|
|
set node [string range $node 1 end]
|
|
}
|
|
# add a session number when configuring services
|
|
set session ""
|
|
set session_len 0
|
|
set session_pad_len 0
|
|
set session_pad ""
|
|
if { $node <= 0 && $model == "services" && $opaque == "" } {
|
|
global g_current_session
|
|
set session [format "0x%x" $g_current_session]
|
|
set session_len [string length $session]
|
|
set session_pad_len [pad_32bit $session_len]
|
|
set session_pad [binary format x$session_pad_len]
|
|
incr len [expr {$session_len + $session_pad_len}]
|
|
}
|
|
|
|
if { $prmsg == 1 } {
|
|
puts -nonewline ">CONF(flags=0,"
|
|
if {$node > -1 } { puts -nonewline "node=$node," }
|
|
puts -nonewline "obj=$model,cflags=0"
|
|
if {$session != "" } { puts -nonewline "session=$session," }
|
|
if {$opaque != "" } { puts -nonewline "opaque=$opaque," }
|
|
puts "types=<$types>,values=<$values>) reply"
|
|
}
|
|
|
|
# types (16-bit values) and values
|
|
set n 0
|
|
set type_len [expr {[llength $types] * 2} ]
|
|
set type_data [binary format cc 4 $type_len]
|
|
set value_data ""
|
|
foreach type $types {
|
|
set t [binary format S $type]
|
|
set type_data $type_data$t
|
|
set val [lindex $values $n]
|
|
if { $val == "" } {
|
|
#puts "warning: empty value $n (type=$type)"
|
|
if { $type != 10 } { set val 0 }
|
|
}
|
|
incr n
|
|
lappend value_data $val
|
|
}; # end foreach
|
|
set value_len 0
|
|
set value_data [join $value_data |]
|
|
set msgval [buildStringTLV 0x5 $value_data value_len]
|
|
set type_pad_len [pad_32bit $type_len]
|
|
set type_pad [binary format x$type_pad_len ]
|
|
set model_len [string length $model]
|
|
set model_pad_len [pad_32bit $model_len]
|
|
set model_pad [binary format x$model_pad_len ]
|
|
# opaque data - used when custom configuring services
|
|
set opaque_len 0
|
|
set msgop [buildStringTLV 0x50 $opaque opaque_len]
|
|
|
|
# 4 bytes header, model TLV
|
|
set len [expr 4+2+$model_len+$model_pad_len]
|
|
if { $node > -1 } { incr len 8 }
|
|
# session number
|
|
set msg3 ""
|
|
if { $session != "" } {
|
|
incr len [expr {2 + $session_len + $session_pad_len }]
|
|
set msg3 [binary format cc 0x0A $session_len]
|
|
set msg3 $msg3$session$session_pad
|
|
}
|
|
if { $opaque_len > 0 } { incr len $opaque_len }
|
|
# types TLV, values TLV
|
|
incr len [expr {2 + $type_len + $type_pad_len + $value_len}]
|
|
|
|
# header, node node number, node model header
|
|
set msgh [binary format c2S {5 0} $len ]
|
|
set msgwl ""
|
|
if { $node > -1 } { set msgwl [binary format c2sI {1 4} 0 $node] }
|
|
set model_hdr [binary format cc 2 $model_len]
|
|
# no flags
|
|
set type_hdr [binary format c2S {3 2} 0 ]
|
|
set msg $msgh$msgwl$model_hdr$model$model_pad$type_hdr$type_data$type_pad
|
|
set msg $msg$msgval$msg3
|
|
puts -nonewline $channel $msg
|
|
if { $opaque_len > 0 } { puts -nonewline $channel $msgop }
|
|
flushChannel channel "Error sending conf reply"
|
|
}
|
|
|
|
# Event Message
|
|
proc sendEventMessage { channel type nodenum name data flags } {
|
|
global showAPI eventtypes
|
|
set prmsg $showAPI
|
|
|
|
set len [expr 8] ;# event type
|
|
if {$nodenum > -1} { incr len 8 }
|
|
set name_len [string length $name]
|
|
set name_pad_len [pad_32bit $name_len]
|
|
if { $name_len > 0 } { incr len [expr {2 + $name_len + $name_pad_len}] }
|
|
set data_len [string length $data]
|
|
set data_pad_len [pad_32bit $data_len]
|
|
if { $data_len > 0 } { incr len [expr {2 + $data_len + $data_pad_len}] }
|
|
|
|
if { $prmsg == 1 } {
|
|
puts -nonewline ">EVENT(flags=$flags," }
|
|
set msg [binary format ccS 8 $flags $len ] ;# message header
|
|
|
|
set msg2 ""
|
|
if { $nodenum > -1 } {
|
|
if { $prmsg == 1 } { puts -nonewline "node=$nodenum," }
|
|
set msg2 [binary format c2sI {0x01 4} 0 $nodenum]
|
|
}
|
|
if { $prmsg == 1} {
|
|
set typestr ""
|
|
foreach t [array names eventtypes] {
|
|
if { $eventtypes($t) == $type } { set typestr "-$t"; break }
|
|
}
|
|
puts -nonewline "type=$type$typestr,"
|
|
}
|
|
set msg3 [binary format c2sI {0x02 4} 0 $type]
|
|
set msg4 ""
|
|
set msg5 ""
|
|
if { $name_len > 0 } {
|
|
if { $prmsg == 1 } { puts -nonewline "name=$name," }
|
|
set msg4 [binary format cc 0x03 $name_len ]
|
|
set name_pad [binary format x$name_pad_len ]
|
|
set msg5 $name$name_pad
|
|
}
|
|
set msg6 ""
|
|
set msg7 ""
|
|
if { $data_len > 0 } {
|
|
if { $prmsg == 1 } { puts -nonewline "data=$data" }
|
|
set msg6 [binary format cc 0x04 $data_len ]
|
|
set data_pad [binary format x$data_pad_len ]
|
|
set msg7 $data$data_pad
|
|
}
|
|
|
|
if { $prmsg == 1 } { puts ")" }
|
|
puts -nonewline $channel $msg$msg2$msg3$msg4$msg5$msg6$msg7
|
|
flushChannel channel "Error sending Event type=$type"
|
|
}
|
|
|
|
|
|
# deploy working configuration using CORE API
|
|
# Deploys a current working configuration. It creates all the
|
|
# nodes and link as defined in configuration file.
|
|
proc deployCfgAPI { sock } {
|
|
global eid
|
|
global node_list link_list annotation_list canvas_list
|
|
global mac_byte4 mac_byte5
|
|
global execMode
|
|
global ngnodemap
|
|
global mac_addr_start
|
|
global deployCfgAPI_lock
|
|
global eventtypes
|
|
global g_comments
|
|
|
|
if { ![info exists deployCfgAPI_lock] } { set deployCfgAPI_lock 0 }
|
|
if { $deployCfgAPI_lock } {
|
|
puts "***error: deployCfgAPI called while deploying config"
|
|
return
|
|
}
|
|
|
|
set deployCfgAPI_lock 1 ;# lock
|
|
|
|
set mac_byte4 0
|
|
set mac_byte5 0
|
|
if { [info exists mac_addr_start] } { set mac_byte5 $mac_addr_start }
|
|
set t_start [clock seconds]
|
|
|
|
global systype
|
|
set systype [lindex [checkOS] 0]
|
|
statgraph on [expr (2*[llength $node_list]) + [llength $link_list]]
|
|
|
|
|
|
sendSessionProperties $sock
|
|
|
|
# this tells the CORE services that we are starting to send
|
|
# configuration data
|
|
# clear any existing config
|
|
sendEventMessage $sock $eventtypes(definition_state) -1 "" "" 0
|
|
# inform CORE services about emulation servers, hook scripts, canvas info,
|
|
# and services
|
|
sendEventMessage $sock $eventtypes(configuration_state) -1 "" "" 0
|
|
sendEmulationServerInfo $sock 0
|
|
sendSessionOptions $sock
|
|
sendHooks $sock
|
|
sendCanvasInfo $sock
|
|
sendNodeTypeInfo $sock 0
|
|
# send any custom service info before the node messages
|
|
sendNodeCustomServices $sock
|
|
|
|
# send Node add messages for all emulation nodes
|
|
foreach node $node_list {
|
|
set node_id "$eid\_$node"
|
|
set type [nodeType $node]
|
|
set name [getNodeName $node]
|
|
if { $type == "pseudo" } { continue }
|
|
|
|
statgraph inc 1
|
|
statline "Creating node $name"
|
|
if { [[typemodel $node].layer] == "NETWORK" } {
|
|
nodeHighlights .c $node on red
|
|
}
|
|
# inform the CORE daemon of the node
|
|
sendNodeAddMessage $sock $node
|
|
pluginCapsInitialize $node "mobmodel"
|
|
writeNodeCoords $node [getNodeCoords $node]
|
|
}
|
|
|
|
# send Link add messages for all network links
|
|
for { set pending_links $link_list } { $pending_links != "" } {} {
|
|
set link [lindex $pending_links 0]
|
|
set i [lsearch -exact $pending_links $link]
|
|
set pending_links [lreplace $pending_links $i $i]
|
|
statgraph inc 1
|
|
|
|
set lnode1 [lindex [linkPeers $link] 0]
|
|
set lnode2 [lindex [linkPeers $link] 1]
|
|
if { [nodeType $lnode2] == "router" && \
|
|
[getNodeModel $lnode2] == "remote" } {
|
|
continue; # remote routers are ctrl. by GUI; TODO: move to daemon
|
|
}
|
|
sendLinkMessage $sock $link add
|
|
}
|
|
|
|
# GUI-specific meta-data send via Configure Messages
|
|
if { [llength $annotation_list] > 0 } {
|
|
sendMetaData $sock $annotation_list "annotation"
|
|
}
|
|
sendMetaData $sock $canvas_list "canvas" ;# assume >= 1 canvas
|
|
# global GUI options - send as meta-data
|
|
set obj "metadata"
|
|
set values [getGlobalOptionList]
|
|
sendConfReplyMessage $sock -1 $obj "10" "{global_options=$values}" ""
|
|
if { [info exists g_comments] && $g_comments != "" } {
|
|
sendConfReplyMessage $sock -1 $obj "10" "{comments=$g_comments}" ""
|
|
}
|
|
|
|
# status bar graph
|
|
statgraph off 0
|
|
statline "Network topology instantiated in [expr [clock seconds] - $t_start] seconds ([llength $node_list] nodes and [llength $link_list] links)."
|
|
|
|
# TODO: turn on tcpdump if enabled; customPostConfigCommands;
|
|
# addons 4 deployCfgHook
|
|
|
|
# draw lines between wlan nodes
|
|
# initialization does not work earlier than this
|
|
|
|
foreach node $node_list {
|
|
# WLAN handling: draw lines between wireless nodes
|
|
if { [nodeType $node] == "wlan" && $execMode == "interactive" } {
|
|
wlanRunMobilityScript $node
|
|
}
|
|
}
|
|
|
|
sendTrafficScripts $sock
|
|
|
|
# tell the CORE services that we are ready to instantiate
|
|
sendEventMessage $sock $eventtypes(instantiation_state) -1 "" "" 0
|
|
|
|
set deployCfgAPI_lock 0 ;# unlock
|
|
|
|
statline "Network topology instantiated in [expr [clock seconds] - $t_start] seconds ([llength $node_list] nodes and [llength $link_list] links)."
|
|
}
|
|
|
|
#
|
|
# emulation shutdown procedure when using the CORE API
|
|
proc shutdownSession {} {
|
|
global link_list node_list eid eventtypes execMode
|
|
|
|
set nodecount [getNodeCount]
|
|
if { $nodecount == 0 } {
|
|
# This allows switching to edit mode without extra API messages,
|
|
# such as when file new is selected while running an existing session.
|
|
return
|
|
}
|
|
|
|
# prepare the channel
|
|
set plugin [lindex [getEmulPlugin "*"] 0]
|
|
set sock [pluginConnect $plugin connect true]
|
|
|
|
sendEventMessage $sock $eventtypes(datacollect_state) -1 "" "" 0
|
|
|
|
# shut down all links
|
|
foreach link $link_list {
|
|
|
|
set lnode2 [lindex [linkPeers $link] 1]
|
|
if { [nodeType $lnode2] == "router" && \
|
|
[getNodeModel $lnode2] == "remote" } {
|
|
continue; # remote routers are ctrl. by GUI; TODO: move to daemon
|
|
}
|
|
|
|
sendLinkMessage $sock $link delete false
|
|
}
|
|
# shut down all nodes
|
|
foreach node $node_list {
|
|
set type [nodeType $node]
|
|
if { [[typemodel $node].layer] == "NETWORK" && $execMode != "batch" } {
|
|
nodeHighlights .c $node on red
|
|
}
|
|
sendNodeDelMessage $sock $node
|
|
pluginCapsDeinitialize $node "mobmodel"
|
|
deleteNodeCoords $node
|
|
}
|
|
|
|
sendNodeTypeInfo $sock 1
|
|
sendEmulationServerInfo $sock 1
|
|
}
|
|
|
|
# inform the CORE services about the canvas information to support
|
|
# conversion between X,Y and lat/long coordinates
|
|
proc sendCanvasInfo { sock } {
|
|
global curcanvas
|
|
|
|
if { ![info exists curcanvas] } { return } ;# batch mode
|
|
set obj "location"
|
|
|
|
set scale [getCanvasScale $curcanvas]
|
|
set refpt [getCanvasRefPoint $curcanvas]
|
|
set refx [lindex $refpt 0]
|
|
set refy [lindex $refpt 1]
|
|
set latitude [lindex $refpt 2]
|
|
set longitude [lindex $refpt 3]
|
|
set altitude [lindex $refpt 4]
|
|
|
|
set types [list 2 2 10 10 10 10]
|
|
set values [list $refx $refy $latitude $longitude $altitude $scale]
|
|
|
|
sendConfReplyMessage $sock -1 $obj $types $values ""
|
|
}
|
|
|
|
# inform the CORE services about the default services for a node type, which
|
|
# are used when node-specific services have not been configured for a node
|
|
proc sendNodeTypeInfo { sock reset } {
|
|
global node_list
|
|
|
|
set obj "services"
|
|
|
|
if { $reset == 1} {
|
|
sendConfRequestMessage $sock -1 "all" 0x3 -1 ""
|
|
return
|
|
}
|
|
# build a list of node types in use
|
|
set typesinuse ""
|
|
foreach node $node_list {
|
|
set type [nodeType $node]
|
|
if { $type != "router" && $type != "OVS" } { continue }
|
|
set model [getNodeModel $node]
|
|
if { [lsearch $typesinuse $model] < 0 } { lappend typesinuse $model }
|
|
}
|
|
|
|
foreach type $typesinuse {
|
|
# build a list of type + enabled services, all strings
|
|
set values [getNodeTypeServices $type]
|
|
set values [linsert $values 0 $type]
|
|
set types [string repeat "10 " [llength $values]]
|
|
sendConfReplyMessage $sock -1 $obj $types $values ""
|
|
# send any custom profiles for a node type; node type passed in opaque
|
|
set machine_type [getNodeTypeMachineType $type]
|
|
set values [getNodeTypeProfile $type]
|
|
if { $values != "" } {
|
|
set types [string repeat "10 " [llength $values]]
|
|
sendConfReplyMessage $sock -1 $machine_type $types $values \
|
|
"$machine_type:$type"
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
# inform the CORE services about any services that have been customized for
|
|
# a particular node
|
|
proc sendNodeCustomServices { sock } {
|
|
global node_list
|
|
foreach node $node_list {
|
|
set cfgs [getCustomConfig $node]
|
|
set cfgfiles ""
|
|
foreach cfg $cfgs {
|
|
set ids [split [getConfig $cfg "custom-config-id"] :]
|
|
if { [lindex $ids 0] != "service" } { continue }
|
|
if { [llength $ids] == 3 } {
|
|
# customized service config file -- build a list
|
|
lappend cfgfiles $cfg
|
|
continue
|
|
}
|
|
set s [lindex $ids 1]
|
|
set values [getConfig $cfg "config"]
|
|
set t [string repeat "10 " [llength $values]]
|
|
sendConfReplyMessage $sock $node services $t $values "service:$s"
|
|
}
|
|
# send customized service config files after the service info
|
|
foreach cfg $cfgfiles {
|
|
set idstr [getConfig $cfg "custom-config-id"]
|
|
set ids [split $idstr :]
|
|
if { [lindex $ids 0] != "service" } { continue }
|
|
set s [lindex $ids 1]
|
|
set filename [lindex $ids 2]
|
|
set data [join [getConfig $cfg "config"] "\n"]
|
|
sendFileMessage $sock $node "service:$s" $filename "" $data \
|
|
[string length $data]
|
|
}
|
|
}
|
|
}
|
|
|
|
# publish hooks to the CORE services
|
|
proc sendHooks { sock } {
|
|
global g_hook_scripts
|
|
if { ![info exists g_hook_scripts] } { return }
|
|
foreach hook $g_hook_scripts {
|
|
set name [lindex $hook 0]
|
|
set state [lindex $hook 1]
|
|
set data [lindex $hook 2]
|
|
# TODO: modify sendFileMessage to make node number optional
|
|
sendFileMessage $sock n0 "hook:$state" $name "" $data \
|
|
[string length $data]
|
|
}
|
|
}
|
|
|
|
# inform the CORE services about the emulation servers that will be used
|
|
proc sendEmulationServerInfo { sock reset } {
|
|
global exec_servers
|
|
set node -1 ;# not used
|
|
set obj "broker"
|
|
|
|
set servernames [getAssignedRemoteServers]
|
|
if { $servernames == "" } { return } ;# not using emulation servers
|
|
|
|
if { $reset == 1} {
|
|
sendConfRequestMessage $sock $node $obj 0x3 -1 ""
|
|
return
|
|
}
|
|
|
|
set servers ""
|
|
foreach servername $servernames {
|
|
set host [lindex $exec_servers($servername) 0]
|
|
set port [lindex $exec_servers($servername) 1]
|
|
lappend servers "$servername:$host:$port"
|
|
}
|
|
|
|
set serversstring [join $servers ,]
|
|
|
|
set types [list 10]
|
|
set values [list $serversstring]
|
|
|
|
sendConfReplyMessage $sock $node $obj $types $values ""
|
|
}
|
|
|
|
# returns the length of node_list minus any pseudo-nodes (inter-canvas nodes)
|
|
proc getNodeCount {} {
|
|
global node_list
|
|
set nodecount 0
|
|
foreach node $node_list {
|
|
if { [nodeType $node] != "pseudo" } { incr nodecount }
|
|
}
|
|
return $nodecount
|
|
}
|
|
|
|
# send basic properties of a session
|
|
proc sendSessionProperties { sock } {
|
|
global currentFile CORE_DATA_DIR CORE_USER
|
|
set sessionname [file tail $currentFile]
|
|
set nodecount [getNodeCount]
|
|
if { $sessionname == "" } { set sessionname "untitled" }
|
|
set tf "/tmp/thumb.jpg"
|
|
if { ![writeCanvasThumbnail .c $tf] } {
|
|
set src "$CORE_DATA_DIR/icons/normal/thumb-unknown.gif"
|
|
set tf "/tmp/thumb.gif"
|
|
if [catch { file copy $src $tf } e] {
|
|
puts -nonewline "warning: failed to copy $src to $tf\n($e)"
|
|
set tf ""
|
|
}
|
|
}
|
|
set user $CORE_USER
|
|
sendSessionMessage $sock 0 0 $sessionname $currentFile $nodecount $tf $user
|
|
}
|
|
|
|
# send session options from global array in Config Message
|
|
proc sendSessionOptions { sock } {
|
|
if { $sock == -1 } {
|
|
set sock [lindex [getEmulPlugin "*"] 2]
|
|
}
|
|
set values [getSessionOptionsList]
|
|
set types [string repeat "10 " [llength $values]]
|
|
sendConfReplyMessage $sock -1 "session" $types $values ""
|
|
}
|
|
|
|
# send annotations as key=value metadata in Config Message
|
|
proc sendAnnotations { sock } {
|
|
global annotation_list
|
|
|
|
if { $sock == -1 } {
|
|
set sock [lindex [getEmulPlugin "*"] 2]
|
|
}
|
|
set values ""
|
|
foreach a $annotation_list {
|
|
global $a
|
|
set val [set $a]
|
|
lappend values "annotation $a=$val"
|
|
}
|
|
set types [string repeat "10 " [llength $values]]
|
|
sendConfReplyMessage $sock -1 "metadata" $types $values ""
|
|
}
|
|
|
|
# send items as key=value metadata in Config Message
|
|
proc sendMetaData { sock items itemtype } {
|
|
|
|
if { $sock == -1 } {
|
|
set sock [lindex [getEmulPlugin "*"] 2]
|
|
}
|
|
set values ""
|
|
foreach i $items {
|
|
global $i
|
|
set val [set $i]
|
|
lappend values "$itemtype $i=$val"
|
|
}
|
|
set types [string repeat "10 " [llength $values]]
|
|
sendConfReplyMessage $sock -1 "metadata" $types $values ""
|
|
}
|
|
|
|
# send an Event message for the definition state (this clears any existing
|
|
# state), then send all node and link definitions to the CORE services
|
|
proc sendNodeLinkDefinitions { sock } {
|
|
global node_list link_list annotation_list canvas_list eventtypes
|
|
global g_comments
|
|
#sendEventMessage $sock $eventtypes(definition_state) -1 "" "" 0
|
|
foreach node $node_list {
|
|
sendNodeAddMessage $sock $node
|
|
pluginCapsInitialize $node "mobmodel"
|
|
}
|
|
foreach link $link_list { sendLinkMessage $sock $link add }
|
|
# GUI-specific meta-data send via Configure Messages
|
|
sendMetaData $sock $annotation_list "annotation"
|
|
sendMetaData $sock $canvas_list "canvas"
|
|
set obj "metadata"
|
|
set values [getGlobalOptionList]
|
|
sendConfReplyMessage $sock -1 $obj "10" "{global_options=$values}" ""
|
|
if { [info exists g_comments] && $g_comments != "" } {
|
|
sendConfReplyMessage $sock -1 $obj "10" "{comments=$g_comments}" ""
|
|
}
|
|
}
|
|
|
|
proc getNodeTypeAPI { node } {
|
|
set type [nodeType $node]
|
|
if { $type == "router" } {
|
|
set model [getNodeModel $node]
|
|
set type [getNodeTypeMachineType $model]
|
|
}
|
|
switch -exact -- "$type" {
|
|
router { return 0x0 }
|
|
netns { return 0x0 }
|
|
jail { return 0x0 }
|
|
OVS { return 0x0 }
|
|
physical { return 0x1 }
|
|
xen { return 0x2 }
|
|
tbd { return 0x3 }
|
|
lanswitch { return 0x4 }
|
|
hub { return 0x5 }
|
|
wlan { return 0x6 }
|
|
rj45 { return 0x7 }
|
|
tunnel { return 0x8 }
|
|
ktunnel { return 0x9 }
|
|
emane { return 0xA }
|
|
default { return 0x0 }
|
|
}
|
|
}
|
|
|
|
# send an Execute message
|
|
proc sendExecMessage { channel node cmd exec_num flags } {
|
|
global showAPI g_api_exec_num
|
|
set prmsg $showAPI
|
|
|
|
set node_num [string range $node 1 end]
|
|
set cmd_len [string length $cmd]
|
|
if { $cmd_len > 255 } { puts "sendExecMessage error: cmd too long!"; return}
|
|
set cmd_pad_len [pad_32bit $cmd_len]
|
|
set cmd_pad [binary format x$cmd_pad_len]
|
|
|
|
if { $exec_num == 0 } {
|
|
incr g_api_exec_num
|
|
set exec_num $g_api_exec_num
|
|
}
|
|
|
|
# node num + exec num + command string
|
|
set len [expr {8 + 8 + 2 + $cmd_len + $cmd_pad_len}]
|
|
|
|
if { $prmsg == 1 } {puts ">EXEC(flags=$flags,$node,n=$exec_num,cmd='$cmd')" }
|
|
|
|
set msg [binary format ccSc2sIc2sIcc \
|
|
3 $flags $len \
|
|
{1 4} 0 $node_num \
|
|
{2 4} 0 $exec_num \
|
|
4 $cmd_len \
|
|
]
|
|
puts -nonewline $channel $msg$cmd$cmd_pad
|
|
flushChannel channel "Error sending file message"
|
|
}
|
|
|
|
# if source file (sf) is specified, then send a message that the file source
|
|
# file should be copied to the given file name (f); otherwise, include the file
|
|
# data in this message
|
|
proc sendFileMessage { channel node type f sf data data_len } {
|
|
global showAPI
|
|
set prmsg $showAPI
|
|
|
|
set node_num [string range $node 1 end]
|
|
|
|
set f_len [string length $f]
|
|
set f_pad_len [pad_32bit $f_len]
|
|
set f_pad [binary format x$f_pad_len]
|
|
set type_len [string length $type]
|
|
set type_pad_len [pad_32bit $type_len]
|
|
set type_pad [binary format x$type_pad_len]
|
|
if { $sf != "" } {
|
|
set sf_len [string length $sf]
|
|
set sf_pad_len [pad_32bit $sf_len]
|
|
set sf_pad [binary format x$sf_pad_len]
|
|
set data_len 0
|
|
set data_pad_len 0
|
|
} else {
|
|
set sf_len 0
|
|
set sf_pad_len 0
|
|
set data_pad_len [pad_32bit $data_len]
|
|
set data_pad [binary format x$data_pad_len]
|
|
}
|
|
# TODO: gzip compression w/tlv type 0x11
|
|
|
|
# node number TLV + file name TLV + ( file src name / data TLV)
|
|
set len [expr {8 + 2 + 2 + $f_len + $f_pad_len + $sf_len + $sf_pad_len \
|
|
+ $data_len + $data_pad_len}]
|
|
# 16-bit data length
|
|
if { $data_len > 255 } {
|
|
incr len 2
|
|
if { $data_len > 65536 } {
|
|
puts -nonewline "*** error: File Message data length too large "
|
|
puts "($data_len > 65536)"
|
|
return
|
|
}
|
|
}
|
|
if { $type_len > 0 } { incr len [expr {2 + $type_len + $type_pad_len}] }
|
|
set flags 1; # add flag
|
|
|
|
if { $prmsg == 1 } {
|
|
puts -nonewline ">FILE(flags=$flags,$node,f=$f,"
|
|
if { $type != "" } { puts -nonewline "type=$type," }
|
|
if { $sf != "" } { puts "src=$sf)"
|
|
} else { puts "data=($data_len))" }
|
|
}
|
|
|
|
set msg [binary format ccSc2sIcc \
|
|
6 $flags $len \
|
|
{1 4} 0 $node_num \
|
|
2 $f_len \
|
|
]
|
|
set msg2 ""
|
|
if { $type_len > 0 } {
|
|
set msg2 [binary format cc 0x5 $type_len]
|
|
set msg2 $msg2$type$type_pad
|
|
}
|
|
if { $sf != "" } { ;# source file name TLV
|
|
set msg3 [binary format cc 0x6 $sf_len]
|
|
puts -nonewline $channel $msg$f$f_pad$msg2$msg3$sf$sf_pad
|
|
} else { ;# file data TLV
|
|
if { $data_len > 255 } {
|
|
set msg3 [binary format ccS 0x10 0 $data_len]
|
|
} else {
|
|
set msg3 [binary format cc 0x10 $data_len]
|
|
}
|
|
puts -nonewline $channel $msg$f$f_pad$msg2$msg3$data$data_pad
|
|
}
|
|
flushChannel channel "Error sending file message"
|
|
}
|
|
|
|
# Session Message
|
|
proc sendSessionMessage { channel flags num name sfile nodecount tf user } {
|
|
global showAPI
|
|
set prmsg $showAPI
|
|
|
|
if { $channel == -1 } {
|
|
set pname [lindex [getEmulPlugin "*"] 0]
|
|
set channel [pluginConnect $pname connect true]
|
|
if { $channel == -1 } { return }
|
|
}
|
|
|
|
set num_len [string length $num]
|
|
set num_pad_len [pad_32bit $num_len]
|
|
set len [expr {2 + $num_len + $num_pad_len}]
|
|
if { $num_len <= 0 } {
|
|
puts "error: sendSessionMessage requires at least one session number"
|
|
return
|
|
}
|
|
set name_len [string length $name]
|
|
set name_pad_len [pad_32bit $name_len]
|
|
if { $name_len > 0 } { incr len [expr { 2 + $name_len + $name_pad_len }] }
|
|
set sfile_len [string length $sfile]
|
|
set sfile_pad_len [pad_32bit $sfile_len]
|
|
if { $sfile_len > 0 } {
|
|
incr len [expr { 2 + $sfile_len + $sfile_pad_len }]
|
|
}
|
|
set nc_len [string length $nodecount]
|
|
set nc_pad_len [pad_32bit $nc_len]
|
|
if { $nc_len > 0 } { incr len [expr { 2 + $nc_len + $nc_pad_len }] }
|
|
set tf_len [string length $tf]
|
|
set tf_pad_len [pad_32bit $tf_len]
|
|
if { $tf_len > 0 } { incr len [expr { 2 + $tf_len + $tf_pad_len }] }
|
|
set user_len [string length $user]
|
|
set user_pad_len [pad_32bit $user_len]
|
|
if { $user_len > 0 } { incr len [expr { 2 + $user_len + $user_pad_len }] }
|
|
|
|
if { $prmsg == 1 } {
|
|
puts -nonewline ">SESSION(flags=$flags" }
|
|
set msgh [binary format ccS 0x09 $flags $len ] ;# message header
|
|
|
|
if { $prmsg == 1 } { puts -nonewline ",sids=$num" }
|
|
set num_hdr [binary format cc 0x01 $num_len]
|
|
set num_pad [binary format x$num_pad_len ]
|
|
set msg1 "$num_hdr$num$num_pad"
|
|
|
|
set msg2 ""
|
|
if { $name_len > 0 } {
|
|
if { $prmsg == 1 } { puts -nonewline ",name=$name" }
|
|
# TODO: name_len > 255
|
|
set name_hdr [binary format cc 0x02 $name_len]
|
|
set name_pad [binary format x$name_pad_len]
|
|
set msg2 "$name_hdr$name$name_pad"
|
|
}
|
|
set msg3 ""
|
|
if { $sfile_len > 0 } {
|
|
if { $prmsg == 1 } { puts -nonewline ",file=$sfile" }
|
|
# TODO: sfile_len > 255
|
|
set sfile_hdr [binary format cc 0x03 $sfile_len]
|
|
set sfile_pad [binary format x$sfile_pad_len]
|
|
set msg3 "$sfile_hdr$sfile$sfile_pad"
|
|
}
|
|
set msg4 ""
|
|
if { $nc_len > 0 } {
|
|
if { $prmsg == 1 } { puts -nonewline ",nc=$nodecount" }
|
|
set nc_hdr [binary format cc 0x04 $nc_len]
|
|
set nc_pad [binary format x$nc_pad_len]
|
|
set msg4 "$nc_hdr$nodecount$nc_pad"
|
|
}
|
|
set msg5 ""
|
|
if { $tf_len > 0 } {
|
|
if { $prmsg == 1 } { puts -nonewline ",thumb=$tf" }
|
|
set tf_hdr [binary format cc 0x06 $tf_len]
|
|
set tf_pad [binary format x$tf_pad_len]
|
|
set msg5 "$tf_hdr$tf$tf_pad"
|
|
}
|
|
set msg6 ""
|
|
if { $user_len > 0 } {
|
|
if { $prmsg == 1 } { puts -nonewline ",user=$user" }
|
|
set user_hdr [binary format cc 0x07 $user_len]
|
|
set user_pad [binary format x$user_pad_len]
|
|
set msg6 "$user_hdr$user$user_pad"
|
|
}
|
|
|
|
if { $prmsg == 1 } { puts ")" }
|
|
puts -nonewline $channel $msgh$msg1$msg2$msg3$msg4$msg5$msg6
|
|
flushChannel channel "Error sending Session num=$num"
|
|
}
|
|
|
|
# return a new execution number and record it in the execution request list
|
|
# for the given callback (e.g. widget) type
|
|
proc newExecCallbackRequest { type } {
|
|
global g_api_exec_num g_execRequests
|
|
incr g_api_exec_num
|
|
set exec_num $g_api_exec_num
|
|
lappend g_execRequests($type) $exec_num
|
|
return $exec_num
|
|
}
|
|
|
|
# ask daemon to load or save an XML file based on the current session
|
|
proc xmlFileLoadSave { cmd name } {
|
|
global oper_mode eventtypes
|
|
|
|
set plugin [lindex [getEmulPlugin "*"] 0]
|
|
set sock [pluginConnect $plugin connect true]
|
|
if { $sock == -1 || $sock == "" } { return }
|
|
|
|
# inform daemon about nodes and links when saving in edit mode
|
|
if { $cmd == "save" && $oper_mode != "exec" } {
|
|
sendSessionProperties $sock
|
|
# this tells the CORE services that we are starting to send
|
|
# configuration data
|
|
# clear any existing config
|
|
sendEventMessage $sock $eventtypes(definition_state) -1 "" "" 0
|
|
sendEventMessage $sock $eventtypes(configuration_state) -1 "" "" 0
|
|
sendEmulationServerInfo $sock 0
|
|
sendSessionOptions $sock
|
|
sendHooks $sock
|
|
sendCanvasInfo $sock
|
|
sendNodeTypeInfo $sock 0
|
|
# send any custom service info before the node messages
|
|
sendNodeCustomServices $sock
|
|
sendNodeLinkDefinitions $sock
|
|
} elseif { $cmd == "open" } {
|
|
# reset config objects
|
|
sendNodeTypeInfo $sock 1
|
|
}
|
|
sendEventMessage $sock $eventtypes(file_$cmd) -1 $name "" 0
|
|
}
|
|
|
|
############################################################################
|
|
#
|
|
# Helper functions below here
|
|
#
|
|
|
|
# helper function to get interface number from name
|
|
proc ifcNameToNum { ifc } {
|
|
# eth0, eth1, etc.
|
|
if {[string range $ifc 0 2] == "eth"} {
|
|
set ifnum [string range $ifc 3 end]
|
|
# l0, l1, etc.
|
|
} else {
|
|
set ifnum [string range $ifc 1 end]
|
|
}
|
|
if { $ifnum == "" } {
|
|
return -1
|
|
}
|
|
if {![string is integer $ifnum]} {
|
|
return -1
|
|
}
|
|
return $ifnum
|
|
}
|
|
|
|
#
|
|
# parse the type and length from a TLV header
|
|
proc parseTLVHeader { data current_ref } {
|
|
global showAPI
|
|
set prmsg $showAPI
|
|
upvar $current_ref current
|
|
|
|
if { [binary scan $data @${current}cc type length] != 2 } {
|
|
if { $prmsg == 1 } { puts "TLV header error" }
|
|
return ""
|
|
}
|
|
set length [expr {$length & 0xFF}]; # convert signed to unsigned
|
|
if { $length == 0 } {
|
|
if { $type == 0 } {
|
|
# prevent endless looping
|
|
if { $prmsg == 1 } { puts -nonewline "(extra padding)" }
|
|
return ""
|
|
} else {
|
|
# support for length > 255
|
|
incr current 2
|
|
if { [binary scan $data @${current}S length] != 1 } {
|
|
puts "error reading TLV length (type=$type)"
|
|
return ""
|
|
}
|
|
set length [expr {$length & 0xFFFF}]
|
|
if { $length == 0 } {
|
|
# zero-length string, not length > 255
|
|
incr current -2
|
|
}
|
|
}
|
|
}
|
|
incr current 2
|
|
return [list $type $length]
|
|
}
|
|
|
|
# return the binary string, and length by reference
|
|
proc buildStringTLV { type data len_ref } {
|
|
upvar $len_ref len
|
|
set data_len [string length $data]
|
|
if { $data_len > 65536 } {
|
|
puts "warning: buildStringTLV data truncated"
|
|
set data_len 65536
|
|
set data [string range 0 65535]
|
|
}
|
|
set data_pad_len [pad_32bit $data_len]
|
|
set data_pad [binary format x$data_pad_len]
|
|
|
|
if { $data_len == 0 } {
|
|
set len 0
|
|
return ""
|
|
}
|
|
|
|
if { $data_len > 255 } {
|
|
set hdr [binary format ccS $type 0 $data_len]
|
|
set hdr_len 4
|
|
} else {
|
|
set hdr [binary format cc $type $data_len]
|
|
set hdr_len 2
|
|
}
|
|
|
|
set len [expr {$hdr_len + $data_len + $data_pad_len}]
|
|
|
|
return $hdr$data$data_pad
|
|
}
|
|
|
|
# calculate padding to 32-bit word boundary
|
|
# 32-bit and 64-bit values are pre-padded, strings and 128-bit values are
|
|
# post-padded to word boundary, depending on type
|
|
proc pad_32bit { len } {
|
|
# total length = 2 + len + pad
|
|
if { $len < 256 } {
|
|
set hdrsiz 2
|
|
} else {
|
|
set hdrsiz 4
|
|
}
|
|
# calculate padding to fill 32-bit boundary
|
|
return [expr { -($hdrsiz + $len) % 4 }]
|
|
}
|
|
|
|
proc macToString { mac_num } {
|
|
set mac_bytes ""
|
|
# convert 64-bit integer into 12-digit hex string
|
|
set mac_num 0x[format "%.12lx" $mac_num]
|
|
while { $mac_num > 0 } {
|
|
# append 8-bit hex number to list
|
|
set uchar [format "%02x" [expr $mac_num & 0xFF]]
|
|
lappend mac_bytes $uchar
|
|
# shift off 8-bits
|
|
set mac_num [expr $mac_num >> 8]
|
|
}
|
|
|
|
# make sure we have six hex digits
|
|
set num_zeroes [expr 6 - [llength $mac_bytes]]
|
|
while { $num_zeroes > 0 } {
|
|
lappend mac_bytes 00
|
|
incr num_zeroes -1
|
|
}
|
|
|
|
# this is lreverse in tcl8.5 and later
|
|
set r {}
|
|
set i [llength $mac_bytes]
|
|
while { $i > 0 } { lappend r [lindex $mac_bytes [incr i -1]] }
|
|
|
|
return [join $r :]
|
|
}
|
|
|
|
proc hexdump { data } {
|
|
# read data as hex
|
|
binary scan $data H* hex
|
|
# split into pairs of hex digits
|
|
regsub -all -- {..} $hex {& } hex
|
|
return $hex
|
|
}
|