assign_wrapper.in 172 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1
#!/usr/bin/perl -w
Leigh B. Stoller's avatar
Leigh B. Stoller committed
2
3
#
# EMULAB-COPYRIGHT
4
# Copyright (c) 2000-2009 University of Utah and the Flux Group.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
5
6
# All rights reserved.
#
7
8
use English;
use Getopt::Std;
9
use POSIX qw(setsid ceil);
10
use POSIX ":sys_wait_h";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
11

12
13
14
15
16
17
18
19
20
21
22
#
# Function phototypes
#
sub RunAssign();
sub getbandwidth($$$);
sub InitPnode($$);
sub nextipportnum($);
sub AddVlan($$$;$);
sub UploadVlans();
sub CheckMaxConcurrent();
sub UploadStats();
23
24
25
sub NewVirtIface($$$;$);
sub AddVirtPatch($$);
sub PatchVirts();
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
sub newvname($$);
sub newvname_simhost($);
sub LoadPhysInfo();
sub interfacespeedmbps($$);
sub requires_delay($$$);
sub LoadVirtNodes();
sub LoadVirtNodeDesires();
sub LoadVirtNodeStartLoc();
sub LoadVirtLans();
sub LoadVirtTypes();
sub LoadExperiment();
sub CreateTopFile();
sub LoadPhysNode($);
sub LoadPhysNodeInterfaces($);
sub LoadPhysResources();
sub physnodenextrtabid($);
sub getrtabid($$);
sub array_diff($$);
sub LoadCurrent();
45
sub SetUpTracing($$$$$);
46
sub fatal(@);
47
sub FinalizeRegression($);
48

49
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
50
51
52
53
54
55
# This function as the main assign loop.  It converts the virtual
# topology into a top input including LAN and delay translation.  It
# then snapshots the current testbed physical state and runs assign,
# looping a couple times if assign fails.  When assign successfully
# completes it will interpret the results.  Attempt to match any
# existing portmap entries and then update the delays and vlans table.
Chad Barb's avatar
Chad Barb committed
56
#
57
58
59
60
# XXX: Update does not work with widearea nodes.
#      Internally created nodes (jailhost,delay,sim) are not treated
#        consistently. Needs more thought.
#
61
62
63
64
# Return codes: We catch all errors with the END block below, and if
# anyone calls die() (exit value is 255) we add in the CANRECOVER bit.
# Failures in assign always cause the caller to stop retrying. 
#
65
# The CANRECOVER bit indicates 'recoverability' (no db or physical
66
67
# state was modified by the time the error occurred). This is relavent
# to only modify operations (update).
68
69
70
#
my $WRAPPER_SUCCESS		 = 0x00;
my $WRAPPER_FAILED		 = 0x01;	# Failed (Add other values)
71
72
my  $WRAPPER_FAILED_CANRECOVER   = 0x40;        # Can recover from update
my  $WRAPPER_FAILED_FATALLY      = 0x80;	# Do not use this.
73
74
# Set this once we modify DB state; forces no recover in fatal().
my $NoRecover = 0;
75

76
77
sub usage ()
{
78
79
80
81
    print STDERR "Usage: $0 [-v] [-u [-f] | -n] pid eid\n";
    print STDERR " -v   - Enables verbose output\n";
    print STDERR " -u   - Enables update mode\n";
    print STDERR " -f   - Fix current resources during update mode\n";
82
83
    print STDERR " -t   - Create the TOP file and then exit\n";
    print STDERR " -n   - Run assign, but do not reserve/modify resources.\n";
84
85
    print STDERR " -p   - Do a precheck for mapability on an empty testbed - ".
		 "implies -n\n";
86
    exit($WRAPPER_FAILED);
87
}
88
my $optlist  = "vutnfpr";
89
my $verbose  = 0;
90
my $fixmode  = 0;
91
92
93
my $updating = 0;
my $toponly  = 0;
my $impotent = 0;
94
my $precheck = 0;
95
my $regression=0;
96
my $warnings = 0;
97
98
99
100
101

#
# Configure variables
#
my $TBROOT	  = "@prefix@";
102
103
my $NFREE         = "$TBROOT/bin/nfree";
my $DBNAME  	  = "@TBDBNAME@";
104
my $DELAYCAPACITY = @DELAYCAPACITY@;	# Can be overridden by user!
105
106
107
108
109
110
111
112
113
114
115
116
117
$ENV{'PATH'} = "/usr/bin:$TBROOT/libexec:$TBROOT/sbin:$TBROOT/bin";

#
# Turn off line buffering on output
#
$| = 1;

#
# Testbed Support libraries
#
use lib "@prefix@/lib";
use libdb;
use libtestbed;
118
use Experiment;
119
use Node;
120
use NodeType;
121
use Lan;
122
use OSinfo;
123
use libadminctrl;
Kevin Atkinson's avatar
Kevin Atkinson committed
124
use libtblog;
Kevin Atkinson's avatar
   
Kevin Atkinson committed
125
use libtblog qw(*SOUT *SERR);
126

Chad Barb's avatar
Chad Barb committed
127
#
128
129
130
131
# assign_wrapper Settings
#
# Maximum delay in ms above which a delay node is needed.
# (Note that the DB represents delays as floating point numbers)
132
my $delaythresh = @DELAYTHRESH@;
Chad Barb's avatar
Chad Barb committed
133

134
# Maximum number of times we run assign.
135
my $maxrun = 3;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
136

137
138
139
# Use the switch to delay when possible. Currentlythis only works for 10mbit
# links (actually, its turned off cause it does not work; auto handshake).
my $delaywithswitch = 0;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
140

141
142
143
144
145
146
147
#
# Some handy constants. Speed in Mbits/sec and Kbits/sec units.
#
# Its probably a good idea to leave portbw (current_speed) in Mbs, since
# those numbers are used at the switch and the interfaces, which really
# only think in Mbps.
#
148
149
150
151
152
153
my $S10Mbs   = 10;
my $S100Mbs  = 100;
my $S1000Mbs = 1000;
my $S10Kbs   = 10000;
my $S100Kbs  = 100000;
my $S1000Kbs = 1000000;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
154

