#!/usr/bin/perl -w

#
# Copyright (c) 2000-2014 University of Utah and the Flux Group.
# 
# {{{EMULAB-LICENSE
# 
# This file is part of the Emulab network testbed software.
# 
# This file is free software: you can redistribute it and/or modify it
# under the terms of the GNU Affero General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
# 
# This file is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Affero General Public
# License for more details.
# 
# You should have received a copy of the GNU Affero General Public License
# along with this file.  If not, see <http://www.gnu.org/licenses/>.
# 
# }}}
#

use English;
use Getopt::Std;
use Math::BigInt;
use List::Util 'shuffle';

use lib "@prefix@/lib";
use libdb qw(TBGetSiteVar);
use libadminctrl;
use libptop;
use EmulabFeatures;

my @SAVEARGV = @ARGV;

my $top = libptop->Create();

my $PGENISUPPORT = @PROTOGENI_SUPPORT@;

$NO_GENI = "0";
$V_0_1 = "0.1";
$V_0_2 = "0.2";
$V_2 = "2";
$V_3 = "3";

$emulabns = "http://www.protogeni.net/resources/rspec/ext/emulab/1";
# XXX: This needs to be changed
$emulaburl = "http://www.protogeni.net/resources/rspec/ext/emulab/1/ptop_extension.xsd";
$sharedns = "http://www.geni.net/resources/rspec/ext/shared-vlan/1";
$sharedurl = "http://www.geni.net/resources/rspec/ext/shared-vlan/1/ad.xsd";
$stitchns = "http://hpn.east.isi.edu/rspec/ext/stitch/0.1/";
$stitchurl = "http://hpn.east.isi.edu/rspec/ext/stitch/0.1/stitch-schema.xsd";
$opns = "http://www.geni.net/resources/rspec/ext/opstate/1";
$opurl = "http://www.geni.net/resources/rspec/ext/opstate/1/ad.xsd";

sub usage()
{
    print("Usage: ptopgen [-v] [-s switch] [-p pid [-e eid]] [-m factor] " .
	  "[-n c/e] [-x] [-g (0.1 | 2)] [-c component-name]".
	  "[-l type-limit-file] [-z]\n" .
	  "       -p include nodes the project has permission to use\n".
	  "       -e include given experiments resources\n" .
	  "          in the ptopfile (as if they were free)\n" .
	  "       -v Include stuff for topologies with virtual nodes\n".
	  "       -r Include stuff for topologies with widearea nodes\n".
#	  "       -s Include stuff for topologies with simulated nodes\n".
	  "       -h Include stuff for topologies with shared nodes\n".
	  "       -a Include even reserved nodes\n".
	  "       -m Override multiplex_factor\n".
	  "       -u Prune unused interfaces of allocated nodes (-e)\n".
	  "       -c Delay capacity override\n".
	  "       -n Add in modelnet core and edge node features\n".
	  "       -x Output into the new xml ptop format\n".
	  "       -g version With -x, geni version. Must be '0', '0.1' or '2'\n".
	  "       -l specifies the location of the type limit file\n" .
          "       -1 Print an rspec containing only the node component-name\n" .
	  "       -z Randomize node output order\n" .
	  "       -Z Force old ptopgen\n");
        exit(-1);
}

my $optlist = "s:e:m:vp:rSan:c:uxg:h1:l:zZCb";
my $mfactor;
my $virtstuff = 0;
my $widearea  = 0;
my $simstuff  = 0;
my $allnodes  = 0;
my $mnetcores = 0;
my $mnetedges = 0;
my $prune     = 0;
my $do_xml    = 0;
my $genimode  = $NO_GENI;
my $useshared = 0;
my $useblockstore = 0;
my $component_name = undef;
my $randomize = 0;
my $usecontrol= 0;

my $OURDOMAIN = "@OURDOMAIN@";
my $MAINSITE  = @TBMAINSITE@;
my $cmuuid = TBGetSiteVar('protogeni/cm_uuid');
my $cmurn = "";
if ($PGENISUPPORT) {
    require GeniHRN;
    $cmurn = &GeniHRN::Generate($OURDOMAIN, "authority", "cm");
}

$opstate = <<'OPSTATE';
<rspec_opstate xmlns="http://www.geni.net/resources/rspec/ext/opstate/1"
  aggregate_manager_id="CMURN"
  start="geni_notready">
  <sliver_type name="raw-pc" />
  <sliver_type name="emulab-openvz" />
  <sliver_type name="emulab-xen" />

  <state name="geni_notready">
    <action name="geni_start" next="geni_configuring">
      <description>Boot the node</description>
    </action>
    <description>Raw PCs and VMs begin powered down or inactive. They
    must be explicitly booted before use.</description>
  </state>
  <state name="geni_configuring">
    <wait type="geni_success" next="geni_ready" />
    <wait type="geni_failure" next="geni_failed" />
    <description>Booting/Reloading takes a significant amount of time, so it
    happens asynchronously while the node is in this
    state.</description>
  </state>
  <state name="geni_ready">
    <action name="geni_restart" next="geni_configuring">
      <description>Reboot the node</description>
    </action>
    <action name="geni_stop" next="geni_stopping">
      <description>Power down or stop the node.</description>
    </action>
    <action name="geni_reload" next="geni_configuring">
      <description>Reload the node</description>
    </action>
    <action name="geni_update_users" next="geni_updating_users">
      <description>Update user SSH keys.</description>
    </action>
    <description>The node is up and ready to use.</description>
  </state>
  <state name="geni_stopping">
    <wait type="geni_success" next="geni_notready" />
    <wait type="geni_failure" next="geni_failed" />
    <description>The node is being stopped or rebooted.</description>
  </state>
  <state name="geni_failed">
    <description>The node has failed and requires administrator
    intervention before it can be used. Please contact
    the administrator for assistance.</description>
  </state>
  <state name="geni_updating_users">
    <action name="geni_update_users_cancel" next="geni_ready">
      <description>Cancel an update users action</description>
    </action>
    <wait type="geni_success" next="geni_ready" />
    <description>Updating users can take a fair amount of time, so it
    happens asynchronously in this state.</description>
  </state>
</rspec_opstate>
OPSTATE

$opstate =~ s/CMURN/$cmurn/g;


my $default_long = undef;
TBGetSiteVar('general/default_longitude', \$default_long);
my $default_lat = undef;
TBGetSiteVar('general/default_latitude', \$default_lat);
my $default_country = undef;
TBGetSiteVar('general/default_country', \$default_country);

my $delaycap_override;

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

# Settings - Change these to your particular network.

#
# Also bogus. The interfaces table does not hold entries for the switch
# side of each link. It will have to at some point, when we have something
# other than 100Mbs ports (say, gbit ports).
#
# Speed in in Kbs!
#
my $default_switchport_speed    = 100000;

#
# Yet more bogosity - we hardcode this weight, which is given to wide-area
# (primarily plab) nodes to prefer spreading across sites
#
my $site_weight = 0.99;

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

my $TBROOT = "@prefix@";
use lib '@prefix@/lib';
require exitonwarn;
use libdb;
use libtblog;
use Experiment;
use Node;
use NodeType;
use Lan;
use BlockstoreType;

tblog_stop_capture('stdout');

my $TRACK_INTERSWITCH_BANDWIDTH = "@TRACK_INTERSWITCH_BANDWIDTH@";

my %switches	  = ();
my %permissions   = ();
my %typemap       = ();
my %auxtypemap    = ();
my %areamap       = ();
my %globalcounts  = ();
my %interfacestate= ();
my %vinterfaces   = ();
my %rusagedata    = ();

my $DEADPID = NODEDEAD_PID();
my $DEADEID = NODEDEAD_EID();

my $pid;
my $exempt_eid;
my $switchtouse;
my $experiment;

my $typelimitfile = "";

sub fatal($);

#
# 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) {
    usage();
}
if (defined($options{"s"})) {
    $switchtouse = $options{"s"};
}
if (defined($options{"m"})) {
    $mfactor = $options{"m"};
}
if (defined($options{"h"})) {
    $useshared = 1;
}
if (defined($options{"b"})) {
    $useblockstore = 1;
}
if (defined($options{"v"})) {
    $virtstuff = 1;
}
if (defined($options{"r"})) {
    $widearea = 1;
}
if (defined($options{"S"})) {
    $simstuff = 1;
}
if (defined($options{"p"})) {
    $pid = $options{"p"};
}
if (defined($options{"a"})) {
    $allnodes = 1;
}
if (defined($options{"u"})) {
    $prune = 1;
}
if (defined($options{"c"})) {
    $delaycap_override = $options{"c"};
}
if (defined($options{"C"})) {
    $usecontrol = 1;
}
if (defined($options{"n"})) {
    if ($options{"n"} =~ /(\d*),(\d*)/) {
	$mnetcores = $1;
	$mnetedges = $2;
    }
    else {
	usage();
    }
}
if (defined($options{"e"})) {
    $exempt_eid = $options{"e"};
    usage()
	if (!defined($pid));
    $experiment = Experiment->Lookup($pid, $exempt_eid);
    die("Could not look up experiment $pid,$exempt_eid\n")
	if (!defined($experiment));
}
if (defined($options{"x"})) {
    if (defined($options{"g"}) && $PGENISUPPORT) {
	$useshared = 1;
	$virtstuff = 1;
	$genimode = $options{"g"};
    }
    $do_xml = 1;
}
if (defined($options{"l"})) {
    $typelimitfile = $options{"l"};
}
if (defined($options{"1"})) {
    $component_name = $options{"1"};
}
if (defined($options{"z"})) {
    $randomize = 1;
}

usage()
    if ($prune && !defined($exempt_eid)
	|| ($genimode ne $NO_GENI
	    && $genimode ne $V_0_1
	    && $genimode ne $V_0_2
	    && $genimode ne $V_2
	    && $genimode ne $V_3));

if (defined($pid) && ! defined($options{"Z"})) {
    my $group = Group->Lookup($pid, $pid);
    if (defined($group)) {
	$EmulabFeatures::verbose = 0;
	my $newptopgen = EmulabFeatures->FeatureEnabled("NewPtopgen", undef,
							$group, undef);
	if ($newptopgen) {
	    my $newpath = "$TBROOT/libexec/ptopgen_new";
	    print STDERR "Invoking new ptopgen from $newpath\n"
		if (!$genimode);
	    exec $newpath, @SAVEARGV;
	    die("*** $0:\n".
		"    Could not exec $newpath: $!");
	}
    }
}

$fake_inet_switch = "internet";
$fake_inet_iface = "(null)";
$fake_air_switch = "airswitch";
$fake_air_iface = "(null)";
if ($genimode ne $NO_GENI) {
    $fake_inet_iface = "border";
    $fake_air_iface = "air";
}

my %nodetointerface;
my %interfaceroles = ();
my %interfacetypes = ();
my %interfaceips = ();

# Read interfaces
my $result =
    DBQueryFatal("SELECT node_id,card,port,iface,interface_type,role,IP" .
		 " from interfaces where logical=0 " .
		 ($genimode ne $NO_GENI ? "and role!='gw'" : ""));
		 
while (($node,$card,$port,$iface,$type,$role,$ip) = $result->fetchrow_array) {
    push @{ $nodetointerface{"$node"} }, $iface;
    $interfacemap{"$node:$card:$port"} = $iface;
    if ((defined $type) && ($type ne "")) {
	$interfacetypes{"$node:$card:$port"} = $type;
    }
    if ((defined $role) && ($role ne "")) {
	$interfaceroles{"$node:$iface"} = $role;
    }
    if ((defined $ip) && ($ip ne "")) {
	$interfaceips{"$node:$iface"} = $ip;
    }
}

my %used_vlans = ();

$result =
    DBQueryFatal("SELECT tag from reserved_vlantags");
while (($vlantag) = $result->fetchrow_array) {
    $used_vlans{$vlantag} = 1;
}

sub AvailableVlans($)
{
    my ($vlanString) = @_;
    my $result = '';
    my $comma = '';
    my @ranges = split(',', $vlanString);
    foreach my $range (@ranges) {
	my @bounds = split('-', $range);
	my $lower = $bounds[0];
	my $upper = $lower;
	if (scalar(@bounds) > 1) {
	    $upper = $bounds[1];
	}
	my $least = $lower;
	my $greatest = $lower;
	my $inRange = 0;
	my $i = $lower;
	for (; $i <= $upper; ++$i) {
	    if ($inRange && (exists($used_vlans{$i}) || $i == $upper)) {
		if ($i == $upper && ! exists($used_vlans{$i})) {
		    $greatest = $i;
		}
		if ($least != $greatest) {
		    $result .= $comma . $least . '-' . $greatest;
		} else {
		    $result .= $comma . $least;
		}
		$comma = ',';
		$inRange = 0;
	    }
	    elsif (! $inRange && ! exists($used_vlans{$i})) {
		$least = $i;
		$inRange = 1;
	    }
	    $greatest = $i;
	}
    }
    return $result;
}

my %external_nodes;
my %external_managers;
my %external_ifaces;
my %external_links;
my %contact_nodes;
my %contact_ifaces;
my %stitch_points;

