libvtop_stable.pm.in 239 KB
Newer Older
1
#!/usr/bin/perl -w
2
3
#
# EMULAB-COPYRIGHT
4
# Copyright (c) 2005-2011 University of Utah and the Flux Group.
5
6
# All rights reserved.
#
7
package libvtop_stable;
8
9
10
11

use strict;
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK
12
	    $VTOP_FLAGS_UPDATE $VTOP_FLAGS_VERBOSE $VTOP_FLAGS_QUIET
13
	    $VTOP_FLAGS_FIXNODES $VTOP_FLAGS_IMPOTENT $VTOP_FLAGS_ALLOCONLY
14
	    $VTOP_FLAGS_REGRESSION);
15
16
17
18
19

@ISA    = "Exporter";
@EXPORT = qw( );

use libdb;
20
use libtblog_simple;
21
22
23
24
25
26
27
28
29
30
use libtestbed;
use Experiment;
use VirtExperiment;
use Node;
use NodeType;
use Lan;
use OSinfo;
use English;
use Data::Dumper;
use Carp;
31
use POSIX;
32
use XML::LibXML;
33
use XML::Simple;
34
use GeniHRN;
35
36

# Configure variables
37
38
my $TB		  = "@prefix@";
my $BOSSNODE      = "@BOSSNODE@";
39
my $AVAIL         = "$TB/bin/avail";
40
41
42
my $NALLOC        = "$TB/bin/nalloc";
my $NFREE         = "$TB/bin/nfree";
my $OS_SELECT     = "$TB/bin/os_select";
43
my $DELAYCAPACITY = @DELAYCAPACITY@;	# Can be overridden by user.
44
my $DELAYTHRESH   = @DELAYTHRESH@;
45
my $PGENISUPPORT  = @PROTOGENI_SUPPORT@;
46
my $OURDOMAIN     = "@OURDOMAIN@";
47
my $mycmurn       = GeniHRN::Generate("@OURDOMAIN@", "authority", "cm");
48
49
50
51

# Flags.
$VTOP_FLAGS_VERBOSE	= 0x01;
$VTOP_FLAGS_UPDATE	= 0x02;
52
$VTOP_FLAGS_FIXNODES	= 0x04;
53
$VTOP_FLAGS_IMPOTENT	= 0x08;
54
$VTOP_FLAGS_REGRESSION  = 0x10;
55
$VTOP_FLAGS_QUIET       = 0x20;
56
$VTOP_FLAGS_ALLOCONLY	= 0x40;
57

58
@EXPORT_OK = qw($VTOP_FLAGS_UPDATE $VTOP_FLAGS_VERBOSE $VTOP_FLAGS_FIXNODES
59
60
		$VTOP_FLAGS_IMPOTENT $VTOP_FLAGS_REGRESSION $VTOP_FLAGS_QUIET
		$VTOP_FLAGS_ALLOCONLY);
61
62
63
64

#
# Create an object representing the stuff we need to create the vtop file.
#
65
sub Create($$$$)
66
{
67
    my ($class, $experiment, $user, $flags) = @_;
68
69
70
71
72
73
74
75
76

    my $virtexperiment = VirtExperiment->Lookup($experiment);
    if (!defined($virtexperiment)) {
	tberror("Could not load virtual experiment object for $experiment\n");
	return undef;
    }

    my $self              = {};
    $self->{'EXPERIMENT'} = $experiment;
77
    $self->{'USER'}       = $user;
78
79
80
    $self->{'VIRTEXPT'}   = $virtexperiment;
    $self->{'FLAGS'}      = $flags;
    $self->{'VNODES'}     = {};
81
82
    $self->{'DELAYNODES'} = {};
    $self->{'LANNODES'}   = {};
83
    $self->{'VLANS'}      = {};
Leigh B Stoller's avatar
Leigh B Stoller committed
84
    $self->{'VPATHS'}     = {};
85
86
87
88
    $self->{'MEMBEROF'}   = {};
    $self->{'COUNTERS'}   = {};
    $self->{'EXPTSTATS'}  = {};
    $self->{'DELAYLINKS'} = {};
Leigh B Stoller's avatar
Leigh B Stoller committed
89
    $self->{'VLINKS'}     = {};
90
91
    $self->{'OPTIONS'}    = {};
    $self->{'DELAYID'}    = 0;
92
    $self->{'PHOSTID'}    = 0;
93
    $self->{'IFACEID'}    = 32768;
94
    $self->{'PORTBW'}     = {};
95
96
97
98
    $self->{'RESULTS'}    = { "nodes"  => [],
			      "links"  => [],
			      "class"  => [],
			      "fixed"  => [] };
99
    $self->{'RSPEC'}      = {};
100
    $self->{'GENIRSPEC'}  = undef;
101
102

    # Mostly for update mode.
103
104
105
106
    $self->{'FIXEDNODES'}  = {};
    $self->{'CURRENT_V2P'} = {};
    $self->{'CURRENT_P2V'} = {};
    $self->{'CURRENT_V2V'} = {};
107
108
    $self->{'OLDRSRVCLEAN_FLAG'}  = 0;
    $self->{'OLDRSRVCLEAN_NODES'} = {};
109
110

    # Below is for interpretation of assign results.
111
    $self->{'PNODES'}      = {};
112
113
    $self->{'SOLUTION'}    = {};
    $self->{'NEWRESERVED'} = {};	# Newly reserved nodes.
114
    $self->{'NORECOVER'}   = 0;	
115
    
116
    bless($self, $class);
117
118
    $virtexperiment->Dump()
	if (0 && $self->verbose());
119
120
121
122
123

    return $self;
}
# accessors
sub experiment($)       { return $_[0]->{'EXPERIMENT'}; }
124
sub user($)             { return $_[0]->{'USER'}; }
125
126
127
sub virtexperiment($)   { return $_[0]->{'VIRTEXPT'}; }
sub flags($)            { return $_[0]->{'FLAGS'}; }
sub vnodes($)           { return $_[0]->{'VNODES'}; }
128
129
sub delaynodes($)       { return $_[0]->{'DELAYNODES'}; }
sub lannodes($)         { return $_[0]->{'LANNODES'}; }
130
sub vlans($)            { return $_[0]->{'VLANS'}; }
131
sub memberof($)         { return $_[0]->{'MEMBEROF'}; }
Leigh B Stoller's avatar
Leigh B Stoller committed
132
sub vpaths($)           { return $_[0]->{'VPATHS'}; }
133
sub counters($)         { return $_[0]->{'COUNTERS'}; }
134
sub counter($$)         { return $_[0]->{'COUNTERS'}->{$_[1]}; }
135
sub options($)          { return $_[0]->{'OPTIONS'}; }
136
137
sub option($$)          { return (exists($_[0]->{'OPTIONS'}->{$_[1]}) ?
				  $_[0]->{'OPTIONS'}->{$_[1]} : undef); }
