# -*- perl -*-
#
# DO NOT MOVE THE FIRST LINE
# It identifies the rest of the file as PERL for EMACS autoformatting
# put perl options at the end of that line, e.g., -p
#
#
# -------------------------------------------------------------------
# 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.
#
# -------------------------------------------------------------------
# $RCSfile: XB_API_SUBS.pm,v $
#
# $Revision: 1.10 $
# $Author: pingali $
# $Date: 2005/03/31 07:03:52 $
# $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Gregory Finn
##################################################
#
# API_SUBS
#
# Xbone Overlay Manager API parser/compiler subroutines
#
# Principal author: Gregory Finn
#
##################################################
package XB_API_SUBS;
use strict;
use XB_Params;
use XB_API_OM;
use XB_XOL;
use Data::Dumper;
########################################################################
#
# sub XB_class_consistency ( classhref, errref )
#
# Checks the netlist and exportlist in an XOL class definition to ensure
# that the nodes, links and interfaces mentioned there do exist.
# classhref is a reference to the hash containing the class data structure.
# If an error is detected, the error string will be stored into the string
# referenced by errref and false will be returned. Otherwise, the directives
# will have passed these checks and progref will be returned.
#
# False is returned if a semantic error was detected. Otherwise, classname
# is returned.
########################################################################
sub XB_class_consistency ( $$ )
{
my ($classhref, $errref) = @_;
my ($result, $nethref, $partshref, $nlistlref, $nodeshref, $linkshref,
$classname, $topohref, $exportslref);
$result = 0;
$classname = $classhref->{class};
$nethref = $classhref->{network};
$partshref = $nethref->{net_parts};
#################################
# Make sure necessary parts exist
#################################
if (!defined ($partshref->{netlist}))
{
$result = "In class $classname, the netlist must be declared";
goto EXIT;
}
else
{ $nlistlref = $partshref->{netlist}; };
if (!defined ($partshref->{nodes}))
{
$result = "In class $classname, nodes must be declared";
goto EXIT;
}
else
{ $nodeshref = $partshref->{nodes}; };
if (!defined ($partshref->{links}))
{
$result = "In class $classname, links must be declared";
goto EXIT;
}
else
{ $linkshref = $partshref->{links}; };
##############################
# Check each link, interior
# and exterior for consistency
##############################
foreach $topohref (@$nlistlref)
{
$result = XB_topo_triple_failure
($classname, $nodeshref, $linkshref, $topohref);
if ($result) { goto EXIT; };
};
$exportslref = $partshref->{exportlist};
foreach $topohref (@$exportslref)
{
$result = XB_topo_endpoint_failure
($classname, $nodeshref, $linkshref, $topohref);
if ($result) { goto EXIT; };
};
#####################################
# Check each node, link and interface
# to ensure that each is used
#####################################
$result = XB_class_failure ($classname, $partshref);
EXIT:
if ($result)
{
$$errref = $result;
return (0);
}
else
{ return ($classname); }
}
########################################################################
#
# sub XB_topo_triple_failure ( classname, nodeshref, linkshref, topohref )
#
# Returns false IF NO ERROR WAS DETECTED. Otherwise, returns an
# error string that reflects the semantic error that was detected.
#
# Marks nodes, links and interfaces of a class as follows:
#
# node --- properties {src_target, dst_target} indicating that
# node is src or dst arget of a link. Property value is
# number of times node is src or dst link target. Should
# have value of at least 1. A topo_triple describes a
# bi-directional link. Thus each node mentioned both
# a src_target and a dst_target.
#
# interface --- property {used} should have property value 1
#
# link --- property {used} should have property value 1
#
########################################################################
sub XB_topo_triple_failure ($$$$)
{
my ($classname, $nodeshref, $linkshref, $topohref) = @_;
my ($nodehref, $ifhref);
my $result = 0;
############################
# Check left node, interface
# and link for existence
############################
if (!defined ($nodeshref->{$topohref->{left_node}}))
{ return
("In class $classname netlist left node $topohref->{left_node} is not defined");
};
$nodehref = $nodeshref->{$topohref->{left_node}};
XB_incr_property ($nodehref, 'src_target');
XB_incr_property ($nodehref, 'dst_target');
$ifhref = $nodehref->{interfaces};
if (!defined ($ifhref->{$topohref->{left_if}}))
{ return
("In class $classname netlist left interface $topohref->{left_if} is not defined");
}
else
{ XB_incr_property ($ifhref->{$topohref->{left_if}}, 'used'); };
if (!defined ($linkshref->{$topohref->{link_name}}))
{ return
("In class $classname netlist link $topohref->{link_name} is not defined");
}
else
{ XB_incr_property ($linkshref->{$topohref->{link_name}}, 'used'); };
####################################
# Now check right node and interface
####################################
if (!defined ($nodeshref->{$topohref->{right_node}}))
{ return
("In class $classname netlist right node $topohref->{right_node} is not defined");
};
$nodehref = $nodeshref->{$topohref->{right_node}};
XB_incr_property ($nodehref, 'dst_target');
XB_incr_property ($nodehref, 'src_target');
$ifhref = $nodehref->{interfaces};
if (!defined ($ifhref->{$topohref->{right_if}}))
{ return
("In class $classname netlist right interface $topohref->{right_if} is not defined");
}
else
{ XB_incr_property ($ifhref->{$topohref->{right_if}}, 'used'); };
return ($result);
}
########################################################################
#
# sub XB_topo_endpoint_failure ( classname, nodeshref, linkshref, topohref )
#
# Returns false IF NO ERROR WAS DETECTED. Otherwise, returns an
# error string that reflects the semantic error that was detected.
#
# Marks nodes and interfaces of a class as follows:
#
# node --- properties {src_target, dst_target} indicating that
# node is src or dst arget of a link. Property value is
# number of times node is src or dst link target. Should
# have value of at least 1. A topo_endpoint does not describe
# a completed link, so the node's src-target and dst_target
# properties are not incremented.
#
# interface --- property {used} should have property value 1
#
########################################################################
sub XB_topo_endpoint_failure ($$$$)
{
my ($classname, $nodeshref, $linkshref, $topohref) = @_;
my ($nodehref, $ifhref);
my $result = 0;
############################
# Check left node, interface
# and link for existence
############################
if (!defined ($nodeshref->{$topohref->{node}}))
{ return
("In class $classname exportlist node $topohref->{node} is not defined");
};
$nodehref = $nodeshref->{$topohref->{node}};
$ifhref = $nodehref->{interfaces};
if (!defined ($ifhref->{$topohref->{if}}))
{ return
("In class $classname exportlist interface $topohref->{if} is not defined");
}
else
{ XB_incr_property ($ifhref->{$topohref->{if}}, 'used'); };
return ($result);
}
########################################################################
#
# sub XB_incr_property ( href, key )
#
# Increments "key" property of hash passed by reference. If "key"
# property not defined, creates it with value of one. Value returned
# is modified value of "key" property.
########################################################################
sub XB_incr_property ($$)
{
my ($href, $prop) = @_;
#########################
# Check key for existence
# and increment it
#########################
if (defined ($href->{$prop}))
{ $href->{$prop}++; }
else
{ $href->{$prop} = 1; }
return ($href->{$prop});
}
########################################################################
#
# sub XB_class_failure ( classname, partshref )
#
# Checks for consistent usage of the nodes, links and interfaces of
# a class definition. Returns false if usage is consistent. Otherwise
# an error message is returned.
########################################################################
sub XB_class_failure ($$)
{
my ($classname, $partshref) = @_;
my ($nodeshref, $ifaceshref, $linkshref);
my ($linkname, $lhref, $nodename, $nhref, $ifname, $ifhref);
my $result = 0;
##############################
# Make sure all this node's
# links exist an are used once
##############################
$linkshref = $partshref->{links};
while (($linkname, $lhref) = each %$linkshref)
{
if (!defined ($lhref->{used}))
{ return ("In class $classname link $linkname is not used"); }
elsif ($lhref->{used} != 1)
{ return
("In class $classname, for node $nodename, link $linkname used more than once");
};
};
$nodeshref = $partshref->{nodes};
while (($nodename, $nhref) = each %$nodeshref)
{
##################################
# Make sure this node is used both
# as source and destination target
##################################
if (!defined ($nhref->{src_target}))
{
return ("In class $classname, node $nodename is not a link source");
};
if (!defined ($nhref->{dst_target}))
{
return ("In class $classname, node $nodename is not a link destination");
};
######################################
# Make sure all this node's interfaces
# exist and are used once
######################################
$ifaceshref = $nhref->{interfaces};
while (($ifname, $ifhref) = each %$ifaceshref)
{
if (!defined ($ifhref->{used}))
{
return ("In class $classname, for node $nodename, interface $ifname is not used");
}
elsif ($ifhref->{used} != 1)
{
return ("In class $classname, for node $nodename, interface $ifname used more than once");
}
};
};
return ($result);
}
########################################################################
#
# sub XB_meta_node_imports ( classhref )
#
# A META_NODE is associated with a pre-defined CLASS. It assumes as its
# interfaces those exported by its CLASS. If there are no exports
# associated with that class, false is returned. Otherwise, a reference
# to the appropriate imported 'interface' property value is returned.
########################################################################
sub XB_meta_node_imports ( $ )
{
my ($classhref) = @_;
my ($partshref, $explref, $ifaceshref, $exphref);
my ($ifhref, $nodeshref, $key, %ifacespl);
$partshref = $classhref->{net_parts};
$explref = $partshref->{exportlist};
$nodeshref = $partshref->{nodes};
if (!scalar (@$explref)) # No exports is an error.
{ return (0); };
######################################
# For each interface in the exportlist
# of the imported class, copy the
# interface properties from the named
# node and interface
######################################
%ifacespl = ();
foreach $exphref (@$explref)
{
my $expifname = $exphref->{if};
my $expnodename = $exphref->{node};
my $actnodehref = $nodeshref->{$expnodename};
my $actifaceshref = $actnodehref->{interfaces};
my $actifhref = $actifaceshref->{$expifname};
my $ifhref = {};
#############################
# Copy the properties of each
# exported interface, but NOT
# any semantic check data
#############################
foreach $key (keys %$actifhref)
{
if ($key ne 'used')
{ $ifhref->{$key} = $actifhref->{$key}; };
};
$ifacespl{$expifname} = $ifhref;
};
return (\%ifacespl);
}
########################################################################
#
# sub XB_directives_consistency ( progref, errref )
#
# Checks the directives in an XOL program to ensure that the classes,
# links and interfaces mentioned do exist. progref is a reference to
# the hash containing the XOL program data structure. If an error is
# detected, the error string will be stored into the string referenced
# by errref and false will be returned. Otherwise, the directives will
# have passed these checks and progref will be returned.
########################################################################
sub XB_directives_consistency ( $$ )
{
my ($proghref, $errref) = @_;
my ($dirhref, $result, $classeshref, $directiveslref, %objmap);
$result = 0;
$classeshref = $proghref->{classes};
$directiveslref = $proghref->{directives};
########################################################
# objmap is a global hash that contains the map
# between declared object names and the class's hash ref
########################################################
%objmap = ();
########################
# Process the directives
########################
for $dirhref (@$directiveslref)
{
if ($dirhref->{directive} eq 'root')
{
$_ = XB_root_declaration_failure ($dirhref, $classeshref);
if ($_)
{
$result = $_;
goto EXIT;
}
$objmap{$dirhref->{object_name}} = # Declared successful
$classeshref->{$dirhref->{class_name}}; # so update object map
}
else
{
$result = "Directive $dirhref->{directive} is unknown";
goto EXIT;
}
};
EXIT:
if ($result)
{
$$errref = $result;
return (0);
}
else
{ return ($proghref); }
}
########################################################################
#
# sub XB_root_declaration_failure ( dirhref, classeshref )
#
# Returns false IF NO ERROR WAS DETECTED. Otherwise, returns an
# error string that reflects the semantic error that was detected.
########################################################################
sub XB_root_declaration_failure ($$)
{
my ($dirhref, $classeshref) = @_;
my $result = 0;
if (!defined ($classeshref->{$dirhref->{class_name}}))
{
$result = "Class $dirhref->{class_name} in root declaration is not defined";
};
return ($result);
}
########################################################################
#
# sub XB_object_linkref_failure ( classhref, linkhref )
#
# Checks that the OBJ_LINKREF is proper for the class definition
# referenced by classhref.
#
# Returns false IF NO ERROR WAS DETECTED. Otherwise, returns an
# error string that reflects the semantic error that was detected.
########################################################################
sub XB_object_linkref_failure ($$)
{
my ($classhref, $linkhref) = @_;
my ($nodeshref, $nhref, $linkshref, $nifhref, $olrstr,
$npartshref, $exportslref);
$npartshref = $classhref->{net_parts};
$nodeshref = $npartshref->{nodes};
$linkshref = $npartshref->{links};
$olrstr = "$linkhref->{object_name}:$linkhref->{node_name}.$linkhref->{if_name}";
################################
# Check left node, interface and
# link for existence in class
################################
if (!defined ($nodeshref->{$linkhref->{node_name}}))
{ return
("Node $linkhref->{node_name} of $olrstr not defined in class $classhref->{class}");
};
$nhref = $nodeshref->{$linkhref->{node_name}};
$nifhref = $nhref->{interfaces};
if (!defined ($nifhref->{$linkhref->{if_name}}))
{ return
("Interface $linkhref->{node_name} of $olrstr not defined in class $classhref->{class}, node $linkhref->{node_name}");
};
if (!defined ($linkshref->{$linkhref->{link_name}}))
{ return
("Link $linkhref->{link_name} of object linkref not defined in class $classhref->{class}");
};
return (0);
}
########################################################################
#
# sub XB_exportlist_member ( exportslref, nodename, ifname, linkname )
#
# Returns false if named node, interface and link are not in a single element
# of an exportlist referenced by exportslref. Otherwise, returns a reference
# to the OBJ_LINKREF hash element that matches nodename, ifname and linkname.
########################################################################
sub XB_exportlist_member ($$$$)
{
my ($exportslref, $nodename, $ifname, $linkname) = @_;
my ($exphref);
foreach $exphref (@$exportslref)
{
if (
($exphref->{node} eq $nodename) &&
($exphref->{if} eq $ifname) &&
($exphref->{link_name} eq $linkname)
)
{ return ($exphref); };
};
return (0);
}
########################################################################
#
# sub XB_embed_directive_failure ( dirhref, classeshref )
#
# Returns false IF NO ERROR WAS DETECTED. Otherwise, returns an
# error string that reflects the semantic error that was detected.
########################################################################
sub XB_embed_directive_failure ($$)
{
my ($dirhref, $classhref) = @_;
return (XB_check_connect_directive ($dirhref, $classhref));
}
########################################################################
#
# sub XB_net_services_actions ( itemref, errref )
#
########################################################################
sub XB_net_services_actions ( $$ )
{
my ($itemref, $errref) = @_;
my %ns = (); my ($rv, $rvtype, $rvvalue, $ix);
$ix = 0;
while (defined $itemref->[$ix])
{
$rv = $itemref->[$ix];
$rvtype = $rv->{type};
$rvvalue = $rv->{value};
if ($rvtype eq 'NET_MGR')
{
if (!defined $ns{net_manager})
{ $ns{net_manager} = []; }
push (@{$ns{net_manager}}, $rvvalue);
}
elsif ($rvtype eq 'NET_ADDRSVR')
{
if (defined $ns{net_addrsvr})
{
$$errref = "only one address server allowed per overlay";
goto EXIT;
}
else
{ $ns{net_addrsvr} = $rvvalue; }
}
elsif ($rvtype eq 'NET_DOMAINSVR')
{
if (!defined $ns{net_domainsvr})
{ $ns{net_domainsvr} = []; }
push (@{$ns{net_domainsvr}}, $rvvalue);
}
elsif ($rvtype eq 'NET_APPLICATIONS')
{
if (defined $ns{net_applications})
{
$$errref = "only one applications list allowed per overlay";
goto EXIT;
}
else
{ $ns{net_applications} = $rvvalue; }
}
elsif ($rvtype eq 'NET_MONITOR')
{
if (defined $ns{net_monitor})
{
$$errref = "only one monitor program allowed per overlay,";
goto EXIT;
}
else
{ $ns{net_monitor} = $rvvalue; }
}
elsif ($rvtype eq 'DYNAMIC_ROUTING')
{
if (defined $ns{dynamic_routing})
{
$$errref = "only one dynamic routing declaration allowed per overlay,";
goto EXIT;
}
else
{
if ($rvvalue =~ /yes|no/i)
{ $ns{dynamic_routing} = $rvvalue; }
else
{
$$errref = "dynamic routing declaration must be YES or NO,";
goto EXIT;
}
}
}
$ix++;
}
if (!defined $ns{net_manager}[0]) # Must be >= one
{
print "\nMANAGER ERROR\n";
$$errref = 'at least one manager must be specified per network';
goto EXIT;
}
EXIT:
if ($$errref)
{ return (undef); }
else
{ return (\%ns); }
}
######################################################################
#
# sub XB_parse_error_messages ($)
#
# The error messages returned by the RecDescent parse are scanned and
# the last message is returned as a single line of text.
######################################################################
sub XB_parse_error_messages ($)
{
my ($errlines) = @_;
my (@errlst, $errors, $errline, $errnum, $maxerrnum);
@errlst = split /\n\n/, $errlines; # errors separated by blank lines
$errors = '';
$maxerrnum = $errnum = -1;
foreach $errline (@errlst)
{
$errline =~ s/\n\s+/ /gm; # two-line errors to single-line
$errline =~ /\s+(\d+)/; # line should now have format of
# ERROR: (line xx) error string
if (!defined ($1))
{ next; } # something wrong here, skip it
else
{
$errnum = $1; # have seen a good error line
if ($errnum > $maxerrnum)
{
$errors = $errline;
$maxerrnum = $errnum;
}
elsif ($errnum == $maxerrnum)
{ $errors .= "\n" . $errline; }
}
};
return ($errors); # return deepest error or empty string
}
1; # Insure TRUE return if module is interpreted.
syntax highlighted by Code2HTML, v. 0.9.1