$result = DBQueryFatal("select w.node_id1, w.card1, w.port1, i1.iface, ".
		       "w.node_id2, w.card2, w.port2, i2.iface, ".
		       "w.external_interface, w.external_wire, ".
		       "e.node_id, e.vlans, ".
		       "e.external_manager, e.network_id, e.external_interface, e.external_wire, e.external_subport ".
		       "from wires as w ".
		       "left join external_networks as e ".
		       "on w.node_id1=e.node_id or w.node_id2=e.node_id ".
		       "left join interfaces as i1 on w.node_id1=i1.node_id and w.card1=i1.card and w.port1=i1.port ".
		       "left join interfaces as i2 on w.node_id2=i2.node_id and w.card2=i2.card and w.port2=i2.port ".
		       "where e.node_id is not null");
while (my ($cnode, $ccard, $cport, $ciface, $enode, $ecard, $eport, $eiface,
	   $external_iface_urn, $external_link_urn, $external, $vlanList,
	   $external_manager_urn,
	   $external_network_id, $external_network_iface_urn,
       $external_network_link_urn, $subport) = $result->fetchrow_array) {
    if ($external eq $cnode) {
	my $temp;
	$temp = $cnode; $cnode = $enode; $enode = $temp;
	$temp = $ccard; $ccard = $ecard; $ecard = $temp;
	$temp = $cport; $cport = $eport; $eport = $temp;
	$temp = $ciface; $ciface = $eiface; $eiface = $temp;
    }
    $stitch_points{"$cnode:$enode"} = 1;
    $enode = $external_network_id;
    if (! defined($eiface)) {
	$eiface = "$ecard.$eport";
    }
    if (! defined($ciface)) {
	$ciface = "$ccard.$cport";
    }
    my $ciface_urn;
    if (defined($subport)) {
	$ciface_urn = $subport;
    } else {
	$ciface_urn = GeniHRN::GenerateInterface($OURDOMAIN,
						 $cnode,
						 $ciface);
    }
    if (! defined($external_iface_urn)) {
	$external_iface_urn = $external_network_iface_urn;
    }
    if (! defined($external_link_urn)) {
	$external_link_urn = $external_network_link_urn;
    }
    if ($allnodes) {
	$external_nodes{$enode} = $vlanList;
    } else {
	$external_nodes{$enode} = AvailableVlans($vlanList);
    }
    $external_managers{"$cnode:$enode"} = $external_manager_urn;
    $external_ifaces{"$cnode:$enode"} = $external_iface_urn;
    $external_links{"$cnode:$enode"} = $external_link_urn;
    if (exists($contact_nodes{$cnode})) {
	push(@{ $contact_nodes{$cnode} }, $enode);
    } else {
	$contact_nodes{$cnode} = [$enode];
    }
    $contact_ifaces{"$cnode:$enode"} = $ciface_urn;
}

print_header();

my %nodetouuid;
my %nodetoavailable;

$result = DBQueryFatal("SELECT n.node_id, n.eventstate, n.role, n.uuid, " .
		       "nt.isremotenode, " .
		       "dedicated_wa_types.attrvalue, b.erole, " .
		       "n.reserved_pid, b.eid " .
		       "from nodes as n " .
		       "left join reserved as b on n.node_id=b.node_id " .
		       "left join node_types as nt on nt.type=n.type " .
		       "left outer join " .
		       "  (select type, attrvalue " .
		       "   from node_type_attributes " .
		       "   where attrkey='dedicated_widearea' " .
		       "   group by type) as dedicated_wa_types " .
		       "  on nt.type=dedicated_wa_types.type " .
		       "where nt.isvirtnode = 0 or nt.isvirtnode is null;");
while (($node,$eventstate, $role, $uuid, $isremotenode,
	$wa_attrvalue, $erole,
	$reserved_pid, $reserved_eid) = $result->fetchrow_array) {
    if (defined($uuid) && $uuid ne "")
    {
	$nodetouuid{$node} = $uuid;
    }
    my $islocal = $role eq 'testnode'
	&& ((! defined($isremotenode) || $isremotenode == 0)
	    || (defined($wa_attrvalue) && $wa_attrvalue == 1));
    my $isup = defined($eventstate)
	&& ($eventstate eq TBDB_NODESTATE_ISUP
	    || $eventstate eq TBDB_NODESTATE_PXEWAIT
	    || $eventstate eq TBDB_NODESTATE_POWEROFF
	    || $eventstate eq TBDB_NODESTATE_ALWAYSUP);
    my $isshared = (defined($erole)
		    && $erole eq "sharedhost"
		    && $useshared
		    && $isup);
    my $isblockstore = (defined($erole)
			&& $erole eq "storagehost"
			&& $useblockstore
			&& $isup);
    my $isreserved = (defined($reserved_eid)
		      || (defined($reserved_pid)
			  && (! defined($pid) || $pid ne $reserved_pid)));
    my $isfree = (!$islocal
		  || (! $isreserved && $isup)
		  || $isshared || $isblockstore);
    $nodetoavailable{$node} = $isfree;
}

# Read class/type maps
$result =
    DBQueryFatal("select class,type,isvirtnode from node_types");

while (my ($class,$type,$isvirt) = $result->fetchrow_array) {
    $map = {};
    $map->{'CLASS'}    = $class;
    $map->{'ISVIRT'}   = $isvirt;
    my $typeinfo       = NodeType->Lookup($type);
    $map->{'DELAYCAP'} = $typeinfo->delay_capacity();
    $map->{'VIRTCAP'}  = $typeinfo->virtnode_capacity();
    $map->{'SIMCAP'}   = $typeinfo->simnode_capacity();
    $map->{'SPEED'}    = $typeinfo->frequency();
    $map->{'RAM'}      = $typeinfo->memory();
    $map->{'OSID'}     = $typeinfo->default_osid();
    $map->{'IMAGEABLE'}= $typeinfo->imageable();
    $map->{'TRIVSPEED'}= $typeinfo->trivlink_maxspeed();
    $map->{'SHARED'}   = $typeinfo->shared();
    $map->{'TYPEINFO'} = $typeinfo;
    $map->{'FEATURES'} = [];
    $map->{'AUXTYPES'} = {};
    $map->{'OSLIST'} = [];
    $typemap{$type} = $map;

    # Default is permission to use all types,classes. 
    $permissions{$class} = 1;
    $permissions{$type}  = 1;
}

# Figure out which nodes will use a USB dongle to boot. As a proxy, we
# look for the pxe_boot_path pointing to the tpm version of grub.
our %node_usb;

$result = DBQueryFatal("select node_id from node_attributes ".
		       "where attrkey='pxe_boot_path' and ".
		       "      attrvalue='/tftpboot/pxeboot_tpm'");
while (($node) = $result->fetchrow_array) {
    $node_usb{$node} = 1;
}

#
# Physical RAM overrides.
#
my %node_ram;

$result = DBQueryFatal("select node_id,attrvalue from node_attributes ".
		       "where attrkey='physical_ram'");
while (my ($nodeid,$ram) = $result->fetchrow_array) {
    $node_ram{$nodeid} = $ram;
}

# Read node_startloc
$result = DBQueryFatal("select node_id,building from node_startloc");
while (($node,$building) = $result->fetchrow_array) {
    # TODO: This screws up the meaning of the @features list. Now it
    # is not just a list of feature strings, but a list of strings
    # which might themselves be space-delimited lists of feature
    # strings. Fix this.
    $areamap{$node} .= " area-$building:0";
}

#
# Read the features table for each type.
# 
$result = DBQueryFatal("select type, feature, weight from node_type_features");
while (my ($type, $feature, $weight) = $result->fetchrow()) {
    push(@{$typemap{$type}->{'FEATURES'}}, "$feature:$weight");
}

#
# Read the auxtypes for each type.
# 
$result = DBQueryFatal("select auxtype,type from node_types_auxtypes");
while (my ($auxtype,$type) = $result->fetchrow()) {
    $typemap{$type}->{'AUXTYPES'}->{$auxtype} = 1;
    $auxtypemap{$auxtype} = $type;
}

#
# Read the features table for each individual node
#
$result = DBQueryFatal("select node_id, feature, weight from node_features");
while (my ($node_id, $feature, $weight) = $result->fetchrow()) {
    if (! defined($features{$node_id})) {
	$features{$node_id} = ["$feature:$weight"];
	next;
    } else {
	push @{$features{$node_id}}, "$feature:$weight";
    }
}

#
# Read in the node_auxtypes table for each node.
#
$result = DBQueryFatal("select node_id, type, count from node_auxtypes");
while (my ($node_id, $type, $count) = $result->fetchrow()) {
    if (! defined($auxtypes{$node_id})) {
	$auxtypes{$node_id} = ["$type:$count"];
	next;
    }
    push @{$auxtypes{$node_id}}, "$type:$count";
}
#
# Read the permission table if given a pid. If there is an entry in
# the table for a type/class, then permission is granted only if there
# is a record with the pid. If not, remove the permission granted above.
# 
if (defined($pid)) {
    $result =
	DBQueryFatal("select type from nodetypeXpid_permissions");
    
    while (my ($type) = $result->fetchrow_array) {
	$permissions{$type} = 0;
    }
    
    $result =
	DBQueryFatal("select type from nodetypeXpid_permissions ".
		     "where pid='$pid'");
    
    while (my ($type) = $result->fetchrow_array) {
	$permissions{$type} = 1;
    }
}

#
# Read the table of which image types are supported on which hardware - we
# limit this to global images and ones that match the PID (if given) We do this
# limiting for two reasons:
# 1) To avoid an explosion in the number of features for nodes
# 2) To avoid information leaks, allowing projects to see each other's images
# 
my $osidquery = "select distinct o.osid, oi.type, o.osname, o.pid, o.OS, o.version, o.description,o.protogeni_export, o.osfeatures from os_info as o " .
	"left join osidtoimageid as oi on o.osid = oi.osid " .
        "left join images as i on oi.imageid = i.imageid ";
if ($pid) {
    $osidquery .= "left join image_permissions as p1 on p1.imageid=i.imageid and p1.permission_type='group' ".
	"left join groups as g on p1.permission_idx=g.gid_idx ";
}
$osidquery .= "where i.global = 1 ";
if ($pid) {
    $osidquery .= " or i.pid='$pid' ".
	" or (g.pid is not null and g.pid='$pid')";
}

my $defaultosidquery = 'select distinct o.osid, t.type, o.osname, o.pid, o.OS, o.version, o.description, o.protogeni_export, o.osfeatures '.
    'from os_info as o left join node_type_attributes as t '.
    'on (o.osid=t.attrvalue) where t.attrkey="default_osid"';

#
# For subOS support (i.e., vnode OSes running atop vhost OSes), we have to
# check both the subosid and all the parent_osid it can run on.
#
my $subosidquery = "select distinct o.osid,o.parent_osid from os_submap as o " .
	"left join osidtoimageid as oi1 on o.osid = oi1.osid " .
	"left join osidtoimageid as oi2 on o.parent_osid = oi2.osid " .
	"left join images as i1 on oi1.imageid = i1.imageid ".
	"left join images as i2 on oi2.imageid = i2.imageid ".
	"where (i1.imageid is null or i1.global = 1";
if ($pid) {
    $subosidquery .= " or i1.pid='$pid'";
}
$subosidquery .= ") and (i2.global = 1";
if ($pid) {
    $subosidquery .= " or i2.pid='$pid'";
}
$subosidquery .= ")";

our %node_type_osids;
our %osid_node_types;
our %osid_subosids;
our %osid_name;
our %osid_pid;
our %osid_os;
our %osid_version;
our %osid_description;
our %osid_avoid_usb;
our %node_countries;
our %node_latitudes;
our %node_longitudes;

our $openvzid;

$result = DBQueryFatal($osidquery);
processOs($result);

$result = DBQueryFatal($defaultosidquery);
processOs($result);

sub processOs
{
    my $result = shift(@_);
    while (my ($osid,$type,$osname,$ospid,$osos, $osversion,
	       $osdescription,$geni,$osfeatures) = $result->fetchrow()) {
	if ($osname eq "OPENVZ-STD") {
	    $openvzid = $osid;
	}
	if ($typemap{$type}) {
	    my $default = $typemap{$type}->{'OSID'};
	    if ($geni eq 1 ||
		(defined($default) && $default eq $osid)) {
		push(@{ $typemap{$type}->{'OSLIST'} }, $osid);
		$osid_name{$osid} = $osname;
		$osid_pid{$osid} = $ospid;
		$osid_os{$osid} = $osos;
		$osid_version{$osid} = $osversion;
		$osid_description{$osid} = $osdescription;
	    }
	}
	if ($node_type_osids{$type}) {
	    push @{$node_type_osids{$type}}, $osid;
	} else {
	    $node_type_osids{$type} = [$osid];
	}
	if (defined($osfeatures) && $osfeatures =~ /no-usb-boot/) {
	    $osid_avoid_usb{$osid} = 1;
	}
	#
	# We have to maintain a data structure telling us which types an OSID could
	# be on for use below with generic OSIDs
	#
	if ($osid_node_types{$osid}) {
	    push @{$osid_node_types{$osid}}, $type;
	} else {
	    $osid_node_types{$osid} = [$type];
	}
    }
}
#
# XXX Note below that for now, subosids cannot redirect to other subosids.
#
$result = DBQueryFatal($subosidquery);
while (my ($subosid,$osid) = $result->fetchrow()) {
    if ($osid_subosids{$osid}) {
	push @{$osid_subosids{$osid}}, $subosid;
    } else {
	$osid_subosids{$osid} = [$subosid];
    }
}

