All new accounts created on Gitlab now require administrator approval. If you invite any collaborators, please let Flux staff know so they can approve the accounts.

tb_compat.tcl.in 18.8 KB
Newer Older
1
# -*- tcl -*-
Leigh B. Stoller's avatar
Leigh B. Stoller committed
2 3
#
# EMULAB-COPYRIGHT
4
# Copyright (c) 2000-2003 University of Utah and the Flux Group.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
5 6 7
# All rights reserved.
#

8 9 10
# This is the tb_compact.tcl that deals with all the TB specific commands.
# It should be loaded at the beginning of any ns script using the TB commands.

Leigh B. Stoller's avatar
Leigh B. Stoller committed
11 12 13 14 15 16 17 18 19 20 21 22 23
# We set up some helper stuff in a separate namespace to avoid any conflicts.
namespace eval TBCOMPAT {
    var_import ::GLOBALS::DB
    var_import ::GLOBALS::pid
    var_import ::GLOBALS::eid

    # This is regular expression that matches slightly more than valid
    # IP addresses.  The only thing it doesn't check is that IP 
    # addresses are in range (i.e. 0-255).
    variable IP {^([0-9]{1,3}\.){3,3}[0-9]{1,3}$}

    # This is an RE to match a floating point number.
    variable FLOAT {(^[0-9]+(\.[0-9]+)?$)|(^\.[0-9]+$)}
24 25 26 27 28 29 30

    # This is the default weight for a soft vtype.
    variable default_soft_vtype_weight 0.5

    # This is the default weight for a hard vtype.
    variable default_hard_vtype_weight 1.0

Leigh B. Stoller's avatar
Leigh B. Stoller committed
31 32 33 34 35 36 37 38 39
    # This is a general procedure that takes a node, an object (lan or link)
    # it is connected to, and an IP address, and sets the IP address
    # for the node on that object.  It checks both the validity of the
    # IP addresses and the fact that the node is actually a member of the
    # lan/link.
    proc set-ip {node obj ip} {
	variable IP
	set caller [lindex [info level -1] 0]
	if {[regexp $IP $ip] == 0} {
40
	    perror "$caller - $ip is not a valid IP address."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
41 42 43 44
	    return
	}
	set port [$node find_port $obj]
	if {$port == -1} {
45
	    perror "$caller - $node is not connected to $obj."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
46 47 48 49 50 51 52
	    return
	}
	$node ip $port $ip
    }

    # Let's set up a hwtypes table that contains all valid hardware types.
    variable hwtypes
53
    variable isremote
54
    variable isvirt
Leigh B. Stoller's avatar
Leigh B. Stoller committed
55
    variable issubnode
Leigh B. Stoller's avatar
Leigh B. Stoller committed
56

Shashi Guruprasad's avatar
Shashi Guruprasad committed
57 58 59
    # NSE hack: sim type is not in DB. Just adding it now
    set hwtypes(sim) 1
    set isremote(sim) 0
60
    set isvirt(sim) 0
Leigh B. Stoller's avatar
Leigh B. Stoller committed
61
    set issubnode(sim) 0
Shashi Guruprasad's avatar
Shashi Guruprasad committed
62

63 64 65 66 67
    # The permissions table. Entries in this table indicate who is allowed
    # to use nodes of a particular type. No entries means anyone can use it.
    #
    # We omit this check in anonymous mode.
    #
68
    variable nodetypeXpid_permissions
69
    
70 71 72 73
    # And a os table with valid OS Descriptor names. While we still call
    # them "osids", we are using the user level name not the internal,
    # globally unique name. We leave it to a later phase to deal with it.
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
74
    # We omit this check in anonymous mode.
75 76 77 78 79 80 81 82 83
    #
    variable osids

    # The default OSID for the node type. 
    variable default_osids

    # A mapping of event objects and types.
    variable objtypes
    variable eventtypes
84 85 86 87 88 89

