# -*- 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_grammar.pm,v $
#
# $Revision: 1.16 $
# $Author: pingali $
# $Date: 2005/03/31 07:03:52 $
# $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Gregory Finn
##################################################
#
# API
#
# Xbone Overlay Manager API parser/compiler routines
#
# Principal author: Gregory Finn
#
##################################################
use strict;
use XB_API_OM;
use XB_API_GUI;
use XB_API_SUBS;
use XB_XOL;
use Parse::RecDescent;
#########################################################################
#
# The following five declarations are used for debugging when making
# a change to the API grammar or compiler run-time code.
#
#########################################################################
$::RD_ERRORS = undef; # undefined implies no error printing
# $::RD_HINT = 1; # the next four decarations for debugging
# $::RD_WARN = 1;
# $::RD_TRACE = 1;
# use Data::Dumper;
my $grammar = <<'GRAMMAR_RULES';
{
my ($semerr) = '';
my (%classes) = ();
}
API: { $semerr = ""; } <reject>
| '(' 'xbone' ARGSTRING ARGSTRING CREDENTIAL COMMAND <commit>
{
my %api = ();
my $result = undef;
$result = \%api;
$api{protocol} = $item[3];
$api{release} = $item[4];
$api{credential} = $item{CREDENTIAL};
$api{command} = $item{COMMAND};
if ($api{protocol} !~ /^[0-9]+\.[A-Za-z0-9-]+$/)
{
$semerr =
"ERROR: language protocol number has format: number.alphanumeric\n";
goto EXIT;
};
if ($api{release} !~ /^[0-9]+\.[A-Za-z-0-9-]+$/)
{
$semerr =
"ERROR: xbone version number has format: number.alphanumeric\n";
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%api; }
}
')' END_OF_FILE
| <error?:$semerr> <reject>
CREDENTIAL: { $semerr = ""; } <reject>
| '(' 'credential' <commit> CRITERION(s)
{
my %cp = (); my ($chref, $clref, $key);
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
##################################
# Perform keyword existence checks
##################################
my (@credential_keys) = ( 'user_name', 'user_email', 'auth_type' );
foreach $key (@credential_keys)
{
if (!exists ($cp{$key}))
{ $semerr = "Missing $key keyword in credentials."; };
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
')'
| <error?:$semerr> <reject>
COMMAND: { $semerr = ""; } <reject>
| '(' 'create_overlay_reply' CRITERION(s) NODE(s?) ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'create_overlay_reply';
$cp{nodes} = $item{NODE};
$retval = XB_API_GUI::XB_check_create_reply (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'create_overlay' CRITERION(s) XOL_PROGRAM ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$retval = undef;
$cp{command} = 'create_overlay';
$cp{xol_program} = $item{XOL_PROGRAM};
$retval = XB_API_OM::XB_check_create (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'list_overlays_reply' CRITERION(?) ARGSTRING(s?) ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'list_overlays_reply';
$cp{overlays} = $item{ARGSTRING};
$retval = XB_API_GUI::XB_check_list_overlays_reply (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'list_overlays' CRITERION(s) ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'list_overlays';
$retval = XB_API_OM::XB_check_list_overlays (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'overlay_status_reply' CRITERION(s) NODE(s?) ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'overlay_status_reply';
$cp{nodes} = $item{NODE};
$retval = XB_API_GUI::XB_check_overlay_status_reply (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'overlay_status' CRITERION(s) ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'overlay_status';
$retval = XB_API_OM::XB_check_overlay_status (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'discover_daemons_reply' CRITERION(s) NODE(s?) ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'discover_daemons_reply';
$cp{nodes} = $item{NODE};
$retval = XB_API_GUI::XB_check_discover_daemons_reply (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'discover_daemons' CRITERION(s) ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'discover_daemons';
$retval = XB_API_OM::XB_check_discover_daemons (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'destroy_overlay_reply' CRITERION(s) ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'destroy_overlay_reply';
$retval = XB_API_GUI::XB_check_destroy_overlay_reply (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'destroy_overlay' CRITERION(s) ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'destroy_overlay';
$retval = XB_API_OM::XB_check_destroy_overlay (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'destroyall_overlays_reply' CRITERION(s) ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'destroyall_overlays_reply';
$retval = XB_APU_GUI::XB_check_destroyall_overlays_reply (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'destroyall_overlays' CRITERION(s) ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'destroyall_overlays';
$retval = XB_API_OM::XB_check_destroyall_overlays (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'host_choices_reply' NODE(s) ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'host_choices_reply';
$cp{nodes} = $item{NODE};
$retval = XB_APU_OM::XB_check_host_choices_reply (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'host_choices' CRITERION(s) NODE(s) ')' <commit>
{
my %cp = (); my ($retval, $chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'host_choices';
$cp{nodes} = $item{NODE};
$retval = XB_APU_GUI::XB_check_host_choices (\%cp);
if ($retval)
{
$semerr = $retval;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| '(' 'error_reply' CRITERION(s) ')'
{
my %cp = (); my ($chref, $clref);
###################################
# Gather CRITERION name/value pairs
###################################
$semerr = "";
$clref = $item{CRITERION};
foreach $chref (@$clref)
{ $cp{$chref->{type}} = $chref->{value}; };
$cp{command} = 'error_reply';
$return = \%cp;
}
| <error?:$semerr> <reject>
NODE: '(' 'node' CRITERION(s) TUNNEL(s?) ')' <commit>
{
my %rv = (); my ($href, $clref, $result);
$semerr = "";
$clref = $item{CRITERION};
foreach $href (@$clref)
{ $rv{$href->{type}} = $href->{value}; };
$rv{tunnels} = $item{TUNNEL};
$result = XB_API_GUI::XB_check_node (\%rv);
if ($result)
{
$semerr = $result;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%rv; }
}
| <error?:$semerr> <reject>
TUNNEL: '(' 'tunnel' CRITERION(s) ')' <commit>
{
my %rv = (); my ($href, $clref, $result);
$semerr = "";
$clref = $item{CRITERION};
foreach $href (@$clref)
{ $rv{$href->{type}} = $href->{value}; };
$result = XB_API_GUI::XB_check_tunnel (\%rv);
if ($result)
{
$semerr = $result;
goto EXIT;
};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%rv; }
}
| <error?:$semerr> <reject>
XOL_PROGRAM: { $semerr = ""; } <reject>
| '(' 'xol' XOL_PROTOCOL CLASS(s) ROOT_DECLARATION ')' <commit>
{
my %program = ();
$program{xol_protocol} = $item{XOL_PROTOCOL};
%classes = ();
$program{classes} = $item{CLASS};
$program{directive} = $item{ROOT_DECLARATION};
if (!XB_API_SUBS::XB_directives_consistency ( \%program,
\$semerr ) )
{ goto EXIT; };
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%program; }
}
| <error?:$semerr> <reject>
CLASS: { $semerr = ""; } <reject>
| '(' 'class' CLASS_NAME NETWORK ')' <commit>
{
my %cp = ();
$cp{class} = $item{CLASS_NAME};
$cp{network} = $item{NETWORK};
if (!XB_API_SUBS::XB_class_consistency (\%cp, \$semerr))
{ goto EXIT };
if (defined $classes{$item{CLASS_NAME}})
{
$semerr = "Class $item{CLASS_NAME} has been defined already";
goto EXIT;
};
$classes{$item{CLASS_NAME}} = $item{NETWORK};
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%cp; }
}
| <error?:$semerr> <reject>
NETWORK: NET_PROPS NET_PART(s)
{
my %nwp = (); my ($rv, $ix); my %pl = ();
$ix = 0;
while (defined $item{NET_PART}[$ix])
{
$rv = $item{NET_PART}[$ix];
$pl{$rv->{type}} = $rv->{value};
$ix++;
}
$nwp{props} = $item{NET_PROPS};
$nwp{net_parts} = \%pl;;
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%nwp; }
}
NET_PROPS: '(' 'netprops' CRITERION(s?) ')'
{
my %pl = (); my ($rv, $ix);
$ix = 0;
while (defined $item{CRITERION}[$ix])
{
$rv = $item{CRITERION}[$ix];
$pl{$rv->{type}} = $rv->{value};
$ix++;
}
$return = \%pl;
}
NET_PART: '(' 'nodelist' NETNODE(s) ')'
{
my %np = (); my ($rv, $ix); my %nodes = ();
$ix = 0;
while (defined $item{NETNODE}[$ix])
{
$rv = $item{NETNODE}[$ix];
$nodes{$rv->{type}} = $rv->{value};
$ix++;
}
$np{type} = 'nodes';
$np{value} = \%nodes;
$return = \%np;
}
| '(' 'linklist' LINK(s) ')'
{
my %np = (); my ($rv, $ix); my %links = ();
$ix = 0;
while (defined $item{LINK}[$ix])
{
$rv = $item{LINK}[$ix];
$links{$rv->{type}} = $rv->{value};
$ix++;
}
$np{type} = 'links';
$np{value} = \%links;
$return = \%np;
}
| '(' 'netlist' TOPO_TRIPLE(s) ')'
{
my %np = ();
$np{type} = 'netlist';
$np{value} = $item{TOPO_TRIPLE};
$return = \%np;
}
| '(' 'exportlist' TOPO_ENDPOINT(s?) ')'
{
my %np = ();
$np{type} = 'exportlist';
$np{value} = $item{TOPO_ENDPOINT};
$return = \%np;
}
| <error>
NETNODE: '(' 'node' SIMPLE_NODE ')'
{
$return = $item{SIMPLE_NODE};
}
| '(' 'node' META_NODE ')'
{
$return = $item{META_NODE};
}
| <error>
SIMPLE_NODE: NODE_NAME NODE_PROPS INTERFACES
{
my %nl = (); my %pl = ();
$pl{props} = $item{NODE_PROPS};
$pl{props}->{class} = undef;
$pl{interfaces} = $item{INTERFACES};
$nl{type} = $item{NODE_NAME};
$nl{value} = \%pl;
$return = \%nl;
}
META_NODE: { $semerr = ""; } <reject>
| NODE_NAME ':' CLASS_NAME NODE_PROPS <commit>
{
my (%nl, %pl) = ((), ());
if (!defined ($classes{$item{CLASS_NAME}}))
{
$semerr = "Class name $item{CLASS_NAME} not previously defined";
goto EXIT;
};
$pl{props} = $item{NODE_PROPS};
$pl{props}->{class} = $item{CLASS_NAME};
$pl{interfaces} =
XB_API_SUBS::XB_meta_node_imports ($classes{$item{CLASS_NAME}});
if (!$pl{interfaces})
{
$semerr = "Class name $item{CLASS_NAME} has an empty exportlist";
goto EXIT;
};
$nl{type} = $item{NODE_NAME};
$nl{value} = \%pl;
EXIT:
if ($semerr)
{ $return = undef; }
else
{ $return = \%nl; }
}
| <error?:$semerr> <reject>
NODE_PROPS: '(' 'nodeprops' CRITERION(s?) ')'
{
my %pl = (); my ($rv, $ix);
$ix = 0;
while (defined $item{CRITERION}[$ix])
{
$rv = $item{CRITERION}[$ix];
$pl{$rv->{type}} = $rv->{value};
$ix++;
}
$return = \%pl;
}
INTERFACES: '(' 'interfaces' INTERFACE(s) ')'
{
my %ifpl = (); my ($rv, $ix);
$ix = 0;
while (defined $item{INTERFACE}[$ix])
{
$rv = $item{INTERFACE}[$ix];
$ifpl{$rv->{type}} = $rv->{value};
$ix++;
}
$return = \%ifpl;
}
| <error>
INTERFACE: '(' 'interface' IF_NAME CRITERION(s?) ')'
{
my %if = (); my ($rv, $ix); my %pl = ();
$ix = 0;
while (defined $item{CRITERION}[$ix])
{
$rv = $item{CRITERION}[$ix];
$pl{$rv->{type}} = $rv->{value};
$ix++;
}
$if{type} = $item{IF_NAME};
$if{value} = \%pl;
$return = \%if;
}
LINK: '(' 'link' LINK_NAME CRITERION(s?) ')'
{
my %ln = (); my %pl = (); my ($rv, $ix);
$ix = 0;
while (defined $item{CRITERION}[$ix])
{
$rv = $item{CRITERION}[$ix];
$pl{$rv->{type}} = $rv->{value};
$ix++;
}
$ln{type} = $item{LINK_NAME};
$ln{value} = \%pl;
$return = \%ln;
}
| <error>
TOPO_TRIPLE: '(' NODE_NAME '.' IF_NAME LINK_NAME NODE_NAME '.' IF_NAME ')'
{
my %tt = ();
$tt{left_node} = $item[2];
$tt{left_if} = $item[4];
$tt{link_name} = $item{LINK_NAME};
$tt{right_node} = $item[6];
$tt{right_if} = $item[8];
$return = \%tt;
}
| <error>
TOPO_ENDPOINT: '(' NODE_NAME '.' IF_NAME ')'
{
my %tt = ();
$tt{node} = $item{NODE_NAME};
$tt{if} = $item{IF_NAME};
$return = \%tt;
}
| <error>
ROOT_DECLARATION: '(' 'root' CLASS_NAME OBJECT_NAME ')'
{
my %objref = ();
$objref{directive} = 'root';
$objref{class_name} = $item{CLASS_NAME};
$objref{object_name} = $item{OBJECT_NAME};
$return = \%objref;
}
| <error>
CRITERION: '(' ARGSTRING ARGSTRING ')'
{
my %nc = ();
$nc{type} = $item[2];
$nc{value} = $item[3];
$return = \%nc;
}
| <error>
XOL_PROTOCOL: { $semerr = ""; } <reject>
| ARGSTRING <commit>
{
if ($item{ARGSTRING} !~ /^[0-9]+\.[A-Za-z0-9-]+$/)
{
$semerr = "Protocol number has format: number.alphanumeric.";
$return = undef;
}
else
{ $return = $item{ARGSTRING}; };
}
| <error?:$semerr> <reject>
ARGSTRING: /"[^"]+"/ # Rules order sensitive ...
{ $item[1] =~ s/"//g; $return = $item[1]; }
| /'[^']+'/
{ $item[1] =~ s/'//g; $return = $item[1]; }
| /[^()\s]+/ # Token can't eat '(' or ')'
CLASS_NAME: /[_A-Za-z0-9-]+/
IF_NAME: /[_A-Za-z0-9-]+/
NODE_NAME: /[_A-Za-z0-9-]+/
LINK_NAME: /[_A-Za-z0-9-]+/
OBJECT_NAME: /[_A-Za-z0-9-.]+/
END_OF_FILE: /\Z/
GRAMMAR_RULES
##########################################################################
#
# Uncomment the following two lines to produce the executable API compiler
# which will be named XB_API_parser.pl.
#
##########################################################################
Parse::RecDescent->Precompile ($grammar, "XB_API_parser") or die "Bad grammar.\n";
exit (1);
my ($result, $message, $msgref);
$message =
#"( xbone 1.5 2.0
# ( discover_daemons_reply (auth_type x509) (creator_name missing)
# (creator_email finn\@isi.edu) (user_id finn\@isi.edu) ( node (class router)
# (dns_name b.postel.org) (ip_address 128.9.112.66) (os kame)
# (release 2.0-BETA) (dynamic_routing no) (authentication 'none, md5, sha1')
# (encryption 'none, des, 3des') (overlays 0) (max_overlays 1000)
# (tunnel_count 0) (max_tunnels 1000) )
#( node (class host) (dns_name tan.isi.edu) (ip_address 128.9.160.198)
# (os kame) (release 2.0-BETA) (dynamic_routing no)
# (authentication 'none, md5, sha1') (encryption 'none, des, 3des')
# (overlays 0) (max_overlays 100) (tunnel_count 0) (max_tunnels 1000) )
#)
#)
#
#"
#(xbone 1.5 2.0
# (credential
# (user_name 'Yu-Shun Wang')
# (user_email yushunwa\@isi.edu)
# (auth_type x509)
# )
# (create_overlay (search_radius 5)
# (xol 1.1
#
# (class TestLine
# (netprops (dns yes) (addresstype ipv4) (IPsec_encryption des)
# (IPsec_authentication md5)
# )
# (nodelist
# (node a
# (nodeprops (os freebsd) )
# (interfaces (interface right) )
# )
# (node b
# (nodeprops (os freebsd) )
# (interfaces (interface left) )
# )
# )
# (linklist
# (link link0)
# )
# (netlist (a.right link0 b.left) )
# (exportlist )
# )
#
# (root TestLine foobar)
# )
# )
# )
#";
"
(xbone 1.5 2.0
(credential
(user_name 'Yu-Shun Wang')
(user_email yushunwa\@isi.edu)
(auth_type x509)
)
(create_overlay (search_radius 5)
(xol 1.1
(class 3Line
(netprops )
(nodelist
(node a
(nodeprops )
(interfaces (interface left) (interface right) )
)
(node b
(nodeprops )
(interfaces (interface left) (interface right) )
)
(node c
(nodeprops )
(interfaces (interface left) (interface right) )
)
)
(linklist
(link link0)
(link link1)
)
(netlist (a.right link0 b.left) (b.right link1 c.left) )
(exportlist (a.left) (c.right) )
)
(class 3LineRing
(netprops )
(nodelist
(node X : 3Line
(nodeprops )
)
(node Y: 3Line
(nodeprops )
)
)
(linklist
(link link0)
(link link1)
)
(netlist (X.left link0 Y.right) (X.right link1 Y.left) )
(exportlist )
)
(root TestLine foobar)
)
)
)
";
$msgref = \$message;
#my (%args) =(());
#
# $args{auth_type} = 'X509';
# $args{user_name} = 'yushun';
# $args{user_email} = 'yushunwa\@isi.edu';
# $args{dns} = 'yes';
# $args{hosts} = 5;
# $args{host_os} = 'freebsd';
# $args{IPsec_authentication} = 'none';
# $args{IPsec_encryption} = 'none';
# $args{dynamic_routing} = 'no';
# $args{overlay_name} = 'test.xbone.net';
# $args{routers} = 1;
# $args{router_os} = 'linux';
# $args{search_radius} = 5;
# $args{topology} = 'star';
# $args{manager} = $XB_Defs::XBONE_OVERLAY_MANAGER;
# $args{manager_port} = undef;
# $args{name_server} = $XB_Defs::DNS_SERVER;
# $args{name_server_port} = undef;
# $args{address_server} = undef;
# $args{address_server_port} = undef;
# $args{net_applications} = undef;
#
# $msgref = XB_API_GUI::XB_build_create_overlay_msg (\%args);
my $parser = new Parse::RecDescent ($grammar) or die "Bad grammar.\n";
####################################
#print "$$msgref\n\n";
my $parse_errfile = "/tmp/stderr.RecDescent";
open (Parse::RecDescent::ERROR, ">$parse_errfile")
or die "Can't redirect parse errors to $parse_errfile";
$result = $parser->API($$msgref);
#$result = $parser->XOL_PROGRAM($$msgref);
#$result = $parser->NET_SERVICES("(services (manager www.xbone.net)
# (name_server dns1.xbone.net) )");
if (!defined ($result))
{
my ($opnok, $errstr);
$opnok = open ERRORS, "<$parse_errfile";
if ($opnok)
{
$errstr = "";
while (<ERRORS>)
{ $errstr .= $_; }
$errstr = XB_API_SUBS::XB_parse_error_messages ($errstr);
};
close ERRORS;
if ($errstr)
{
print "\n$errstr\n";
print "Bad program\n";
exit (1);
};
}
####################################
if (!defined ($result))
{
print "\nSYNTACTIC ERROR\n\n";
print "Bad program\n";
exit (1);
}
print "\n\nGOOD PROGRAM\n\n";
$result = Dumper(\$result);
print "$result\n\n";
1; # Insure TRUE return if module is interpreted.
syntax highlighted by Code2HTML, v. 0.9.1