#
# We also have to resolve the 'generic' OSIDs, which use the nextosid field to
# redirect to another OSID
#
$result = DBQueryFatal("select osid,nextosid from os_info where " .
    "nextosid is not null");
while (my ($osid,$nextosid) = $result->fetchrow()) {
    if (defined($openvzid) && $osid == $openvzid) {
	$openvzid = $nextosid;
    }
    #
    # Check to see if they were allowed to use the real OSID
    #
    my $realosid = TBResolveNextOSID($osid, $pid, $exempt_eid);
    if (defined($realosid) && $osid_node_types{$realosid}) {
	foreach my $type (@{$osid_node_types{$realosid}}) {
	    push @{$node_type_osids{$type}}, $osid;
	}
    }
}

# Print switches
if (defined($switchtouse) && ! defined($component_name)) {
    # Should probably get the last four args out of the database, but I don't
    # think we ever actually use this case...
    print_switch($switchtouse,undef,undef,undef,undef,undef);
    $switches{$switchtouse} = 1;
}
elsif (! defined($component_name)) {
    $result =
	DBQueryFatal("select n.node_id,n.uuid,country,latitude,longitude, ".
		     "       na.attrvalue ".
                     "   from nodes as n ".
		     "left join widearea_nodeinfo as wn ".
                     "     on n.node_id=wn.node_id " .
		     "left join node_types as nt on ".
		     "     nt.type=n.type ".
		     "left join node_type_attributes as na on ".
		     "     na.type=n.type and ".
		     "     na.attrkey='forwarding_protocols' ".
		     "where ".
		     ($usecontrol ?
		      "role='ctrlswitch' and nt.isswitch=1" :
		      "role='testswitch' or role='widearea_switch' or ".
		      "n.type='external-switch' or ".
		      "      (role='testnodefoo' and nt.isswitch=1)"));

    while (($switch, $uuid, $country, $latitude, $longitude, $protocols) =
            $result->fetchrow_array) {
	print_switch($switch, $uuid,
		     $country, $latitude, $longitude, $protocols);
	$switches{$switch} = 1;
    }
}

#
# Get the global counts.
#
$result =
    DBQueryFatal("select phys_nodeid,count(phys_nodeid) from reserved as r ".
		 "left join nodes as n on n.node_id=r.node_id ".
		 "where n.node_id!=n.phys_nodeid ".
		 (defined($exempt_eid) ?
		  "and not (pid='$pid' and eid='$exempt_eid') " : " ") .
		 "group by phys_nodeid");
while (my ($node_id,$count) = $result->fetchrow_array) {
    $globalcounts{$node_id} = $count;
}

#
# Get the memory usage on each physical node. 
# This will be subtracted from whatever the type/node info says.
# Note that we have to exclude nodes from this experiment
# that are already mapped to the node since the user already owns that memory.
#
my %node_ramusage;

if ($virtstuff) {
    $result =
	DBQueryFatal("select n.phys_nodeid,n.reserved_memory from nodes as n ".
		     "left join reserved as r on r.node_id=n.node_id ".
		     "where n.node_id!=n.phys_nodeid ".
		     (defined($experiment) ?
		      "and r.exptidx!=" . $experiment->idx() : ""));

    while (my ($pnode,$memory) = $result->fetchrow_array()) {
	$node_ramusage{$pnode} = 0
	    if (!exists($node_ramusage{$pnode}));
	
	$node_ramusage{$pnode} += $memory;
    }

    #
    # When running xen and there is a dom0mem attribute, we need to
    # subtract that too since it is not available. But we do not know
    # for sure that the node is running XEN. Need to addres this at
    # some point.
    #
    $result = DBQueryFatal("select node_id,attrvalue from nodes as n ".
			   "left join node_type_attributes as na on ".
			   "     na.type=n.type and ".
			   "     na.attrkey='dom0mem' ".
			   "where na.attrkey is not null");
    while (my ($pnode,$ram) = $result->fetchrow_array) {
	$node_ramusage{$pnode} = 0
	    if (!exists($node_ramusage{$pnode}));

	# Ug, units.
	if ($ram =~ /^(\d*)M$/) {
	    $ram = $1;
	}
	$node_ramusage{$pnode} += $ram;
    }
}

# Find available nodes.
#
# This first query deals with just local nodes. Local nodes can host
# virtnodes, according to the delay_capacity in the types table. 
#

# the ordinary free condition for a local node.
my $free_condition = "(b.node_id is null and ".
                     " (np.eventstate='" . TBDB_NODESTATE_ISUP . "' or ".
                     "  np.eventstate='" . TBDB_NODESTATE_PXEWAIT . "' or ".
                     "  np.eventstate='" . TBDB_NODESTATE_POWEROFF . "' or ".
                     "  np.eventstate='" . TBDB_NODESTATE_ALWAYSUP . "')) ";

if (defined($pid)) {
    $free_condition = "($free_condition and ".
	"(np.reserved_pid is null or np.reserved_pid='$pid'))";
}

# if the user has specified an exempt pid/eid, 
# then view any node which is reserved to that experiment as available.
if (defined($exempt_eid)) {
    $free_condition = "($free_condition or ".
	"(b.pid='$pid' and b.eid='$exempt_eid'))"; 
}

# In shared mode, allow allocated nodes whose sharing_mode is set.
if ($useshared) {
    $free_condition = "($free_condition or ".
	"(b.node_id is not null && b.erole='sharedhost' && ".
	" np.eventstate='" . TBDB_NODESTATE_ISUP . "'))";
}

# In blockstore mode, allow allocated nodes who are storagehosts.
if ($useblockstore) {
    $free_condition = "($free_condition or ".
	"(b.node_id is not null && b.erole='storagehost' && ".
	" np.eventstate='" . TBDB_NODESTATE_ISUP . "'))";
}

# If the user wants all nodes, we consider everything to be free (this
# overrides the other possible free conditions
if ($allnodes) {
    $free_condition = "1";
}

# By default, include no wide area nodes when setting up the data structures.
#$free_condition = "($free_condition and ".
#    "(t.isremotenode=0 or ".
#    "dedicated_wa_types.attrvalue=1))";

# But if they have asked for widearea, we want this prepass to include
# these nodes.
#if ($widearea) {
#    $free_condition = "($free_condition or ".
#	"(t.isremotenode=1 and ".
#	"t.isvirtnode=0 and t.type!='pcfedphys' and ".
#	"dedicated_wa_types.attrvalue is NULL))";
#}


# In genimode exclude nodes with exclusion attribute.
if ($genimode ne $NO_GENI) {
    $free_condition = "($free_condition and ".
	"(nat1.attrvalue is null or nat1.attrvalue=0))";
}

if (defined($component_name)) {
    $free_condition = "(a.node_id = \"$component_name\")";
}

$result =
    DBQueryFatal("select a.node_id,a.type,a.phys_nodeid,t.class,t.issubnode," .
		 "a.def_boot_osid,(b.pid is not null and b.eid is not null), ".
		 "  np.reserved_pid,np.eventstate, ".
		 "  np.battery_percentage,np.uuid,b.sharing_mode, ".
		 "  ru.load_1min, ru.load_5min, ru.status_timestamp, ".
		 "  a.def_boot_osid, nat2.attrvalue, wn.country, " .
                 "  wn.latitude, wn.longitude, t.isremotenode, b.erole, ".
		 "  nat3.attrvalue, so.osfeatures ".
		 "from nodes as a ".
		 "left join reserved as b on a.node_id=b.node_id ".
		 "left join reserved as m on a.phys_nodeid=m.node_id ".
		 "left join nodes as np on a.phys_nodeid=np.node_id ".
		 "left join node_types as t on t.type=a.type ".
		 "left join node_attributes as nat1 on ".
		 "     nat1.node_id=a.node_id and ".
		 "     nat1.attrkey='protogeni_exclude' ".
		 "left join node_attributes as nat2 on ".
		 "     nat2.node_id=a.node_id and ".
		 "     nat2.attrkey='shared_weight' ".
		 "left join node_attributes as nat3 on ".
		 "     nat3.node_id=a.node_id and ".
		 "     nat3.attrkey='allowed_projects' ".
		 "left join node_rusage as ru on ru.node_id=a.node_id ".
		 "left outer join ". 
		 "  (select type,attrvalue ".
		 "   from node_type_attributes ".
		 "   where attrkey='dedicated_widearea' ".
		 "   group by type) as dedicated_wa_types ".
		 "  on t.type=dedicated_wa_types.type ".
                 "left join widearea_nodeinfo as wn on a.node_id=wn.node_id ".
		 "left join os_info as so on a.def_boot_osid=so.osid ".
		 "where $free_condition and ".
		 "   (a.role='testnode' and (t.isremotenode=0 or ".
		 "                           dedicated_wa_types.attrvalue=1))");

%storage_node = ();

#
# Scan the results, checking permissions and adding to the list
# You get to use a node type if no pid was specified (that is, you get
# to use all nodes), or if there is no entry in the perms table for
# the type/class of node.
#
while (($node,$type,$physnode,$class,$issubnode,$def_boot_osid,$reserved,
	$prereserved,$eventstate,$battery_perc,$uuid,$sharing_mode,
	$load_1min,$load_5min,$load_tstamp,$osid,$weight,$country,$latitude,
        $longitude,$isremote,$erole,
	$allowed_projects,$osfeatures) = $result->fetchrow_array) {
    my $current = $top->CreateNode($node);
    $current->SetSubnode($physnode, $issubnode);
    $current->SetRemote($isremote);

    #
    # Look for a specific node restriction. Easier to to do here
    # then trying to do this up above in the already bizarre query.
    #
    if (defined($pid) && defined($allowed_projects)) {
	my @allowed = split(",", $allowed_projects);
	next
	    if (! grep {$_ eq $pid} @allowed);	
    }

    $nodes{$node} = $type
	if (!defined($pid) ||
	    ($permissions{$type} && $permissions{$class}));
    $node_def_boot_osid{$node} = $def_boot_osid;

    if ($reserved) {
	$is_reserved{$node} = 1;
    } else {
	$is_reserved{$node} = 0;
    }
    if ($useshared && $sharing_mode) {
	$sharing_mode{$node} = { "load_1min"   => $load_1min,
				 "load_5min"   => $load_5min,
				 "load_tstamp" => $load_tstamp,
				 "osid"        => $osid,
				 "osfeatures"  => $osfeatures,
				 "weight"      => $weight };
    } else {
	$sharing_mode{$node} = 0;
    }

    if (defined($erole) && $erole eq "storagehost") {
	$storage_node{$node} = 1;
    }

    if (defined($prereserved) && !(defined($pid) && $prereserved eq $pid)) {
	$is_prereserved{$node} = $prereserved;
    }

    $curr_state{$node} = $eventstate;
    $curr_batt{$node} = $battery_perc;

    $node_countries{$node} = $country;
    $node_latitudes{$node} = $latitude;
    $node_longitudes{$node} = $longitude;
}

#
# Find out which nodes are connected to which, so that we can add some special
# features
#
$result = DBQueryFatal("SELECT DISTINCT node_id1, node_id2 " .
                       "  FROM wires where logical=0 and type!='Unused'");
my %connections = ();
while (my ($node_id1, $node_id2) = $result->fetchrow()) {
    foreach my $nodes ([$node_id1, $node_id2], [$node_id2, $node_id1]) {
        my ($node1, $node2) = @$nodes;
        if ($connections{$node1}) {
            # Check to see if we've already added this one (possible if the
            # nodes appeared in node1,node2 order, then node2,node1
            if (!grep(/^$node2$/, @{$connections{$node1}})) {
                push @{$connections{$node1}}, $node2;
            }
        } else {
            $connections{$node1} = [$node2];
        }
    }
}

@nodenames = keys(%nodes);
if ($randomize)
{
    @nodenames = shuffle(@nodenames);
}

