delay_config.in 21.9 KB
Newer Older
Leigh Stoller's avatar
Leigh Stoller committed
1
#!/usr/bin/perl -wT
Leigh Stoller's avatar
Leigh Stoller committed
2 3 4

#
# EMULAB-COPYRIGHT
5
# Copyright (c) 2000-2011 University of Utah and the Flux Group.
Leigh Stoller's avatar
Leigh Stoller committed
6 7 8
# All rights reserved.
#

9 10
use English;
use Getopt::Std;
11
use XML::Simple;
12

13 14 15 16 17
#
# Change delay params for a link.
#
sub usage()
{
18
    print(STDERR
19
	  "Usage: delay_config [-m] [-d] [-s vnode] <pid> <eid> <link | bridge>".
20
	  " PARAM=VALUE ...\n".
21
	  "       delay_config [-d] -X <xmlfile>\n".
22
	  "Required: pid, eid, link, and at least one parameter to change!\n".
23 24 25 26 27
	  "  pid   = Project ID\n".
	  "  eid   = Experiment ID\n".
	  " link   = link name from ns file, ie. 'link1' in\n".
	  "          'set link1 [\$ns duplex-link \$A \$B 10Kb 0ms DropTail]'\n".
	  " bridge = or the bridge name, if explicitly using a bridge node\n".
28 29
	  "Options:\n".
	  "   -d = turn on debugging\n".
30
	  "   -b = bridge mode; operating on a bridge node instead of link\n".
31
	  "   -s = Select the source of the link to determine which pipe\n".
32
	  "        In bridge mode (-b) these are the link names attached\n".
33
	  "   -m = Modify the base experiment in addition to current state.\n".
34
	  "   -X = Get args and parameters from an XML file.\n".
35 36 37 38 39 40 41 42
	  "Parameters:\n".
	  " BANDWIDTH=NNN    - N=bandwidth (10-100000 Kbits per second)\n",
	  " PLR=NNN          - N=lossrate (0 <= plr < 1)\n".
	  " DELAY=NNN        - N=delay (one-way delay in milliseconds > 0)\n".
	  " LIMIT=NNN        - The queue size in bytes or packets\n".
	  " QUEUE-IN-BYTES=N - 0 means in packets, 1 means in bytes\n".
	  "RED/GRED Options: (only if link was specified as RED/GRED)\n".
	  " MAXTHRESH=NNN    - Maximum threshold for the average queue size\n".
Leigh Stoller's avatar
Leigh Stoller committed
43
	  " THRESH=NNN       - Minimum threshold for the average queue size\n".
44 45
	  " LINTERM=NNN      - Packet dropping probability\n".
	  " Q_WEIGHT=NNN     - For calculating the average queue size\n");
46 47
    # Web interface cares about this return value!
    exit(2);
48
}
49
my  $optlist = "dms:cX:b";
50 51 52 53 54 55

#
# Configure variables
#
my $TB		= "@prefix@";
my $TBOPS       = "@TBOPSEMAIL@";
56
my $TEVC        = "$TB/bin/tevc";
57
my $GENTOPO     = "$TB/libexec/gentopofile";
58 59 60 61 62 63 64 65 66 67 68 69

# Locals
my $pid;
my $eid;
my $link;
my $modify     = 0;
my $srcvnode;
my %config;
my $pipeno;
my $pipe;
my $debug      = 0;
my $compatmode = 0;
70
my $bridemode  = 0;
71 72 73 74

#
# Testbed Support libraries
#
75 76
use lib "@prefix@/lib";
use libdb;
77
use libtestbed;
78 79
use Experiment;
use User;
80

81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
#
# Function prototypes
#
sub ChangeDelayConfig();
sub ChangeLinkDelayConfig();
sub ChangeVirtLans();
sub ParseXmlArgs($$$$$$);
sub fatal($);