155
#
156
157
# Parse command arguments. Once we return from getopts, all that should be
# left are the required arguments.
158
#
159
160
161
%options = ();
if (! getopts($optlist, \%options)) {
    usage();
162
}
163
164
if (@ARGV != 2) {
    usage();
Chad Barb's avatar
Chad Barb committed
165
}
166
if (defined($options{"v"})) {
167
    $verbose++;
Chad Barb's avatar
   
Chad Barb committed
168
}
169
if (defined($options{"u"})) {
Chad Barb's avatar
   
Chad Barb committed
170
    $updating = 1;
171
}
172
173
174
175
176
if (defined($options{"t"})) {
    $toponly = 1;
}
if (defined($options{"n"})) {
    $impotent = 1;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
177
}
178
179
180
181
if (defined($options{"p"})) {
    $impotent = 1;
    $precheck = 1;
}
182
183
184
if (defined($options{"f"})) {
    $fixmode = 1;
}
185
186
187
188
189
190
if (defined($options{"r"})) {
    if ($DBNAME eq "tbdb") {
	fatal("Cannot use regression mode on main DB");
    }
    $regression = 1;
}
191
192
my $pid = $ARGV[0];
my $eid = $ARGV[1];
193
my $ptopfile = ($regression ? "$pid-$eid.ptop" : "$pid-$eid-$$.ptop");
194
195
196
197
# Since the topfile could change across
# swapins and modifies, it makes sense
# to store all of them. Helps in
# degugging.
198
my $topfile  = ($regression ? "$pid-$eid.top" : "$pid-$eid-$$.top");
199

Shashi Guruprasad's avatar
Shashi Guruprasad committed
200
201
TBDebugTimeStampsOn();

202
203
204
205
#
# We want warnings to cause assign_wrapper to exit abnormally.
# We will come through here no matter how we exit though.
# 
206
207
208
209
# FIXME: Is this still needed.  "warn" is only used once.  Also this
#  will cause perl internal warnings (such as "Use of uninitialized
#  value ..."  to cause assign_wrapper to fail. -- kevina
#
Kevin Atkinson's avatar
   
Kevin Atkinson committed
210
$SIG{__WARN__} = sub { tbwarn $_[0];$warnings++; };
211
212
213
214
215
216
217
218