#
# Loop through and print out all nodes
#
foreach $node (@nodenames) {
    my $current = $top->nodes()->{$node};

    # Wide area nodes are handled below
#    next
#	if ($current->is_remote());

    my $type  = $nodes{$node};
    my $class = $typemap{$type}->{'CLASS'};
    my $delay_capacity = $typemap{$type}->{'DELAYCAP'};
    my $simnode_capacity = $typemap{$type}->{'SIMCAP'};
    my $cpu_speed = $typemap{$type}->{'SPEED'};
    my $ram = $typemap{$type}->{'RAM'};
    my $trivspeed = $typemap{$type}->{'TRIVSPEED'};
    my $uuid = $nodetouuid{$node};
    
    my @types = ("$type:1");
    my @sliver_types = ();
    my @features = ();
    my @flags;
    my $needvirtgoo = 0;

    my ($latitude, $longitude, $country);

    # per-node override RAM.
    $ram = $node_ram{$node} if (exists($node_ram{$node}));
    if (exists($node_ramusage{$node})) {
	$ram -= $node_ramusage{$node};
	# Should this be an error?
	$ram = 0
	    if ($ram < 0);
    }

    # XXX temporary hack until node reboot avoidance 
    # is available. Nodes running the FBSD-NSE image
    # will have a feature def-osid-fbsd-nse 0.0
    # This is used by assign to prefer these pnodes
    # first before using others.
    if($node_def_boot_osid{$node} && ($node_def_boot_osid{$node} eq 
	TBOSID(TB_OPSPID, "FBSD-NSE"))) { 
	push(@features, "FBSD-NSE:0.0");
    }

    #
    # XXX: Temporary hack - don't march switches that are testnodes
    # as having class 'switch' - assign treats those specially. We
    # use the knowledge that 'real' switches don't hit this point!
    #
    if ($class eq "switch") {
	$class = $type;
    }
        
    # Might be equal, which assign would sum as two, not one!
    if ($type ne $class) {
	push(@types, "$class:1");
    }

    my $explicit =
	$typemap{$type}->{'TYPEINFO'}->GetAttribute("explicit_request");
    if (defined($explicit)) {
	push(@features, "$type-explicit:1");
    }
    if (defined($delay_capacity) && $delay_capacity > 0) {
	# Comes from the NS file;
	$delay_capacity = $delaycap_override
	    if (defined($delaycap_override) &&
		$delaycap_override > 0 &&
		$delaycap_override < $delay_capacity);
	
	push @types, "delay:$delay_capacity";
	push @types, "delay-${type}:$delay_capacity";
    }

    #
    # Prototype shared mode.
    #
    if ($sharing_mode{$node}) {
	#
	# Add a feature that says this node should not be picked
	# unless the cooresponding desire is in the vtop. This
	# allows the node to be picked, subject to other type constraints.
	#
	push(@features, "pcshared:1.0");

	#
	# Add a first-free feature which spreads VMs amongs shared nodes.
	#
	push(@features, "*&spreadshared:0.6");

	#
	# The pool daemon may override the share weight.
	#
	if (defined($sharing_mode{$node}->{"weight"})) {
	    my $weight = $sharing_mode{$node}->{"weight"};
	    
	    push(@features, "shareweight:$weight");
	}
	else {
	    #
	    # The point of this feature is to have assign favor shared nodes
	    # that already have nodes on them, so that they are well packed.
	    # Shared nodes with just a few vnodes on them are avoided so that
	    # they will free up eventually. 
	    #
	    my $maxvnodes = 10;
	    my $weight    = 0.5;
	    my $gcount    = $globalcounts{$node} || 0.0;

	    foreach my $auxinfo (@{$auxtypes{$node}}) {
		my ($auxtype,$count) = split(":", $auxinfo);
		
		if ($auxtype eq "pcvm") {
		    $maxvnodes = $count;
		    last;
		}
	    }
	    #
	    # No point in the feature if no room left. 
	    #
	    if ($maxvnodes > $gcount) {
		my $factor = ($gcount / $maxvnodes);
		if ($factor < 0.25) {
		    $weight = 0.8;
		}
		elsif ($factor > 0.75) {
		    $weight = 0.1;
		}
		else {
		    $weight = 0.3;
		}
		#push(@features, "shareweight:$weight");
	    }
	}
	my $osfeatures = $sharing_mode{$node}->{'osfeatures'};
	if (defined($osfeatures)) {
	    my @features = split(',', $osfeatures);
	    my $i = 0;
	    for (; $i < scalar(@features); ++$i) {
		if ($features[$i] eq 'openvz-host') {
		    push(@sliver_types, "emulab-openvz");
		} elsif ($features[$i] eq 'xen-host') {
		    push(@sliver_types, "emulab-xen");
		}
	    }
	}
    } else {
	push(@sliver_types, "raw-pc");
	push(@sliver_types, "emulab-openvz");
	push(@sliver_types, "emulab-xen");	
    }

    #
    # Storage Nodes
    #
    if (exists($storage_node{$node})) {
	push(@features, "pcstorage:1.0");
    }

    #
    # Add any auxiliary types
    #
    foreach my $auxinfo (@{$auxtypes{$node}}) {
	my ($auxtype,$count) = split(":", $auxinfo);
	my $realtype;

	# Map an auxtype back to its real type, unless it is a real type.
	if (defined($auxtypemap{$auxtype})) {
	    $realtype = $auxtypemap{$auxtype};
	}
	else {
	    $realtype = $auxtype;
	}

	if ($typemap{$realtype}->{'ISVIRT'} && $count > 0) {
	    next
		if (! $virtstuff);

	    #
	    # If the node is shared, must subtract the current global count
	    # from the max first, to see if there is any room left.
	    #
	    if ($sharing_mode{$node} && exists($globalcounts{$node})) {
		$count -= $globalcounts{$node};
	    }
	    if (defined($mfactor) && $mfactor <= $count) {
		$count = $mfactor;
	    }
	    $auxinfo = "$auxtype:$count";
	    $needvirtgoo = 1;

	    #
	    # Add in machine specific auxtypes that use the same count.
	    #
	    push(@types, "${type}-vm:$count");

	    # And a legacy type.
	    my $legacy_type = $type;
	    if (($legacy_type =~ s/pc/pcvm/)) {
		push(@types, "${legacy_type}:$count");
	    }
	}
	push(@types, $auxinfo);
    }

    if (defined($areamap{$node})) {
	push @features, $areamap{$node};
    }

    my $cpu_ram_features_present = 0;
    #
    # This stuff is extra goo for local virtual nodes.
    # 
    if ($needvirtgoo) {
	push @types, "*lan:*";
	# Add trivial bw spec., but only if the node type has it
	if ($trivspeed) {
	    push @flags, "trivial_bw:$trivspeed";
	}
	# Add CPU and RAM information
	$cpu_ram_features_present++;

	if (! $sharing_mode{$node}) {
	    # This number can be use for fine-tuning packing
	    push @features, "?+virtpercent:100";
	}
	# Put this silly feature in so that we can try to keep vnodes
	# on the same pnode they were before - but only if updating
        if ($exempt_eid) {
            push @features, "${node}:0.0";
        }
    }

    if ($simstuff && defined($simnode_capacity) && $simnode_capacity > 0) {
	#
	# Use user specified multiplex factor
	#
	if (defined($mfactor) && $mfactor <= $simnode_capacity) {
	    push @types, "sim:$mfactor";
	}
	else {
	    push @types, "sim:$simnode_capacity";
	}
	# Add CPU and RAM information
	$cpu_ram_features_present++;
	push @types, "*lan:*";
	# Add trivial bw spec.
	push @flags, "trivial_bw:100000";
    }
    if ($cpu_ram_features_present) {
	# Add CPU and RAM information
	push @features, "?+cpu:$cpu_speed"
	    if (defined($cpu_speed));
	push @features, "?+ram:$ram"
	    if (defined($ram));
	push @features, "?+cpupercent:92"; # XXX Hack
	push @features, "?+rampercent:80"; # XXX Hack
    }

    # Add features
    if (! $sharing_mode{$node}) {
	push(@features, @{$typemap{$type}->{'FEATURES'}});
	if (defined($features{$node})) {
	    push @features, @{$features{$node}};
	}
    } else {
	for my $feature (@{$typemap{$type}->{'FEATURES'}}) {
	    # TODO: Un-hardcode this. Ugh.
	    if ($feature =~ /highvlan/) {
		push(@features, $feature);
	    }
	}
    }

    #
    # Add in OS features.
    #
    if ($sharing_mode{$node}) {
	#
	# A shared node is running just one OS, and we put that in
	# so that the user can specify which of the current VM types
	# is wanted.
	#
	my $osid = $sharing_mode{$node}->{'osid'};
	push(@features, "OS-$osid:0.5");
	# Add any subOSes the shared node osid can support
	if (defined($osid_subosids{$osid})) {
	    push (@features, map "OS-$osid-$_:0", @{$osid_subosids{$osid}});
	}
    }
    elsif ($node_type_osids{$type}) {
	#
	# Add in features for all of the OSes that this node (as
	# evidenced by its type) can support
	#
	foreach my $o1 (@{$node_type_osids{$type}}) {
	    if (! exists($node_usb{$node}) || ! exists($osid_avoid_usb{$o1})) {
		push @features, "OS-$o1:0";
		foreach my $o2 (@{$osid_subosids{$o1}}) {
		    push @features, "OS-$o1-$o2:0";
		}
	    }
	}
    }
    elsif (! $typemap{$type}->{'IMAGEABLE'} &&
	   defined($typemap{$type}->{'OSID'})) {
	#
	# If node is not imageable (and thus no entries in osidtoimageid,
	# then assume it always has its default OSID loaded and ready to
	# go, so that assign will agree to the allocation (assign_wrapper
	# adds a desire that says it has to be running the OSID the user
	# has selected, or the default OSID from the node_types table).
	#
	push @features, map "OS-$_:0", $typemap{$type}->{'OSID'};
    }

    # Add features indicating what this node has connections to
    if ($connections{$node} && !$sharing_mode{$node}) {
        my @connected_to  = @{$connections{$node}};
        foreach my $other_end (@connected_to) {
            push(@features,"connected-to-$other_end:0.0");
        }
    }

    # This is for the case that we are modifying an existing experiment - tell
    # assign to prefer nodes the user has already allocated
    if ($exempt_eid && !$allnodes && $is_reserved{$node}) {
	push(@features,"already_reserved:0");
    }

    if (exists($is_prereserved{$node})) {
	push(@features,"prereserved:0.9");
    }

    # For robots, prefer ones that are already powered on and/or won't need to
    # be recharged soon.
    if (defined($curr_state{$node}) && ($curr_state{$node} eq TBDB_NODESTATE_POWEROFF)) {
	push(@features,"poweroff:0.9");
    }
    if (defined($curr_batt{$node})) {
	push(@features,"powerneeded:" . (1.0 - $curr_batt{$node} / 100.0));
    }

    #
    # Handle subnodes
    #
    # XXX This breaks if subnodes can themselves have subnodes
    if ($current->is_subnode()) {
	# We don't want to include subnodes unless their parent node is going
	# to be in the ptop file too
	if (! exists($nodes{$current->subnode_of()}) ||
	    $sharing_mode{$current->subnode_of()} ||
	    !$nodetoavailable{$current->subnode_of()}) {
	    # In fact, nuke it from %nodes so that we don't include its links,
	    # either
	    $nodetoavailable{$node} = 0;
	    if (! $allnodes || ! exists($nodes{$current->subnode_of()})) {
		delete $nodes{$node};
		next;
	    }
	}
	# Push the subnode's information into its flags
	push @flags, "subnode_of:" . $current->subnode_of();
    }

    #
    # Handle node locations
    #
    $country = $node_countries{$node};
    $latitude = $node_latitudes{$node};
    $longitude = $node_longitudes{$node};

    my @parse_features = split(" ", join(" ", @features));
    print_node($node, \@types, \@parse_features, \@flags, $uuid,
	       $nodetointerface{$node}, $country, $latitude, $longitude,
	       $type, \@sliver_types);
}

#
# Print out all blockstores
#
if ($useblockstore) {
    $result = DBQueryFatal("select b.node_id, b.bs_id, b.lease_idx, b.type, ".
			   "s.remaining_capacity ".
			   "from blockstores as b ".
			   "left join blockstore_state as s ".
			   "on b.bsidx=s.bsidx ".
			   "where s.ready=1");
    while (my ($nodeId, $bsId, $leaseIdx, $typeName,
	       $capacity) = $result->fetchrow_array) {
	my $type = BlockstoreType->Lookup($typeName);
	if (defined($type)) {
	    my @features = ();
	    foreach my $attr (values %{$type->GetAttributes()}) {
		if (exists($attr->{'isfeature'}) && $attr->{'isfeature'}) {
		    my $attrkey = $attr->{'key'};
		    my $attrval = $attr->{'value'};
		    push (@features, "bs-${attrkey}-${attrval}:0.5");
		}
	    }
	    my $divisible;
	    $type->GetAttribute("divisible", \$divisible);
	    my $slots = "1";
	    if (defined($divisible) && $divisible) {
		$slots = "*";
	    }

	    #
	    # If this is a persistent block store, i.e. has a non-zero
	    # lease_idx, we need to ensure that only someone explicitly
	    # asking for it gets it. We use a unique feature, based on
	    # the lease index, with a weight of one. This is matched by
	    # a desire put into the vtop file when someone requests
	    # mapping of the blockstore.
	    #
	    if ($leaseIdx > 0) {
		push(@features, "bs-lease-$leaseIdx:1.0");
	    }

	    push(@features, "+bs-capacity:$capacity");
	    print_node("$nodeId:$bsId", ["blockstore:$slots"], \@features,
		       ["subnode_of:$nodeId"], "", $nodetointerface{$nodeId},
		       $node_countries{$nodeId}, $node_latitudes{$nodeId},
		       $node_longitudes{$nodeId}, "blockstore", []);
	}
    }
}

my @inet_protos = ("ipv4");
if (($widearea && ! defined($component_name)) || $genimode ne $NO_GENI) {
    #
    # Set up 'the Internet' as a fake switch that all widearea nodes can
    # talk to.
    # Some day, it may make sense to connect control net ports to this
    # switch.
    #
    my @types = map("*$_:*", @inet_protos);
    print_node($fake_inet_switch, \@types, [], [], undef, [], undef, undef,
        undef, undef, []);
}