#
# These are the fields that we allow to come in from the XMLfile.
#
my $SLOT_OPTIONAL	= 0x1;	# The field is not required.
my $SLOT_REQUIRED	= 0x2;  # The field is required and must be non-null.
my $SLOT_ADMINONLY	= 0x4;  # Only admins can set this field.
my %xmlfields =
    # XML Field Name        DB slot name         Flags             Default
    ("pid"		=> ["pid",		$SLOT_REQUIRED],
     "eid"		=> ["eid",		$SLOT_REQUIRED],
     "link"		=> ["vname",		$SLOT_REQUIRED],

     "vnode"		=> ["vnode",		$SLOT_OPTIONAL],
     "modify"		=> ["modbase",		$SLOT_OPTIONAL,	   0],
     "compat"		=> ["compat",		$SLOT_OPTIONAL,	   0],

     "bandwidth"	=> ["bandwidth",	$SLOT_OPTIONAL],
     "plr"		=> ["lossrate",		$SLOT_OPTIONAL],
     "delay"		=> ["delay",		$SLOT_OPTIONAL],
     "limit"		=> ["q_limit",		$SLOT_OPTIONAL],
     "queue-in-bytes"	=> ["q_bytes",		$SLOT_OPTIONAL],
     "thresh"		=> ["q_maxthresh",	$SLOT_OPTIONAL],
     "minthresh"	=> ["q_minthresh",	$SLOT_OPTIONAL],
     "linterm"		=> ["q_linterm",	$SLOT_OPTIONAL],
     "q_weight"		=> ["q_weight",		$SLOT_OPTIONAL]);

116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
#
# Turn off line buffering on output
#
$| = 1;

#
# Untaint the path
# 
$ENV{'PATH'} = "/bin:/sbin:/usr/bin:/usr/sbin";
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

#
# Parse command arguments. Once we return from getopts, all that should be
# left are the required arguments.
#
%options = ();
if (! getopts($optlist, \%options)) {
    usage();
}
135 136 137
if (@ARGV < 4 && !defined($options{"X"}) ) {
    usage();
}
138
if (defined($options{"d"})) {
139 140
    $debug = 1;
}
141 142 143
if (defined($options{"c"})) {
    $compatmode = 1;
}
144 145 146
if (defined($options{"b"})) {
    $bridgemode = 1;
}
147
if (!defined($options{"X"})) {
148 149 150
    $pid  = shift(@ARGV);
    $eid  = shift(@ARGV);
    $link = shift(@ARGV);
151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
}
else {
    $xmlfile = $options{"X"};

    my %xmlargs = (); 
    my %errors = ();
    ParseXmlArgs($xmlfile, "virt_lans", \%xmlfields, $debug,
		 \%xmlargs, \%errors);
    if (keys(%errors)) {
	foreach my $errkey (keys(%errors)) {
	    my $errval = $errors{$errkey};
	    print "${errkey}: $errval\n";
	}
	fatal("XML arg error");
    }
166

167 168 169
    # There should be no other trailing args along with -X <xmlfile>.
    usage()
	if (@ARGV > 0);
170

171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197
    foreach my $arg (keys(%xmlargs)) {
	# Required.
	if ($arg eq "pid") {
	    $pid = $xmlargs{"pid"};
	}
	elsif ($arg eq "eid") {
	    $eid = $xmlargs{"eid"};
	}
	elsif ($arg eq "link") {
	    $link = $xmlargs{"link"};
	}
	# Optional.
	elsif ($arg eq "modify") {
	    $modify = $xmlargs{"modify"};
	}
	elsif ($arg eq "compat") {
	    $compatmode = $xmlargs{"compat"};
	}
	elsif ($arg eq "vnode") {
	    $srcvnode = $xmlargs{"vnode"};
	}
	# Push parameters onto ARGV for handling below.
	else {
	    push(@ARGV, "$arg=" . $xmlargs{$arg});
	}
    }
}
198 199 200
if (defined($options{"m"})) {
    $modify = 1;
}
201 202
if (defined($options{"s"})) {
    $srcvnode = $options{"s"};
Leigh Stoller's avatar
Leigh Stoller committed
203

204
    # Taint check cause it goes to a shell command.
Leigh Stoller's avatar
Leigh Stoller committed
205
    if ($srcvnode =~ /^([-\w]+)$/) {
Leigh Stoller's avatar
Leigh Stoller committed
206
	$srcvnode = $1;
Leigh Stoller's avatar
Leigh Stoller committed
207 208 209 210 211
    }
    else {
	die("*** Bad srcvnode name: $srcvnode.\n");
    }
}
212

