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