138
sub exptstats($)        { return $_[0]->{'EXPTSTATS'}; }
Leigh B Stoller's avatar
Leigh B Stoller committed
139
sub vlinks($)           { return $_[0]->{'VLINKS'}; }
140
141
142
sub delaylinks($)       { return $_[0]->{'DELAYLINKS'}; }
sub delaynodecount()    { return scalar(keys(%{ $_[0]->delaynodes() })); }
sub portbw($)           { return $_[0]->{'PORTBW'}; }
143
sub results($)          { return $_[0]->{'RESULTS'}; }
144
145
146
147
148
sub current_v2p($)      { return $_[0]->{'CURRENT_V2P'}; }
sub current_p2v($)      { return $_[0]->{'CURRENT_P2V'}; }
sub current_v2v($)      { return $_[0]->{'CURRENT_V2V'}; }
sub pnodes($)           { return $_[0]->{'PNODES'}; }
sub fixednodes($)       { return $_[0]->{'FIXEDNODES'}; }
149
sub newreserved($)      { return $_[0]->{'NEWRESERVED'}; }
150
sub rspec($)            { return $_[0]->{'RSPEC'}; }
151
sub genirspec($)        { return $_[0]->{'GENIRSPEC'}; }
152
sub newreservednodes($) { return keys(%{ $_[0]->{'NEWRESERVED'} }); }
153
sub oldreservednodes($) { return $_[0]->{'OLDRSRVCLEAN_NODES'}; }
154
sub norecover($)        { return $_[0]->{'norecover'}; }
155
156
157
158
159
160
161
162
163
sub pid($)		{ return $_[0]->experiment()->pid(); }
sub pid_idx($)		{ return $_[0]->experiment()->pid_idx(); }
sub eid($)		{ return $_[0]->experiment()->eid(); }
sub exptidx($)		{ return $_[0]->experiment()->idx(); }

# The virtual tables from the DB.
sub virt_table($$)      { return $_[0]->virtexperiment()->Table($_[1]); }
sub virt_vtypes($)	{ return $_[0]->virt_table("virt_vtypes"); }
sub virt_nodes($)       { return $_[0]->virt_table("virt_nodes"); }
164
165
sub virt_lans($)        { return $_[0]->virt_table("virt_lans"); }
sub virt_lan_lans($)    { return $_[0]->virt_table("virt_lan_lans"); }
Leigh B Stoller's avatar
Leigh B Stoller committed
166
sub virt_paths($)       { return $_[0]->virt_table("virt_paths"); }
167
168
sub virt_desires($)	{ return $_[0]->virt_table("virt_node_desires"); }
sub virt_startloc($)	{ return $_[0]->virt_table("virt_node_startloc"); }
169
170
171
172
sub virt_trafgens($)	{ return $_[0]->virt_table("virt_trafgens"); }
sub virt_lan_settings($){ return $_[0]->virt_table("virt_lan_settings"); }
sub virt_lan_member_settings($)	{
    return $_[0]->virt_table("virt_lan_member_settings"); }
173
174
175
176

# Given a vname, is it a node in the topo (or something else like a delay).
sub isatoponode($$)     { return exists($_[0]->vnodes()->{$_[1]}); }
sub isadelaynode($$)    { return exists($_[0]->delaynodes()->{$_[1]}); }
177
178
179

