assign_wrapper.in

#!/usr/bin/perl -w
#
# EMULAB-COPYRIGHT
# Copyright (c) 2000-2004 University of Utah and the Flux Group.
# All rights reserved.
#
use English;
use Getopt::Std;
use POSIX qw(setsid);
use POSIX ":sys_wait_h";

#
# 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.
#
# XXX: Update does not work with widearea nodes.
#      Internally created nodes (jailhost,delay,sim) are not treated
#        consistently. Needs more thought.
#
# Return codes: -1 is an uncontrolled error (someone called die()). No
# recovery is possible so the caller has to check for this explicitly.
# The CANRECOVER bit indicates 'recoverability' (no db or physical
# state was modified by the time the error occurred). It also is used
# to signal that a retry is possible. 
#
my $WRAPPER_SUCCESS		 = 0x00;
my $WRAPPER_FAILED		 = 0x01;	# Failed (Add other values)
my  $WRAPPER_FAILED_MAXCONCURENT = 0x02;	# max_concurrent violation
my  $WRAPPER_FAILED_BANDWIDTH    = 0x04;	# Bandwidth violation
my  $WRAPPER_FAILED_LINKUSERS    = 0x08;	# Linkusers violation
my  $WRAPPER_FAILED_DESIRES      = 0x10;	# Desires violation
my  $WRAPPER_FAILED_UNASSIGNED   = 0x20;	# Unassigned violation
my  $WRAPPER_FAILED_CANRECOVER   = 0x40;        # Can recover, retry.
my $WRAPPER_DIED_A_HORRIBLE_DEATH= 0x80;	# Do not use this.
# Set this once we modify DB state; forces no recover in fatal().
my $NoRecover = 0;
    
sub usage ()
{
    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";
    print STDERR " -t   - Create the TOP file and then exit\n";
    print STDERR " -n   - Run assign, but do not reserve/modify resources.\n";
    exit(-1);
}
my $optlist  = "vutnf";
my $verbose  = 0;
my $fixmode  = 0;
my $updating = 0;
my $toponly  = 0;
my $impotent = 0;

#
# Configure variables
#
my $TBROOT	  = "@prefix@";
my $DELAYCAPACITY = @DELAYCAPACITY@;
$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;
require exitonwarn;

#
# assign_wrapper Settings
#
# Maximum delay in ms above which a delay node is needed.
# (Note that the DB represents delays as floating point numbers)
my $delaythresh = 2;

# Maximum number of times we run assign.
my $maxrun = 20;

# 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;

#
# 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.
#
my $S10Mbs   = 10;
my $S100Mbs  = 100;
my $S1000Mbs = 1000;
my $S10Kbs   = 10000;
my $S100Kbs  = 100000;
my $S1000Kbs = 1000000;

#
# Parse command arguments. Once we return from getopts, all that should be
# left are the required arguments.
#
%options = ();
if (! getopts($optlist, \%options)) {
    usage();
}
if (@ARGV != 2) {
    usage();
}
if (defined($options{"v"})) {
    $verbose = 1;
}
if (defined($options{"u"})) {
    $updating = 1;
}
if (defined($options{"t"})) {
    $toponly = 1;
}
if (defined($options{"n"})) {
    $impotent = 1;
}
if (defined($options{"f"})) {
    $fixmode = 1;
}
my $pid = $ARGV[0];
my $eid = $ARGV[1];
my $ptopfile = "$pid-$eid-$$.ptop";
# Since the topfile could change across
# swapins and modifies, it makes sense
# to store all of them. Helps in
# degugging.
my $topfile  = "$pid-$eid-$$.top";

sub fatal ($$)
{
    my($exitcode, $message) = @_;

    print STDERR "*** $0:\n".
	         "    $message\n";

    # Remove recover bit.
    $exitcode = $exitcode & ~$WRAPPER_FAILED_CANRECOVER
	if ($NoRecover);
    
    exit($exitcode);
}

sub printdb ($)
{
    if ($verbose) {
	print $_[0];
    }
}

print "assign_wrapper improved started\n";
TBDebugTimeStamp("assign_wrapper started");

#
# The main data structures:
#
# 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.
#
my %virt_nodes = ();