213 214 215
my $experiment = Experiment->Lookup($pid, $eid);
if (!defined($experiment)) {
    fatal("No such experiment $pid,$eid");
Leigh Stoller's avatar
Leigh Stoller committed
216
}
217 218 219 220 221
# Untaint args for shell later.
$pid = $experiment->pid();
$eid = $experiment->eid();

# Taint check link cause it goes to a shell command.
Leigh Stoller's avatar
Leigh Stoller committed
222 223 224 225
if ($link =~ /^([-\w]+)$/) {
    $link = $1;
}
else {
226
    fatal("Bad link name: $link");
227
}
228

229 230 231
#
# Permission check.
#
232 233 234 235 236 237 238 239
my $this_user = User->ThisUser();
if (! defined($this_user)) {
    fatal("You ($UID) do not exist!");
}

if ($UID && !$this_user->IsAdmin() &&
    ! $experiment->AccessCheck($this_user, TB_EXPT_MODIFY)) {
    fatal("You do not have permission to modify the delay parameters!\n");
240 241 242 243 244
}

#
# No transitional experiments.
#
245
my $estate = $experiment->state();
246 247
if ($estate ne EXPTSTATE_ACTIVE &&
    $estate ne EXPTSTATE_SWAPPED) {
248
    fatal("Experiment must be ACTIVE or SWAPPED to change delays");
249 250
}

251 252 253 254 255
#
# Parse options, which will modify the existing configuration below.
#
while (@ARGV) {
    my $opt = shift(@ARGV);
256

257 258 259 260 261 262 263 264 265 266
    #
    # The parameter names correspond roughly to the names that the user
    # uses in the NS file. The $config{} keys correspond to the names of
    # the slots in the DB table. Well, roughly correspond since the delays
    # table uses q0_ and q1_, but we handle that below.
    #
    # XXX If you add to this list, be sure to add to agentmap hash below.
    #
    SWITCH: for ($opt) {
	/^BANDWIDTH=([0-9]*)$/i && do {
267
	    if ($1 > 100000 || $1 < 10) {
268 269 270 271 272 273 274 275 276 277 278 279 280
		usage();
	    }
	    $config{"bandwidth"} = $1;
	    last SWITCH;
	};
	/^DELAY=([0-9]*)$/i && do {
	    if ($1 < 0) {
		usage();
	    }
	    $config{"delay"} = $1;
	    last SWITCH;
	};
	/^PLR=([0-9\.]*)$/i && do {
281
	    if ($1 < 0 || $1 > 1) {
282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314
		usage();
	    }
	    $config{"lossrate"} = $1;
	    last SWITCH;
	};
	/^LIMIT=([0-9]*)$/i && do {
	    $config{"q_limit"} = $1;
	    last SWITCH;
	};
	/^QUEUE-IN-BYTES=(\d)$/i && do {
	    if ($1 != 0 && $1 != 1) {
		usage();
	    }
	    $config{"q_qinbytes"} = $1;
	    last SWITCH;
	};
	/^MAXTHRESH=(\d*)$/i && do {
	    $config{"q_maxthresh"} = $1;
	    last SWITCH;
	};
	/^THRESH=(\d*)$/i && do {
	    $config{"q_minthresh"} = $1;
	    last SWITCH;
	};
	/^LINTERM=([0-9\.]*)$/i && do {
	    $config{"q_linterm"} = $1;
	    last SWITCH;
	};
	/^Q_WEIGHT=([0-9\.]*)$/i && do {
	    $config{"q_weight"} = $1;
	    last SWITCH;
	};
	print "Invalid config option: $opt\n";
315 316
	usage();
    }
317
}
318