# Debug output.
sub verbose($)		{ return $_[0]->flags() & $VTOP_FLAGS_VERBOSE; }
180
sub quiet($)		{ return $_[0]->flags() & $VTOP_FLAGS_QUIET; }
181
sub updating($)		{ return $_[0]->flags() & $VTOP_FLAGS_UPDATE; }
182
sub fixcurrent($)	{ return $_[0]->flags() & $VTOP_FLAGS_FIXNODES; }
183
sub impotent($)		{ return $_[0]->flags() & $VTOP_FLAGS_IMPOTENT; }
184
sub alloconly($)	{ return $_[0]->flags() & $VTOP_FLAGS_ALLOCONLY; }
185
sub regression($)	{ return $_[0]->flags() & $VTOP_FLAGS_REGRESSION; }
186
sub printdb($$)		{ print $_[1] if ($_[0]->verbose()); return 1; }
187

188
# We name delay nodes internally as they are needed.
189
sub nextdelayname($)    { return "tbdelay" . $_[0]->{'DELAYID'}++; }
190
# For when the user wants a specific delay os. Use a desire.
191
192
193
194
# sub delay_desire($)	{ return $_[0]->option("delay_desire_string"); }
sub delay_desire_type($)	{ return $_[0]->option("delay_desire_type"); }
sub delay_desire_name($)	{ return $_[0]->option("delay_desire_name"); }
sub delay_desire_penalty($)	{ return $_[0]->option("delay_desire_penalty"); }
195
196
# For XML
sub nextifacenumber($)  { return $_[0]->{'IFACEID'}++; }
197
sub nextphostnumber($)  { return $_[0]->{'PHOSTID'}++; }
198

199
200
201
202
# Virtual Types. 
sub virttypeisvtype($$) { return $_[0]->virt_vtypes()->Find($_[1]); }
sub VirtTypes($)        { return $_[0]->virt_vtypes()->Rows(); }

203
204
205
# Caller will want these.
sub minimum_nodes($)    { return $_[0]->counter("minimum_nodes"); }
sub maximum_nodes($)    { return $_[0]->counter("maximum_nodes"); }
206
sub nodecount($)	{ return $_[0]->counter("nodecount"); }
207
sub plabcount($)	{ return $_[0]->counter("plabcount"); }
208
sub genicount($)	{ return $_[0]->counter("genicount"); }
209
210
211
sub virtnodecount($)	{ return $_[0]->counter("virtcount"); }
sub simnodecount($)	{ return $_[0]->counter("simcount"); }
sub remotenodecount($)	{ return $_[0]->counter("remotecount"); }
212
sub sharednodecount($)	{ return $_[0]->counter("sharedcount"); }
213

214
sub createLink($$$$$$$$$)
215
{
216
217
218
    # $others here will be a hashtable for the link flags.  The table
    # could also contain non-default values for latency and
    # packet_loss
219
    my ($self, $name, $plink, $cm, $src, $dst, $bw, $type, $others) = @_;
Tarun Prabhu's avatar
Tarun Prabhu committed
220
    my $ref = {
221
222
223
	'virtual_id'     => $name,
	'plink'		 => $plink,
	'manager_urn'    => $cm,
224
	'link_type'      => $type,
Tarun Prabhu's avatar
Tarun Prabhu committed
225
226
227
228
229
230
231
232
233
	'interface_ref'  => [$src, $dst],
	'capacity'       => $bw,
	'packet_loss'    => "0",
	'latency'        => "0"
    };
    
    if ($others) {
	while ( my ($key, $value) = each %{$others} ) {
	    $ref->{$key} = $value;
234
	}
Tarun Prabhu's avatar
Tarun Prabhu committed
235
236
237
238
239
    }
    if (!exists($self->rspec()->{'link'})) {
	$self->rspec()->{'link'} = [];
    }
    push(@{ $self->rspec()->{'link'} }, $ref);
240
241
}

242
sub createNode ($$$$$$$;$)
243
{
244
245
246
    # $others here will be a hashtable for the desires
    # The key will be the desire name and the value will be a pair
    # of the desire type and the penalty
247
    my ($self, $name, $cm, $type, $typecount, $desires, $others, $ifaces) = @_;
Tarun Prabhu's avatar
Tarun Prabhu committed
248
    my $ref = {
249
250
	'virtual_id'    => $name,
	'manager_urn'   => $cm,
Tarun Prabhu's avatar
Tarun Prabhu committed
251
252
253
254
255
256
257
258
259
260
261
262
    };
    
    my $typename = $type;
    my $typeslots = $typecount;
    my $isstatic = 0;
    if ($typename =~ /^\*([-\w]*)$/) {
	$typename = $1;
	$isstatic = 1;
    }
    if ($typecount eq '*') {
	$typeslots = 'unlimited';
    }
263

Tarun Prabhu's avatar
Tarun Prabhu committed
264
265
    # We will need this to generate interface names later
    $ref->{'interface_count'} = 0;
266
    $ref->{'interfaces'} = $ifaces;
Tarun Prabhu's avatar
Tarun Prabhu committed
267
268
269
270
271
272
273
274
275

    $ref->{'node_type'} = $typename;
    $ref->{'type_slots'} = $typecount;
    $ref->{'node_static'} = $isstatic;

    my $desiretable = {};
    if ($desires) {
	while ( my ($key, $value) = each %{$desires} ) {
	    $desiretable->{$key} = $value;
276
	}
Tarun Prabhu's avatar
Tarun Prabhu committed
277
278
279
280
281
282
    }
    $ref->{'desires'} = $desiretable;
    
    if ($others) {
	while ( my ($key, $value) = each %{$others} ) {
	    $ref->{$key} = $value;
283
	}
Tarun Prabhu's avatar
Tarun Prabhu committed
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
    }
    
    if (!exists($self->rspec()->{'node'})) {
	$self->rspec()->{'node'} = [];
    }
    push(@{ $self->rspec()->{'node'} }, $ref);
}