#
# 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,
#                           useveth      => 0,
#                           trivok       => 0
#                          }
#                 link1 => ...
#                )
#
my %virt_lans = ();

#
# 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 = ();

# 
# interface_types: We need this to find out the bandwidths of the devices
# we actually have on the testbed. Index by interface type name.
#
my %interface_types = ();

#
# 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 = ();

#
# 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 = ();

#
# 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 = ();

#
# 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  = ();
my %oldreservednodes = ();
# reserved_p2vmap is indexed by physical and contains one or more virtual
# nodes
my %reserved_p2vmap  = ();

#
# 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;

# For admission control. Not well defined yet.
my $cpu_usage;
my $mem_usage;

# Allow override of jail/delay osids.
my $jail_osid;
my $delay_osid;

# 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;

######################################################################

# 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 = ();

# delaylinks stores the actual link delay info, converted from the
# virt delay params above. It is indexed by link name and contains a
# [delay,bw,loss] array for each direction. The final member of the
# 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     = ();

# 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 = ();

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

# 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;
my $reserved_pcount  = 0;
my $reserved_vcount  = 0;
my $reserved_simcount= 0;
my $remotecount      = 0;
my $virtcount        = 0;
my $plabcount        = 0;
my $needwanassign    = 0;
my $simcount         = 0;

#
# 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,
		  # wanodes includes plabnodes.
		  plabnodes   => 0,
		  simnodes    => 0,
		  delaynodes  => 0,
		  linkdelays  => 0,
		  links       => 0,
		  walinks     => 0,
		  lans        => 0,
		  shapedlinks => 0,
		  shapedlans  => 0,
		  minlinks    => 100000,
		  # includes emulated links. Maybe thats wrong.
		  maxlinks    => 0,
);

my $simhost_id     = 0;
my %pnode2simhostid;
my %simhostid2pnode;

# Counters for generating IDs.
my $virtnode_id  = 0;
my $veth_id      = 0;

#
# 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 = ();

######################################################################
# Step 1 - Setup virtual topology
#
# 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.
#
########################################################################

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

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

#
# Load phys info. Interface types, node types, etc. Its any physical stuff
# we need.
#
LoadPhysInfo();

#
# Load the Experiment info and virt topology.
#
LoadExperiment();

#
# If updating, load current experiment resources. We have to be careful
# of how this is merged in with the (new) desired topology. See below.
#
if ($updating) {
    LoadCurrent();
    print STDERR "Resetting DB before updating.\n";
    TBExptRemovePhysicalState( $pid, $eid );
}

#
# Check Max Concurrent for OSID violations.
#
CheckMaxConcurrent();

#
# Create the TOP file.
#
CreateTopFile();

TBDebugTimeStamp("TOP finished");

# Stop here ...
if ($toponly) {
    print "Stopping after creating the TOP file, as directed.\n";
    exit(0);
}


######################################################################
# 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.
#
#######################################################################

my $currentrun = 1;
my $canceled   = 0;

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

TBDebugTimeStamp("assign_loop started");
while (1) {
    # Check cancel flag before continuing. 
    TBGetCancelFlag($pid, $eid, \$canceled);
    fatal($WRAPPER_FAILED|$WRAPPER_FAILED_CANRECOVER,
	  "Cancel flag set; aborting assign run!")
	if ($canceled);

    print "Assign Run $currentrun\n";

    #
    # RunAssign returns 0 if successful. Returns -1 if there was an
    # an error in RunAssign that is deemed fatal; do not try anymore.
    # The exitcode is returned in $exitcode. If RunAssign returns a
    # postive value, it means there was a problem, but we can keep
    # trying.
    #
    my $exitcode = 0;
    my $retval   = RunAssign(\$exitcode);

    # Success!
    last
	if ($retval == 0);

    if ($currentrun >= $maxrun) {
	fatal($exitcode, "Reached run limit. Giving up.");
    }

    if ($retval < 0) {
	#
	# Failure in assign.
	#
	fatal($exitcode, "Unretriable error. Giving up.");
    }
    
    print "Waiting 5 seconds and trying again...\n";
    sleep(5);
    $currentrun++;
}
TBDebugTimeStamp("assign_loop finished");