319 320 321 322 323 324 325 326 327 328 329 330
#
# More sanity checks.
#
foreach my $key (keys(%config)) {
    my $val = $config{$key};

    if ($debug) {
	print "$key=$val\n";
    }
}

#
331
# These map the names I am using in the config hash (which correspond
332 333 334 335 336 337 338 339 340 341 342 343 344 345 346
# to the DB slot names) into the event parameter names to send over to the
# delay agent.
#
my %agentmap =
    ( bandwidth		=> BANDWIDTH,
      delay             => DELAY,
      lossrate		=> PLR,
      q_limit		=> LIMIT,
      q_qinbytes	=> "QUEUE-IN-BYTES",
      q_maxthresh	=> MAXTHRESH,
      q_minthresh	=> THRESH,
      q_linterm		=> LINTERM,
      q_weight		=> Q_WEIGHT
    );

347
#
348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364
# Link or Lan or Bridge.
#
if ($bridgemode) {
    $query_result =
	DBQueryFatal("select * from virt_bridges where vname='$link'");

    if (!$query_result->numrows) {
	fatal("$link is not a bridge in $pid/$eid!\n");
    }
}
else {
    $query_result =
	DBQueryFatal("select member,bridge_vname from virt_lans ".
		     "where pid='$pid' and eid='$eid' and vname='$link'");
    if (!$query_result->numrows) {
	fatal("$link is not a link in $pid/$eid!\n");
    }
365
}
366
my $islink = ($query_result->numrows == 2 ? 1 : 0);
367

368 369 370 371 372 373 374 375 376 377 378 379 380
#
# When a link is bridged, must call this script with the bridge name
# instead of the link name, since a link can potentially be bridged on
# both sides, and because a bridge connects two *different* links.
#
if (!$bridgemode) {
    while (my ($member,$bridge_vname) = $query_result->fetchrow_array()) {
	if (defined($bridge_vname)) {
	    fatal("$link is bridged; please use the -b option instead.\n");
	}
    }
}

381
#
382
# If experiment is not active, all we can do is change virt_lans.
383
#
384 385 386 387 388 389 390 391 392
if ($estate ne EXPTSTATE_ACTIVE) {
    if ($modify) {
	ChangeVirtLans();
    }
    else {
	print "Experiment $pid/$eid is not active. If you want to change\n".
	    "the base experiment configuration, please use the -m option!\n";
    }
    exit(0);
393
}
394

395 396 397 398 399 400
#
# Check to see if linkdelays or normal delay nodes. This is a gross
# complication of this entire script!
#
if (ChangeDelayConfig() < 0 &&
    ChangeLinkDelayConfig() < 0) {
401
    die("*** $0:\n".
402
	"    $link is not a traffic shaped link in $pid/$eid!\n");
403
}
404 405 406
if ($modify) {
    ChangeVirtLans();
}
407

408 409 410 411 412 413 414 415 416 417 418 419 420 421 422
#
# Inject an event. 
#
my $inject_string = "$TEVC -e $pid/$eid now $link";

# Direct the event to the whoever is handling this particular delay.
$inject_string .= "-${srcvnode} "
    if (defined($srcvnode));

$inject_string .= " modify ";