sub createVClass ($$$$)
{
    my ($self, $name, $weight, $members) = @_;
    my $ref = {
	'name'    => $name,
	'weight'  => $weight,
	'members' => $members
    };
    if (!exists($self->rspec()->{'vclass'})) {
	$self->rspec()->{'vclass'} = [];
    }
    push(@{ $self->rspec()->{'vclass'} }, $ref);
}

sub createFixedNode ($$$)
{
    my ($self, $vnode, $pnode) = @_;
    my $ref = { 'vnode' => $vnode,
310
311
		# XXX Going to need a URN in rspec output ...
		'pnode' => $pnode,
Tarun Prabhu's avatar
Tarun Prabhu committed
312
313
314
315
316
317
318
    };
    if (!exists($self->rspec()->{'fixed'})) {
	$self->rspec()->{'fixed'} = [];
    }
    push(@{ $self->rspec()->{'fixed'} }, $ref);
}

319
320
321
322
323
324
325
###############################################################################
# Virtual Nodes. A separate package so we can create objects for each one
# and then add local stuff to them.
#
package libvtop::virt_node;
use Carp;
use vars qw($AUTOLOAD);
326
use overload ('""' => 'Stringify');
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356

# To avoid wrtting out all the methods.
sub AUTOLOAD {
    my $self = shift;
    my $type = ref($self) or croak "$self is not an object";

    my $name = $AUTOLOAD;
    $name =~ s/.*://;   # strip fully-qualified portion

    if (@_) {
	return $self->{'HASH'}->{$name} = shift;
    }
    elsif (exists($self->{'HASH'}->{$name})) {
	return $self->{'HASH'}->{$name};
    }
    else {
	return $self->virt_node()->$name();
    }
}

#
# Wrap up a virt node.
#
sub Create($$$)
{
    my ($class, $vtop, $virt_node) = @_;

    my $self = {};
    bless($self, $class);

357
358
359
360
361
    $self->{'VIRTNODE'}   = $virt_node;
    $self->{'VTOP'}       = $vtop;
    $self->{'HASH'}       = {};
    # The virtlans this virtnode is a member of. 
    $self->{'MEMBERSHIP'} = {};
362
    
363
364
365
366
367
368
    return $self;
}
# accessors
sub virt_node($)	{ return $_[0]->{'VIRTNODE'}; }
sub vtop($)		{ return $_[0]->{'VTOP'}; }
sub hash($)		{ return $_[0]->{'HASH'}; }
369
370
sub membership($)       { return $_[0]->{'MEMBERSHIP'}; }
sub memberlist($)       { return values(%{ $_[0]->{'MEMBERSHIP'} }); }
371
372
373
374
375
376
377
378

# Break circular reference someplace to avoid exit errors.
sub DESTROY {
    my $self = shift;

    $self->{'VIRTNODE'}   = undef;
    $self->{'VTOP'}       = undef;
    $self->{'HASH'}       = undef;
379
    $self->{'MEMBERSHIP'} = undef;
380
381
}

382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
sub Stringify($)
{
    my ($self) = @_;
    my $vname  = $self->vname();

    return "[vnode:$vname]";
}

###############################################################################
# Virtual Lans. This wraps up the virt_lan_lan table, and allows storing
# the members (virt_lans table entries).
#
package libvtop::virt_lan;
use Carp;
use vars qw($AUTOLOAD);
use overload ('""' => 'Stringify');

# To avoid wrtting out all the methods.
sub AUTOLOAD {
    my $self = shift;
    my $type = ref($self) or croak "$self is not an object";

    my $name = $AUTOLOAD;
    $name =~ s/.*://;   # strip fully-qualified portion

    if (@_) {
	return $self->{'HASH'}->{$name} = shift;
    }
    elsif (exists($self->{'HASH'}->{$name})) {
	return $self->{'HASH'}->{$name};
    }
    else {
	return $self->virt_lanlan()->$name();
    }
}