#
# Widearea Nodes. Includes plab nodes. Note that widearea nodes are never
# allocated directly (they are in a holding experiment), but assign deals
# with it by allocating multiple vnodes on a pnode.
#
# The underlying physnode has to be "up", as determined by the
# autostatus stuff; this will prevent us from allocating a dead
# virtual node to an experiment.  This is especially hacky. We need
# another mechanism for this. We only add virtnodes when assign says
# we need them. This reduces the problem size for assign.
#
# The types we lay out are only those in the auxtypes table for the node,
# since that is where we define what vtypes are hosted on a particular
# physnode. 
#
if ($widearea && ! defined($component_name)) {
    #
    # Note - there is currently an assumption in this query that widearea nodes
    # have only one control interface.
    #
    $result =
	DBQueryFatal("select n.node_id,nt.type,ns.status,r.pid,r.eid,wn.site,".
                     "wn.country,wn.latitude,wn.longitude, ".
                     "i.iface,wn.bwlimit,n.uuid ".
		     "from nodes as n ".
		     "left join node_types as nt on nt.type=n.type ".
		     "left join reserved as r on r.node_id=n.node_id ".
		     "left join node_status as ns on ns.node_id=n.node_id ".
		     "left join widearea_nodeinfo as wn on ".
		     "     wn.node_id=n.node_id ".
		     "left join interfaces as i on ".
		     "     n.node_id=i.node_id and ".
		     "     i.role='" . TBDB_IFACEROLE_CONTROL() . "' ".
		     "left outer join ". 
		     "  (select type,attrvalue ".
		     "   from node_type_attributes ".
		     "   where attrkey='dedicated_widearea' ".
		     "   group by type) as dedicated_wa_types ".
		     "  on nt.type=dedicated_wa_types.type ".
		     "where  (n.role='testnode' and nt.isremotenode=1 and ".
		     "        nt.isvirtnode=0 and nt.type!='pcfedphys' and ".
		     "        dedicated_wa_types.attrvalue is NULL)");
    
    while (($physnode,$ptype,$status,$mpid,$meid,$site,$country,$latitude,
            $longitude,$iface,$bwlimit,$uuid)
	   = $result->fetchrow_array) {
	my $current = $top->nodes()->{$physnode};

	my $class = $typemap{$ptype}->{'CLASS'};
	my @types;
	my @features;
	my @flags;
	my $maxvnodes;

	#
	# Grab the global allocation count of vnodes on this pnode (if there
	# is one). This modifies the counts below.  If the count has already
	# been reached, then do not put this node into the ptop file.
	#
	$maxvnodes =
	    $typemap{$ptype}->{'TYPEINFO'}->GetAttribute("global_capacity");
	
	if (defined($maxvnodes) && exists($globalcounts{$physnode})) {
	    $maxvnodes -= $globalcounts{$physnode};
	    next
		if ($maxvnodes <= 0);
	}

	#
	# Mark any nodes that are not up with a feature, so that they won't
	# normally get assigned. We want to include them, though, because we
	# allow people to do fix-node to down nodes
	#
	if (!defined($status)) {
	    fatal("status not defined for $physnode\n");
	}
	if (!defined($mpid) || !defined($meid)) {
	    fatal("pid,eid not defined for $physnode\n");
	}
	
	if (($status && ($status ne 'up')) ||
	    ($mpid eq $DEADPID && $meid eq $DEADEID)) {
	    # But not in genimode.
	    next
		if ($genimode ne $NO_GENI);
	    
	    push @features, "down:1";
	}

	#
	# Mark which site this node belongs to
	#
	if ($site) {
	    push @features, "*&$site:$site_weight";
	}

	#
	# Add any auxiliary types.
	#
	foreach my $auxinfo (@{$auxtypes{$physnode}}) {
	    my ($auxtype,$count) = split(":", $auxinfo);

	    $count = $maxvnodes
		if (defined($maxvnodes) && $maxvnodes < $count);

	    if (defined($mfactor) && $mfactor <= $count) {
		$auxinfo = "$auxtype:$mfactor";
	    }
	    else {
		$auxinfo = "$auxtype:$count";
	    }
	    push(@types, $auxinfo);
	}

	# Add trivial bw spec.
	push @flags, "trivial_bw:400000";

	# Indicate that these nodes are beautiful and unique snowflakes
	push @flags, "unique";

	# Add features
	push(@features, @{$typemap{$ptype}->{'FEATURES'}});
	if (defined($features{$physnode})) {
	    push @features, @{$features{$physnode}};
	}

	#
	# Add in features for all of the OSes that this node (as evidenced by
	# its type) can support
	#
	if ($node_type_osids{$ptype}) {
	    push @features, map "OS-$_:0", @{$node_type_osids{$ptype}};
	}

        #
        # Put in a feature indicating whether or not this node has a bandwidth
        # cap
        #
        if (!defined($bwlimit) || $bwlimit eq "-1") {
	    push @features, "nobwlimit:0";
        } else {
	    push @features, "bwlimit:0";
        }

	print_node($physnode, \@types, \@features, \@flags, $uuid,
		   $nodetointerface{$physnode},$country,$latitude,$longitude,
		   undef, []);

        #
        # Print out a link to the 'internet'.
        # Note - we make up a fake bandwidth. In the future, maybe we
        # could put something real in there.
        #
        if ($iface && $genimode eq $NO_GENI) {
	    print_simple_link($physnode, $iface,
			      $fake_inet_switch, $fake_inet_iface,
			      100000, 0, 0, \@inet_protos);
        }

	# Insert into nodes array in case there are wires entries.
	$nodes{$physnode} = $ptype;
    }
}

if ($genimode ne $NO_GENI) {
    foreach $key (keys %interfaceroles) {
	if (is_public_interface($key)) {
	    if ($key =~ /^([^:]+):([^:]+)$/) {
		my $node = $1;
		my $iface = $2;
		if (defined($nodes{$node})) {
		    print_simple_link($node, $iface,
				      $fake_inet_switch, $fake_inet_iface,
				      100000, 0, 0, \@inet_protos);
		}
	    }
	}
    }
}

# Read interface types. First need to find the protocols an interface supports
# and then then the speed for each of those protocols.
# Note that we are going to assume anything attached to a switch is ethernet.
$result = DBQueryFatal("SELECT type,capkey,capval from interface_capabilities ".
		       "where capkey='protocols' or capkey like '%_defspeed'"); 
while (($type,$capkey,$capval) = $result->fetchrow_array) {
    if ($capkey eq "protocols") {
	$interfaceprotocols{$type} = [ split(",", $capval) ];
    }
    elsif ($capkey =~ /^([-\w]+)_defspeed$/) {
	$interfacespeeds{$type}{$1} = $capval;
    }
    else {
	die("Improper defspeed $capval for $type!\n");
    }
}

# Read interface switches
$result = DBQueryFatal("SELECT node_id1, iface, node_id2 FROM wires AS w " .
	"LEFT JOIN interfaces as i ON w.node_id1=i.node_id AND w.card1=i.card ".
	"where w.logical=0");

while (($node,$iface,$switch) = $result->fetchrow_array) {
    if ($node && $iface) {
	$interfaceswitches{"$node:$iface"} = $switch;
    }
}

# Read interface cards and ports
$result = DBQueryFatal("SELECT node_id, iface, card, port, IP ".
		       "FROM interfaces where logical=0");

while (($node,$iface,$card,$port,$IP) = $result->fetchrow_array) {
    next
	if ($prune && $is_reserved{$node} && !$sharing_mode{$node} && 
	    (!defined($IP) || $IP eq ""));

    $interfacecardports{"$node:$iface"} = [$card,$port];
}

# Read interface_state
$result = DBQueryFatal("select * from interface_state");

while (my $ref = $result->fetchrow_hashref()) {
    my $node  = $ref->{'node_id'};
    my $iface = $ref->{'iface'};
    
    $interfacestate{"$node:$iface"} = $ref;
}

#
# Add back in the used shared bandwidth.
#
if (defined($experiment)) {
    # Read the vinterfaces table to get any bandwidth in use by
    # this experiment.
    my $exptidx   = $experiment->idx();
    my $pstateDir = $experiment->WorkDir() . "/pstate";

    DBQueryFatal("create temporary table if not exists ".
		 "vinterfaces_${exptidx} like vinterfaces");

    DBQueryFatal("delete from vinterfaces_${exptidx}");
    
    DBQueryFatal("load data infile '$pstateDir/vinterfaces' ".
		 "into table vinterfaces_${exptidx}")
	    if (-e "$pstateDir/vinterfaces");
    
    $result = DBQueryFatal("select * from vinterfaces_$exptidx ".
			   "where exptidx=$exptidx");

    while (my $row = $result->fetchrow_hashref()) {
	my $node      = $row->{'node_id'};
	my $iface     = $row->{'iface'};
	my $bandwidth = $row->{'bandwidth'};

	next
	    if (!defined($iface) || $bandwidth <= 0);
	next
	    if (!exists($interfacestate{"$node:$iface"}));

	my $ref = $interfacestate{"$node:$iface"};
	$ref->{'remaining_bandwidth'} =
	    $ref->{'remaining_bandwidth'} + $bandwidth;
    }
}

$result = DBQueryFatal("SELECT node_id1,card1,port1,node_id2,card2,port2" .
		       " from wires where logical=0 and ".
		       "   (type='Trunk' or ".
		       ($usecontrol ? "type='Control'" : "type='Node'") . ")");

while (($node1,$card1,$port1,$node2,$card2,$port2) = 
       $result->fetchrow_array) {
    if ((defined($nodes{$node1}) || defined($switches{$node1})) && 
	(defined($nodes{$node2}) || defined($switches{$node2})) &&
	! defined($component_name)) {

	#
	# When it is a node,switch link, the switch always used to be
	# node2, but now switches are explicitly tagged. But we also
	# have a node,node links and switch,switch links (trunks).
	#
	my $node1obj = Node->Lookup($node1);
	if (!defined($node1obj)) {
	    fatal("Could not lookup $node1");
	}
	my $node2obj = Node->Lookup($node2);
	if (!defined($node2obj)) {
	    fatal("Could not lookup $node2");
	}
	my $switchobj = ($node2obj->isswitch() ? $node2obj :
			 ($node1obj->isswitch() ? $node1obj : undef));

	# This comes from the switch info, unless its a direct link
	# between two nodes; use ethernet in this case.
	my $basetype;

	if (!defined($switchobj)) {
	    $basetype = "ethernet";
	}
	elsif ($switchobj->NodeTypeAttribute("forwarding_protocols",
					     \$basetype) ||
	       !defined($basetype) || $basetype eq "") {
	    fatal("No forwarding_protocols set for $switchobj (type)");
	}
	$iface1 = get_iface($node1,$card1,$port1);
	$iface2 = get_iface($node2,$card2,$port2);
	$iface1bw = get_ifacebw($node1,$card1,$port1,$basetype);
	$iface2bw = get_ifacebw($node2,$card2,$port2,$basetype);

        my @types = ($basetype);

	#
	# The pc side of any link must have an interfaces table,
	# or else we just skip it. Typically, the switch side does
	# not have entry, unless its a trunk like and we want it to
	# go into the ptop file. 
	#
	if (!$node1obj->isswitch()) {
	    next
		if (! exists($interfacecardports{"$node1:$iface1"}));
	}
	if (!$node2obj->isswitch()) {
	    next
		if (! exists($interfacecardports{"$node2:$iface2"}));
	}

	#
	# Determine the (maximum) supported bandwidth for the link.
	#
	if (!defined($switches{$node1}) && defined($switches{$node2})) {
	    $bw = $iface1bw;
	} else {
	    if ($iface1bw < $iface2bw) {
		$bw = $iface1bw;
	    } else {
		$bw = $iface2bw;
	    }
	}
	# For now, switches that are testnode should not be considered as
	# an interconnect.
	if (($node1obj->isswitch() &&
	     ($node1obj->role() eq "testswitch" ||
	      $node1obj->role() eq "widearea_switch")) &&
	    ($node2obj->isswitch() &&
	     ($node2obj->role() eq "testswitch" ||
	      $node2obj->role() eq "widearea_switch"))) {
	    # interswitch link
	    if (defined($interconnects{"$node1:$node2"})) {
		$interconnects{"$node1:$node2"} += $bw;
	    } else {
		$interconnects{"$node1:$node2"} = new Math::BigInt $bw;
	    }
	} else {
	    #
            # Node-to-switch link
	    #
	    # We used to hardwire in the knowledge that the switch is
	    # always node2 in the wires table. Now, we actually mark
	    # switches as being switches.
	    #
            # Come up with some other types for this link. The idea is
            # that it allows people to ask for links to specific
            # switches, specific interface types, etc.
	    #
	    if (defined($switchobj)) {
		push(@types, $basetype . "-" . $switchobj->node_id());

		#
		# Look for wire_* atrributes on the switch and convert that
		# to a link type. Added, so we could associate a
		# highvlan feature on wires attached to switches that
		# allow high numbered vlans. This is needed in Utah,
		# where only parts of the fabric support high vlans.
		#
		my $attributes = $switchobj->GetNodeAttributes();
		if (defined($attributes)) {
		    foreach my $key (keys(%{ $attributes })) {
			next
			    if ($key !~ /^wire_/);

			my $val = $attributes->{$key}->{"attrvalue"};
			
			push @types, "$basetype-$val";
		    }
		}
	    }

            if ($interfacetypes{"$node1:$card1:$port1"}) {
                push @types, "$basetype-" .
                    $interfacetypes{"$node1:$card1:$port1"};
            }
            push @types, "$basetype-$bw";

	    if ($sharing_mode{$node1}) {
		$bw =
		    $interfacestate{"$node1:$iface1"}->{'remaining_bandwidth'};
		if ($bw < 0) {
		    $bw = 0;
		}
		next
		    if ($bw == 0);
	    }

	    print_simple_link($node1, $iface1,
			      $node2, $iface2,
			      $bw, 0, 0, \@types);
	}
    } 
}