# Append the parameters.
foreach my $key (keys(%config)) {
    my $val = $config{$key};
    my $str = $agentmap{$key};
423 424 425 426 427 428 429 430 431 432 433 434 435 436

    #
    # When changing an entire lan, we have to adjust delay/loss since
    # there is a delay *to* the lan and a delay *from* the lan.
    # We do not do this for links since there is just a single delay.
    # When changing a single node in a lan, we fall back to the way things
    # operate in the parser, which is that the user intended to change both
    # directions to exactly this value. 
    #
    if (!$islink && !defined($srcvnode) && !$compatmode) {
        if ($key eq "delay") {
	    # This follows what is done in the parser.
	    $val = $val / 2.0;
	}
Leigh Stoller's avatar
Leigh Stoller committed
437
        elsif ($key eq "lossrate") {
438 439 440 441
	    # This follows what is done in the parser.
	    $val = 1-sqrt(1-$val);
	}
    }
442 443 444 445 446 447 448 449 450
    $inject_string .= "${str}=$val ";
}
if ($debug) {
    print "$inject_string\n";
}

system($inject_string) &&
    die("*** $0:\n".
	"    Failed to inject delay update event!\n");
451 452 453 454 455 456 457

print "*** WARNING:\n";
print "    You should *always* test your links and lans to make sure they\n";
print "    are behaving as you expect. You can do this by hand with ping,\n";
print "    or you can use Emulab's LinkTest feature.\n";
print "    Type 'linktest' into the Emulab search box to find out how to ".
    "use it.\n";
458 459 460
    
exit(0);

461
#
462 463 464 465 466
# Get current delay configuration. 
# 
sub ChangeDelayConfig() {
    my $query_clause;
    my $query_string;
467

468
    $query_string = "select * from delays ".
469
	"where pid='$pid' and eid='$eid' and vname='$link' and noshaping=0 ";
470

471 472 473 474 475 476 477 478 479
    if (defined($srcvnode)) {
	if ($bridgemode) {
	    # The src is the name of the link.
	    $query_string .= "and (vlan0='$srcvnode' or vlan1='$srcvnode')";
	}
	else {
	    $query_string .= "and (vnode0='$srcvnode' or vnode1='$srcvnode')";
	}
    }
480

481 482 483 484 485 486
    #
    # Okay, see if there is a delay node.
    # 
    my $query_result = DBQueryFatal($query_string);
    if (! $query_result->numrows) {
	return -1;
487
    }
488 489 490 491 492 493 494 495 496 497 498 499 500 501
    
    if (defined($srcvnode) && $islink) {
	#
	# If given a source node of a duplex link, must map that into
	# the actual delay pipe side and the pipe number, since the
	# names of the slots in the DB table have a 0/1 appended. Big
	# Yuck.
	#
	if ($query_result->numrows != 1) {
	    die("*** $0:\n".
		"    Too many delay links for $link in $pid/$eid!\n");
	}
	my %row = $query_result->fetchhash();

502
	if ($row{'vnode0'} eq $srcvnode || $row{'vlan0'} eq $srcvnode) {
503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522
	    $pipe   = 0;
	}
	else {
	    $pipe   = 1;
	}
	$pipeno = $row{"pipe${pipe}"};
	
	foreach my $key (keys(%config)) {
	    my $val = $config{$key};

	    $query_clause .= ", "
		if (defined($query_clause));
		
	    if ($key =~ /^q_(.*)/) {
		$query_clause .= "q${pipe}_${1}=$val";
	    }
	    else {
		$query_clause .= "${key}${pipe}=$val";
	    }
	}
523
    }
524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540
    else {
	#
	# We are changing a link or entire lan symmetrically, or we are
	# changing one node in a lan symmetrically. Note, we cannot yet
	# make an asymmetric change to an indvidual lan node. Sorry, too
	# much pain. 
	#
	foreach my $key (keys(%config)) {
	    my $val = $config{$key};

	    $query_clause .= ", "
		if (defined($query_clause));
		
	    if ($key =~ /^q_(.*)/) {
		$query_clause .= "q0_${1}=$val,q1_${1}=$val";
	    }
	    else {
541 542 543 544 545 546 547 548 549
		#
		# When changing an entire lan, we have to adjust delay/loss
		# since there is a delay *to* the lan and a delay *from*
		# the lan.  We do not do this for links since there is just
		# a single delay.  When changing a single node in a lan, we
		# fall back to the way things operate in the parser, which
		# is that the user intended to change both directions to
		# exactly this value.
		#
550 551
		if (!$bridgemode &&
		    !$islink && !defined($srcvnode) && !$compatmode) {
552 553 554 555
		    if ($key eq "delay") {
			# This follows what is done in the parser.
			$val = $val / 2.0;
		    }
Leigh Stoller's avatar
Leigh Stoller committed
556
		    elsif ($key eq "lossrate") {
557 558 559 560
			# This follows what is done in the parser.
			$val = 1-sqrt(1-$val);
		    }
		}
561 562 563
		$query_clause .= "${key}0=$val,${key}1=$val";
	    }
	}
564
    }
565 566 567 568 569 570 571 572 573 574
    
    #
    # Update the delays table.
    #
    $query_string =
	"update delays set $query_clause ".
	"where pid='$pid' and eid='$eid' and vname='$link' ";
    
    if (defined($srcvnode)) {
	$query_string .= "and (vnode0='$srcvnode' or vnode1='$srcvnode')";
575 576
    }
    if ($debug) {
577
	print "$query_string\n";
578
    }
579 580 581
    DBQueryFatal($query_string);
    return 0;
}    
582