#
# Wrap up a virt lan.
#
sub Create($$$$)
{
    my ($class, $vtop, $virt_lanlan) = @_;

    my $self = {};
    bless($self, $class);

    $self->{'VIRTLANLAN'}    = $virt_lanlan;
    $self->{'VTOP'}          = $vtop;
430
431
    $self->{'MEMBERHASH'}    = {};
    $self->{'MEMBERLIST'}    = [];
432
433
434
435
436
437
438
    $self->{'SHAPEDMEMBERS'} = {};
    $self->{'HASH'}          = {};

    return $self;
}
# accessors
sub virt_lanlan($)	{ return $_[0]->{'VIRTLANLAN'}; }
439
440
sub members($)		{ return $_[0]->{'MEMBERHASH'}; }
sub memberlist($)       { return @{ $_[0]->{'MEMBERLIST'} }; }
441
442
443
444
445
446
447
448
449
sub shapedmembers($)	{ return $_[0]->{'SHAPEDMEMBERS'}; }
sub vtop($)		{ return $_[0]->{'VTOP'}; }
sub hash($)		{ return $_[0]->{'HASH'}; }

# Break circular reference someplace to avoid exit errors.
sub DESTROY {
    my $self = shift;

    $self->{'VIRTLANLAN'} = undef;
450
451
    $self->{'MEMBERHASH'} = undef;
    $self->{'MEMBERLIST'} = undef;
452
453
454
455
456
457
458
459
460
461
462
463
    $self->{'VTOP'}       = undef;
    $self->{'HASH'}       = undef;
}

sub Stringify($)
{
    my ($self) = @_;
    my $vname  = $self->vname();

    return "[vlan:$vname]";
}

464
465
466
467
468
sub addmember($$)
{
    my ($self, $vlanmember) = @_;
    
    $self->members()->{$vlanmember->member()} = $vlanmember;
469
470

    @{ $self->{'MEMBERLIST'} }[$vlanmember->vindex()] = $vlanmember;
471
472
473
474

    return 0;
}

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
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
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
#
# Other support functions.
#
sub usevirtiface($)
{
    my ($self) = @_;
    my $encap  = $self->_encapstyle();

    return ($encap eq "veth" || $encap eq "veth-ne" || $encap eq "vlan");
}
sub membershaped($$) {
    my ($self, $member) = @_;
    return $self->shapedmembers()->{"$member"};
}
sub setmembershaped($$) {
    my ($self, $member) = @_;
    $self->shapedmembers()->{"$member"} = 1;
}

###############################################################################
# Virtual Lans Member. A separate package so we can create objects for
# each one and then add local stuff to them.
#
package libvtop::virt_lan_member;
use Carp;
use vars qw($AUTOLOAD);
use overload ('""' => 'Stringify');

# To avoid wrtting out all the methods.
sub AUTOLOAD {
    my $self = shift;
    my $type = ref($self) or croak "$self is not an object";

    my $name = $AUTOLOAD;
    $name =~ s/.*://;   # strip fully-qualified portion

    if (@_) {
	return $self->{'HASH'}->{$name} = shift;
    }
    elsif (exists($self->{'HASH'}->{$name})) {
	return $self->{'HASH'}->{$name};
    }
    else {
	return $self->virt_member()->$name();
    }
}

#
# Wrap up a virt lan member.
#
sub Create($$$$)
{
    my ($class, $vtop, $virt_member, $virt_lan) = @_;

    my $self = {};
    bless($self, $class);

    $self->{'VIRTMEMBER'} = $virt_member;
    $self->{'VIRTLAN'}    = $virt_lan;
    $self->{'VIRTNODE'}   = $vtop->vnodes()->{$virt_member->vnode()};
    $self->{'VTOP'}       = $vtop;
    $self->{'HASH'}       = {};

    return $self;
}
# accessors
sub virt_member($)	{ return $_[0]->{'VIRTMEMBER'}; }
sub virt_lan($)		{ return $_[0]->{'VIRTLAN'}; }
sub virt_node($)	{ return $_[0]->{'VIRTNODE'}; }
sub vtop($)		{ return $_[0]->{'VTOP'}; }
sub hash($)		{ return $_[0]->{'HASH'}; }

# Break circular reference someplace to avoid exit errors.
sub DESTROY {
    my $self = shift;

    $self->{'VIRTLAN'}    = undef;
    $self->{'VIRTNODE'}   = undef;
    $self->{'VIRTMEMBER'} = undef;
    $self->{'VTOP'}       = undef;
    $self->{'HASH'}       = undef;
}

sub Stringify($)
{
    my ($self) = @_;
    my $vnode  = $self->vnode();
    my $vport  = $self->vport();

    return "$vnode:$vport";
}

Leigh B Stoller's avatar
Leigh B Stoller committed
567
568
569
570
571
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
599
600
601
602
603
604
605
606
607
608
609
610
###############################################################################
# Virtual Paths This wraps up the virt_paths table
#
package libvtop::virt_path;
use Carp;
use vars qw($AUTOLOAD);
use overload ('""' => 'Stringify');