#
# If we're supposed to track interswitch bandwidth, subtract out the amount
# that's already in use
#
if ($TRACK_INTERSWITCH_BANDWIDTH) {
    #
    # Get a list of all VLANs
    #
    my @vlans;
    if (VLan->AllVLans(\@vlans) != 0) {
	die("*** $0:\n".
	    "    Unable to load VLANs for all experiments\n");
    }
    foreach my $vlan (@vlans) {
	my @members;

	if ($vlan->MemberList(\@members) != 0) {
	    die("*** $0:\n".
		"    Unable to load members for $vlan\n");
	}
	my %switches = ();
	foreach my $member (@members) {
	    my $node;
	    my $iface;

	    if ($member->GetNodeIface(\$node, \$iface) != 0) {
		die("*** $0:\n".
		    "    Missing attributes for $member in $vlan\n");
	    }
	    my $nodeid = $node->node_id();
	    
	    my $switch = get_ifaceswitch($nodeid,$iface);
	    my ($card, $port) = get_ifacecardport($nodeid,$iface);
	    my $bw = get_ifacebw($nodeid,$card,$port,"ethernet");
	    $switches{$switch} += $bw;
	}

	#
	# Check to see if more than one switch was found among the member
	# list, and if so, go through all the pairs
	#
	my @switches = keys %switches;
	if (@switches > 1) {
	    for (my $i = 0; $i < (@switches -1); $i++) {
		my $switch1 = $switches[$i];
		my $switch2 = $switches[$i+1];
		my $bw = $switches{$switch1};
		if ($switches{$switch2} < $bw) {
			$bw = $switches{$switch2};
		}
		#
		# The trunk link could be listed in either order
		#
		if ($interconnects{"$switch1:$switch2"}) {
		    $interconnects{"$switch1:$switch2"} -= $bw;
		} elsif ($interconnects{"$switch2:$switch1"}) {
		    $interconnects{"$switch2:$switch1"} -= $bw;
		}
	    }
	}
    }
}

if (! defined($component_name)) {
  # TODO: Figure out how to actually add interconnect interfaces rather than
  #       just having them be (null).
  foreach $interconnect (keys(%interconnects)) {
      ($src,$dst) = split(":",$interconnect);
      my $speed = $interconnects{$interconnect};
      # This is really dumb - BigInts like to print out with a leading '+',
      # which we don't want. Stript it off.
      $speed =~ s/^\+|-//;
      print_named_interconnect("link-$interconnect",
  		     $src, "(null)",
		     $dst, "(null)",
		     $speed, 0, 0, ["ethernet"]);
  }
}

#
# Fake switch. Hardwired for now. 
#
my @wireless_protos = ("80211", "80211a", "80211b", "80211g", "flex900",
		       "xcvr2450");

my @fake_switch_types = map("*$_:*", @wireless_protos);
if (! defined($component_name)) {
  $air_printed = 0;

  foreach my $interface (keys(%interfacetypes)) {
      my ($node,$card,$port) = split(":", $interface);
      
      next
	  if (!defined($nodes{$node}));;
      
      my $type    = $interfacetypes{$interface};
      
      next
	  if (!defined($interfaceprotocols{$type}));
      
      my @protos  = @{ $interfaceprotocols{$type} };
      my $iface   = get_iface($node,$card,$port);

      #
      # Get the intersection of the protocols supported by this interface, and
      # the wireless protocols we know about
      #
      my (%union, %intersection);
      foreach $proto (@protos, @wireless_protos) {
	  $union{$proto}++ && $intersection{$proto}++;
      }
      
      my @intersection = keys %intersection;

      #
      # Skip this interface if it speaks no wireless protocols
      #
      next unless @intersection;
      
      #
      # Find the max bandwidth supported by any of the wireless protocols
      # supported by this interface
      #
      my $max_bw = 0;
      foreach my $proto (@intersection) {
	  my $ifacebw = get_ifacebw($node,$card,$port,$proto);
	  if ($ifacebw > $max_bw) {
	      $max_bw = $ifacebw;
	  }
      }
      if (! $air_printed) {
	  print_node($fake_air_switch, \@fake_switch_types, [], [], undef,
		     [], undef, undef, undef, undef, []);
	  $air_printed = 1;
      }
      print_simple_link($node, $iface,
			$fake_air_switch, $fake_air_iface,
			$max_bw, 0, 0, \@intersection);
  }
}

print_footer();

exit(0);

# Print out links
sub get_iface {
    ($node,$card,$port) = @_;
    if (defined($interfacemap{"$node:$card:$port"})) {
	if ($interfacemap{"$node:$card:$port"} eq "") {
	    return "(null)";
	} else {
	    return $interfacemap{"$node:$card:$port"};
	}
    } else {
	# shark hack
	if ($node =~ /^sh/) {
	    return "eth0";
	} else {
	    return "(null)";
	}
	# end shark hack 
    }
};

# Find the bandwidth for an interface, when using the given protocol (which
# most of the time is ethernet).
sub get_ifacebw {
    ($node,$card,$port,$protocol) = @_;
    if (defined($interfacetypes{"$node:$card:$port"})) {
	my $bw = $interfacespeeds{$interfacetypes{"$node:$card:$port"}}{$protocol};
	return $bw if defined( $bw );
    }
    return $default_switchport_speed;
}

sub get_ifaceswitch {
    ($node,$iface) = @_;
    if (defined($interfaceswitches{"$node:$iface"})) {
	return $interfaceswitches{"$node:$iface"};
    } else {
	return undef;
    }
}

sub get_ifacecardport {
    ($node,$iface) = @_;
    if (defined($interfacecardports{"$node:$iface"})) {
	return @{$interfacecardports{"$node:$iface"}};
    } else {
	return ();
    }
}

######################################################################
# Functions for printing XML
######################################################################

sub print_header {
    if ($do_xml) {
	if ($genimode eq $NO_GENI) {
	    print "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";
	    print "<ptop testbed=\"@THISHOMEBASE@\" "
		. "xmlns=\"http://emulab.net/resources/ptop/0.1\">\n";
	} else {
	    print "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";
	    print "<rspec ";
	    print "xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" ";
	    my $ns = "";
	    my $url = "";
	    if ($genimode eq $V_0_1) {
		$ns = "http://www.protogeni.net/resources/rspec/0.1";
		$url = "http://www.protogeni.net/resources/rspec/0.1/ad.xsd";
	    } elsif ($genimode eq $V_0_2) {
		$ns = "http://www.protogeni.net/resources/rspec/0.2";
		$url = "http://www.protogeni.net/resources/rspec/0.2/ad.xsd";
	    } elsif ($genimode eq $V_2) {
		$ns = "http://www.protogeni.net/resources/rspec/2";
		$url = "http://www.protogeni.net/resources/rspec/2/ad.xsd";
	    } elsif ($genimode eq $V_3) {
		$ns = "http://www.geni.net/resources/rspec/3";
		$url = "http://www.geni.net/resources/rspec/3/ad.xsd";
	    }
	    print "xmlns=\"$ns\" ";
	    if ($genimode eq $V_2 || $genimode eq $V_3) {
		print "xmlns:emulab=\"$emulabns\" ";
		print "xsi:schemaLocation=\"$ns $url $emulabns $emulaburl ";
		print "$stitchns $stitchurl ";
		print "$sharedns $sharedurl ";
		print "$opns $opurl ";
		print "\" ";
	    }
	    else {
		print "xsi:schemaLocation=\"$ns $url\" ";
	    }
	    print "type=\"advertisement\" ";
	    my @times = gmtime(time());
	    printf("generated=\"%04d-%02d-%02dT%02d:%02d:%02dZ\" ",
		   $times[5] + 1900, $times[4] + 1, $times[3],
		   $times[2], $times[1], $times[0]);
	    if ($genimode eq $V_2 || $genimode eq $V_3) {
		print "expires=";
	    } else {
		print "valid_until=";
	    }
	    printf("\"%04d-%02d-%02dT%02d:%02d:%02dZ\" ",
		   $times[5] + 1900, $times[4] + 1, $times[3],
		   $times[2], $times[1], $times[0]);
	    print ">\n";
	    for my $iface (keys(%external_ifaces)) {
		if (defined($external_managers{$iface})) {
		    print "<external_ref ".
			"component_id=\"".$external_ifaces{$iface}."\"\n  ".
			"component_manager_id=\"" . $external_managers{$iface}.
			"\" />\n";
		}
	    }
	    my $result = DBQueryFatal("select token from shared_vlans ".
				      "where open=1");
	    if ($result->rows > 0) {
		print "<rspec_shared_vlan xmlns=\"" . $sharedns . "\">\n";
		while (($token) = $result->fetchrow_array) {
		    print "  <available name=\"" . $token . "\"/>\n";
		}
		print "</rspec_shared_vlan>\n";
	    }
	    print $opstate . "\n";
	}
    }
}

sub print_footer {
    if (!$do_xml) {
	print_type_limits();
    }
    if ($do_xml && $genimode eq $NO_GENI) {
	print "</ptop>\n";
    } elsif ($do_xml && $genimode ne $NO_GENI) {
	if ($genimode eq $V_2 || $genimode eq $V_3) {
	    print_type_limits();
	    if (scalar(keys(%contact_nodes)) > 0) {
		print "<stitching xmlns=\"$stitchns\" ";
		my @times = gmtime(time());
		printf("lastUpdateTime=\"%04d-%02d-%02dT%02d:%02d:%02dZ\" ",
		       $times[5] + 1900, $times[4] + 1, $times[3],
		       $times[2], $times[1], $times[0]);
		print ">\n";
		my $cmurl = "@PROTOGENI_URL@";
		print "<aggregate id=\"$cmurn\" url=\"$cmurl/am\">\n";
		print  "<aggregatetype>protogeni</aggregatetype>\n".
		    "<stitchingmode>chainANDTree</stitchingmode>\n".
		    "<scheduledservices>false</scheduledservices>\n".
		    "<negotiatedservices>false</negotiatedservices>\n".
		    "<lifetime id=\"life\">\n".
		    "    <start type=\"time\">";
		printf("%04d-%02d-%02dT%02d:%02d:%02dZ",
		       $times[5] + 1900, $times[4] + 1, $times[3],
		       $times[2], $times[1], $times[0]);
		print "</start>\n".
		    "    <end type=\"time\">";
		printf("%04d-%02d-%02dT%02d:%02d:%02dZ",
		       $times[5] + 1900, $times[4] + 1, $times[3],
		       $times[2], $times[1], $times[0]);
		print "</end>\n".
		    "</lifetime>\n";


		foreach my $node (keys(%contact_nodes)) {
		    print_stitch_node($node);
		}
		print "</aggregate>\n";
		print "</stitching>\n";
	    }
	}
	print "</rspec>\n";
    }
}

# Special print function for switches.
sub print_switch
{
    my $name = shift(@_);
    my $uuid = shift(@_);
    my $country = shift(@_);
    my $latitude = shift(@_);
    my $longitude = shift(@_);
    my $protocols = shift(@_);
    my $interfaces = [];
    if ($do_xml && $genimode ne $NO_GENI)
    {
	push @$interfaces, "(null)";
    }
    # XXX - local hack for Utah - don't allow our 'hub' switch to be host for
    # LAN nodes, which encourages the placement of all LAN members on the same
    # switch
    my $types = ["switch:1"];
    if (!(defined($MAINSITE) && $MAINSITE && $name eq "procurve1")) {
	push(@$types, "*lan:*");
    }

    #
    # If there is are non-standard forwarding_protocol, add them.
    #
    if ($protocols) {
	my @forwarding_protocols = split(",", $protocols);
	foreach my $protocol (@forwarding_protocols) {
	    next
		if ($protocol eq "ethernet");

	    push(@$types, "*${protocol}:*");
	}
    }
    
    # This is for mixing real nodes with pnodes in a lan. The goal is to
    # prevent assign from putting the lan node on a pc; always prefer a
    # real switch. See corresponding change in libvtop. 
    my $features = ["real-switch:0"];
    print_node($name, $types, $features, [], $uuid, $interfaces,
        $country, $latitude, $longitude, undef, []);
}