583 584 585 586 587 588
#
# Change linkdelays.
# 
sub ChangeLinkDelayConfig() {
    my @query_clauses;
    my $query_string;
589

590 591 592 593
    $query_string = "select l.*,o.OS from linkdelays as l ".
	"left join nodes as n on n.node_id=l.node_id ".
	"left join os_info as o on o.osid=n.def_boot_osid ".
	"where l.pid='$pid' and l.eid='$eid' and l.vlan='$link' ";
594

595
    $query_string .= "and l.vnode='$srcvnode'"
596
	if (defined($srcvnode));
597

598 599 600 601 602 603
    #
    # Okay, see if there is a linkdelay.
    # 
    my $query_result = DBQueryFatal($query_string);
    if (! $query_result->numrows) {
	return -1;
604
    }
605

606 607 608 609 610 611 612 613
    #
    # XXX Check for linux; temporary.
    #
    while (my $row = $query_result->fetchrow_hashref()) {
	my $vnode = $row->{'vnode'};
	my $OS    = $row->{'OS'};

	if ($OS eq "Linux") {
614 615 616 617
	    print STDERR
		"*** $0:\n".
		"    Oops, dynamic events do not yet work on Linux!\n";
	    exit(2);
618 619 620
	}
    }

621
    #
622 623 624 625 626 627
    # This is much easier than delay nodes! As above, we cannot change a
    # lan node asymmetrically yet.
    #
    foreach my $key (keys(%config)) {
	my $val = $config{$key};

628 629 630 631 632
	if (!$islink && !defined($srcvnode) && !$compatmode) {
	    if ($key eq "delay") {
		# This follows what is done in the parser.
		$val = $val / 2.0;
	    }
Leigh Stoller's avatar
Leigh Stoller committed
633
	    elsif ($key eq "lossrate") {
634 635 636 637
		# This follows what is done in the parser.
		$val = 1-sqrt(1-$val);
	    }
	}
638 639 640 641 642 643 644 645 646 647 648 649 650 651
	push(@query_clauses, "${key}=$val");
	
	#
	# For a lan node, must also set the "r" params.
	# 
	if (!$islink &&
	    ($key eq "delay" ||
	     $key eq "bandwidth" ||
	     $key eq "lossrate")) {

	    push(@query_clauses, "r${key}=$val");
	}
    }
    
652
    #
653
    # Update the delays table.
654
    #
655 656 657
    $query_string = "update linkdelays set ".
	join(",", @query_clauses) . 
	" where pid='$pid' and eid='$eid' and vlan='$link' ";
658
    
659 660 661 662 663 664 665 666
    if (defined($srcvnode)) {
	$query_string .= "and vnode='$srcvnode'";
    }
    if ($debug) {
	print "$query_string\n";
    }
    DBQueryFatal($query_string);
    return 0;
667 668 669
}