# To avoid wrtting out all the methods.
sub AUTOLOAD {
    my $self = shift;
    my $type = ref($self) or croak "$self is not an object";

    my $name = $AUTOLOAD;
    $name =~ s/.*://;   # strip fully-qualified portion

    if (@_) {
	return $self->{'HASH'}->{$name} = shift;
    }
    elsif (exists($self->{'HASH'}->{$name})) {
	return $self->{'HASH'}->{$name};
    }
    else {
	return $self->virt_path()->$name();
    }
}

#
# Wrap up a virt path
#
sub Create($$$$)
{
    my ($class, $vtop, $pathname, $layer) = @_;

    my $self = {};
    bless($self, $class);

    $self->{'PATHNAME'}      = $pathname;
    $self->{'LAYER'}         = $layer;
    $self->{'VTOP'}          = $vtop;
    $self->{'MEMBERHASH'}    = {};
    $self->{'MEMBERLIST'}    = [];
    $self->{'VIRTLANHASH'}   = {};
    $self->{'VIRTLANLIST'}   = [];
611
    $self->{'IMPLEMENTS'}    = {};
Leigh B Stoller's avatar
Leigh B Stoller committed
612
613
614
615
616
617
618
619
620
    $self->{'HASH'}          = {};

    return $self;
}
# accessors
sub pathname($)		{ return $_[0]->{'PATHNAME'}; }
sub layer($)		{ return $_[0]->{'LAYER'}; }
sub members($)		{ return $_[0]->{'MEMBERHASH'}; }
sub memberlist($)       { return @{ $_[0]->{'MEMBERLIST'} }; }
621
sub virtlanlist($)      { return @{ $_[0]->{'VIRTLANLIST'} }; }
Leigh B Stoller's avatar
Leigh B Stoller committed
622
623
624
625
sub member($$)		{ return $_[0]->{'MEMBERLIST'}->[$_[1]]; }
sub lanlink($$)		{ return $_[0]->{'VIRTLANLIST'}->[$_[1]]; }
sub vtop($)		{ return $_[0]->{'VTOP'}; }
sub hash($)		{ return $_[0]->{'HASH'}; }
626
sub implements($)	{ return $_[0]->{'IMPLEMENTS'}; }
Leigh B Stoller's avatar
Leigh B Stoller committed
627
628
629
630
631
632
633
634
635
636
637
638

# Break circular reference someplace to avoid exit errors.
sub DESTROY {
    my $self = shift;

    $self->{'LAYER'}      = undef;
    $self->{'PATHNAME'}   = undef;
    $self->{'MEMBERHASH'} = undef;
    $self->{'MEMBERLIST'} = undef;
    $self->{'VIRTLANHASH'} = undef;
    $self->{'VIRTLANLIST'} = undef;
    $self->{'VTOP'}       = undef;
639
    $self->{'IMPLEMENTS'} = undef;
Leigh B Stoller's avatar
Leigh B Stoller committed
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
    $self->{'HASH'}       = undef;
}

sub Stringify($)
{
    my ($self) = @_;
    my $vname  = $self->pathname();
    my $layer  = $self->layer();

    return "[vpath:$vname:$layer]";
}

sub addmember($$$)
{
    my ($self, $vpath, $virtlan) = @_;
    
    $self->members()->{$vpath->segmentname()} = $vpath;
    $self->{'VIRTLANHASH'}->{$vpath->segmentname()} = $virtlan;
    # We care about this ordering.
    $self->{'MEMBERLIST'}->[$vpath->segmentindex()]  = $vpath;
    $self->{'VIRTLANLIST'}->[$vpath->segmentindex()] = $virtlan;
    return 0;
}

sub firstmember($)
{
    my ($self) = @_;

    # The lanlink for the first segment.
    my $virtlan = $self->lanlink(0);

    # Both members of a link.
    my ($member0,$member1) = $virtlan->memberlist();

    # The first member.
    return $member0;
}

sub lastmember($)
{
    my ($self) = @_;

    # The lanlink for the last segment.
    my $virtlan = $self->lanlink(scalar($self->memberlist()) - 1);

    # Both members of a link.
    my ($member0,$member1) = $virtlan->memberlist();

    # The last member.
    return $member1;
}
691

692
693
694
695
696
697
698
699
700
701
702
703
704
sub addimplements($$)
{
    my ($self, $virtlan) = @_;

    $self->implements()->{$virtlan->vname()} = $virtlan;
}
sub doesimplement($$)
{
    my ($self, $virtlan) = @_;

    return exists($self->implements()->{$virtlan->vname()});
}

705
706
707
#############################################################################
# Back to the main package.
#
708
package libvtop_stable;
709