#
# Run assign once.
# 
sub RunAssign ($)
{
    my ($retval) = @_;

    # Clear globals for each run.
    undef %v2pmap;
    undef %p2vmap;
    undef %v2vmap;
    undef %plinks;
    undef %virtnodes;

    my %toreserve = ();
    my %subnodes  = ();
    
    TBDebugTimeStamp("ptopgen started");
    # Snapshot physical resources.
    #
    # if updating (-u), include any resources that may already be
    # allocated to experiment in the PTOP results.
    #
    my $ptopargs = "-p $pid ";
    $ptopargs   .= "-e $eid "
	if ($updating);
    $ptopargs   .= "-m $multiplex_factor "
	if (defined($multiplex_factor));
    $ptopargs   .= "-v "
	if ($virtcount);
    $ptopargs   .= "-r "
	if ($remotecount);
    $ptopargs   .= "-S "
	if ($simcount);
    system("ptopgen $ptopargs > $ptopfile");

    TBDebugTimeStamp("ptopgen finished");

    # Get number of nodes
    my $numnodes = TBAvailablePCs($pid);
    
    if ($numnodes < ($minimum_nodes - $reserved_pcount)) {
	fatal($WRAPPER_FAILED|$WRAPPER_FAILED_CANRECOVER,
	      "Insufficient nodes available.");
    }

    TBDebugTimeStamp("assign started");
    # Run assign
    my $cmdargs = "$ptopfile $topfile";
    $cmdargs = "-uPod -c .75 $cmdargs"
	if ($virtcount);

    my $cmd;

    # If doing an experiment with virtnodes, use the prepass wrapper for assign
    # Turned off for now, because it needs some work.
    #if ($virtcount) {
    #	$cmd = "assign_prepass";
    #	$cmdargs = "-m $multiplex_factor $cmdargs"
    #	    if ($multiplex_factor);
    #} else {
    #	$cmd = "assign";
    #}

    $cmd = "assign";
    print "$cmd $cmdargs\n";

    #
    # 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.
	    TBGetCancelFlag($pid, $eid, \$canceled);
	    if ($canceled) {
		if ((my $pgrp = getpgrp($childpid)) > 0) {
		    kill('TERM', -$pgrp);
		    waitpid($childpid, 0);
	    
		    fatal($WRAPPER_FAILED|$WRAPPER_FAILED_CANRECOVER,
			  "Cancel flag set; aborting assign run!");
		}
		# 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();
	exec("nice $cmd $cmdargs > assign.log");
	die("*** $0:\n".
	    "    Could not start assign!\n");
    }

    # Check cancel flag before continuing. 
    TBGetCancelFlag($pid, $eid, \$canceled);
    fatal($WRAPPER_FAILED|$WRAPPER_FAILED_CANRECOVER, 
	  "Cancel flag set; aborting assign run!")
	if ($canceled);

    my $violations = 0;
    my $score = -1;


    # Saving up assign.log coz each swapin/modify is
    # different and it is nice to have every mapping
    # for debugging and archiving purposes
    system("/bin/cp assign.log assign-$pid-$eid-$$.log");
    open(ASSIGNFP, "assign.log") or
	fatal($WRAPPER_FAILED|$WRAPPER_FAILED_CANRECOVER,
	      "Could not open assign logfile!");

    if ($assignexitcode == 0) {
	# read output
	# Header
	printdb "Reading assign results.\n";
	while (<ASSIGNFP>) {
	    chop;
	    /No physical nodes of type (.+)$/ && do {
		$score=-2;
		print $_ . "\n";
	    };
	    /^With ([0-9]+) violations$/ && do {
		$violations = $1;
		last;
	    };
	    /^[ \t]+BEST SCORE: [ \t]+([0-9]+(\.[0-9]+)?)/ && do {
		$score=$1;
		print $_ . "\n";
	    };
	}
	if ($score == -2) {
	    # Type error
	    fatal($WRAPPER_FAILED|$WRAPPER_FAILED_CANRECOVER,
		  "Type error. Giving up!");
	}
	printdb "Found score $score, violations $violations.\n";
    }

    #
    # If we found violations above, or if the score is <0 then figure
    # out what happened, and return the result. I am not sure if this
    # stuff is set when the assign exitcode is 2 (no retry), but we end up
    # in here anyway. Should be harmless.
    #
    if ($violations || $score < 0 || $assignexitcode) {
	# Compute the exitcode and return it. Caller decides what to do.
	my $exitcode = $WRAPPER_FAILED|$WRAPPER_FAILED_CANRECOVER;

	# spit out up to nodes
	print "ASSIGN FAILED: \n";       
	while (<ASSIGNFP>) {
	    if (/link_users:\s*(\d+)$/) {
		$exitcode |= $WRAPPER_FAILED_LINKUSERS;
	    }
	    elsif (/bandwidth:\s*(\d+)$/) {
		$exitcode |= $WRAPPER_FAILED_BANDWIDTH;
	    }
	    elsif (/unassigned:\s*(\d+)$/) {
		$exitcode |= $WRAPPER_FAILED_UNASSIGNED;
	    }
	    elsif (/desires:\s*(\d+)$/) {
		$exitcode |= $WRAPPER_FAILED_DESIRES;
	    }
	    if (/^Nodes:/) {last;}
	    print "$_";
	}
	close(ASSIGNFP);
	$$retval = $exitcode;

	# Signal retriable to caller, since assign thinks it is.
	return 1
	    if ($assignexitcode == 1);
	return -1;
    }

    #
    # Assign success; parse results.
    # 
    # read nodes section
    while (<ASSIGNFP> !~ /^Nodes:/) {}
    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)) {
		#
		# 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");
		}
		elsif ($reserved_v2pmap{$virtual} eq $physical) {
		    my $reserved = $reserved_v2vmap{$virtual};

		    physnodesetreuse($reserved, "reused");
		    physnodesetreuse($physical, "reused");
		}
		else {
		    physnodesetreuse($physical, "reused");
		}
	    }
	    else {
		#
		# 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.
		#
		if (!exists($reserved_v2pmap{$virtual}) ||
		    $reserved_v2pmap{$virtual} ne $physical) {
		    physnodesetreuse($physical, "reboot");
		}
		else {
		    physnodesetreuse($physical, "reused");
		}
	    }
	}
	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
		if (!virtnodeisremote($virtual));
	}
	
	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} = [];
	    }
	    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} = [];
	}
	push(@{$p2vmap{$physical}}, $virtual);
	printdb "  $virtual $physical\n";
    }

    #
    # 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;

	TBPhysNodeID($physical, \$parent);

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

	#
	# 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}));

	# Make up a name and add to the list.
	my $newvname = newvname($parent, "phost");

	$v2pmap{$newvname} = $parent;
	$p2vmap{$parent} = [ $newvname ];
	$toreserve{$parent} = 1;
	printdb "  Adding subnode host: $newvname $parent\n";
    }

    # read Edges
    # By convention, in plinks, the delay node is always the second
    # entry.
    while (<ASSIGNFP> !~ /^Edges:/) { }
    printdb "Edges:\n";
    EDGEWHILE: while (<ASSIGNFP>) {
	/^End Edges$/ && last EDGEWHILE;
	@info = split;
	$line = $_;
	$_ = $info[1]; # type
        SWITCH1: {
	    /^intraswitch$/ && do {
		($vlink,$rawA,$rawB) = @info[0,3,5];
		last SWITCH1;
	    };
	    /^interswitch$/ && do {
		($vlink,$rawA,$rawB) = @info[0,3,$#info];
		last SWITCH1;
	    };
	    /^direct$/ && do {
		($vlink,$rawA,$rawB) = @info[0,3,5];
		last SWITCH1;
	    };
	    /^trivial$/ && do {
		# we don't have plinks for trivial links
		$vlink = $info[0];
		$plinks{$vlink} = [];
		next EDGEWHILE;
	    };
	    print "Found garbage: $line\n";
	}
	$nodeportA = &getnodeport($rawA);
	$nodeportB = &getnodeport($rawB);
	$nodeportA =~ s/\//:/;
	$nodeportB =~ s/\//:/;
	$plinks{$vlink} = [$nodeportA,$nodeportB];
	printdb "  $vlink " . join(" ",@{$plinks{$vlink}}) . "\n";
    }
    close(ASSIGNFP);
    TBDebugTimeStamp("assign finished");

    # Reserve resources
    if ($impotent) {
	print "Skipping physical reservation, as directed.\n";
	return 0;
    }

    # From here, we can't recover anymore, coz we move
    # previously reserved pnodes/vnodes to the holding reservation
    # and back. By doing this, we will avoid any UNIQUE key issues
    # when a virt_node in the topology moves from one pnode to another
    # from previous to new mapping.
    # Another reason to do this just before nalloc of a new toreserve
    # nodes is that, we can get into name clashes
    # For example, lets say the user called his node pc2 and it was
    # actually mapped to pc99 in the initial swapin. If this was a
    # swapmod where the user asked for another node node0 which got 
    # mapped to pc2. nalloc of pc2 will result in UNIQUE key problems
    # since there exists a reserved vname pc2 (virtual name). By 
    # having this operation of moving the nodes into 
    # OLDRESERVED_PID/OLDRESERVED_EID and back before a new nalloc,
    # avoid this UNIQUE key problem. Also note that simply updating
    # the vname to be the same as the node_id field also won't
    # work all the time i.e. in the example discussed above
    my $oldreserved_pid = OLDRESERVED_PID;	
    my $oldreserved_eid = OLDRESERVED_EID;
    if (scalar(keys %oldreservednodes)) {
	# We can't recover after this coz we are making changes to
	# the DB
	$NoRecover = 1;
	TBDebugTimeStamp("Moving Old Reserved nodes to ".
	    		 "$oldreserved_pid/$oldreserved_eid ".
			 "and back started");
	system("nfree -o $pid $eid " . join(" ", keys(%oldreservednodes)) );
	system("nalloc $pid $eid " . join(" ", keys(%oldreservednodes)) );
	my $exitval  = $? >> 8;
	TBDebugTimeStamp("Moving Old Reserved nodes to ".
	    		 "$oldreserved_pid/$oldreserved_eid ".
			 "and back finished");
	#
	# If nalloc failed with a fatal error, lets give it up. No retry.
	# 
	if ($exitval != 0) {
	    fatal($WRAPPER_FAILED,
	    	  "Failed to move back Old Reserved nodes back to reserved\n");
	}
	# We need to move this back and forth the holding reservation only
	# once i.e. in the first call to RunAssign(). If it gets repeatedly
	# called coz only some pnode resources got nalloc'ed, we don't have
	# to do the above again.
	undef %oldreservednodes;
    }

    TBDebugTimeStamp("reserving started");
    system("nalloc -p $pid $eid " . join(" ", keys(%toreserve)));
    TBDebugTimeStamp("reserving finished");
    my $exitval  = $? >> 8;

    #
    # If nalloc failed with a fatal error, lets give it up. No retry.
    # 
    if ($exitval < 0) {
	print "Failed to reserve any nodes.\n";
	$$retval = $WRAPPER_FAILED|$WRAPPER_FAILED_CANRECOVER;
	return -1; 
    }

    #
    # Okay, if nalloc got anything, we have to set the norecover bit,
    # since tbswap operates on the principle that any change in the DB
    # means no recover is possible. This can probably me dealt with by
    # deallocating any nodes we allocated in the wrapper before exiting.
    #
    $NoRecover = 1;

    #
    # Otherwise, all newly allocated nodes MUST go to the INIT_DIRTY
    # allocstate since the user now has control of them. If we eventually
    # fail, nodes not in RES_READY are deallocated (retry/modify). 
    #
    if ($exitval > 0) {
	my @reserved = ExpNodes($pid, $eid);

	# We got only some. Need to figure out which.
	print "Reserved some nodes ($exitval) we needed, but not all.\n";
	
	foreach my $node (@reserved) {
	    if (exists($toreserve{$node})) {
		TBSetNodeAllocState($node, TBDB_ALLOCSTATE_RES_INIT_DIRTY());
	    }
	}

	#
	# We check to see if were were able to reserve all the fixed
	# nodes we needed. If we couldn't get the fixed list, then
	# this experiment is unlikely to map in the "near" future, so
	# give up now (no retry).
	#
	foreach my $node (values(%fixed_nodes)) {
	    if (! grep {$_ eq $node} @reserved) {
		printdb "  Could not allocate fixed node $node!\n";
		$$retval = $WRAPPER_FAILED;
		return -1;
	    }
	}