#
670
# Change the virt_lans entry.
671
#
672 673 674 675
sub ChangeVirtLans() {
    my @query_clauses;
    my $query_string;
    my @query_clauses2;
676

677
    #
678
    # The first case is for changing a node in a duplex link asymmetrically.
679
    #
680 681 682 683 684 685
    if ($islink && defined($srcvnode)) {
	#
	# In a duplex link the delay/bw/plr params are split between the
	# two virt_lan members using the "r" params to hold the "from
	# switch" half of the value. This makes it rather confusing.
	# 
686 687 688 689
	foreach my $key (keys(%config)) {
	    my $val = $config{$key};

	    if ($key eq "delay") {
690
		my $delay = $val / 2.0;
691

692 693
		push(@query_clauses,  "delay=$delay");
		push(@query_clauses2, "rdelay=$delay");
694 695
	    }
	    elsif ($key eq "lossrate") {
696
		my $lossrate = 1-sqrt(1-$val);
697 698

		push(@query_clauses, "lossrate=$lossrate");
699
		push(@query_clauses2, "rlossrate=$lossrate");
700 701 702
	    }
	    elsif ($key eq "bandwidth") {
		push(@query_clauses, "bandwidth=$val");
703
		push(@query_clauses2, "rbandwidth=$val");
704 705 706 707 708 709 710
	    }
	    else {
		push(@query_clauses, "$key=$val");
	    }
	}
	$query_string = "update virt_lans set ".
	    join(",", @query_clauses) .
711 712 713
	    " where pid='$pid' and eid='$eid' and ".
	    "      vname='$link' and member like '${srcvnode}:%'";
	
714 715 716 717
	if ($debug) {
	    print "$query_string\n";
	}
	DBQueryFatal($query_string);
718 719 720 721 722 723 724 725 726 727 728 729 730

	if (@query_clauses2) {
	    $query_string =
		"update virt_lans set ".
		join(",", @query_clauses2) .
		" where pid='$pid' and eid='$eid' and ".
		"      vname='$link' and member not like '${srcvnode}:%'";
	
	    if ($debug) {
		print "$query_string\n";
	    }
	    DBQueryFatal($query_string);
	}
731 732 733
    }
    else {
	#
734 735 736 737 738
	# When changing an entire link or lan symmetrically its easy; they can
	# be done the same. When changing one node in a lan (symmetrically),
	# the numbers are slightly different for delay/lossrate, but otherwise
	# its the same operation, except for operating on a single node.
	#
739 740 741 742
	foreach my $key (keys(%config)) {
	    my $val = $config{$key};

	    if ($key eq "delay") {
743
		my $delay = $val;
744

745 746 747 748 749 750 751
		# This follows what is done in the parser;
		# See tb-set-node-lan-delay
		$delay = $delay / 2.0
		    if (!defined($srcvnode));

		push(@query_clauses, "delay=$delay");
		push(@query_clauses, "rdelay=$delay");
752 753
	    }
	    elsif ($key eq "lossrate") {
754 755 756 757 758 759
		my $lossrate = $val;

		# This follows what is done in the parser.
		# See tb-set-node-lan-lossrate
		$lossrate = 1-sqrt(1-$lossrate)
		    if (!defined($srcvnode));
760 761

		push(@query_clauses, "lossrate=$lossrate");
762
		push(@query_clauses, "rlossrate=$lossrate");
763 764 765
	    }
	    elsif ($key eq "bandwidth") {
		push(@query_clauses, "bandwidth=$val");
766
		push(@query_clauses, "rbandwidth=$val");
767 768 769 770 771
	    }
	    else {
		push(@query_clauses, "$key=$val");
	    }
	}
772

773 774
	$query_string = "update virt_lans set ".
	    join(",", @query_clauses) .
775 776 777 778 779 780 781 782 783
	    " where pid='$pid' and eid='$eid' and vname='$link'";

	#
	# A lan node change since it cannot be a link if srcvnode defined.
	# 
	if (defined($srcvnode)) {
	    $query_string .= " and member like '${srcvnode}:%'";
	}

784 785 786 787 788
	if ($debug) {
	    print "$query_string\n";
	}
	DBQueryFatal($query_string);
    }
789 790 791 792 793 794 795 796
    #
    # Now we need to regen the linktest map file ...
    #
    system("$GENTOPO $pid $eid");
    if ($?) {
	die("*** $0:\n".
	    "    $GENTOPO failed!\n");
    }
797
}
798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840