710
711
712
713
714
715
716
717
718
719
720
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
#
# Load some physical info (for types, interfaces, speeds).
#
sub LoadPhysInfo($)
{
    my ($self) = @_;

    $self->printdb("Loading physical info\n");

    #
    # Interface capabilities, for getting speeds.
    #
    my %interface_capabilities = ();

    my $query_result =
	DBQueryWarn("select * from interface_capabilities");
    return -1
	if (!$query_result);

    while (my ($type, $capkey, $capval) = $query_result->fetchrow()) {
	$interface_capabilities{$type} = {}
  	    if (!defined($interface_capabilities{$type}));
	$interface_capabilities{$type}->{$capkey} = $capval;
    }

    #
    # Now get interface speeds for each type/class. We use this for
    # determining if a delay node is required. Very hacky, quite
    # wrong.
    #
    my %node_type_linkbw = ();
    
    # XXX: PlanetLab hack - PlanetLab 'control' interfaces are also
    # 'experimental' interfaces! We probably need a way to express
    # this in the interfaces table or interface_types
    #
    $query_result =
	DBQueryWarn("select distinct i.interface_type,n.type ".
		    "  from interfaces as i ".
		    "left join nodes as n on n.node_id=i.node_id ".
		    "where i.role='" . TBDB_IFACEROLE_EXPERIMENT . "' ".
		    "      or (n.type='pcplabphys' and i.role='" .
		                 TBDB_IFACEROLE_CONTROL . "')");
    return -1
	if (!$query_result);

    # XXX Special hack for sim nodes.
    $node_type_linkbw{"sim"} = {};

    while (my ($iface_type, $node_type) = $query_result->fetchrow()) {
	my $typeinfo = NodeType->Lookup($node_type);
	if (!defined($typeinfo)) {
762
	    warn("No type info for node type $node_type\n");
763
764
765
766
767
768
769
770
771
772
	    return -1;
	}
	my $node_class = $typeinfo->class();

	$node_type_linkbw{$node_type} = {}
	    if (!defined($node_type_linkbw{$node_type}));
	$node_type_linkbw{$node_class} = {}
	    if (!defined($node_type_linkbw{$node_class}));

	if (!defined($interface_capabilities{$iface_type}->{"protocols"})) {
773
	    warn("No protocols listed in capabilities for $iface_type!\n");
774
775
776
777
778
779
780
781
782
783
	    return -1;
	}
	my @protolist =
	    split(",", $interface_capabilities{$iface_type}->{"protocols"});

	foreach my $proto (@protolist) {
	    my $def_speed =
		$interface_capabilities{$iface_type}->{"${proto}_defspeed"};

	    if (!defined($def_speed)) {
784
		warn("No default speed in capabilites for $iface_type!\n");
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
		return -1;
	    }

	    my $auxspeeds =
		$interface_capabilities{$iface_type}->{"${proto}_auxspeeds"};
	    my @auxspeedlist = ();
	    if ($auxspeeds) {
		@auxspeedlist = split(",", $auxspeeds);
	    }

	    foreach my $speed ($def_speed, @auxspeedlist) {
		$node_type_linkbw{$node_type}{$proto}->{$speed} = 1;
		$node_type_linkbw{$node_class}{$proto}->{$speed} = 1;

		#
		# If the type/class has a non-zero simnode capacity, then add
		# entries for the interface speed so that requires_delay can
		# figure out interface speeds the underlying node type
		# supports.
		#
		if ($typeinfo->simnode_capacity()) {
		    $node_type_linkbw{"sim"}{$proto}->{$speed} = 1;
		}
	    }
	}
    }
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832

    #
    # Ug, it just gets worse and worse. We also need to map between the
    # auxtypes that a node (its physical type) can take on. For example,
    # a link between two pcvm nodes is really a link between a pc600 and
    # pc850.
    #
    $query_result =
	DBQueryFatal("select distinct n.type,at.type from node_auxtypes as at ".
		     "left join nodes as n on n.node_id=at.node_id");

    while (my ($phystype, $auxtype) = $query_result->fetchrow()) {
	next
	    if (!exists($node_type_linkbw{$phystype}));
	
	$node_type_linkbw{$auxtype} = $node_type_linkbw{$phystype};
    }

    #
    # Here it goes getting even worse - we have to do a similar thing for
    # vtypes.
    #
833
834
835
    foreach my $ref ($self->VirtTypes()) {
	my $vtype   = $ref->name();
	my @members = split(" ", $ref->members());
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863

	foreach my $phystype (@members) {
	    next
		if (!exists($node_type_linkbw{$phystype}));

	    $node_type_linkbw{$vtype} = {}
	        if (!defined($node_type_linkbw{$vtype}));

	    foreach my $protocol (keys(%{ $node_type_linkbw{$phystype} })) {
		my @list = keys(%{ $node_type_linkbw{$phystype}{$protocol} });
		foreach my $speed (@list) {
		    $node_type_linkbw{$vtype}{$protocol}->{$speed} = 1;
		}
	    }
	}
    }

    if ($self->verbose()) {
	$self->printdb("Interface Speeds:\n");
	foreach my $type (keys(%node_type_linkbw)) {
	    foreach my $protocol (keys(%{ $node_type_linkbw{$type} })) {
		my @list = keys(%{ $node_type_linkbw{$type}{$protocol} });

		$self->printdb(" $type:$protocol - @list\n");
	    }
	}
    }
    
864
865
866
867
868
    $self->{'IFACECAPS'}  = \%interface_capabilities;
    $self->{'TYPELINKBW'} = \%node_type_linkbw;
    
    return 0;
}
869
870
871
872
873
874
sub interfacespeedmbps($$$)
{
    my ($self, $type, $which) = @_;
        
    return $self->{'IFACECAPS'}->{$type}->{"${which}_defspeed"}/1000.0;
}
875