    # Existing (reserved nodes).
    variable reserved_list
    variable reserved_type
    variable reserved_node
    set reserved_list {}
90 91
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
92 93
# IP addresses routines.  These all do some checks and convert into set-ip
# calls.
94
proc tb-set-ip {node ip} {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
95 96
    $node instvar portlist
    if {[llength $portlist] != 1} {
97
	perror "\[tb-set-ip] $node does not have a single connection."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
98 99 100
	return
    }
    ::TBCOMPAT::set-ip $node [lindex $portlist 0] $ip
101 102
}
proc tb-set-ip-interface {src dst ip} {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
103 104 105 106
    set sim [$src set sim]
    set reallink [$sim find_link $src $dst]
    if {$reallink == {}} {
	perror \
107
	    "\[tb-set-ip-interface] No connection between $src and $dst."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
108
	return
109
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
110
    ::TBCOMPAT::set-ip $src $reallink $ip
111 112
}
proc tb-set-ip-lan {src lan ip} {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
113
    if {[$lan info class] != "Lan"} {
114
	perror "\[tb-set-ip-lan] $lan is not a LAN."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
115 116 117
	return
    }
    ::TBCOMPAT::set-ip $src $lan $ip
118 119
}
proc tb-set-ip-link {src link ip} {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
120
    if {[$link info class] != "Link"} {
121
	perror "\[tb-set-ip-link] $link is not a link."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
122 123 124
	return
    }
    ::TBCOMPAT::set-ip $src $link $ip
125
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
126

127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
#
# Set the netmask. To make it easier to compute subnets later, do
# allow the user to alter the netmask beyond the bottom 3 octets.
# This restricts the user to a lan of 4095 nodes, but that seems okay
# for now. 
# 
proc tb-set-netmask {lanlink netmask} {
    var_import ::TBCOMPAT::IP
    
    if {[$lanlink info class] != "Link" && [$lanlink info class] != "Lan"} {
	perror "\[tb-set-netmask] $lanlink is not a link or a lan."
	return
    }
    if {[regexp $IP $netmask] == 0} {
	perror "\[tb-set-netmask] - $netmask is not a valid IP mask"
	return
    }
    set netmaskint [inet_atohl $netmask]
    if {[expr ($netmaskint & 0xFFFFF000)] != 0xFFFFF000} {
	perror "\[tb-set-netmask] - $netmask is too big"
	return
    }
    $lanlink set netmask $netmask
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
152
# Node state routines.
153
proc tb-set-hardware {node type args} {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
154
    var_import ::TBCOMPAT::hwtypes
155
    var_import ::TBCOMPAT::isremote
156
    var_import ::TBCOMPAT::isvirt
Leigh B. Stoller's avatar
Leigh B. Stoller committed
157
    var_import ::TBCOMPAT::issubnode
158 159 160
    var_import ::GLOBALS::vtypes
    if {(! [info exists hwtypes($type)]) &&
	(! [info exists vtypes($type)])} {
161
	perror "\[tb-set-hardware] Invalid hardware type $type."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
162 163
	return
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
164
    if {! ${GLOBALS::anonymous} && ! ${GLOBALS::passmode}} {
165 166
	var_import ::TBCOMPAT::nodetypeXpid_permissions
	var_import ::GLOBALS::pid
Leigh B. Stoller's avatar
Leigh B. Stoller committed
167
	set allowed 1
168 169
	
	if {[info exists nodetypeXpid_permissions($type)]} {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
170
	    set allowed 0
171 172 173 174 175 176 177 178 179 180 181
	    foreach allowedpid $nodetypeXpid_permissions($type) {
		if {$allowedpid == $pid} {
		    set allowed 1
		}
	    }
	}
	if {! $allowed} {
	    perror "\[tb-set-hardware] No permission to use type $type."
	    return
	}
    }
182 183 184 185
    set remote 0
    if {[info exists isremote($type)]} {
	set remote $isremote($type)
    }
186 187 188 189
    set isv 0
    if {[info exists isvirt($type)]} {
	set isv $isvirt($type)
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
190 191 192 193 194
    set issub 0
    if {[info exists isvirt($type)]} {
	set issub $issubnode($type)
    }
    $node set_hwtype $type $remote $isv $issub
195
}
196

197
proc tb-set-node-os {node os} {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
198
    if {! ${GLOBALS::anonymous} && ! ${GLOBALS::passmode}} {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
199 200
	var_import ::TBCOMPAT::osids
	if {! [info exists osids($os)]} {
201
	    perror "\[tb-set-node-os] Invalid osid $os."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
202 203 204 205 206 207 208 209 210 211
	    return
	}
    }
    $node set osid $os
}
proc tb-set-node-cmdline {node cmdline} {
    $node set cmdline $cmdline
}
proc tb-set-node-rpms {node args} {
    if {$args == {}} {
212
	perror "\[tb-set-node-rpms] No rpms given."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
213 214
	return
    }
215
    $node set rpms [join $args :]
216
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
217 218 219 220 221
proc tb-set-node-startup {node cmd} {
    $node set startup $cmd
}
proc tb-set-node-tarfiles {node args} {
    if {$args == {}} {
222
	perror "\[tb-set-node-tarfiles] tb-set-node-tarfiles <node> (<dir> <tar>)+"
Leigh B. Stoller's avatar
Leigh B. Stoller committed
223 224 225
	return
    }
    if {[expr [llength $args] % 2] != 0} {
226
	perror "\[tb-set-node-tarfiles] Arguments should be node and series of pairs."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
227 228
	return
    }
229 230 231 232 233 234
    set tarfiles {}
    while {$args != {}} {
	lappend tarfiles [join [lrange $args 0 1]]
	set args [lrange $args 2 end]
    }
    $node set tarfiles [join $tarfiles :]
Leigh B. Stoller's avatar
Leigh B. Stoller committed
235 236 237
}
proc tb-set-node-deltas {node args} {
    if {$args == {}} {
238
	perror "\[tb-set-node-deltas] No deltas given."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
239 240
	return
    }
241
    $node set deltas [join $args :]
Leigh B. Stoller's avatar
Leigh B. Stoller committed
242
}
243 244 245
proc tb-set-ip-routing {type} {
    var_import ::GLOBALS::default_ip_routing_type

246
    if {$type == {}} {
247
	perror "\[tb-set-ip-routing] No type given."
248 249 250
	return
    }
    if {($type != "none") &&
251 252
	($type != "ospf")} {
	perror "\[tb-set-ip-routing] Type is not one of none|ospf"
253 254
	return
    }
255
    set default_ip_routing_type $type
256
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
257 258 259 260 261 262

# Lan/Link state routines.

# This takes two possible formats:
# tb-set-link-loss <link> <loss>
# tb-set-link-loss <src> <dst> <loss>
263
proc tb-set-link-loss {srclink args} {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
264
    var_import ::TBCOMPAT::FLOAT
265 266
    if {[llength $args] == 2} {
	set dst [lindex $args 0]
Leigh B. Stoller's avatar
Leigh B. Stoller committed
267 268 269 270
	set lossrate [lindex $args 1]
	set sim [$srclink set sim]
	set reallink [$sim find_link $srclink $dst]
	if {$reallink == {}} {
271
	    perror "\[tb-set-link-loss] No link between $srclink and $dst."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
272
	    return
273 274
	}
    } else {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
275
	set reallink $srclink
276
	set lossrate [lindex $args 0]
Leigh B. Stoller's avatar
Leigh B. Stoller committed
277 278 279
    }
    if {([regexp $FLOAT $lossrate] == 0) ||
	($lossrate > 1.0)} {
280
	perror "\[tb-set-link-loss] $lossrate is not a valid loss rate."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
281
    }
282 283
    $reallink instvar loss
    $reallink instvar rloss
Leigh B. Stoller's avatar
Leigh B. Stoller committed
284 285 286
    set adjloss [expr 1-sqrt(1-$lossrate)]
    foreach pair [array names loss] {
	set loss($pair) $adjloss
287
	set rloss($pair) $adjloss
288
    }
289
}
290

Leigh B. Stoller's avatar
Leigh B. Stoller committed
291 292 293
proc tb-set-lan-loss {lan lossrate} {
    var_import ::TBCOMPAT::FLOAT
    if {[$lan info class] != "Lan"} {
294
	perror "\[tb-set-lan-loss] $lan is not a lan."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
295 296 297 298
	return
    }
    if {([regexp $FLOAT $lossrate] == 0) ||
	($lossrate > 1.0)} {
299
	perror "\[tb-set-lan-loss] $lossrate is not a valid loss rate."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
300 301
    }
    $lan instvar loss
302
    $lan instvar rloss
Leigh B. Stoller's avatar
Leigh B. Stoller committed
303 304 305
    set adjloss [expr 1-sqrt(1-$lossrate)]
    foreach pair [array names loss] {
	set loss($pair) $adjloss
306
	set rloss($pair) $adjloss
Leigh B. Stoller's avatar
Leigh B. Stoller committed
307
    }
Christopher Alfeld's avatar
Added:  
Christopher Alfeld committed
308
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
309 310 311

proc tb-set-node-lan-delay {node lan delay} {
    if {[$node info class] != "Node"} {
312
	perror "\[tb-set-node-lan-delay] $node is not a node."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
313 314 315
	return
    }
    if {[$lan info class] != "Lan"} {
316
	perror "\[tb-set-node-lan-delay] $lan is not a lan."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
317 318 319 320
	return
    }
    set port [$lan get_port $node]
    if {$port == {}} {
321
	perror "\[tb-set-node-lan-delay] $node is not in $lan."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
322 323 324
	return
    }
    $lan set delay([list $node $port]) [parse_delay $delay]
325
    $lan set rdelay([list $node $port]) [parse_delay $delay]
Christopher Alfeld's avatar
Added:  
Christopher Alfeld committed
326
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
327 328
proc tb-set-node-lan-bandwidth {node lan bw} {
    if {[$node info class] != "Node"} {
329
	perror "\[tb-set-node-lan-delay] $node is not a node."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
330 331 332
	return
    }
    if {[$lan info class] != "Lan"} {
333
	perror "\[tb-set-node-lan-delay] $lan is not a lan."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
334 335 336 337
	return
    }
    set port [$lan get_port $node]
    if {$port == {}} {
338
	perror "\[tb-set-node-lan-delay] $node is not in $lan."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
339 340 341
	return
    }
    $lan set bandwidth([list $node $port]) [parse_bw $bw]
342
    $lan set rbandwidth([list $node $port]) [parse_bw $bw]
343
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
344 345 346
proc tb-set-node-lan-loss {node lan loss} {
    var_import ::TBCOMPAT::FLOAT
    if {[$node info class] != "Node"} {
347
	perror "\[tb-set-node-lan-delay] $node is not a node."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
348 349 350
	return
    }
    if {[$lan info class] != "Lan"} {
351
	perror "\[tb-set-node-lan-delay] $lan is not a lan."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
352 353 354 355
	return
    }
    set port [$lan get_port $node]
    if {$port == {}} {
356
	perror "\[tb-set-node-lan-delay] $node is not in $lan."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
357 358 359 360
	return
    }
    if {([regexp $FLOAT $loss] == 0) ||
	($loss > 1.0)} {
361
	perror "\[tb-set-link-loss] $loss is not a valid loss rate."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
362 363
    }
    $lan set loss([list $node $port]) $loss
364
    $lan set rloss([list $node $port]) $loss
Christopher Alfeld's avatar
Added:  
Christopher Alfeld committed
365
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
366 367 368 369
proc tb-set-node-lan-params {node lan delay bw loss} {
    tb-set-node-lan-delay $node $lan $delay
    tb-set-node-lan-bandwidth $node $lan $bw
    tb-set-node-lan-loss $node $lan $loss
370
}
371 372 373 374 375 376 377 378 379 380 381

proc tb-set-node-failure-action {node type} {
    if {[$node info class] != "Node"} {
	perror "\[tb-set-node-failure-action] $node is not a node."
	return
    }
    if {[lsearch -exact {fatal nonfatal ignore} $type] == -1} {
	perror "\[tb-set-node-failure-action] type must be one of fatal|nonfatal|ignore."
	return
    }
    $node set failureaction $type
382 383 384 385
}

proc tb-fix-node {vnode pnode} {
    if {[$vnode info class] != "Node"} {
386
	perror "\[tb-fix-node] $vnode is not a node."
387 388
	return
    }
389
    $vnode set_fixed $pnode
390 391
}

392 393
proc tb-make-soft-vtype {name types} {
    var_import ::TBCOMPAT::hwtypes
394
    var_import ::TBCOMPAT::isremote
395 396 397 398 399 400 401 402 403 404 405 406 407
    var_import ::GLOBALS::vtypes
    var_import ::TBCOMPAT::default_soft_vtype_weight

    foreach type $types {
	if {! [info exists hwtypes($type)]} {
	    perror "\[tb-make-soft-vtype] Invalid hardware type $type."
	}
    }
    set vtypes($name) [Vtype $name $default_soft_vtype_weight $types]
}

proc tb-make-hard-vtype {name types} {
    var_import ::TBCOMPAT::hwtypes
408
    var_import ::TBCOMPAT::isremote
409 410 411 412 413 414 415 416 417 418 419 420 421
    var_import ::GLOBALS::vtypes
    var_import ::TBCOMPAT::default_hard_vtype_weight

    foreach type $types {
	if {! [info exists hwtypes($type)]} {
	    perror "\[tb-make-hard-vtype] Invalid hardware type $type."
	}
    }
    set vtypes($name) [Vtype $name $default_hard_vtype_weight $types]
}

proc tb-make-weighted-vtype {name weight types} {
    var_import ::TBCOMPAT::hwtypes
422
    var_import ::TBCOMPAT::isremote
423 424 425 426 427
    var_import ::GLOBALS::vtypes
    var_import ::TBCOMPAT::FLOAT

    foreach type $types {
	if {! [info exists hwtypes($type)]} {
428 429 430 431
	    perror "\[tb-make-weighted-vtype] Invalid hardware type $type."
	}
	if {$isremote($type)} {
	    perror "\[tb-make-weighted-vtype] Remote type $type not allowed."
432 433 434 435 436 437 438
	}
    }
    if {([regexp $FLOAT $weight] == 0) ||
	($weight <= 0) || ($weight >= 1.0)} {
	perror "\[tb-make-weighted-vtype] $weight is not a valid weight. (0 < weight < 1)."
    }
    set vtypes($name) [Vtype $name $weight $types]
439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510
}

proc tb-set-link-simplex-params {link src delay bw loss} {
    var_import ::TBCOMPAT::FLOAT
    if {[$link info class] != "Link"} {
	perror "\[tb-set-link-simplex-params] $link is not a link."
	return
    }
    if {[$src info class] != "Node"} {
	perror "\[tb-set-link-simplex-params] $src is not a link."
	return
    }
    set port [$link get_port $src]
    if {$port == {}} {
	perror "\[tb-set-link-simplex-params] $src is not in $link."
	return
    }
    if {([regexp $FLOAT $loss] == 0) || ($loss > 1.0)} {
	perror "\[tb-set-link-simplex-params] $loss is not a valid loss rate."
	return
    }
    set adjloss [expr 1-sqrt(1-$loss)]
    set np [list $src $port]
    foreach nodeport [$link set nodelist] {
	if {$nodeport != $np} {
	    set onp $nodeport
	}
    }

    set realdelay [parse_delay $delay]
    set realbw [parse_bw $bw]
    $link set delay($np) [expr $realdelay / 2.0]
    $link set rdelay($onp) [expr $realdelay / 2.0]
    $link set bandwidth($np) $realbw
    $link set rbandwidth($onp) $realbw
    $link set loss($np) [expr $adjloss]
    $link set rloss($onp) [expr $adjloss]
}

proc tb-set-lan-simplex-params {lan node todelay tobw toloss fromdelay frombw fromloss} {
    var_import ::TBCOMPAT::FLOAT
    if {[$node info class] != "Node"} {
	perror "\[tb-set-node-lan-delay] $node is not a node."
	return
    }
    if {[$lan info class] != "Lan"} {
	perror "\[tb-set-node-lan-delay] $lan is not a lan."
	return
    }
    set port [$lan get_port $node]
    if {$port == {}} {
	perror "\[tb-set-node-lan-delay] $node is not in $lan."
	return
    }
    if {([regexp $FLOAT $toloss] == 0) || ($toloss > 1.0)} {
	perror "\[tb-set-link-loss] $toloss is not a valid loss rate."
    }
    if {([regexp $FLOAT $fromloss] == 0) || ($fromloss > 1.0)} {
	perror "\[tb-set-link-loss] $fromloss is not a valid loss rate."
    }

    set realtodelay [parse_delay $todelay]
    set realfromdelay [parse_delay $fromdelay]
    set realtobw [parse_bw $tobw]
    set realfrombw [parse_bw $frombw]

    $lan set delay([list $node $port]) $realtodelay
    $lan set rdelay([list $node $port]) $realfromdelay
    $lan set loss([list $node $port]) $toloss
    $lan set rloss([list $node $port]) $fromloss
    $lan set bandwidth([list $node $port]) $realtobw
    $lan set rbandwidth([list $node $port]) $realfrombw
511 512 513
}

proc tb-set-uselatestwadata {onoff} {
514
    var_import ::GLOBALS::uselatestwadata
515 516 517 518 519 520 521 522

    if {$onoff != 0 && $onoff != 1} {
	perror "\[tb-set-uselatestwadata] $onoff must be 0/1"
	return
    }

    set uselatestwadata $onoff
}
523

524 525 526 527 528 529 530 531 532 533 534
proc tb-set-usewatunnels {onoff} {
    var_import ::GLOBALS::usewatunnels

    if {$onoff != 0 && $onoff != 1} {
	perror "\[tb-set-usewatunnels] $onoff must be 0/1"
	return
    }

    set usewatunnels $onoff
}

535
proc tb-use-endnodeshaping {onoff} {
536 537 538
    var_import ::GLOBALS::uselinkdelays

    if {$onoff != 0 && $onoff != 1} {
539
	perror "\[tb-use-endnodeshaping] $onoff must be 0/1"
540 541 542 543 544 545
	return
    }

    set uselinkdelays $onoff
}

546
proc tb-force-endnodeshaping {onoff} {
547 548 549
    var_import ::GLOBALS::forcelinkdelays

    if {$onoff != 0 && $onoff != 1} {
550
	perror "\[tb-force-endnodeshaping] $onoff must be 0/1"
551 552 553 554 555 556
	return
    }

    set forcelinkdelays $onoff
}

557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574
proc tb-set-wasolver-weights {delay bw plr} {
    var_import ::GLOBALS::wa_delay_solverweight
    var_import ::GLOBALS::wa_bw_solverweight
    var_import ::GLOBALS::wa_plr_solverweight

    if {($delay < 0) || ($bw < 0) || ($plr < 0)} {
	perror "\[tb-set-wasolver-weights] Weights must be postive integers."
	return
    }
    if {($delay == {}) || ($bw == {}) || ($plr == {})} {
	perror "\[tb-set-wasolver-weights] Must provide delay, bw, and plr."
	return
    }

    set wa_delay_solverweight $delay
    set wa_bw_solverweight $bw
    set wa_plr_solverweight $plr
}
575 576 577 578

#
# Control emulated for a link (lans not allowed yet). 
# 
579
proc tb-set-multiplexed {link onoff} {
580
    if {[$link info class] != "Link"} {
581
	perror "\[tb-set-multiplexed] $link is not a link."
582 583 584 585 586 587
	return
    }
    $link set emulated $onoff
}

#
588
# For emulated links, allow bw shaping to be turned off
589
# 
590
proc tb-set-noshaping {link onoff} {
591
    if {[$link info class] != "Link"} {
592
	perror "\[tb-set-noshaping] $link is not a link."
593 594
	return
    }
595
    $link set nobwshaping $onoff
596
}
597

598 599 600 601 602 603 604 605 606 607 608
#
# For emulated links, allow veth device to be used. Not a user option.
# 
proc tb-set-useveth {link onoff} {
    if {[$link info class] != "Link"} {
	perror "\[tb-set-useveth] $link is not a link."
	return
    }
    $link set useveth $onoff
}

609 610 611 612 613 614
#
# Control linkdelays for lans and links
# 
proc tb-set-endnodeshaping {lanlink onoff} {
    if {[$lanlink info class] != "Link" && [$lanlink info class] != "Lan"} {
	perror "\[tb-set-endnodeshaping] $lanlink is not a link or a lan."
615 616
	return
    }
617
    $lanlink set uselinkdelay $onoff
618
}
619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646

#
# Crude control of colocation of virt nodes. Will be flushed when we have
# a real story. Sets it for the entire link or lan. Maybe set it on a
# per node basis?
#
proc tb-set-allowcolocate {lanlink onoff} {
    if {[$lanlink info class] != "Link" && [$lanlink info class] != "Lan"} {
	perror "\[tb-set-allowcolocate] $lanlink is not a link or a lan."
	return
    }
    $lanlink set trivial_ok $onoff
}

#
# Another crude control. Allow override of multiplex factor that is listed
# in the node_types table. 
#
proc tb-set-colocate-factor {factor} {
    var_import ::GLOBALS::multiplex_factor

    if {$factor < 1 || $factor > 100} {
	perror "\[tb-set-colocate-factor] factor must be 1 <= factor <= 100"
	return
    }

    set multiplex_factor $factor
}
647 648 649 650 651 652 653 654 655 656 657 658 659 660

#
# Set the sync server for the experiment. Must a vnode name that has been
# allocated.
#
proc tb-set-sync-server {node} {
    var_import ::GLOBALS::sync_server

    if {[$node info class] != "Node"} {
	perror "\[tb-set-sync-server] $node is not a node."
	return
    }
    set sync_server $node
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
661 662 663 664 665 666

#
# Set the startup command for a node. Replaces the tb-set-node-startup
# command above, but we have to keep that one around for a while. This
# new version dispatched to the node object, which uses a program object.
# 
667
proc tb-set-node-startcmd {node command} {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
668
    if {[$node info class] != "Node"} {
669
	perror "\[tb-set-node-startcmd] $node is not a node."
Leigh B. Stoller's avatar
Leigh B. Stoller committed
670 671
	return
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
672
    set command "($command ; /usr/local/etc/emulab/startcmddone \$?)"
673 674 675
    set newprog [$node start-command $command]

    return $newprog
Leigh B. Stoller's avatar
Leigh B. Stoller committed
676
}
677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701

#
# More crude controls.
#
proc tb-set-mem-usage {usage} {
    var_import ::GLOBALS::mem_usage

    if {$usage < 1 || $usage > 5} {
	perror "\[tb-set-mem-usage] usage must be 1 <= factor <= 5"
	return
    }

    set mem_usage $usage
}
proc tb-set-cpu-usage {usage} {
    var_import ::GLOBALS::cpu_usage

    if {$usage < 1 || $usage > 5} {
	perror "\[tb-set-cpu-usage] usage must be 1 <= factor <= 5"
	return
    }

    set cpu_usage $usage
}

702 703 704 705 706 707
#
# This is nicer syntax for subnodes.
#
proc tb-bind-parent {sub phys} {
    tb-fix-node $sub $phys
}