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