sub print_node
{
    my $name = shift(@_);
    my $types = shift(@_);
    my $features = shift(@_);
    my $flags = shift(@_);
    my $uuid = shift(@_);
    my $interfaces = shift(@_);
    my $country = shift(@_);
    my $lat = shift(@_);
    my $long = shift(@_);
    my $mainType = shift(@_);
    my $sliverTypes = shift(@_);
    if (! defined($lat) || ! defined($long)) {
	$lat = $default_lat;
	$long = $default_long;
    }
    if (! defined($country)) {
	$country = $default_country;
    }
    if (!$do_xml) {
	my $text = "node $name " .
	    join(" ", @$types) . " - " . join(" ", @$features) .
		" - " . join(" ", @$flags);
	print "$text\n";
    } elsif ($genimode ne $NO_GENI) {
	if (exists($external_nodes{$name})) {
	    # Do not print out this node in XML mode because it is a
	    # 'fake' node and we are actually printing out real remote
	    # interfaces instead.
	    return;
	}
	add_stitch_interfaces($name, $interfaces);

	# rspec format
	my $exclusive = "true";
	if ($sharing_mode{$name}) {
	    $exclusive = "false";
	}
	print "<node ";
	if ($genimode eq $V_0_1 || $genimode eq $V_0_2) {
	    print "component_manager_uuid=\"$cmurn\" ";
	} elsif ($genimode eq $V_2 || $genimode eq $V_3) {
	    print "component_manager_id=\"$cmurn\" ";
	}
	print "component_name=\"$name\" ";
	my $urn = GeniHRN::Generate($OURDOMAIN, "node", $name);
	if ($genimode eq $V_0_1 || $genimode eq $V_0_2) {
	    print " component_uuid=\"$urn\" ";
	} elsif ($genimode eq $V_2 || $genimode eq $V_3) {
	    print " component_id=\"$urn\" ";
	}
	if ($genimode eq $V_2 || $genimode eq $V_3) {
	    print " exclusive=\"$exclusive\" ";
	}
	print ">\n";
	if (defined($mainType) && $genimode eq $V_0_2) {
	    print_raw_osids($mainType);
	}
	print_node_types($mainType, $types, $sliverTypes);
	my $avail = "false";
	if ($nodetoavailable{$name}
	    || $name eq $fake_inet_switch
	    || $name eq $fake_air_switch) {
	    $avail = "true";
	}
	if ($genimode eq $V_0_1 || $genimode eq $V_0_2)
	{
	    print "  <available>$avail</available>\n";
	} elsif ($genimode eq $V_2 || $genimode eq $V_3)
	{
	    print "  <available now=\"$avail\" />\n";
	}
	if ($genimode eq $V_0_1 || $genimode eq $V_0_2) {
	    print "  <exclusive>$exclusive</exclusive>\n";
	}
	if ($name eq $fake_inet_switch)
	{
	    print "  <cloud />\n";
	    print_node_interfaces($name, $fake_inet_iface);
	} elsif ($name eq $fake_air_switch) {
	    print "  <cloud />\n";
	    print_node_interfaces($name, $fake_air_iface);
	}
        if (defined($lat) && defined($long)) {
            # TODO: May not be a good default for country
            if (!defined($country) || $country eq "") {
                $country = "US";
            }
            print "  <location country=\"$country\" longitude=\"$long\" " .
                  "latitude=\"$lat\" />\n";
        }
	print_node_flags(@$flags);
	print_node_interfaces($name, @$interfaces);
	print_node_features(@$features);
	print "</node>\n";
    } else {
	# ptop format
	print "<node name=\"$name\"";
	print ">\n";
	print_node_types($mainType, $types);
	print_node_flags(@$flags);
	print_node_features(@$features);
	print "</node>\n";
    }
}

sub add_stitch_interfaces
{
    my ($name, $interfaces) = @_;
#    add_stitch_point($name, $interfaces, \%external_nodes, \%external_ifaces);
    add_stitch_point($name, $interfaces, \%contact_nodes, \%contact_ifaces);
}

sub add_stitch_point
{
    my ($name, $interfaces, $stitch_nodes, $stitch_ifaces) = @_;
    if (exists($stitch_nodes->{$name})) {
	foreach my $key (keys(%$stitch_ifaces)) {
	    if ($key =~ /([^:]+):([^:]+)/) {
		if ($name eq $1 || $name eq $2) {
		    my (undef, undef, $iface) = GeniHRN::ParseInterface($stitch_ifaces->{$key});
		    my $foundCount = grep $_ eq $iface,
		                          @$interfaces;
		    if ($foundCount == 0) {
			push(@$interfaces, $iface);
		    }
		}
	    }
	}
    }
}

sub print_raw_osids
{
    my ($type) = @_;
    print_osids($typemap{$type}->{'OSLIST'},
		$typemap{$type}->{'OSID'});
}

# Print osids
sub print_osids
{
    my ($osids_arg, $default) = @_;
    if (defined ($osids_arg)) {
	my @osids = @{ $osids_arg };
	foreach my $os (@osids) {
	    if (defined($osid_name{$os})) {
		my $urn = GeniHRN::Generate($OURDOMAIN, "image",
					    $osid_pid{$os} . "//" . $osid_name{$os});
		print "<disk_image ";
		print "name=\"" . $urn . "\" ";
		print "os=\"" . $osid_os{$os} . "\" ";
		print "version=\"" . $osid_version{$os} . "\" ";
		print "description=\"" . $osid_description{$os} . "\" ";
		if (defined($default) && $os eq $default) {
		    print "default=\"true\" ";
		}
		print "/>\n";
	    }
	}
    }
}

sub print_type_limits 
{
    if ($typelimitfile ne "") {
	open(TYPELIMIT, "<$typelimitfile") or 
	    die("Count not open type limit file $typelimitfile\n");
	my @typelimits = <TYPELIMIT>;
	close(TYPELIMIT);

	foreach $line (@typelimits) { 
	    chomp($line);
	    my ($typeclass, $count) = split(" ", $line);
	    
	    if ($genimode eq $NO_GENI) {
		print "set-type-limit $typeclass $count\n";
	    }
	    else {
		if ($genimode eq $V_2 || $genimode eq $V_3) {
		    print "<emulab:set_type_limit ";
		    print "typeclass=\"$typeclass\" ";
		    print "count=\"$count\"";
		    print "/>\n";
		}
	    }
	}
    }
}

# The order print_node_types(), print_node_features(),
# print_node_flags() must always be observed lest we break the schema.
sub print_node_types
{
    my $mainType = shift(@_);
    my @types = @{ shift(@_) };
    my @sliverTypes = @{ shift(@_) };
    my $i = 0;
    for (; $i < scalar(@types); ++$i) {
	my ($name, $count) = split(/:/, $types[$i], 2);
	my $is_static = 0;
	if ($name =~ /^\*/) {
	    $name = substr($name, 1);
	    $is_static = 1;
	}
	if ($genimode eq $V_0_1 || $genimode eq $V_0_2) {
	    print "  <node_type \n";
	    print "    type_name=\"$name\"\n";
	    if ($count eq "*") {
		print "    type_slots=\"unlimited\"\n";
	    } else {
		print "    type_slots=\"$count\"\n";
	    }
	    if ($is_static) {
		print "static=\"true\"\n";
	    }
	    print "  />\n";
	} elsif ($genimode eq $V_2 || $genimode eq $V_3) {
#	    if ($name eq "pc" || $name eq "pcRemote") {
#		print "  <sliver_type name=\"raw-pc\">\n";
#		if (defined($mainType)) {
#		    print_raw_osids($mainType);
#		}
#		print "  </sliver_type>\n";
#	    }
#	    if ($name eq "pcvm") {
#		print "  <sliver_type name=\"emulab-openvz\">\n";
#		if (defined($openvzid)) {
#		    print_osids($osid_subosids{$openvzid}, undef);
#		}
#		print "  </sliver_type>\n";
#	    }
	    print "  <hardware_type name=\"$name\">\n";
	    if ($count eq "*") {
		print "    <emulab:node_type type_slots=\"unlimited\" ";
	    } else {
		print "    <emulab:node_type type_slots=\"$count\" ";
	    }
	    if ($is_static) {
		print "static=\"true\"";
	    }
	    print "/>\n";
	    print "  </hardware_type>\n";
	}
    }
    if ($genimode eq $V_2 || $genimode eq $V_3) {
	for ($i = 0; $i < scalar(@sliverTypes); ++$i) {
	    print "  <sliver_type name=\"" . $sliverTypes[$i] . "\">\n";

	    if ($sliverTypes[$i] eq "raw-pc") {
		if (defined($mainType)) {
		    print_raw_osids($mainType);
		}
	    } elsif ($sliverTypes[$i] eq "emulab-openvz") {
		if (defined($openvzid)) {
		    print_osids($osid_subosids{$openvzid}, undef);
		}
	    } elsif ($sliverTypes[$i] eq "emulab-xen") {
		print_raw_osids("pcvm");
	    }
	    print "  </sliver_type>\n";
	}
    }
}

sub print_node_features
{
    my $i = 0;
    for (; $i < scalar(@_); ++$i) {
	my ($name, $value) = split(/:/, $_[$i], 2);
	my $flags = "";
	if ($value >= 1.0) {
	    $flags .= " violatable=\"true\" ";
	}
	if ($name =~ /^\?\+/) {
	    $flags .= " local_operator=\"+\" ";
	    $name = substr($name, 2);
	}
	elsif ($name =~ /^\*&/) {
	    $flags .= " global_operator=\"FirstFree\" ";
	    $name = substr($name, 2);
	}
	elsif ($name =~ /^\*!/) {
	    $flags .= " global_operator=\"OnceOnly\" ";
	    $name = substr($name, 2);
	}
	if ($genimode eq $V_2 || $genimode eq $V_3) {
	    print "  <emulab:fd name=\"$name\" weight=\"$value\" ";
	    if ($flags ne "") {
		print $flags;
	    }
	    print "/>\n";
	}
	elsif ($genimode eq $NO_GENI) {
	    print "  <fd \n";
	    print "     fd_name=\"$name\" \n";
	    print "     fd_weight=\"$value\" \n";
	    if ($flags ne "") {
		print $flags."\n";
	    }
	    print "  />\n";
	}
    }
}

sub print_node_flags
{
    my $i = 0;
    for (; $i < scalar(@_); ++$i) {
	my ($name, $value) = split(/:/, $_[$i], 2);
	if ($name eq "trivial_bw"){
	    if ($genimode eq $NO_GENI) {
		print "  <trivial_bandwidth>$value</trivial_bandwidth>\n";
	    }
	    elsif ($genimode eq $V_2 || $genimode eq $V_3) {
		print "  <emulab:trivial_bandwidth value=\"$value\" />\n";
	    }
	}
	elsif ($name eq "subnode_of") {
	    if ($genimode eq $NO_GENI) {
		print "  <subnode_of>$value</subnode_of>\n";
	    }
	    elsif ($genimode eq $V_2 || $genimode eq $V_3) {
		$value = GeniHRN::Generate($OURDOMAIN, "node", $value);
		print "  <relation type=\"subnode_of\" ";
		print "component_id=\"$value\" />\n";
	    } 
	}
	elsif ($name eq "unique") {
	    if ($genimode eq $NO_GENI) {
		print "  <unique/>\n";
	    }
	    elsif ($genimode eq $V_2 || $genimode eq $V_3) {
		print "  <emulab:unique />\n";
	    }
	}
	elsif ($name eq "disallow_trivial_mix") {
	    if ($genimode eq $NO_GENI) {
		print "  <disallow_trivial_mix/>\n";
	    }
	    elsif ($genimode eq $V_2 || $genimode eq $V_3) {
		print "  <emulab:disallow_trivial_mix /> \n";
	    }
	}
    }
}

sub make_ip
{
    my $in = shift(@_);
    my @octets = split(/\./, $in);
    my $result = 0;
    my $i = 0;
    for (; $i < scalar(@octets); ++$i) {
	$result = (($result << 8) | $octets[$i]);
    }
    return $result;
}

sub is_routable
{
    my @privateIps   = (make_ip("10.0.0.0"), make_ip("172.16.0.0"),
			make_ip("192.168.0.0"));
    my @privateMasks = (8, 12, 16);

    my $in = shift(@_);
    my $result = 0;
    if (defined($in) && $in =~ /\d+\.\d+\.\d+\.\d+/) {
	$result = 1;
	my $ip = make_ip($in);
	my $i = 0;
	for ($i = 0; $i < scalar(@privateIps); ++$i) {
	    my $mask = (0xffffffff << (32 - $privateMasks[$i]));
	    if (($ip & $mask) == ($privateIps[$i] & $mask)) {
		$result = 0;
	    }
	}
    }
    return $result;
}

sub is_public_interface
{
    my $key = shift(@_);
    my $result = 0;
    if (exists($interfaceroles{$key})
	&& exists($interfaceips{$key})) {
	if ($interfaceroles{$key} eq "ctrl"
	    && is_routable($interfaceips{$key})) {
	    $result = 1;
	}
    }
    return $result;
}

