### Local Variables: ***
### mode:perl ***
### comment-column:0 ***
### comment-start: "### " ***
### comment-end: "***" ***
### End: ***
#
# ****************DO NOT MOVE OR CHANGE LINES ABOVE THIS*********************
#
# The first set of lines runs perl from any shell. The second set of lines
# identifies the rest of the file as PERL for EMACS autoformatting.
# See end of copyright for more information.
#
#
# -------------------------------------------------------------------
# X-BONE
#
# http://www.isi.edu/xbone
# USC Information Sciences Institute (USC/ISI)
# Marina del Rey, California 90292, USA
# Copyright (c) 1998-2005
#
# -------------------------------------------------------------------
#
# Copyright (c) 1998-2005 by the University of Southern California.
# All rights reserved.
#
# Permission to use, copy, modify, and distribute this software and
# its documentation in source and binary forms for non-commercial
# purposes and without fee is hereby granted, provided that the above
# copyright notice appear in all copies and that both the copyright
# notice and this permission notice appear in supporting
# documentation, and that any documentation, advertising materials,
# and other materials related to such distribution and use acknowledge
# that the software was developed by the University of Southern
# California, Information Sciences Institute. The name of the
# University may not be used to endorse or promote products derived
# from this software without specific prior written permission.
#
# THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT
# THE SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE. THIS SOFTWARE IS
# PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES,
# INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# Other copyrights might apply to parts of this software and are so
# noted when applicable.
#
# -------------------------------------------------------------------
#
# Effort partly sponsored by the Defense Advanced Research Projects
# Agency (DARPA) and Air Force Research Laboratory, Air Force Materiel
# Command, USAF, under agreement numbers F30602-98-1-0200 (X-Bone) and
# F30602-01-2-0529 (DynaBone). The views and conclusions contained
# herein are those of the authors and should not be interpreted as
# necessarily representing the official policies or endorsements,
# either expressed or implied, of the Defense Advanced Research
# Projects Agency (DARPA), the Air Force Research Laboratory, or the
# U.S. Government.
#
# This work was partly supported by the NSF STI-XTEND (ANI-0230789)
# and NETFS (ANI-0129689) projects. Any opinions, findings, and
# conclusions or recommendations expressed in this material are those
# of the authors and do not necessarily reflect the views of the
# National Science Foundation.
#
# -------------------------------------------------------------------
##################################################
#
#
# XBone API utilities used only by the GUI
#
# Principal author: Gregory Finn
#
##################################################
package XB_API_GUI;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw();
use strict;
use Data::Dumper; # Used for debugging, comment out for release.
#use XB_Log; # Problematic, logging from GUI not supported.
use XB_Params;
use XB_XOL;
use Parse::RecDescent;
#######################################################################
#
# XB_build_create_overlay_msg ( ahref )
#
#######################################################################
sub XB_build_create_overlay_msg ($)
{
my ( $ahref ) = @_;
my ($string, $credential_ref, $program_ref, $indent, $nxt_indent);
$indent = ' ';
$nxt_indent = ' ' . $indent;
$string = "( xbone $XB_Params::XBONE_PROTOCOL $XB_Params::XBONE_RELEASE\n";
$credential_ref = XB_XOL::XB_build_criterions (
'user_name', "'$ahref->{user_name}'",
'user_email', $ahref->{user_email},
'auth_type', $ahref->{auth_type}
);
$string .= $indent . '(credential ' . $$credential_ref . ")\n";
$string .= $indent . "(create_overlay (search_radius $ahref->{search_radius})\n";
$program_ref = XB_API_GUI::XB_build_xol_program_msg ($ahref, $nxt_indent);
if (!defined ($program_ref))
{
#RETURN ERROR MESSAGE
};
$string .= $$program_ref;
$string .= $indent . ")\n"; # End ( create_overlay
$string .= ")\n"; # End ( xbone
return (\$string);
}
#######################################################################
#
# XB_build_destroy_overlay_msg ( auth_type, overlay_name, user_name,
# user_email)
#
#######################################################################
sub XB_build_destroy_overlay_msg ($$$$)
{
my ($auth_type, $overlay_name, $user_name, $user_email ) = @_;
my ($string, $cs_ref, $credential_ref);
$credential_ref = XB_XOL::XB_build_criterions (
'user_name', "'$user_name'",
'user_email', $user_email,
'auth_type', $auth_type
);
$cs_ref = XB_XOL::XB_build_criterions (
'auth_type', $auth_type,
'overlay_name', $overlay_name,
'user_id', $user_email
);
if (!defined ($cs_ref)) {
#LOG FATAL ERROR MESSAGE
};
$string = "( xbone $XB_Params::XBONE_PROTOCOL $XB_Params::XBONE_RELEASE\n";
$string .= ' (credential '. $$credential_ref. ")\n";
$string .= " (destroy_overlay ";
$string .= $$cs_ref;
$string .= ")\n"; # End ( destroy_overlay
$string .= ")\n"; # End ( xbone
#$string .= "XboneEOC\n"; # End record
return (\$string);
}
#######################################################################
#
# XB_build_overlay_status_msg ( auth_type, overlay_name, search_radius, user_id )
#
#######################################################################
sub XB_build_overlay_status_msg ($$$$)
{
my ($auth_type, $overlay_name, $search_radius, $user_id) = @_;
my ($string, $cs_ref);
$string = "( xbone $XB_Params::XBONE_PROTOCOL $XB_Params::XBONE_RELEASE\n";
$string .= "\t(overlay_status ";
$cs_ref = XB_XOL::XB_build_criterions ( 'auth_type', $auth_type,
'overlay_name', $overlay_name,
'search_radius', $search_radius,
'user_id', $user_id
);
if (!defined ($cs_ref))
{
#LOG FATAL ERROR MESSAGE
};
$string .= $$cs_ref;
$string .= ")\n"; # End ( overlay_status
$string .= ")\n"; # End ( xbone
$string .= "XboneEOC\n"; # End record
return (\$string);
}
#######################################################################
#
# XB_build_discover_daemons_msg ( auth_type, creator_name, creator_email,
# search_radius, timeout, user_id )
#
#######################################################################
sub XB_build_discover_daemons_msg ($$$$$$)
{
my ($auth_type, $creator_name, $creator_email, $search_radius,
$timeout, $user_id ) = @_; my ($string, $cs_ref);
$string = "( xbone $XB_Params::XBONE_PROTOCOL $XB_Params::XBONE_RELEASE\n";
$string .= "\t(discover_daemons ";
$cs_ref = XB_XOL::XB_build_criterions ( 'auth_type', $auth_type,
'creator_name', $creator_name,
'creator_email', $creator_email,
'search_radius', $search_radius,
'timeout', $timeout,
'user_id', $user_id
);
if (!defined ($cs_ref))
{
#LOG FATAL ERROR MESSAGE
};
$string .= $$cs_ref;
$string .= ")\n"; # End ( discover_daemons
$string .= ")\n"; # End ( xbone
$string .= "XboneEOC\n"; # End record
return (\$string);
}
#######################################################################
#
# XB_build_destroyall_overlays_msg ( auth_type, user_id )
#
#######################################################################
sub XB_build_destroyall_overlays_msg ($$)
{
my ($auth_type, $user_id) = @_; my ($string, $cs_ref);
$string = "( xbone $XB_Params::XBONE_PROTOCOL $XB_Params::XBONE_RELEASE\n";
$string .= "\t(destroyall_overlays ";
$cs_ref = XB_XOL::XB_build_criterions ( 'auth_type', $auth_type,
'user_id', $user_id
);
if (!defined ($cs_ref))
{
#LOG FATAL ERROR MESSAGE
};
$string .= $$cs_ref;
$string .= ")\n"; # End ( destroyall_overlays
$string .= ")\n"; # End ( xbone
$string .= "XboneEOC\n"; # End record
return (\$string);
}
#######################################################################
#
# XB_build_list_overlays_msg ( auth_type, user_name, user_email )
#
#######################################################################
sub XB_build_list_overlays_msg ($$$)
{
my ($auth_type, $user_name, $user_email) = @_;
my ($string, $credential_ref, $cs_ref);
$credential_ref = XB_XOL::XB_build_criterions (
'user_name', "'$user_name'",
'user_email', $user_email,
'auth_type', $auth_type
);
$cs_ref = XB_XOL::XB_build_criterions ( 'auth_type', $auth_type,
'user_id', $user_email
);
if (!defined ($cs_ref)){
#LOG FATAL ERROR MESSAGE
};
$string = "( xbone $XB_Params::XBONE_PROTOCOL $XB_Params::XBONE_RELEASE\n";
$string .= " (credential ". $$credential_ref. ")\n";
$string .= " (list_overlays ";
$string .= $$cs_ref;
$string .= ")\n"; # End ( list_overlays
$string .= ")\n"; # End ( xbone
#$string .= "XboneEOC\n"; # End record
return (\$string);
}
######################################################################
#
# sub XB_check_create_reply ( chref )
#
######################################################################
sub XB_check_create_reply ($)
{
my ($chref) = @_;
my ($key, $retval);
my @create_reply_keys = ('command', 'error');
##################################
# Perform keyword existence checks
##################################
if (!defined ($chref->{error}))
{
@create_reply_keys = ('command', 'user_id', 'overlay_name',
'creator_name', 'creator_email', 'topology',
'auth_type', 'nodes');
};
foreach $key (@create_reply_keys)
{
if (!exists ($chref->{$key}))
{ return ("Missing $key keyword in create_reply\n"); };
};
##############################
# Perform keyword value checks
##############################
$retval = XB_XOL::XB_check_criterion_values ($chref, @create_reply_keys);
if ($retval)
{ return ($retval); };
return (0);
}
######################################################################
#
# sub XB_check_list_overlays_reply ( chref )
#
######################################################################
sub XB_check_list_overlays_reply ($)
{
my ($chref) = @_;
my ($key);
my @list_overlays_reply_keys = ('command', 'overlays');
##################################
# Perform keyword existence checks
##################################
foreach $key (@list_overlays_reply_keys)
{
if (!exists ($chref->{$key}))
{ return ("Missing $key keyword in list_overlays_reply\n"); };
};
##############################
# Perform keyword value checks
##############################
if ($chref->{command} !~ /^list_overlays_reply$/)
{ return ("Command must be list_overlays_reply\n"); }
$key = ref ($chref->{overlays});
if ($key ne 'ARRAY')
{ return ("overlays value must be a list of names\n"); }
return (0);
}
######################################################################
#
# sub XB_check_overlay_status_reply ( chref )
#
######################################################################
sub XB_check_overlay_status_reply ($)
{
my ($chref) = @_;
my ($key, $retval);
my @overlay_status_reply_keys = ('command', 'user_id', 'auth_type',
'creator_name', 'creator_email',
'overlay_name', 'topology', 'authentication',
'encryption');
##################################
# Perform keyword existence checks
##################################
foreach $key (@overlay_status_reply_keys)
{
if (!exists ($chref->{$key}))
{ return ("Missing $key keyword in overlay_status_reply\n"); };
};
##############################
# Perform keyword value checks
##############################
if ($chref->{command} !~ /^overlay_status_reply$/)
{ return ("Command must be overlay_status_reply\n"); }
else
{ shift (@overlay_status_reply_keys); } # command value has been checked
$retval = XB_XOL::XB_check_criterion_values ( $chref,
@overlay_status_reply_keys );
if ($retval)
{ return ($retval); };
return (0);
}
######################################################################
#
# sub XB_check_discover_daemons_reply ( chref )
#
######################################################################
sub XB_check_discover_daemons_reply ($)
{
my ($chref) = @_;
my ($key, $retval);
my @discover_reply_keys = ('command', 'user_id', 'auth_type',
'creator_name', 'creator_email');
##################################
# Perform keyword existence checks
##################################
foreach $key (@discover_reply_keys)
{
if (!exists ($chref->{$key}))
{ return ("Missing $key keyword in discover_reply\n"); };
};
##############################
# Perform keyword value checks
##############################
if ($chref->{command} !~ /^discover_daemons_reply$/)
{ return ("Command must be discover_daemons_reply\n"); }
else
{ shift (@discover_reply_keys); } # command value has been checked
$retval = XB_XOL::XB_check_criterion_values ( $chref,
@discover_reply_keys );
if ($retval)
{ return ($retval); };
return (0);
}
######################################################################
#
# sub XB_check_destroy_overlay_reply ( chref )
#
######################################################################
sub XB_check_destroy_overlay_reply ($)
{
my ($chref) = @_;
my ($key, $retval);
my @destroy_overlay_reply_keys = ('command', 'overlay_name');
##################################
# Perform keyword existence checks
##################################
foreach $key (@destroy_overlay_reply_keys)
{
if (!exists ($chref->{$key}))
{ return ("Missing $key keyword in destory_overlay_reply\n"); };
};
##############################
# Perform keyword value checks
##############################
if ($chref->{command} !~ /^destroy_overlay_reply$/)
{ return ("Command must be destroy_overlay_reply\n"); }
else
{ shift (@destroy_overlay_reply_keys); } # command checked
$retval = XB_XOL::XB_check_criterion_values ( $chref,
@destroy_overlay_reply_keys );
if ($retval)
{ return ($retval); }
return (0);
}
######################################################################
#
# sub XB_check_destroyall_overlays_reply ( chref )
#
######################################################################
sub XB_check_destroyall_overlays_reply ($)
{
my ($chref) = @_;
my ($key, $retval);
my @destroyall_overlays_reply_keys = ('command', 'message');
##################################
# Perform keyword existence checks
##################################
foreach $key (@destroyall_overlays_reply_keys)
{
if (!exists ($chref->{$key}))
{ return ("Missing $key keyword in destoryall_overlays_reply\n"); };
};
##############################
# Perform keyword value checks
##############################
if ($chref->{command} !~ /^destroyall_overlays_reply$/)
{ return ("Command must be destroyall_overlays_reply\n"); }
else
{ shift (@destroyall_overlays_reply_keys); } # command value checked
$retval = XB_XOL::XB_check_criterion_values ( $chref,
@destroyall_overlays_reply_keys );
if ($retval)
{ return ($retval); };
return (0);
}
######################################################################
#
# sub XB_check_node ( href )
#
######################################################################
sub XB_check_node ($)
{
my ($href) = @_; my ($key, $thref, $retval);
my @node_keys = ('os', 'ip_address', 'class');
##################################
# Perform keyword existence checks
##################################
foreach $key (@node_keys)
{
if (!exists ($href->{$key}))
{ return ("Missing $key keyword in node specification\n"); };
};
##############################
# Perform keyword value checks
# Add optional key/value pairs
##############################
push (@node_keys, ('authentication', 'class', 'dns_name', 'dynamic_routing',
'encryption', 'interfaces', 'ip_address', 'max_interfaces',
'max_overlays', 'os', 'overlays', 'release', 'max_tunnels',
'tunnel_count') );
$retval = XB_XOL::XB_check_criterion_values ($href, @node_keys);
if ($retval)
{ return ($retval); };
return (0);
}
######################################################################
#
# sub XB_check_tunnel ( href )
#
######################################################################
sub XB_check_tunnel ($)
{
my ($href) = @_; my ($key, $retval);
my @tunnel_keys = ('local_ip_address', 'remote_ip_address', 'status');
##################################
# Perform keyword existence checks
##################################
foreach $key (@tunnel_keys)
{
if (!exists ($href->{$key}))
{ return ("Missing $key keyword in tunnel specification\n"); };
};
##############################
# Perform keyword value checks
##############################
$retval = XB_XOL::XB_check_criterion_values ($href, @tunnel_keys);
if ($retval)
{ return ($retval); };
return (0);
}
#######################################################################
#
# XB_build_xol_program_msg ( ahref, indent )
#
#######################################################################
sub XB_build_xol_program_msg ($;$)
{
my ( $ahref, $indent ) = @_;
my ($string, $sref, $omref, $nxt_indent);
if (!defined ($indent))
{ $indent = ''; };
$nxt_indent = ' ' . "$indent";
$string .= $indent . "(xol $XB_Params::xol_ver\n";
$omref = XB_build_class_msg ($ahref, $nxt_indent);
if (!defined ($omref))
{
#RETURN ERROR MESSAGE
};
$string .= $$omref;
##################
# root declaration
##################
$string .= $nxt_indent . "(root $ahref->{topology} $ahref->{overlay_name})\n";
$string .= $indent . ")\n"; # End ( xol
return (\$string);
}
#######################################################################
#
# XB_build_class_msg ( ahref, indent )
#
#######################################################################
sub XB_build_class_msg ($;$)
{
my ($ahref, $indent) = @_;
my ($string, $sref, $ix, $nxt_indent);
if (!defined ($indent))
{ $indent = ''; };
$nxt_indent = ' ' . "$indent";
$string = $indent . "(class $ahref->{topology} \n";
##########################
# build ( netprops portion
##########################
$sref = XB_XOL::XB_build_criterions (
'IPsec_authentication', $ahref->{IPsec_authentication},
'dns', $ahref->{dns},
'dynamic_routing', $ahref->{dynamic_routing},
'IPsec_encryption', $ahref->{IPsec_encryption},
'addresstype', 'ipv4'
);
$string .= $nxt_indent . "(netprops $$sref )\n";
############################
# Generate simple nets parts
############################
$sref = XB_create_net_topology ( $ahref, $nxt_indent );
$string .= $$sref;
######################
# exportlist is empty
######################
$string .= $nxt_indent . "(exportlist )\n";
$string .= $indent . ")\n"; # End ( class
return (\$string);
}
#######################################################################
#
# XB_build_application_msg ( program_sref, params_sref )
#
# program_sref is a reference to a string that contains the program name.
# params_sref is a reference to a string that contains several arguments
# separated by whitespace.
#######################################################################
sub XB_build_application_msg ($$)
{
my ($program_sref, $params_sref ) = @_;
my ($string);
$string = ' (application ';
$string .= $$program_sref . ' ' . XB_XOL::XB_qstring ($$params_sref);
$string .= ")\n"; # End ( application
return (\$string);
}
###################################################################
#
# XB_create_net_topology ( ahref, indent )
#
# Creates a network topology string.
#
# A reference to the program string created is usually returned.
# A false result is returned on error.
###################################################################
sub XB_create_net_topology ($;$)
{
my ($ahref, $indent) = @_;
my ($type, $result);
if (!defined ($indent))
{ $indent = ''; };
$result = 0;
$type = $ahref->{topology};
if ($type eq 'star')
{ $result = XB_create_topology_star_msg ( $ahref->{hosts},
$ahref->{host_os},
$ahref->{router_os}, $indent );
}
elsif ($type eq 'linear')
{ $result = XB_create_topology_line_msg ( $ahref->{hosts},
$ahref->{host_os},
$ahref->{routers},
$ahref->{router_os}, $indent );
}
elsif ($type eq 'ring')
{ $result = XB_create_topology_ring_msg ( $ahref->{hosts},
$ahref->{host_os},
$ahref->{routers},
$ahref->{router_os}, $indent );
}
elsif ($type eq 'custom')
{ $result = XB_create_topology_custom_msg ( \$ahref->{custom_netlist},
$ahref->{host_os},
$ahref->{router_os}, $indent );
}
else
{ die ("Unknown network type:$type passed"); }; # Unknown network topology
return ($result);
}
###################################################################
#
# XB_create_nodeprops ( npsref, indent )
#
# nplref is a reference to a list ( name, value, name, value ...) strings
# that are turned into a sequence CRITERION rules.
#
# Returns a reference to a (node ... ) string.
###################################################################
sub XB_create_nodeprops ($;$)
{
my ($npsref, $indent) = @_;
my ($string, $strref);
if (!defined ($indent))
{ $indent = ''; };
$strref = XB_XOL::XB_build_criterions (@$npsref);
$string = "$indent" . '(nodeprops' . $$strref . ')';
return (\$string);
}
###################################################################
#
# XB_create_interfaces ( iflref, indent )
#
# iflref is a reference to a list of interface specifications, which
# take the form ( name, ifplref, name, ifplref ... )
#
# Returns a reference to an (interfaces ... ) string.
###################################################################
sub XB_create_interfaces ($;$)
{
my ($iflref, $indent) = @_;
my ($string, $ifname, $ifplref, $nxt_indent, $strref);
if (!defined ($indent))
{ $indent = ''; };
$nxt_indent = ' ' . "$indent";
$string = "$indent(interfaces\n";
$ifname = shift (@$iflref); # Get first interface name
while (defined ($ifname))
{
$ifplref = shift (@$iflref); # Get interface properties
$strref = XB_create_interface ($ifname, $ifplref);
$string .= $nxt_indent . $$strref . "\n";
$ifname = shift (@$iflref); # Get next interface name
};
$string .= "$indent)";
return (\$string);
}
###################################################################
#
# XB_create_interface ( ifname, ifplref )
#
# ifname is the name of the interface
# ifplref is a reference to a list of interface specifications, which
# take the form ( name, value, name, value ... )
#
# Returns a reference to an (interface ... ) string.
###################################################################
sub XB_create_interface ($$;$)
{
my ($ifname, $ifplref) = @_;
my ($string, $strref);
$strref = XB_XOL::XB_build_criterions (@$ifplref);
$string = '(interface ' . $ifname . $$strref . ')';
return (\$string);
}
###################################################################
#
# XB_create_node ( nref, indent )
#
# nref is a reference to a list of information associated with a node.
# It takes the format ( name props ifaces )
# name ---- string name
# propstr - see XB_create_nodeprops()
# ifaces -- see XB_create_interfaces()
#
# Returns a reference to a (node ... ) string.
###################################################################
sub XB_create_node ($;$)
{
my ($nref, $indent) = @_;
my ($string, $strref, $nxt_indent);
if (!defined ($indent))
{ $indent = ''; };
$nxt_indent = ' ' . "$indent";
$string = "$indent" . '(node ' . $nref->[0] . "\n";
$strref = XB_create_nodeprops ($nref->[1], $nxt_indent);
$string .= $$strref . "\n";
$strref = XB_create_interfaces ($nref->[2], $nxt_indent);
$string .= $$strref . "\n";
$string .= "$indent)\n";
return (\$string);
}
###################################################################
#
# XB_create_nodelist ( nlref, indent )
#
# Returns a reference to a (nodelist ... ) string.
###################################################################
sub XB_create_nodelist ($;$)
{
my ($nlref, $indent) = @_;
my ($string, $strref, $nref, $nxt_indent);
if (!defined ($indent))
{ $indent = ''; };
$nxt_indent = ' ' . "$indent";
$string = "$indent(nodelist\n";
foreach $nref (@$nlref)
{
$strref = XB_create_node ($nref, $nxt_indent);
$string .= $$strref;
};
$string .= "$indent)\n";
return (\$string);
}
###################################################################
#
# XB_create_linklist ( linkslref, indent )
#
# linkslref references a list of the form:
# ( linkname (--) linkname (--) ...)
# where (--) is the criteria list associated with the preceeding
# named link, taking the form ( name, value, name, value ... )
#
# Returns a reference to a (linklist ... ) string.
###################################################################
sub XB_create_linklist ($;$)
{
my ($linkslref, $indent) = @_;
my ($string, $strref, $linkname, $clref, $nxt_indent);
if (!defined ($indent))
{ $indent = ''; };
$nxt_indent = ' ' . "$indent";
$string = "$indent(linklist\n";
$linkname = shift (@$linkslref);
while (defined ($linkname))
{
$clref = shift (@$linkslref);
$strref = XB_create_link ($linkname, $clref, $nxt_indent);
$string .= $$strref . "\n";
$linkname = shift (@$linkslref);
};
$string .= "$indent)\n";
return (\$string);
}
###################################################################
#
# XB_create_link ( linkname, clref, indent )
#
# linkname names a link, clref references the criteria for this link.
# The clref list takes the form ( name, value, name, value ... )
#
# Returns a reference to a (link ... ) string.
###################################################################
sub XB_create_link ($$;$)
{
my ($linkname, $clref, $indent) = @_;
my ($string, $strref);
if (!defined ($indent))
{ $indent = ''; };
$string = "$indent(link $linkname";
$strref = XB_XOL::XB_build_criterions (@$clref);
$string .= "$$strref)";
return (\$string);
}
###################################################################
#
# XB_create_netlist ( linkslref, indent )
#
# linkslref references a list of the form:
# ( (nodename linkname nodename) ... (nodename linkname nodename) )
#
# where each triple indicates that the named link connects the two
# named nodes.
#
# Returns a reference to a (linklist ... ) string.
###################################################################
sub XB_create_netlist ($;$)
{
my ($linkslref, $indent) = @_;
my ($string, $strref, $lref, $nxt_indent);
if (!defined ($indent))
{ $indent = ''; };
$nxt_indent = ' ' . $indent;
$string = "$indent(netlist\n";
$lref = shift (@$linkslref);
while (defined ($lref))
{
$string .= $nxt_indent . "($lref->[0] $lref->[1] $lref->[2])\n";
$lref = shift (@$linkslref);
};
$string .= "$indent)\n";
return (\$string);
}
###################################################################
#
# XB_create_topology_star_msg ( hosts, host_os, router_os, indent )
#
# Creates the nodelist, linklist and netlist parts of a star network.
# The hosts argument specifies the number of hosts attached to a router.
# One router is created. Interface, router and host names are picked
# by this routine. The router_os and host_os are the names of the
# operating systems for the respective router and hosts.
#
# A reference to the program string created is returned.
###################################################################
sub XB_create_topology_star_msg ($$$;$)
{
my ($hosts, $host_os, $router_os, $indent) = @_;
my ($string, $nodeslref, $rmref, $ix);
my ($nodelref, $nodename, $ifname, $ifaceslref, $ifproplref, $linkslref, $linkname);
if (!defined ($indent))
{ $indent = ''; };
#########################
# Create host information
#########################
$nodeslref = [];
for ($ix = 0; $ix < $hosts; $ix++)
{
$nodelref = [];
$nodename = "host_$ix";
$ifaceslref = [];
$ifname = "if_0"; # No per-interface properties
$ifproplref = [];
push (@$ifaceslref, $ifname);
push (@$ifaceslref, $ifproplref);
push (@$nodelref, $nodename);
push (@$nodelref, ['os', $host_os] );
push (@$nodelref, $ifaceslref);
push (@$nodeslref, $nodelref)
}
########################
# Add one router to that
########################
$nodelref = [];
$nodename = "router_0";
$ifaceslref = [];
for ($ix = 0; $ix < $hosts; $ix++)
{
$ifname = "if_$ix"; # No per-interface properties
push (@$ifaceslref, $ifname);
push (@$ifaceslref, []);
}
push (@$nodelref, $nodename);
push (@$nodelref, ['os', $router_os] );
push (@$nodelref, $ifaceslref);
push (@$nodeslref, $nodelref);
############################
# Create the ( nodelist part
############################
$rmref = XB_create_nodelist ($nodeslref, $indent);
$string = "$$rmref";
#########################
# Create link information
#########################
$linkslref = [];
for ($ix = 0; $ix < $hosts; $ix++)
{
$linkname = "link_$ix";
push (@$linkslref, $linkname);
push (@$linkslref, []); # No per-link properties
};
############################
# Create the ( linklist part
############################
$rmref = XB_create_linklist ($linkslref, $indent);
$string .= "$$rmref";
################################
# Create the netlist information
################################
$linkslref = [];
for ($ix = 0; $ix < $hosts; $ix++)
{
$linkname = "link_$ix";
$nodename = "host_$ix.if_0";
push (@$linkslref, [ $nodename, $linkname, "router_0.if_$ix" ] );
};
############################
# Create the ( netlist part
############################
$rmref = XB_create_netlist ($linkslref, $indent);
$string .= "$$rmref";
return (\$string);
};
###################################################################
#
# XB_create_topology_line_msg ( hosts, host_os, routers, router_os, indent )
#
# Creates the nodelist, linklist and netlist parts of a line network.
# The arguments are the number of hosts, routers and their operating systems.
# Host, interface and link names will be picked by this routine.
#
# Hosts are attached to end routers in 50/50 split.
#
# A reference to the program string created is returned.
###################################################################
sub XB_create_topology_line_msg ($$$$;$)
{
my ($hosts, $host_os, $routers, $router_os, $indent) = @_;
my ($string, $nodeslref, $rmref, $ix, $left_hosts, $right_hosts, $linkname);
my ($nodelref, $nodename, $ifname, $ifaceslref, $ifproplref, $linkslref);
if (!defined ($indent))
{ $indent = ''; };
#####################################
# A one router line network is a star
#####################################
if ($routers == 1)
{ return (XB_create_topology_star_msg ($hosts, $host_os, $router_os, $indent) ); };
#########################
# Create host information
#########################
$nodeslref = [];
for ($ix = 0; $ix < $hosts; $ix++)
{
$nodelref = [];
$nodename = "host_$ix";
$ifaceslref = [];
$ifname = "if_0"; # No per-interface properties
$ifproplref = [];
push (@$ifaceslref, $ifname);
push (@$ifaceslref, $ifproplref);
push (@$nodelref, $nodename);
push (@$nodelref, ['os', $host_os] );
push (@$nodelref, $ifaceslref);
push (@$nodeslref, $nodelref)
}
###############################
# Create the router information
# for any center routers.
###############################
if ($routers > 2)
{
for ($ix = 1; $ix < ($routers - 1); $ix++)
{
$nodelref = [];
$nodename = "router_$ix";
$ifaceslref = [];
$ifname = "if_0"; # No per-interface properties
push (@$ifaceslref, $ifname);
push (@$ifaceslref, []);
$ifname = "if_1";
push (@$ifaceslref, $ifname);
push (@$ifaceslref, []);
push (@$nodelref, $nodename);
push (@$nodelref, ['os', $router_os] );
push (@$nodelref, $ifaceslref);
push (@$nodeslref, $nodelref);
};
};
###############################
# Create the router information
# for the two end routers.
###############################
$nodelref = [];
$nodename = "router_0";
$left_hosts = $hosts >> 1; # Interfaces needed for leftmost router - 1
$right_hosts = $hosts - $left_hosts; # " " rightmost router - 1
$ifaceslref = [];
for ($ix = 0; $ix <= $left_hosts; $ix++)
{
$ifname = "if_$ix"; # No per-interface properties
push (@$ifaceslref, $ifname);
push (@$ifaceslref, []);
};
push (@$nodelref, $nodename);
push (@$nodelref, ['os', $router_os] );
push (@$nodelref, $ifaceslref);
push (@$nodeslref, $nodelref);
$nodelref = [];
$_ = $routers - 1;
$nodename = "router_$_";
$ifaceslref = [];
for ($ix = 0; $ix <= $right_hosts; $ix++)
{
$ifname = "if_$ix"; # No per-interface properties
push (@$ifaceslref, $ifname);
push (@$ifaceslref, []);
};
push (@$nodelref, $nodename);
push (@$nodelref, ['os', $router_os] );
push (@$nodelref, $ifaceslref);
push (@$nodeslref, $nodelref);
############################
# Create the ( nodelist part
############################
$rmref = XB_create_nodelist ($nodeslref, $indent);
$string = "$$rmref";
#########################
# Create link information
#########################
$linkslref = [];
for ($ix = 0; $ix < $hosts; $ix++)
{
$linkname = "hlink_$ix";
push (@$linkslref, $linkname);
push (@$linkslref, []); # No per-link properties
};
for ($ix = 0; $ix < ($routers - 1); $ix++)
{
$linkname = "rlink_$ix";
push (@$linkslref, $linkname);
push (@$linkslref, []);
};
############################
# Create the ( linklist part
############################
$rmref = XB_create_linklist ($linkslref, $indent);
$string .= "$$rmref";
################################
# Create the netlist information
################################
$linkslref = [];
for ($ix = 0; $ix < $left_hosts; $ix++) # Leftmost router - host links
{
$linkname = "hlink_$ix";
$nodename = "host_$ix.if_0";
push (@$linkslref, [ $nodename, $linkname, "router_0.if_$ix" ] );
};
for ($ix = 0; $ix < $right_hosts; $ix++) # Rightmost router - host links
{
$_ = $ix + $left_hosts;
$linkname = "hlink_$_";
$nodename = "host_$_.if_0";
$_ = $routers - 1;
push (@$linkslref, [ $nodename, $linkname, "router_$_.if_$ix" ] );
};
############################
# Create netlist information
# for any center routers.
############################
if ($routers > 2)
{
for ($ix = 1; $ix < ($routers - 2); $ix++)
{
$linkname = "rlink_$ix";
$_ = $ix + 1;
push (@$linkslref, [ "router_$ix.if_1", $linkname, "router_$_.if_0" ] );
};
};
############################
# Create netlist information
# for the leftmost router.
############################
push (@$linkslref, [ "router_0.if_$left_hosts", 'rlink_0', "router_1.if_0" ] );
############################
# Create netlist information
# for the rightmost router.
############################
$_ = $routers - 1;
$linkname = $_ - 1;
push (@$linkslref,
[ "router_$linkname.if_1", "rlink_$linkname", "router_$_.if_$right_hosts" ] );
############################
# Create the ( netlist part
############################
$rmref = XB_create_netlist ($linkslref, $indent);
$string .= "$$rmref";
return (\$string);
};
###################################################################
#
# XB_create_topology_ring_msg ( hosts, host_os, routers, router_os, indent )
#
# Creates the nodelist, linklist and netlist parts of a line network.
# The arguments are the number of hosts, routers and their operating systems.
# Host, interface and link names will be picked by this routine.
#
# Hosts are dealt around ring to routers.
#
# A reference to the program string created is returned.
###################################################################
sub XB_create_topology_ring_msg ($$$$;$)
{
my ($hosts, $host_os, $routers, $router_os, $indent) = @_;
my ($string, $nodeslref, $rmref, $ix, $linkname);
my ($nodelref, $nodename, $ifname, $ifaceslref, $ifproplref, $linkslref);
my ($avif, $avlink, $cycles);
if (!defined ($indent))
{ $indent = ''; };
#####################################
# A one router ring network is a star
#####################################
if ($routers == 1)
{ return (XB_create_topology_star_msg ($hosts, $host_os, $router_os, $indent) ); };
#########################
# Create host information
#########################
$nodeslref = [];
for ($ix = 0; $ix < $hosts; $ix++)
{
$nodelref = [];
$nodename = "host_$ix";
$ifaceslref = [];
$ifname = "if_0"; # No per-interface properties
$ifproplref = [];
push (@$ifaceslref, $ifname);
push (@$ifaceslref, $ifproplref);
push (@$nodelref, $nodename);
push (@$nodelref, ['os', $host_os] );
push (@$nodelref, $ifaceslref);
push (@$nodeslref, $nodelref)
};
#######################
# Add the router-router
# interfaces
#######################
for ($ix = 0; $ix < $routers; $ix++)
{
$nodelref = [];
$nodename = "router_$ix";
$ifaceslref = [];
push (@$ifaceslref, 'if_0'); # No per-interface properties
push (@$ifaceslref, []);
push (@$ifaceslref, 'if_1');
push (@$ifaceslref, []);
$cycles = int ($hosts / $routers);
$avif = 2;
while ($cycles > 0)
{
push (@$ifaceslref, "if_$avif");
push (@$ifaceslref, []);
$cycles--;
$avif++;
};
$_ = $hosts % $routers;
if ($_ && ($ix < $_))
{
push (@$ifaceslref, "if_$avif");
push (@$ifaceslref, []);
};
push (@$nodelref, $nodename);
push (@$nodelref, ['os', $router_os] );
push (@$nodelref, $ifaceslref);
push (@$nodeslref, $nodelref)
};
#####################
# Add the router-host
# interfaces
#####################
for ($ix = 0; $ix < $hosts; $ix++) # Connect hosts to the ring
{
if (!($ix % $routers)) { $avif++; };
};
############################
# Create the ( nodelist part
############################
$rmref = XB_create_nodelist ($nodeslref, $indent);
$string = "$$rmref";
#########################
# Create link information
#########################
$linkslref = [];
for ($ix = 0; $ix < ($hosts + $routers); $ix++)
{
$ifname = "link_$ix";
push (@$linkslref, $ifname);
push (@$linkslref, []); # No per-link properties
};
############################
# Create the ( linklist part
############################
$rmref = XB_create_linklist ($linkslref, $indent);
$string .= "$$rmref";
################################
# Create the netlist information
################################
$linkslref = [];
for ($ix = 0; $ix < $routers; $ix++) # Connect routers into a ring
{
$linkname = "link_$ix";
$_ = ($ix + 1) % $routers;
push (@$linkslref, [ "router_$ix.if_1", $linkname, "router_$_.if_0" ] );
};
$avif = 1; # Initialize counters, last router iface used
$avlink = $routers; # Next available link
for ($ix = 0; $ix < $hosts; $ix++) # Connect hosts to the ring
{
if (!($ix % $routers)) { $avif++; };
$linkname = "link_$ix";
$_ = $ix % $routers;
push (@$linkslref, [ "host_$ix.if_0", "link_$avlink", "router_$_.if_$avif" ] );
$avlink++;
};
############################
# Create the ( netlist part
############################
$rmref = XB_create_netlist ($linkslref, $indent);
$string .= "$$rmref";
return (\$string);
};
###################################################################
#
# XB_create_topology_custom_msg ( nlsref, host_os, router_os, indent )
#
# Creates the nodelist, linklist and netlist parts of a network, using a
# netlist description string passed by reference in nlsref.
#
# The netlist description string is a sequence of node pairs, one pair per
# line. A full-duplex link is presumed to exist between both nodes in each
# pair. Example:
# center tom
# center dick
# center harry
#
# This specifies a star network, with the router node named 'center'
# connected to three hosts that are named tom, dick and harry.
#
# The links and interfaces needed to create a complete XOL overlay
# specification are a automatically created and named.
#
# A reference to the program string created is returned.
###################################################################
sub XB_create_topology_custom_msg ($$$;$)
{
my ($nlsref, $host_os, $router_os, $indent) = @_;
my ($string, $linkcount);
my (@lines, $line, $node, %nodes, @links);
my ($nodeslref, $rmref, $ix);
my ($nodelref, $nodename, $ifname, $ifaceslref, $ifproplref, $linkslref);
if (!defined ($indent))
{ $indent = ''; };
################
# Get link count
################
@lines = split /\n+/, $$nlsref;
$linkcount = scalar (@lines);
########################
# Generate hash of nodes
########################
%nodes = ();
foreach $line (@lines)
{
$_ = $line;
@links = split;
if (scalar (@links) != 2) # Discard bad specification lines
{ next; };
foreach $node (@links)
{
if (!defined ($nodes{$node})) # Count interfaces per node
{ $nodes{$node} = 1; }
else
{ $nodes{$node}++; };
};
};
####################################
# Create host and router information
####################################
$nodeslref = [];
$ix = 0;
foreach $node (keys (%nodes))
{
my $ifx;
$nodelref = [];
$ifaceslref = [];
$ifx = 0;
while ($ifx < $nodes{$node})
{
$ifproplref = []; # No per-interface properties
$ifname = "if_$ifx";
push (@$ifaceslref, $ifname);
push (@$ifaceslref, $ifproplref);
$ifx++;
};
push (@$nodelref, $node);
if ($nodes{$node} == 1)
{ push (@$nodelref, ['os', $host_os] ); }
else
{ push (@$nodelref, ['os', $router_os] ); };
push (@$nodelref, $ifaceslref);
push (@$nodeslref, $nodelref);
$ix++;
};
############################
# Create the ( nodelist part
############################
$rmref = XB_create_nodelist ($nodeslref, $indent);
$string = "$$rmref";
#########################
# Create link information
#########################
$linkslref = [];
for ($ix = 0; $ix < $linkcount; $ix++)
{
$ifname = "link_$ix";
push (@$linkslref, $ifname);
push (@$linkslref, []); # No per-link properties
};
############################
# Create the ( linklist part
############################
$rmref = XB_create_linklist ($linkslref, $indent);
$string .= "$$rmref";
################################
# Create the netlist information
################################
$linkslref = [];
for ($ix = 0; $ix < $linkcount; $ix++)
{
$_ = $lines[$ix];
@links = split;
$nodes{$links[0]}--; # Decrement interface counts for each node
$nodes{$links[1]}--; # since interfaces are named starting at zero.
push (@$linkslref, [ "$links[0].if_$nodes{$links[0]} ", "link_$ix",
" $links[1].if_$nodes{$links[1]}" ] );
};
############################
# Create the ( netlist part
############################
$rmref = XB_create_netlist ($linkslref, $indent);
$string .= "$$rmref";
return (\$string);
};
1; # Insure TRUE return if module is interpreted.
syntax highlighted by Code2HTML, v. 0.9.1