876
877
878
879
#
# When updating with fixednodes turned on, we need the current set
# of nodes that need to be fixed.
#
880
sub LoadCurrentResources($)
881
882
883
884
885
886
887
{
    my ($self) = @_;

    $self->counters()->{'reserved_simcount'}  = 0;
    $self->counters()->{'reserved_virtcount'} = 0;
    $self->counters()->{'reserved_physcount'} = 0;

888
889
    $self->printdb("Loading current resources" .
		   ($self->regression() ? " in regression mode" : "") . "\n");
890

891
    my @nodelist = $self->experiment()->NodeList(0, 1);
892
893
894
    return 0
	if (!@nodelist);

895
896
897
898
899
900
901
902
903
    if ($self->regression()) {
	#
	# In regression mode, we just store the p2v mapping for fixnode.
	#
	foreach my $pnode (@nodelist) {
	    my $vname   = $pnode->vname();
	    my $node_id = $pnode->node_id();

	    if ($pnode->isvirtnode()) {
904
		$node_id = $pnode->phys_nodeid();
905
	    }
906
907
	    $self->fixednodes()->{$vname} = $node_id;
	    $self->printdb("  fixing $vname -> $node_id\n");
908
909
910
911
	}
	return 0;
    }

912
    foreach my $pnode (@nodelist) {
913
914
915
916
917
918
919
920
921
	my $vname   = $pnode->vname();
	my $node_id = $pnode->node_id();
	my $rsrv    = $pnode->ReservedTableEntry();

	# A list of vnodes on this pnode.
	$self->current_p2v()->{$pnode->phys_nodeid()} = []
	    if (! exists($self->current_p2v()->{$pnode->phys_nodeid()}));
	$self->pnodes()->{$node_id} = $pnode;

922
923
924
925
	#
	# WIDEAREA nodes are going to break.
	#
	if ($pnode->isremotenode() &&
926
927
	    !($pnode->isplabdslice() || $pnode->isfednode() ||
	      $pnode->isdedicatedremote())) {
928
929
930
931
932
	    tberror("Cannot update widearea nodes yet!\n");
	    return -1;
	}
	if ($pnode->isvirtnode()) {
	    $self->counters()->{'reserved_virtcount'}++;
933
934
935
936
937
938
939

	    # Get the underlying physical node.
	    my $ppnode = Node->Lookup($pnode->phys_nodeid());
	    if (!defined($ppnode)) {
		tberror("Cannot map $pnode to its real physnode");
		return -1;
	    }
940
	    my $ppnode_id = $ppnode->node_id();
941

942
943
944
	    $self->fixednodes()->{$vname} = $ppnode_id
		if ($self->fixcurrent());
	    
945
946
947
	    #
	    # Record the mappings. 
	    #
948
949
	    $self->current_v2v()->{$vname} = $pnode->node_id();
	    $self->current_v2p()->{$vname} = $ppnode->node_id();
950
951
952
953
954
	    push(@{ $self->current_p2v()->{$ppnode->node_id()} }, $vname);
	    
	    # Mark the node as unused until later.
	    $pnode->_reuse("unused");
	    $ppnode->_reuse("unused");
955
956
957
958
959
960
961
962
963

	    #
	    # Add the pnode node to the oldreserved list for nfree.
	    # See the comment below. We cannot use p2v because we
	    # might not own all those nodes, if on a shared node.
	    # We do not add the ppnode. It will get added in the
	    # next clause if we actually own it.
	    #
	    $self->oldreservednodes()->{$pnode->node_id()} = $pnode;
964
965
	    
	    $self->printdb("current v2p: $node_id ($ppnode_id) -> $vname\n");
966
967
968
969
970
971
972
973
974
975
	}
	else {
	    #
	    # All the sim stuff is bit rotting cause no one understands it.
	    #
	    if ($rsrv->{'erole'} eq TBDB_RSRVROLE_SIMHOST) {
		tberror("Cannot update sim nodes yet!\n");
		return -1;
	    }
	    else {
976
977
978
		$self->fixednodes()->{$vname} = $pnode->node_id()
		    if ($self->fixcurrent());
		
979
		$self->counters()->{'reserved_physcount'}++;
980
981
982
983

		#
		# Record the mapping. 
		#
984
		$self->current_v2p()->{$vname} = $pnode->node_id();
985
986
987
988
		push(@{ $self->current_p2v()->{$node_id} }, $vname);
		# Mark the node as unused until later.
		$pnode->_reuse("unused");

989
990
991
992
993
994
995
		#
		# Add the pnode node to the oldreserved list for nfree.
		# See the comment below. We cannot use p2v because we
		# might not own all those nodes, if on a shared node.
		#
		$self->oldreservednodes()->{$pnode->node_id()} = $pnode;

996
		$self->printdb("current v2p: $node_id -> $vname\n");
997
998
999
1000
	    }
	}
    }
    return 0;
For faster browsing, not all history is shown. View entire blame