END {
    # Watch for getting here cause of a die()/exit() statement someplace.
    my $exitcode = $?;

    if ($exitcode && $exitcode != $WRAPPER_FAILED) {
	$exitcode = $WRAPPER_FAILED|$WRAPPER_FAILED_FATALLY;
    }
219
    
220
    if ($warnings > 0) {
Kevin Atkinson's avatar
   
Kevin Atkinson committed
221
	tberror "$warnings warnings.\n";
222
223
224
225
226
227
228
229
230
231

	$exitcode |= $WRAPPER_FAILED;
    }

    # Set recover bit if we are going to fail.
    $exitcode = $exitcode|$WRAPPER_FAILED_CANRECOVER
	if ($exitcode && !$NoRecover);

    # And change the exitcode to be what we want it to be!
    $? = $exitcode;
232
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
233

234
235
sub printdb ($)
{
Leigh B. Stoller's avatar
Leigh B. Stoller committed
236
237
238
    if ($verbose) {
	print $_[0];
    }
239
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
240

241
print "assign_wrapper improved started\n";
242
243
TBDebugTimeStamp("assign_wrapper started");

Leigh B. Stoller's avatar
Leigh B. Stoller committed
244
#
245
# The main data structures:
Leigh B. Stoller's avatar
Leigh B. Stoller committed
246
#
247
248
249
250
251
# virt_nodes: The virtual nodes, indexed by vname. Each entry is a
# hash reference, initially of just the DB info, but possibly
# augmented as we proceed through assign.  Do not confuse these
# virtual nodes with the other virtual nodes! These are the ones from
# the actual topology, the virt_nodes table in the DB.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
252
#
253
254
my %virt_nodes = ();

255
256
257
258
259
260
261
262
263
264
#
# Helper functions to get virt_node info. Because of internally created
# nodes (tbdelay, vhost, sim), we need a virtnodeisvnode() test to prevent
# entries getting stuck into $virt_nodes when calling, say, virtnodeisvirt.
# Should we create entries for these nodes instead?
#
sub virtnodeisvnode($)  { return exists($virt_nodes{$_[0]}); }
sub virtnodetype($)	{ return $virt_nodes{$_[0]}->{"type"}; }
sub virtnodename($)	{ return $virt_nodes{$_[0]}->{"vname"}; }
sub virtnodeelabrole($) { return $virt_nodes{$_[0]}->{"inner_elab_role"}; }
265
sub virtnodeplabrole($) { return $virt_nodes{$_[0]}->{"plab_role"}; }
266
sub virtnodeosname($)   { return $virt_nodes{$_[0]}->{"__osname"}; }
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
sub virtnodeosid($)     { return $virt_nodes{$_[0]}->{"__osid"}; }
sub virtnodesetosid($$) { return $virt_nodes{$_[0]}->{"__osid"} = $_[1]; }
sub virtnodeparent($)   { return $virt_nodes{$_[0]}->{"__parent"}; }
sub virtnodepnode($)    { return $virt_nodes{$_[0]}->{"__physnode"}; }
sub virtnodesetpnode($$){ return $virt_nodes{$_[0]}->{"__physnode"} = $_[1]; }
sub virtnodeusewan($)   { return $virt_nodes{$_[0]}->{"__usewanassign"}; }
sub virtnodesetusewan($){ return $virt_nodes{$_[0]}->{"__usewanassign"} = 1;}
sub virtnodesettings($) { return @{$virt_nodes{$_[0]}->{"__settings"}}; }
sub virtnodestartloc($) { return $virt_nodes{$_[0]}->{"__startloc"}; }
sub virtnodeisremote($) {
    return virtnodeisvnode($_[0]) && $virt_nodes{$_[0]}->{"__isremotenode"};
}
sub virtnodeisvirt($)   {
    return virtnodeisvnode($_[0]) && $virt_nodes{$_[0]}->{"__isvirtnode"};
}
sub virtnodeissubnode($)   {
    return virtnodeisvnode($_[0]) && $virt_nodes{$_[0]}->{"__issubnode"};
}
sub virtnodeissim($)   {
    return virtnodeisvnode($_[0]) && $virt_nodes{$_[0]}->{"__issimnode"};
}
sub virtnodeisdynamic($)   {
    return virtnodeisvnode($_[0]) && $virt_nodes{$_[0]}->{"__isdynamic"};
}
sub virtnodeisplabnode($)   {
    return virtnodeisvnode($_[0]) && $virt_nodes{$_[0]}->{"__isplabnode"};
}
sub virtnodeisjailed($) {
    return virtnodeisvirt($_[0]) && physnodeisjailed(virtnodepnode($_[0]));
}
sub virtnodedesires     {
    my @desires;
    while (my ($desire, $weight) = each %{$virt_nodes{$_[0]}->{"__desires"}}) {
	push @desires, $desire . ":" . sprintf("%f",$weight);
    }
    return join(" ",@desires);
}
Timothy Stack's avatar
   
Timothy Stack committed
304
305
306
307
308
309
sub virtnodeneedslinkdelays($) {
    return $virt_nodes{$_[0]}->{"__needslinkdelays"};
}
sub virtnodesetneedslinkdelays($) {
    return $virt_nodes{$_[0]}->{"__needslinkdelays"} = 1;
}
310

Leigh B. Stoller's avatar
Leigh B. Stoller committed
311
#
312
313
314
315
316
317
318
319
320
321
322
323
# virt_lans: The equivalent of virt_nodes; the virt_lans table in the DB.
# Since there are multiple rows per lan (one for each node), this is a
# multilevel structure. The first slot is another hash, one for each node.
# The rest of the slots store other random things associated with the lan.
# So, looks something like:
#
#   %virt_lans = (link0 => {members    => member0 => { db row ref },
#                                         member1 => { db row ref }}
#                           mustdelay    => 0,
#                           emulated     => 0,
#                           uselinkdelay => 0,
#                           nobwshaping  => 0,
324
#                           encapstyle   => "default",
325
326
327
328
329
330
331
#                           trivok       => 0
#                          }
#                 link1 => ...
#                )
#
my %virt_lans = ();

332
333
sub virtlanexists($)	{ return exists($virt_lans{$_[0]}); }
sub virtlanname($)	{ return $virt_lans{$_[0]}->{"VNAME"}; }
334
sub virtlanidx($)	{ return $virt_lans{$_[0]}->{"IDX"}; }
335
336
337
338
339
340
sub virtlanmembers($)	{ return @{$virt_lans{$_[0]}->{"MEMBERLIST"}}; }
sub virtlanmustdelay($)	{ return $virt_lans{$_[0]}->{"MUSTDELAY"}; }
sub virtlanemulated($)	{ return $virt_lans{$_[0]}->{"EMULATED"}; }
sub virtlanlinkdelay($) { return $virt_lans{$_[0]}->{"USELINKDELAY"}; }
sub virtlannobwshape($)	{ return $virt_lans{$_[0]}->{"NOBWSHAPING"}; }
sub virtlantrivok($)	{ return $virt_lans{$_[0]}->{"TRIVIAL_OK"}; }
341
sub virtlanencapstyle($){ return $virt_lans{$_[0]}->{"ENCAPSTYLE"}; }
342
343
344
sub virtlantunnel($)	{ return $virt_lans{$_[0]}->{"TUNNEL"}; }
sub virtlandelayinfo($$){ return @{$virt_lans{$_[0]}->{"DELAYINFO"}->{$_[1]}};}
sub virtlanqueueinfo($$){ return @{$virt_lans{$_[0]}->{"QUEUEINFO"}->{$_[1]}};}
345
sub virtlantraceinfo($$){ return @{$virt_lans{$_[0]}->{"TRACEINFO"}->{$_[1]}};}
346
347
348
349
sub virtlannetmask($)	{ return $virt_lans{$_[0]}->{"MASK"}; }
sub virtlanwidearea($)  { return $virt_lans{$_[0]}->{"WIDEAREA"}; }
sub virtlanallsim($)    { return $virt_lans{$_[0]}->{"ALLSIM"}; }
sub virtlanprotocol($)  { return $virt_lans{$_[0]}->{"PROTOCOL"}; }
350
351
352
353
354
355
356
357
358
359
sub virtlandelayed($)   { return $virt_lans{$_[0]}->{"DELAYED"}; }
sub virtlansetdelayed($){ $virt_lans{$_[0]}->{"DELAYED"} = 1; }

sub virtlanmembershaped($$) {
    return $virt_lans{$_[0]}->{"SHAPEDMEMBERS"}->{$_[1]};
}
sub virtlansetmembershaped($$) {
    $virt_lans{$_[0]}->{"SHAPEDMEMBERS"}->{$_[1]} = 1;
    # Mark the lan as having shaped members.
}
360
361
362
363
364
sub virtlanAP($)        {
    return $virt_lans{$_[0]}->{"ACCESSPOINT"}
        if (defined($virt_lans{$_[0]}->{"ACCESSPOINT"}));
    return undef;
}
365
366
367
368
sub virtlanusevirtiface($) {
    my $encap = virtlanencapstyle($_[0]);
    return ($encap eq "veth" || $encap eq "veth-ne" || $encap eq "vlan");
}
369
370
371
372
sub virtlanusetuniface($) {
    my $encap = virtlanencapstyle($_[0]);
    return ($encap eq "gre" || $encap eq "egre" || $encap eq "vtun");
}
Robert Ricci's avatar
Robert Ricci committed
373
374
375
376
377
# We hardcode (for now) the set of LAN/link "protocols" that are wireless.
# Eventually, this should probably come from the database.
sub virtlanwireless($) {
    return (virtlanprotocol($_[0]) =~ /^(80211|flex900)/);
}
378
379
380
381
# Quick way to get to any fixed iface info for the lan and member.
sub virtlanfixediface($$) { 
    return $virt_lans{$_[0]}->{"MEMBERS"}->{$_[1]}->{"fixed_iface"};
}
Robert Ricci's avatar
Robert Ricci committed
382
383
384
385
386
387
388
389
390
# We don't actually store information about the protocol heirarchy in the
# database, so we use a simple conventions for now - <basetype>[-subtype]
sub protocolbasetype($) {
    if ($_[0] =~ /^([^-]+)-/) {
        return $1;
    } else {
        return $_[0];
    }
}
391

392
393
394
395
396
397
398
399
400
401
402
#
# virt_vtypes: The virt_vtypes table in the DB, indexed by the vtype
# name (user chosen name).
#
my %virt_vtypes = ();

#
# node_types: The node_types table from the DB, indexed by the type name.
#
my %node_types = ();

403
sub nodetypeistype($)   { return exists($node_types{$_[0]}); }
404
405
406
407
408
409
410
411
412
413
414
sub nodetypetype($)     { return $node_types{$_[0]}->type(); }
sub nodetypeclass($)    { return $node_types{$_[0]}->class(); }
sub nodedelayosid($)    { return $node_types{$_[0]}->delay_osid(); }
sub nodedefaultosid($)  { return $node_types{$_[0]}->default_osid(); }
sub nodetypeisremote($) { return $node_types{$_[0]}->isremotenode(); }
sub nodetypeisvirt($)   { return $node_types{$_[0]}->isvirtnode(); }
sub nodetypeisdynamic($){ return $node_types{$_[0]}->isdynamic(); }
sub nodetypeissub($)    { return $node_types{$_[0]}->issubnode(); }
sub nodetypeisplab($)   { return $node_types{$_[0]}->isplabdslice(); }
sub nodetypeissim($)    { return $node_types{$_[0]}->issimnode(); }
sub nodetypesimcap($)   { return $node_types{$_[0]}->simnode_capacity(); }
415
416
417
418
419
420
421
sub nodetypeisdedicatedremote($) {
    my $ded = $node_types{$_[0]}->GetAttribute("dedicated_widearea");
    if (defined($ded) && "$ded" eq "1") {
	return 1;
    }
    return 0;
}
422

Leigh B. Stoller's avatar
Leigh B. Stoller committed
423
# 
424
# interface_capabilities: We need this to find out the bandwidths of the devices
425
426
# we actually have on the testbed. Index by interface type name.
#
427
my %interface_capabilities = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
428

429
430
431
432
433
434
435
436
#
# XXX Hack table for determining if a delay node is required. We store
# the native link speeds for each type,class. Indexed by type and class,
# the value is a list of link hardware speeds for which no delay node is
# required. This is an awful way to do this, and quite wrong.
#
my %node_type_linkbw = ();

437
438
439
440
441
442
443
444
#
# phys_nodes: The equiv of virt_nodes above, except that these are pulled
# from the DB once the physical resources have been allocated. Indexed
# by physname, but there is a pointer from the virt_nodes table entry
# to the the corresponding physnode entry. 
# 
my %phys_nodes = ();

445
sub physnodeallocated($) { return exists($phys_nodes{$_[0]}); }
446
447
448
449
450
451
sub physnodeisvirtnode($){ return $phys_nodes{$_[0]}->{'p'}->isvirtnode();}
sub physnodeisjailed($)  { return $phys_nodes{$_[0]}->{'p'}->jailflag(); }
sub physnodeissubnode($) { return $phys_nodes{$_[0]}->{'p'}->issubnode(); }
sub physnodephysnode($)  { return $phys_nodes{$_[0]}->{'p'}->phys_nodeid(); }
sub physnodecontroliface($){return $phys_nodes{$_[0]}->{'p'}->control_iface();}
sub physnodetype($)      { return $phys_nodes{$_[0]}->{'p'}->type(); }
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
sub physnodesetvnode($$) { return $phys_nodes{$_[0]}->{"__vname"} = $_[1]; }
sub physnodevnode($$)    { return $phys_nodes{$_[0]}->{"__vname"}; }
sub physnodereuse($)     { return $phys_nodes{$_[0]}->{"__reuse"}; }
sub physnodesetreuse($$) { return $phys_nodes{$_[0]}->{"__reuse"} = $_[1]; }
sub physnodenextpipe($)  {
    my $pipeno = $phys_nodes{$_[0]}->{"__pipeno"} += 10;

    fatal("Too many ipfw pipes on node $pnode!")
	if ($pipeno >= 65535);
    
    return $pipeno;
}
sub physnodenextrtabid($)  {
    my $rtabid = $phys_nodes{$_[0]}->{"__rtabid"} += 1;
    return $rtabid;
}


#
# phys_node_interfaces: ???
#

sub physnodeinterface($$) { return $phys_node_interfaces{$_[0]}{$_[1]}; }
sub physinterfacetype($$) {
    return $phys_node_interfaces{$_[0]}{$_[1]}{"interface_type"};
}
478
479
480
sub physinterfacerole($$) {
    return $phys_node_interfaces{$_[0]}{$_[1]}{"role"};
}
481

482
483
484
485
486
487
488
489
490
491
492
493
494
495
#
# More physical side data structures.
# v2pmap is indexed by virtual and contains the physical node.
my %v2pmap = ();
# p2vmap is indexed by physical and contains one or more virtual nodes.
my %p2vmap = ();
# plinks is indexed by virtual name and contains
#  (pnodeportA,pnodeportB) .  If one is a delay node it is always
#  the second.
my %plinks = ();
# virtnodes is the list of subnodes on physnodes.
my %virtnodes = ();
my %v2vmap = ();

496
497
498
499
# for consing up vlan names.
my $vlanid = 0;
my %protovlans = ();

500
501
502
# Admission control counts
my %admission_control = ();

503
504
505
506
507
508
509
#
# Support for experiment modify. We create v2p and v2v mappings of the
# current topology so we can figure out how its changed after assign
# runs. These correspond to v2pmap and v2vmap mentioned above.
# 
my %reserved_v2pmap  = ();
my %reserved_v2vmap  = ();
510
my %oldreservednodes = ();
511
512
my %newreservednodes = ();
my $oldreservedclean = 0;
513
514
515
# reserved_p2vmap is indexed by physical and contains one or more virtual
# nodes
my %reserved_p2vmap  = ();
516

Leigh B. Stoller's avatar
Leigh B. Stoller committed
517
#
518
519
520
521
522
523
524
525
526
527
528
529
# Experiment wide options. See below. They come from the experiments table.
# Defining these will override experiment table setting. 
#
# Set this when forcing linkdelays instead of delay nodes. Set in the NS
# file with a tb-compat directive. The force directive says to set up a
# link delay, even when no delay would otherwise be inserted.
# usewatunnels is also set in the NS, and can be used to turn them off. 
# The multiplex_factor is to override node_types table for virtnode.
my $uselinkdelays;
my $forcelinkdelays;
my $usewatunnels;
my $multiplex_factor;
530
my $experiment_idx;
531
my $useprepass;
532
my $delaycap_override;
533
my $elabinelab = 0;
534
my $experiment;
535

536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
#
# Notes on virtual interfaces.
#
# If a link is EMULATED (virtlanemulated) then it will have an "encapsulation
# style" (virtlanencapstyle).  That value is one of:
#
# "alias"	emulation is done with IP aliases on a physical interface;
#		there is no packet encapsulation.
#		Works on FreeBSD or Linux.
#
# "veth"	emulation is done with "veth" virtual devices;
#		encapsulation is standard veth style.
#		Works on FreeBSD only.
#
# "veth-ne"	emulation is done with "veth" devices;
#		no encapsulation is used (uses made-up MAC addresses instead)
#		Works on FreeBSD only.
#
# "vlan"	emulation is done with "vlan" devices;
#		uses 802.1q VLAN tagging.
#		Works on FreeBSD or Linux.
#
# "default"	emulation style was not explicitly set by the users;
#		encap style depends on context ("veth" for vnode, "alias" ow)
#
# Note that the encapsulation style for "default" depends on the node type.
# For non-vnodes the default is "alias".  For vnodes the default is "veth"
# since they must always have some pseudo-device on which to hang a route
# table ID; i.e., we cannot just do IP aliasing.
#
# Encapsulation can be specified per link.  The default link encapsulation
# can also be specified by a per-experiment setting.  At the moment, only
# the latter (global) is implemented.
#
my $encapstyle;

572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
#
# Determine if a given link/lan uses linkdelays
#
sub virtlan_use_linkdelay($$) {
    my ($virtlan,$shaped) = @_;
    #
    # Here are the conditions for using linkdelays on each link/lan
    # Note: $forcelinkdelays and $uselinkdelays are global
    #
    if ( # linkdelays can be globally forced
         $forcelinkdelays ||
         # We use linkdelays on emulated virtlans
         virtlanemulated($virtlan) ||
         # The user requested linkdelays, and this is a virtlan that gets
         # shaped (note - in this case, non-shaped virtlans don't get
         # linkdelays)
         ($uselinkdelays && $shaped) ||
         # The user forced linkdelays for this specific virtlan
         virtlanlinkdelay($virtlan)) {
        # Yep, use linkdelays
        return 1;
    } else {
        # No - either won't be delayed at all, or we'll use a delay node
        return 0;
    }
}

599
600
601
602
# For admission control. Not well defined yet.
my $cpu_usage;
my $mem_usage;

603
604
605
606
# XXX woeful NSE hack
my $sim_osid;
my $sim_osname = "FBSD-NSE";

607
608
609
# Allow override of jail/delay osids.
my $jail_osid;
my $delay_osid;
610
my $delay_osid_desire;
611

612
613
614
615
616
617
# Flag that tells us whether to fix-node current
# resources or not during a swap modify. This is
# useful when vnode weights are tweaked by the experimenter
# before doing a swapmod
my $fix_current_resources;

618
######################################################################
Leigh B. Stoller's avatar
Leigh B. Stoller committed
619

620
621
622
623
624
# ips is indexed by node:port and contains the IP address for the port.
my %ips	      = ();

# memberof is indexed by node:port and holds the lan it is a member of.
my %memberof = ();
625
626

# delaylinks stores the actual link delay info, converted from the
627
# virt delay params above. It is indexed by link name and contains a
628
# [delay,bw,backfill,loss] array for each direction. The final member of the
629
630
631
# array is an indicator of whether the info is there strictly for a 
# trivial link (linkdelay inserted only when assign makes link trivial).
my %delaylinks     = ();
632
633
634
635
636
637
638
639
640
641
642

# delaynodes stores the names of delaynodes that we create on the
# fly using delayid. This is useful for doing isdelay? tests.
my %delaynodes = ();
my $delayid    = 0;

# nodedelays and linkdelays are the final (!) representation. Indexed by
# integer id, they store the physical node info and the delay info. 
my %nodedelays = ();
my %linkdelays = ();

643
644
645
646
# Virtual nodes that the user has requested be "fixed" to a specific
# physical node.
my %fixed_nodes     = ();

647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
# portbw is indexed by virtual nodeport and contains the bandwidth of
# that port. Note that port bandwidth in the interfaces table is left
# in Mbps units for now. Thats inconsistent, I know. For LANs with
# other bandwidths the port speed will be 100 and a delay node will be
# inserted.
my %portbw = ();

# lannodes is indexed by physical name and is the set of fake lan nodes.
# lan nodes are named lan/<virtual lan>. We need to know these so that
# when they come back from assign, we can ignore them.
my %lannodes = ();

# Node estimates and counts. Avoid running assign if there is no way to
# satisfy the estimates for physical nodes.
my $minimum_nodes;
my $maximum_nodes;
663
664
my $reserved_pcount  = 0;
my $reserved_vcount  = 0;
665
my $reserved_simcount= 0;
666
667
668
669
my $remotecount      = 0;
my $virtcount        = 0;
my $plabcount        = 0;
my $needwanassign    = 0;
670
my $simcount         = 0;
671

672
673
674
# for checks made during topfile creation.
my $toperrors        = 0;

675
676
677
678
679
680
681
682
683
684
685
686
#
# This is for stats gathering. It might duplicate other stuff, but
# thats okay.
#
my %expt_stats = (# pnodes include jailnodes and delaynodes.
		  # We let the wrapper determine pnodes once the
		  # experiment is fully swapped in so that the record
		  # is not "committed" until successful swapin.
		  jailnodes   => 0,
		  vnodes      => 0,
                  # vnodes include wanodes.
		  wanodes     => 0,
687
688
		  # wanodes includes plabnodes.
		  plabnodes   => 0,
689
690
691
692
693
694
		  simnodes    => 0,
		  delaynodes  => 0,
		  linkdelays  => 0,
		  links       => 0,
		  walinks     => 0,
		  lans        => 0,
695
		  wirelesslans => 0,
696
697
698
699
700
701
702
		  shapedlinks => 0,
		  shapedlans  => 0,
		  minlinks    => 100000,
		  # includes emulated links. Maybe thats wrong.
		  maxlinks    => 0,
);

703
704
705
my $simhost_id     = 0;
my %pnode2simhostid;
my %simhostid2pnode;
Shashi Guruprasad's avatar
Shashi Guruprasad committed
706

707
# Counters for generating IDs.
708
my $virtnode_id  = 0;
709
my $veth_id      = 0;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
710

711
712
713
714
715
716
717
718
719
720
#
# Every vnode on a pnode gets its own routing
# table, thus an rtabid. In the case of simulated
# nodes, we need rtabids only for border nodes
# i.e. nodes that have links going out of the pnode.
# Either way, new rtabids are requested via getrtabid(<vnode>,<pnode>)
# when the interfaces table is updated or new veth_interfaces
# are inserted. This hash maintains the rtabids per vnode
my %vnode2rtabid = ();

721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
#
# OSinfo lookups.
#
sub osidlookup($)
{
    my $osid   = $_[0];
    my $osinfo = OSinfo->Lookup($osid);
    if (!defined($osinfo)) {
	tbwarn("No such OSID $osid\n");
	return undef;
    }
    return $osinfo;
}
sub osidpath($)
{
    my $osinfo = osidlookup($_[0]);
    return (defined($osinfo) ? $osinfo->path() : undef);
}
sub osidos($)
{
    my $osinfo = osidlookup($_[0]);
    return (defined($osinfo) ? $osinfo->OS() : undef);
}
sub osidfeaturesupported($$)
{
    my $osinfo = osidlookup($_[0]);
    return (defined($osinfo) ? $osinfo->FeatureSupported($_[1]) : 0);
}
sub osidhaspath($)
{
    my $path = osidpath($_[0]);
    return (defined($path) && ($path ne ""));
}
sub osidnextosinfo($)
{
    my $osinfo = osidlookup($_[0]);
    return undef
	if (!defined($osinfo));
    return $osinfo
	if (!defined($osinfo->nextosid()));
    my $nextosinfo = $osinfo->ResolveNextOSID($experiment);
    return undef
	if (!defined($nextosinfo));
    return $nextosinfo;
}
sub osidnextosid($)
{
    my $nextosinfo = osidnextosinfo($_[0]);
    return (defined($nextosinfo) ? $nextosinfo->osid() : undef);
}
sub osidbootcmd($$$)
{
    my ($osid, $role, $default) = @_;
    my $nextosinfo = osidnextosinfo($osid);
    return undef
	if (!defined($nextosinfo) ||
	    $nextosinfo->OSBootCmd($role, \$default) != 0);
    return $default;
}

781
782
######################################################################
# Step 1 - Setup virtual topology
783
#
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
# Here we need to read the virtual topology in from the virt_nodes
# and virt_lans table.  We then need to add delay and lan nodes as
# necessary.
#
# Conversion details:
#   Let L be a LAN with N members.
#   If N == 2 
#      Let N1 be node 1
#      Let N2 be node 2
#      If L is delayed
#         Generate delay node D
#         Link N1 to D
#         Link N2 to D
#      Else
#         Link N1 to N2
#   Else
#      Generate lan node A
#      If L is delayed
#        Foreach node N in L
#           Generate delay node DN
#           Link A to DN
#           Link N to DN
#      Else
#        Foreach node N in L
#           Link N to A
#
# Delay node names:
#  delay nodes are named tbdelayXX N > 2
#   and tbsdelayXX for N == 2.
#
########################################################################
Chad Barb's avatar
   
Chad Barb committed
815

816
817

# Slowly convert to using Experiment module.
818
$experiment = Experiment->Lookup($pid, $eid);
819
820
821
822
if (!defined($experiment)) {
    fatal("Could not lookup experiment object!")
}

823
824
printdb "Generating TOP file.\n";
TBDebugTimeStamp("TOP started");
825

826
827
828
#
# Do admission control test right away.
#
829
if (!($toponly || $regression)) {
830
    fatal("Failed admission control checks!")
831
	if (!TBAdmissionControlCheck(undef, $experiment, \%admission_control));
832
833
}

834
835
836
837
838
839
#
# vtypes are a funny mix beteween physical and virtual state, so we have to
# load them before getting the PhysInfo.
#
LoadVirtTypes();

840
841
842
843
844
#
# Load phys info. Interface types, node types, etc. Its any physical stuff
# we need.
#
LoadPhysInfo();
845

846
847
848
849
#
# Load the Experiment info and virt topology.
#
LoadExperiment();
850

851
852
853
854
855
856
if ($regression) {
    print STDERR "Freeing reserved nodes in regression mode\n";
    system("export NORELOAD=1; $NFREE -x -a $pid $eid") == 0
	or fatal("Could not release nodes in regression mode");
}

857
858
859
860
#
# If updating, load current experiment resources. We have to be careful
# of how this is merged in with the (new) desired topology. See below.
#
861
862
863
if ($updating || $regression) {
    LoadCurrent()
	if ($updating);
864
    print STDERR "Resetting DB before updating.\n";
865
    $experiment->RemovePhysicalState();
866
}
Chad Barb's avatar
   
Chad Barb committed
867

868
869
870
871
#
# Check Max Concurrent for OSID violations.
#
CheckMaxConcurrent();
872

873
874
875
876
#
# Create the TOP file.
#
CreateTopFile();
877

878
879
TBDebugTimeStamp("TOP finished");

880
881
882
883
# Stop if creating the top file generated errors.
exit($WRAPPER_FAILED)
    if ($toperrors);

884
885
886
887
# Stop here ...
if ($toponly) {
    print "Stopping after creating the TOP file, as directed.\n";
    exit(0);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
888
}
889

890

891
892
893
894
895
896
897
898
899
######################################################################
# Step 2 - Assign Loop
# 
# Here we loop up to maxrun times.  In each loop we snapshot the
# current testbed state into a ptop file.  We then run assign.  If
# assign succeeds we attempt to reserve the resources.  If that works
# we're done with step 2 otherwise we loop again.
#
#######################################################################
Leigh B. Stoller's avatar
Leigh B. Stoller committed
900

901
902
my $currentrun = 1;
my $canceled   = 0;
Kevin Atkinson's avatar
   
Kevin Atkinson committed
903
my $tried_precheck = 0;
904
905

# XXX plab hack - only run assign once on plab topologies, since they're easy
906
# to map and the physical topology does not change frequently.
907
if ($plabcount && (keys(%virt_nodes) == $plabcount)) {
908
    $maxrun = 2;
909
}
910

911
912
TBDebugTimeStamp("assign_loop started");
while (1) {
913
    print "Assign Run $currentrun\n";
914

915
    #
916
917
    # RunAssign returns  0 if successful.
    #           returns -1 if failure, but assign says to stop trying.
918
919
    #           returns  1 if failure, but assign says to try again.
    #           returns  2 if we made some forward progress.
920
    #
921
    my $retval = RunAssign();
922
923
924
925

    # Success!
    last
	if ($retval == 0);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
926

927
928
929
930
931
    if ($regression) {
	FinalizeRegression(1);
	fatal("Failed to find solution in regression mode");
    }

Kevin Atkinson's avatar
   
Kevin Atkinson committed
932
    if (!$precheck && !$tried_precheck) {
Kevin Atkinson's avatar
   
Kevin Atkinson committed
933
	my $ptopfile0 = $ptopfile;
Kevin Atkinson's avatar
   
Kevin Atkinson committed
934
935
	my $impotent0 = $impotent;
	print("Trying assign on an empty testbed.\n");
Kevin Atkinson's avatar
   
Kevin Atkinson committed
936
	$ptopfile = "$pid-$eid-$$-empty.ptop";
Kevin Atkinson's avatar
   
Kevin Atkinson committed
937
938
939
940
	$impotent = 1;
	$precheck = 1;
	my $retval = RunAssign();
	if ($retval != 0) {
941
942
	    fatal({type=>'extra', cause=>'user', severity=>SEV_ERROR,
	           error=>['infeasible_resource_assignment']}, 
Kevin Atkinson's avatar
   
Kevin Atkinson committed
943
944
945
946
947
948
949
		  "This experiment cannot be instantiated on this ".
                  "testbed. You have most likely asked for hardware ".
                  "this testbed does not have, such as nodes of a type ".
                  "it does not contain, or nodes with too many network ".
                  "interfaces.  You will need to modify this experiment ".
                  "before it can be swapped in - re-submitting the ".
                  "experiment as-is will always result in failure.");
Kevin Atkinson's avatar
   
Kevin Atkinson committed
950
951
952
953
	}
	print("Assign succeeded on an empty testbed.\n");
	$precheck = 0;
	$impotent = $impotent0;
Kevin Atkinson's avatar
   
Kevin Atkinson committed
954
	$ptopfile = $ptopfile0;
Kevin Atkinson's avatar
   
Kevin Atkinson committed
955
956
957
958
	$tried_precheck = 1;
    }


959
    if ($currentrun >= $maxrun && $retval != 2) {
960
961
962
	fatal({type => 'primary', severity => SEV_ERROR,
	       error => ['reached_assign_run_limit']},
	      "Reached run limit. Giving up.");
963
964
    }

965
966
967
968
    if ($retval < 0) {
	#
	# Failure in assign.
	#
969
970
971
	fatal({type => 'primary', severity => SEV_ERROR,
	       error => ['unretriable_assign_error']},
	      "Unretriable error. Giving up.");
972
    }
973
    
974
975
976
977
978
979
980
981
982
    print "Waiting 5 seconds and trying again...\n";
    sleep(5);
    $currentrun++;
}
TBDebugTimeStamp("assign_loop finished");

#
# Run assign once.
# 
983
sub RunAssign ()
984
985
{
    # Clear globals for each run.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
986
987
    undef %v2pmap;
    undef %p2vmap;
988
    undef %v2vmap;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
989
    undef %plinks;
990
    undef %virtnodes;
991
992
993

    my %toreserve = ();
    my %subnodes  = ();
Shashi Guruprasad's avatar
Shashi Guruprasad committed
994
    
995
    TBDebugTimeStamp("ptopgen started");
996
    # Snapshot physical resources.
Chad Barb's avatar
   
Chad Barb committed
997
998
999
1000
    #
    # if updating (-u), include any resources that may already be
    # allocated to experiment in the PTOP results.
    #
1001
1002
    my $ptopargs = "-p $pid ";
    $ptopargs   .= "-e $eid "
1003
	if ($updating);
1004
1005
    $ptopargs   .= "-u "
	if ($updating && $elabinelab);
1006
1007
    $ptopargs   .= "-m $multiplex_factor "
	if (defined($multiplex_factor));
1008
1009
    $ptopargs   .= "-v "
	if ($virtcount);
1010
1011
    $ptopargs   .= "-r "
	if ($remotecount);
1012
1013
    $ptopargs   .= "-S "
	if ($simcount);
1014
1015
    $ptopargs	.= "-a "
    	if ($precheck);
1016
1017
1018
1019
    $ptopargs	.= "-c $delaycap_override "
    	if (defined($delaycap_override));

    print "ptopargs $ptopargs\n";
1020
    system("ptopgen $ptopargs > $ptopfile");
1021
    TBDebugTimeStamp("ptopgen finished");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1022

1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
    if (scalar(keys(%admission_control))) {
	open(PTOP, ">> $ptopfile") or
	    return -1;

	foreach my $typeclass (keys(%admission_control)) {
	    my $count = $admission_control{$typeclass};

	    print PTOP "set-type-limit $typeclass $count\n";
	}
	close(PTOP);
    }

1035
    TBDebugTimeStamp("assign started");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1036
    # Run assign
1037
1038
    my $cmdargs = "-P $ptopfile $topfile";
    $cmdargs = "-uod -c .75 $cmdargs"
1039
	if ($virtcount || $simcount);
1040
1041
    $cmdargs = "-n $cmdargs"
    	if ($precheck);
1042
1043
    $cmdargs = "-s 123456 $cmdargs"
    	if ($regression);
1044
1045
1046
1047
1048

    my $cmd;

    # If doing an experiment with virtnodes, use the prepass wrapper for assign
    # Turned off for now, because it needs some work.
1049
1050
1051
1052
1053
1054
1055
1056
    if ($useprepass) {
    	$cmd = "assign_prepass";
    	$cmdargs = "-m $multiplex_factor $cmdargs"
    	    if ($multiplex_factor);
    } else {
    	$cmd = "assign";
    }

1057
    print "$cmd $cmdargs\n";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1058

1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
    #
    # Fork a child to run assign. Parent spins watching the cancel flag
    # and waiting for assign to finish.
    #
    if (my $childpid = fork()) {
	while (1) {
	    sleep(2);

	    if (waitpid($childpid, &WNOHANG) == $childpid) {
		$assignexitcode = $? >> 8;
		last;
	    }

	    # Check cancel flag.
1073
	    TBGetCancelFlag($pid, $eid, \$canceled);
1074
1075
1076
1077
	    if ($canceled) {
		if ((my $pgrp = getpgrp($childpid)) > 0) {
		    kill('TERM', -$pgrp);
		    waitpid($childpid, 0);
1078

1079
1080
1081
		    fatal({cause => 'canceled', severity => SEV_IMMEDIATE,
			   error => ['cancel_flag']},
			  "Cancel flag set; aborting assign run!");
1082
		    return -1;
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
		}
		# Loop again to reap child above before exit.
	    }
	}
    }
    else {
	#
	# Change our session so the child can get a killpg without killing
	# the parent. 
	#
        POSIX::setsid();
Kevin Atkinson's avatar
   
Kevin Atkinson committed
1094
	exec("nice assign_wrapper2 $cmd $cmdargs > assign.log");
Kevin Atkinson's avatar
Kevin Atkinson committed
1095
	die "Could not start assign!\n";
1096
    }
Chad Barb's avatar
Chad Barb committed
1097

1098
    # Check cancel flag before continuing. 
1099
    TBGetCancelFlag($pid, $eid, \$canceled);
1100
    if ($canceled) {
1101
1102
1103
	fatal({cause => 'canceled', severity => SEV_IMMEDIATE,
	       error => ['cancel_flag']},
	      "Cancel flag set; aborting assign run!");
1104
1105
	return -1;
    }
1106

1107
1108
    # Check for possible full filesystem ...
    if (-z "assign.log") {
Kevin Atkinson's avatar
   
Kevin Atkinson committed
1109
	tbnotice("assign.log is zero length! Stopping ...\n");
1110
1111
1112
	return -1;
    }

1113
1114
1115
    # Saving up assign.log coz each swapin/modify is
    # different and it is nice to have every mapping
    # for debugging and archiving purposes
1116
1117
    # We do not call it .log though, since we do not want it copied
    # out to the user directory every swapin. See Experiment.pm
1118
1119
    my $assignlog = ($regression ? "$pid-$eid.assign" : "$pid-$eid-$$.assign");
    system("/bin/cp assign.log $assignlog");
1120
1121
1122
1123
    if (!open(ASSIGNFP, "assign.log")) {
	print("Could not open assign logfile!\n");
	return -1;
    }
1124

1125
1126
1127
    printdb "Reading assign results.\n";

    #
Kevin Atkinson's avatar
   
Kevin Atkinson committed
1128
1129
1130
    # We no longer care what assign has to say when it fails!
    # Any relevent info was already sent to stderr so just 
    # tell the caller whether we want to keep trying or not.
1131
1132
    #
    if ($assignexitcode) {
Kevin Atkinson's avatar
   
Kevin Atkinson committed
1133
	close ASSIGNFP;
1134
	return (($assignexitcode == 1) ? 1 : -1);
1135
    }
1136
    
1137
1138
1139
1140
1141
1142
1143
1144
1145
    #
    # If we were doing the precheck, go ahead and exit now - there won't be
    # any useful information to parse out
    #
    if ($precheck) {
	print "Precheck succeeded.\n";
	return 0;
    }

1146
1147
1148
1149
    #
    # Assign success; parse results.
    # 
    # read nodes section
1150
1151
    my $found_nodes_section = 0;
    while (<ASSIGNFP>) {
1152
1153
	# find the 'BEST SCORE' line and print that out for informational
	# purposes
1154
1155
	if (/BEST SCORE/) {
	    print;
1156
	}
1157
1158
1159
1160
1161
1162
1163
1164
1165
        if (/^Nodes:/) {
            $found_nodes_section = 1;
            last;
        }
    }
    if (!$found_nodes_section) {
        tbwarn("Internal error - unable to find Nodes section in " .
               "assign output");
        return 1;
1166
    }
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
    printdb "Nodes:\n";
    while (<ASSIGNFP>) {
	chop;
	/^End Nodes$/ && last;
	@info = split;
	my ($virtual,$physical) = @info[0,1];

	# We don't care about LAN nodes anymore.
	if (defined($lannodes{$virtual})) {
	    next;
	}

	if (physnodeallocated($physical)) {
	    #
	    # Mark node as being reused.
	    #
	    # Look at virtual node being mapped to node;
	    # if it wasn't in the previous map, mark node for reboot.
	    #
	    if (physnodereuse($physical) eq "reboot") {
		# No changes once it goes into reboot.
		;
	    }
	    elsif (virtnodeisvirt($virtual)) {
1191
		#
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
		# A new virt virtual node on an existing physical node
		# does not force the physnode to be rebooted; we can
		# set up a new virtnode on it without a reboot. If its
		# an existing virtual on the same physnode, then mark
		# both as reused; no need to reboot either. If the 
		# virtnode has moved here from someplace else, no
		# reboot of the physnode either, but obviously the
		# vnode will be released and a new one allocated.  What
		# we cannot determine is if its just a renamed node
		# (which would require a reboot of the the virtual
		# node). 
		# 
		if (!exists($reserved_v2pmap{$virtual})) {
		    physnodesetreuse($physical, "reused");
Chad Barb's avatar
   
Chad Barb committed
1206
		}
1207
1208
		elsif ($reserved_v2pmap{$virtual} eq $physical) {
		    my $reserved = $reserved_v2vmap{$virtual};
1209

1210
1211
		    physnodesetreuse($reserved, "reused");
		    physnodesetreuse($physical, "reused");
1212
1213
		}
		else {
1214
		    physnodesetreuse($physical, "reused");
1215
1216
1217
		}
	    }
	    else {
Chad Barb's avatar
   
Chad Barb committed
1218
		#
1219
1220
1221
1222
1223
1224
1225
		# If a new virtual node mapped to this physnode (maybe
		# even the luser changed the name of the node), or if an
		# existing virtual node moved to this physnode, must
		# reboot the physnode. Else, the physnode is being
		# reused as is, and no need to mess with it. If the
		# user requested reboot, that will be handled outside
		# of this script.
1226
		#
1227
1228
1229
1230
1231
1232
		if (!exists($reserved_v2pmap{$virtual}) ||
		    $reserved_v2pmap{$virtual} ne $physical) {
		    physnodesetreuse($physical, "reboot");
		}
		else {
		    physnodesetreuse($physical, "reused");
1233
		}
1234
	    }
1235
1236
1237
1238
1239
1240
1241
1242
	}
	else {
	    #
	    # This is a new node; we'll have to reserve it. Note that
	    # we do not reserve a widearea physnode when a virtual node
	    # is mapped to it; they are special.
	    #
	    $toreserve{$physical} = 1
1243
1244
1245
		if (!virtnodeisvnode($virtual) ||
		    !(virtnodeisremote($virtual)
		      && !nodetypeisdedicatedremote(virtnodetype($virtual))));
1246
1247
1248
1249
1250
1251
1252
1253
1254
	}
	
	if (virtnodeisvirt($virtual)) {
	    #
	    # If mapping a virtual node, then record that, since we need
	    # to allocate the virtnodes on that physnode, later.
	    #
	    if (!defined($virtnodes{$physical})) {
		$virtnodes{$physical} = [];
Shashi Guruprasad's avatar
Shashi Guruprasad committed
1255
	    }
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
	    push(@{$virtnodes{$physical}}, $virtual);
	}
	elsif (virtnodeissubnode($virtual)) {
	    #
	    # Need to allocate the parent to. Should be optional?
	    # Save away and deal with once we have all the results.
	    #
	    $subnodes{$virtual} = $physical;
	}
	
	$v2pmap{$virtual} = $physical;
	if( ! defined($p2vmap{$physical}) ) {
	    $p2vmap{$physical} = [];
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1269
	}
1270
1271
1272
	push(@{$p2vmap{$physical}}, $virtual);
	printdb "  $virtual $physical\n";
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1273

1274
1275
1276
1277
1278
1279
1280
1281
1282
    #
    # Process the subnodes. We have to allocate the parent at the same
    # time, lest it get sucked away for some other purpose by another
    # experiment. We might want to push this off into nalloc, but not
    # sure yet.
    #
    for my $virtual (keys(%subnodes)) {
	my $physical = $subnodes{$virtual};
	my $parent;
1283

1284
	TBPhysNodeID($physical, \$parent);
1285

1286
	printdb "  Subnode: $virtual $physical $parent\n";
1287

1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
	#
	# See if we already have it. Swapmod, retry, or perhaps
	# the parent could be named separately? Or maybe there are
	# several subnodes on the physnode?
	#
	next
	    if (exists($p2vmap{$parent}));