sub ParseXmlArgs($$$$$$) {
    my ($xmlfile, $table_name, $fields_ref, $debug, 
	$args_ref, $errs_ref) = @_;
    #
    # Input args:
    #  $xmlfile	   - XML file path.
    #  $table_name - table_regex table_name for low-level checking patterns.
    #  $fields_ref - xmlfields specification (hash reference.)
    #  $debug
    #
    # Output args:
    #  $args_ref   - Parsed argument values (hash reference.)
    #  $errs_ref   - Error messages on failure (hash reference.)

    #
    # Must wrap the parser in eval since it exits on error.
    #
    my $xmlparse = eval { XMLin($xmlfile,
				VarAttr => 'name',
				ContentKey => '-content',
				SuppressEmpty => undef); };
    if ($@) {
	$errs_ref->{"XML Parse Error"} = "Return code $@";
	return;
    }

    #
    # Make sure all the required arguments were provided.
    #
    my $key;
    foreach $key (keys(%{ $fields_ref })) {
	my (undef, $required, undef) = @{$fields_ref->{$key}};

	$errs_ref->{$key} = "Required value not provided"
	    if ($required & $SLOT_REQUIRED  &&
		! exists($xmlparse->{'attribute'}->{"$key"}));
    }
    return
	if (keys(%{ $errs_ref }));

    foreach $key (keys(%{ $xmlparse->{'attribute'} })) {
	my $value = $xmlparse->{'attribute'}->{"$key"}->{'value'};
Russ Fish's avatar
Russ Fish committed
841 842 843
	if (!defined($value)) {	# Empty string comes from XML as an undef value.
	    $xmlparse->{'attribute'}->{"$key"}->{'value'} = $value = "";
	}
844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892

	if ($debug) {
	    print STDERR "User attribute: '$key' -> '$value'\n";
	}

	$errs_ref->{$key} = "Unknown attribute"
	    if (!exists($fields_ref->{$key}));

	my ($dbslot, $required, $default) = @{$fields_ref->{$key}};

	if ($required & $SLOT_REQUIRED) {
	    # A slot that must be provided, so do not allow a null value.
	    if (!defined($value)) {
		$errs_ref->{$key} = "Must provide a non-null value";
		next;
	    }
	}
	if ($required & $SLOT_OPTIONAL) {
	    # Optional slot. If value is null skip it. Might not be the correct
	    # thing to do all the time?
	    if (!defined($value)) {
		next
		    if (!defined($default));
		$value = $default;
	    }
	}
	if ($required & $SLOT_ADMINONLY) {
	    # Admin implies optional, but thats probably not correct approach.
	    $errs_ref->{$key} = "Administrators only"
		if (! $this_user->IsAdmin());
	}

	# Now check that the value is legal.
	if (! TBcheck_dbslot($value, $table_name, $dbslot, 
			     TBDB_CHECKDBSLOT_ERROR)) {
	    $errs_ref->{$key} = TBFieldErrorString();
	    next;
	}

	$args_ref->{$key} = $value;
    }
}

sub fatal($) {
    my($mesg) = $_[0];

    die("*** $0:\n".
	"    $mesg\n");
}