sub print_node_interfaces
{
    my $nodeName = shift(@_);
    my @interfaces = @_;
    my $i = 0;
    for (; $i < scalar(@interfaces); ++$i) {
	my $name = $interfaces[$i];
	if (defined($MAINSITE) && $MAINSITE && $nodeName eq "instageni-nc7"
	    && $name ne "eth5") {
	    next;
	}
	my $urn = GeniHRN::GenerateInterface($OURDOMAIN, $nodeName, $name);
	print "  <interface component_id=\"$urn\" ";
	if (exists($interfaceroles{"$nodeName:$name"})) {
	    my $roleString = $interfaceroles{"$nodeName:$name"};
	    if ($roleString eq "ctrl") {
		print "role=\"control\" ";
	    } elsif ($roleString eq "expt") {
		print "role=\"experimental\" ";
	    }
	}
	if (is_public_interface("$nodeName:$name")) {
	    my $ip = $interfaceips{"$nodeName:$name"};
	    print "public_ipv4=\"$ip\" ";
	}
	print ">\n";
	if ($genimode eq $V_2 || $genimode eq $V_3)
	{
	    print "    <emulab:interface name=\"$name\"/>\n";
	}
	print "  </interface>\n";
    }
}

sub print_named_link_ptop
{
    my $name = shift(@_);
    my $source = shift(@_);
    my $source_if = shift(@_);
    my $dest = shift(@_);
    my $dest_if = shift(@_);
    my $bw = shift(@_);
    my $delay = shift(@_);
    my $loss = shift(@_);
    my @proto = @{ shift(@_) };
    my $is_interconnect = shift(@_);

    if (defined($MAINSITE) && $MAINSITE &&
	(($source eq "instageni-nc7" && $source_if ne "eth5") ||
	 ($dest eq "instageni-nc7" && $dest_if ne "eth5"))) {
	return;
    }
    my $source_full = "$source:$source/$source_if";
    # Not sure about (null) stuff ... 
    my $dest_full = "$dest:" .
	(($dest_if eq "(null)") ? "$dest_if" : "$dest/$dest_if");
    if ($is_interconnect)
    {
	$source_full = $source;
	$dest_full = $dest;
    }
    print "link $name $source_full "
	. "$dest_full $bw $delay $loss 1 " . join(" ", @proto) . "\n";
}

sub print_named_link_xml_geni
{
    my $name = shift(@_);
    my $source = shift(@_);
    my $source_if = shift(@_);
    my $dest = shift(@_);
    my $dest_if = shift(@_);
    my $bw = shift(@_);
    my $delay = shift(@_);
    my $loss = shift(@_);
    my @proto = @{ shift(@_) };
    my $is_interconnect = shift(@_);
    my $source_urn = GeniHRN::GenerateInterface($OURDOMAIN, $source,
						$source_if);
    my $dest_urn = GeniHRN::GenerateInterface($OURDOMAIN, $dest,
					      $dest_if);
    if (defined($MAINSITE) && $MAINSITE &&
	(($source eq "instageni-nc7" && $source_if ne "eth5") ||
	 ($dest eq "instageni-nc7" && $dest_if ne "eth5"))) {
	return;
    }
	$name =~ s/:/\/\//g;
	my $external_manager_urn;
	my $urn = GeniHRN::Generate($OURDOMAIN, "link", $name);
    my $contact;
    my %source_ifaces;
    my %dest_ifaces;
	if (exists($stitch_points{"$source:$dest"})) {
	    $contact = $source;
	    %source_ifaces = %contact_ifaces;
	    %dest_ifaces = %external_ifaces;
	} elsif (exists($stitch_points{"$dest:$source"})) {
	    $contact = $dest;
	    %source_ifaces = %external_ifaces;
	    %dest_ifaces = %contact_ifaces;
	}
    if (defined($contact)) {
	foreach my $external (@{ $contact_nodes{$contact} }) {
	    $source_urn = $source_ifaces{"$contact:$external"};
	    $dest_urn = $dest_ifaces{"$contact:$external"};
	    $urn = $external_links{"$contact:$external"};
	    $external_manager_urn = $external_managers{"$contact:$external"};
      print_single_link_xml_geni($source, $source_if, $dest, $dest_if,
			         $bw, $delay, $loss, \@proto, $is_interconnect,
			         $urn, $source_urn, $dest_urn,
			         $external_manager_urn);
	}
    } else {
      print_single_link_xml_geni($source, $source_if, $dest, $dest_if,
			         $bw, $delay, $loss, \@proto, $is_interconnect,
			         $urn, $source_urn, $dest_urn,
			         $external_manager_urn);
    }
}

sub print_single_link_xml_geni
{
    my $source = shift(@_);
    my $source_if = shift(@_);
    my $dest = shift(@_);
    my $dest_if = shift(@_);
    my $bw = shift(@_);
    my $delay = shift(@_);
    my $loss = shift(@_);
    my @proto = @{ shift(@_) };
    my $is_interconnect = shift(@_);
    my $urn = shift(@_);
    my $source_urn = shift(@_);
    my $dest_urn = shift(@_);
    my $external_manager_urn = shift(@_);

    my $proto_count = scalar(@proto);
	my (undef, undef, $name) = GeniHRN::Parse($urn);
	print "<link ";
	my $cmurn = GeniHRN::Generate($OURDOMAIN, "authority", "cm");
	if ($genimode eq $V_0_1 || $genimode eq $V_0_2) {
	    print "component_manager_uuid=\"$cmurn\" ";
	}
	print "component_name=\"$name\" ";
	if ($genimode eq $V_0_1 || $genimode eq $V_0_2) {
	    print "component_uuid=\"$urn\" ";
	} elsif ($genimode eq $V_2 || $genimode eq $V_3) {
	    print "component_id=\"$urn\" ";
	}
	print ">\n";
	if ($genimode eq $V_2 || $genimode eq $V_3) {
	    print "<component_manager name=\"$cmurn\" />\n";
	    if (defined($external_manager_urn)) {
		print "<component_manager name=\"$external_manager_urn\" />\n";
	    }
	}
	print_interface($source, $source_urn);
	print_interface($dest, $dest_urn);
    if ($genimode eq $V_0_1 || $genimode eq $V_0_2) {
	print "  <bandwidth>$bw</bandwidth>\n";
	print "  <latency>$delay</latency>\n";
	print "  <packet_loss>$loss</packet_loss>\n";
    } elsif ($genimode eq $V_2 || $genimode eq $V_3) {
	print_property($source_urn, $dest_urn,
		       $bw, $delay, $loss);
	print_property($dest_urn, $source_urn,
		       $bw, $delay, $loss);
    }
    my $i = 0;
    for (; $i < $proto_count; ++$i) {
	if ($genimode eq $V_0_1 || $genimode eq $V_0_2) {
	    print "  <link_type type_name=\"" . $proto[$i] . "\" />\n";
	} elsif ($genimode eq $V_2 || $genimode eq $V_3) {
	    print "  <link_type name=\"" . $proto[$i] . "\" />\n";
	}
    }
    print "</link>\n\n";
}

sub print_named_link_xml_plain
{
    my $name = shift(@_);
    my $source = shift(@_);
    my $source_if = shift(@_);
    my $dest = shift(@_);
    my $dest_if = shift(@_);
    my $bw = shift(@_);
    my $delay = shift(@_);
    my $loss = shift(@_);
    my @proto = @{ shift(@_) };
    my $is_interconnect = shift(@_);
    my $proto_count = scalar(@proto);
    my $source_urn = GeniHRN::GenerateInterface($OURDOMAIN, $source,
						$source_if);
    my $dest_urn = GeniHRN::GenerateInterface($OURDOMAIN, $dest,
					      $dest_if);
    if (defined($MAINSITE) && $MAINSITE &&
	(($source eq "instageni-nc7" && $source_if ne "eth5") ||
	 ($dest eq "instageni-nc7" && $dest_if ne "eth5"))) {
	return;
    }
	print "<link name=\"$name\">\n";
	print "  <source_interface><interface>\n";
	print_interface_contents($source, $source_if);
	print "  </interface></source_interface>\n";
	print "  <destination_interface><interface>\n";
	print_interface_contents($dest, $dest_if);
	print "  </interface></destination_interface>\n";
	print "  <bandwidth>$bw</bandwidth>\n";
	print "  <latency>$delay</latency>\n";
	print "  <packet_loss>$loss</packet_loss>\n";
    my $i = 0;
    for (; $i < $proto_count; ++$i) {
	    print "  <link_type><type_name>" . $proto[$i]
		. "</type_name></link_type>\n";
    }
    print "</link>\n\n";
}

sub print_interface
{
    my ($node, $interfaceUrn) = @_;
    print "  <interface_ref ";
    my $nodeUrn = GeniHRN::Generate($OURDOMAIN, "node", $node);
    if ($genimode eq $V_0_1 || $genimode eq $V_0_2) {
	print "component_node_uuid=\"$nodeUrn\" ";
	print "component_interface_id=\"" . $interfaceUrn . "\"";
    } elsif ($genimode eq $V_2 || $genimode eq $V_3) {
	print "component_id=\"$interfaceUrn\"";
    }
    print "/>\n";
}

sub print_property
{
    my ($source_urn, $dest_urn, $bw, $delay, $loss) = @_;
    print "<property source_id=\"$source_urn\" dest_id=\"$dest_urn\" ";
    print " capacity=\"$bw\" latency=\"$delay\" packet_loss=\"$loss\" />\n";
}

sub print_interface_contents
{
    my $node = shift(@_);
    my $interface = shift(@_);
    print "    <node_name>$node</node_name>\n";
    print "    <interface_name>$interface</interface_name>\n";
}

# Print a link with a unique name not necessarily related to source,
# dest, source_if, and dest_if.
sub print_named_link
{
    if (!$do_xml) {
	print_named_link_ptop(@_, 0);
    } elsif ($do_xml && $genimode eq $NO_GENI) {
	print_named_link_xml_plain(@_, 0);
    } elsif ($do_xml) {
	print_named_link_xml_geni(@_, 0);
    }
}

sub print_named_interconnect
{
    if (!$do_xml) {
	print_named_link_ptop(@_, 1);
    } elsif ($do_xml && $genimode eq $NO_GENI) {
	print_named_link_xml_plain(@_, 1);
    } elsif ($do_xml) {
	print_named_link_xml_geni(@_, 1);
    }
}

# Print a link where the name is just a recapitulation of the source
# and destination node and interface names.
sub print_simple_link
{
    print_named_link("link-".$_[0].":".$_[1]."-".$_[2].":".$_[3], @_);
}

sub print_type_relation
{
    my $type = shift(@_);
    my $osids = @_;
}

sub print_stitch_node
{
    my ($node) = @_;
    my $node_urn = GeniHRN::Generate($OURDOMAIN, "node", $node);
    print "<node id=\"$node_urn\">\n";
    foreach my $external (@{ $contact_nodes{$node} }) {
	my $vlans = $external_nodes{$external};
	if (defined($external_links{"$node:$external"})) {
	    print_stitch_port($node,
			      $contact_ifaces{"$node:$external"},
			      $external_ifaces{"$node:$external"},
			      1000000, $vlans, 0);
	}
    }
    print "</node>\n";
}

sub print_stitch_port
{
    my ($node, $iface_urn, $remote_iface_urn, $capacity,
	$vlans, $vlan_will_translate) = @_;
    my (undef, undef, $iface) = GeniHRN::Parse($iface_urn);
    my $port_urn = GeniHRN::Generate($OURDOMAIN, "stitchport",
				     $iface);
    my $vlan_translate = "false";
    if ($vlan_will_translate) {
	$vlan_translate = "true";
    }
    print "  <port id=\"$port_urn\">\n";
    print "    <capacity>$capacity</capacity>\n";
    print "    <maximumReservableCapacity>$capacity".
	"</maximumReservableCapacity>\n";
    print "    <minimumReservableCapacity>1000".
	"</minimumReservableCapacity>\n";
    print "    <granularity>1</granularity>\n";
    print "    <link id=\"$iface_urn\">\n";
    print "      <remoteLinkId>$remote_iface_urn</remoteLinkId>\n";
    print "      <trafficEngineeringMetric>10</trafficEngineeringMetric>\n";
    print "      <capacity>$capacity</capacity>\n";
    print "      <maximumReservableCapacity>$capacity".
	"</maximumReservableCapacity>\n";
    print "      <minimumReservableCapacity>1000".
	"</minimumReservableCapacity>\n";
    print "      <granularity>1</granularity>\n";
    print "      <switchingCapabilityDescriptor>\n";
    print "        <switchingcapType>l2sc</switchingcapType>\n";
    print "        <encodingType>ethernet</encodingType>\n";
    print "        <switchingCapabilitySpecificInfo>\n";
    print "         <switchingCapabilitySpecificInfo_L2sc>\n";
    print "          <interfaceMTU>1500</interfaceMTU>\n";
    print "          <vlanRangeAvailability>$vlans".
	"</vlanRangeAvailability>\n";
    print "          <vlanTranslation>$vlan_translate</vlanTranslation>\n";
    print "         </switchingCapabilitySpecificInfo_L2sc>\n";
    print "        </switchingCapabilitySpecificInfo>\n";
    print "      </switchingCapabilityDescriptor>\n";
    print "    </link>\n";
    print "  </port>\n";
}

sub fatal($)
{
    my ($mesg) = @_;

    print STDERR "*** $0:\n".
	         "    $mesg\n";
    exit(-1);
}