# -*- 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_CTL_parser.pm,v $
#
# $Revision: 1.26 $
#   $Author: pingali $
#     $Date: 2005/03/31 07:03:53 $
#    $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Yu-Shun Wang
# Description:
#   This is the parser generator for the XBone Control Protocol messages.

package XB_CTL_parser;

require Exporter;
@ISA       = qw(Exporter);
@EXPORT    = qw();
@EXPORT_OK = qw(xb_ctl_grammar parser);

use strict;

#use Net::IP;
use Parse::RecDescent;
use Data::Dumper;
$Data::Dumper::Indent = 1;

# TODO Order of some fields should not matter, need to relax them.
# TODO some msgs need credential, some don't; have no way to check yet

#=> set it for standalone testing
$XB_CTL_parser::standalone = 0;

#=> debugging variables

$::RD_ERRORS = undef;       # undefined implies no error printing
$::RD_HINT   = 1;            # the next four decarations for debugging
$::RD_WARN   = 1;
#$::RD_TRACE = 1;

#=> define the grammar

#   TODO add (node $nodename) to all ACK-* messages, easier to debug!

$XB_CTL_parser::xb_ctl_grammar = <<'GRAMMAR_RULES';

  <autotree>

  xb_ctl     :

    '(' /(xbonecontrol|xbone-ctl)/ /\S+/ /\S+/ seq(?) credential(?) command ')'
    END_OF_CTL

    {
      my %ctl          = ();
      $ctl{version}    = $item[3];
      $ctl{release}    = $item[4];
      $ctl{sequence}   = $item[5];
      $ctl{credential} = $item[6];
      $ctl{command}    = $item{command};
      $return          = \%ctl;
    }

  seq        : /\d+/    { $return = $item[1]; }

  credential : '(' 'credential' username useremail authtype ')'
    {
      my %credential  = ();
      $credential{user_name}  = $item{username};
      $credential{user_email} = $item{useremail};
      $credential{auth_type}  = $item{authtype};
      $return                 = \%credential;
    }

  command    : simple_cmd   { $return = $item[1]; } |
               invite       { $return = $item[1]; } |
               ack_invite   { $return = $item[1]; } |
               select       { $return = $item[1]; } |
               dispatch     { $return = $item[1]; } |
               ack_dispatch { $return = $item[1]; } |
               config       { $return = $item[1]; } |
               ack_status   { $return = $item[1]; } |
               refresh      { $return = $item[1]; } |
               discover     { $return = $item[1]; } |
               ack_disc     { $return = $item[1]; } |
               addr_req     { $return = $item[1]; } |
               error        { $return = $item[1]; }

  simple_cmd   : '(' /(ack-(select|config|stop)|stop|status|release)/
                     app_type app_name level nodename(?) ')'
    {
      my %cmd            = ();
      $cmd{command}      = $item[2];
      $cmd{app_type}     = $item{app_type};
      $cmd{app_name}     = $item{app_name};
      $cmd{level}        = $item{level};
      $cmd{hostname}     = $item[6];
      if(@{$cmd{hostname}} == 1){
        $cmd{hostname} = $cmd{hostname}[0];
      }else{
        delete $cmd{hostname};
      }
      $return            = \%cmd;
    }

  invite     : '(' 'invite' app_type app_name app_vers level routing ipsec_opt
                    qos_opt addr_type node_req(3) app_deploy(s?) ')'
    {
      my %cmd            = ();
      $cmd{command}      = $item[2];
      $cmd{app_type}     = $item{app_type};
      $cmd{app_name}     = $item{app_name};
      $cmd{app_vers}     = $item{app_vers};
      $cmd{level}        = $item{level};
      $cmd{routing}      = $item{routing};
      $cmd{ipsec}        = $item{ipsec_opt};
      $cmd{qos}          = $item{qos_opt};
      $cmd{addr_type}    = $item{addr_type};
      my $nodes          = $item[11];
      for my $n (@{$nodes}){
        unless (exists $cmd{$n->{type}}){
          $cmd{$n->{type}}=$n;
          delete $cmd{$n->{type}}->{type};
        }else{
          #error die!
        }
      }
      for my $h (@{$item[12]}){
        while(my ($k, $v) = each %{$h}){
          $cmd{app_deploy}{$k} = $v;
        }
      }
      $return            = \%cmd;
    }

  ack_invite : '(' 'ack-invite' app_type app_name app_vers level nodetype
                    nodename addr_type ctl_addr app_addr any_pair(s)
                    app_deploy(s?) ')'
    {
      my %cmd            = ();
      $cmd{command}      = 'ack-invite';
      $cmd{app_type}     = $item{app_type};
      $cmd{app_name}     = $item{app_name};
      $cmd{app_vers}     = $item{app_vers};
      $cmd{level}        = $item{level};
      $cmd{node_type}    = $item{nodetype};
      $cmd{hostname}     = $item{nodename};
      $cmd{addr_type}    = $item{addr_type};
      $cmd{ctl_addr}     = $item{ctl_addr};
      $cmd{app_addr}     = $item{app_addr};
      my $arr            = $item[12];
      my ($k, $v);
      for my $h (@{$arr}){ while(($k, $v) = each %{$h}){ $cmd{$k} = $v; }}
      for my $h (@{$item[13]}){
        while(my ($k, $v) = each %{$h}){
          $cmd{app_deploy}{$k} = $v;
        }
      }

      $return            = \%cmd;
    }

  select     : '(' 'select' app_type app_name level connection nodetype(?) ')'
    {
      my %cmd            = ();
      $cmd{command}      = 'select';
      $cmd{app_type}     = $item{app_type};
      $cmd{app_name}     = $item{app_name};
      $cmd{level}        = $item{level};
      $cmd{persistent_connection} = $item{connection};
      $cmd{node_type}    = $item[7];
      $return            = \%cmd;
    }

  dispatch   : '(' 'dispatch' app_type app_name app_vers level retry
                   connection app_cmd ')'
    {
      my %cmd            = ();
      $cmd{command}      = $item[2];
      $cmd{app_type}     = $item{app_type};
      $cmd{app_name}     = $item{app_name};
      $cmd{app_vers}     = $item{app_vers};
      $cmd{level}        = $item{level};
      $cmd{retry}        = $item{retry};
      $cmd{application}  = $item{app_cmd};
      $return            = \%cmd;
    }

  ack_dispatch : '(' 'ack-dispatch' app_type app_name level addr_range(s?) 
                     exp_iface(s?) ')'
    {
      my %cmd            = ();
      $cmd{command}      = 'ack-dispatch';
      $cmd{app_type}     = $item{app_type};
      $cmd{app_name}     = $item{app_name};
      $cmd{level}        = $item{level};
      $cmd{addr_range}   = $item[6];
      my $export_ifs     = $item[7];
      for my $i (@{$export_ifs}){
        while (my ($k, $v) = each %{$i}){ $cmd{export_ifs}{$k} = $v; }
      }
      $return            = \%cmd;
    }

  config     : '(' 'config' app_type app_name app_vers level node_cmds(s) ')'
    {
      my %cmd            = ();
      $cmd{command}      = $item[2];
      $cmd{app_type}     = $item{app_type};
      $cmd{app_name}     = $item{app_name};
      $cmd{app_vers}     = $item{app_vers};
      $cmd{level}        = $item{level};
      my (%ncmds, $k, $v);
      my $ncmd_array     = $item[7];
      for my $n (@{$ncmd_array}){
        while (($k, $v) = each %{$n}){ $ncmds{$k} = $v; }
      }
      $cmd{node_cmds}    = \%ncmds;
      $return            = \%cmd;
    }

  ack_status : '(' 'ack-status' app_type app_name level nodename node_state(s)
               ')'
    {
      my %cmd            = ();
      $cmd{command}      = $item[2];
      $cmd{app_type}     = $item{app_type};
      $cmd{app_name}     = $item{app_name};
      $cmd{level}        = $item{level};
      my (%ncmds, $k, $v);
      my $ncmd_array     = $item[7];
      for my $n (@{$ncmd_array}){
        while (($k, $v) = each %{$n}){ $ncmds{$k} = $v; }
      }
      $cmd{vnodes}       = \%ncmds;
      $return            = \%cmd;
    }


  error      : '(' 'error' command app_type app_name level msg ')'
    {
      my %cmd;
      $cmd{command}  = 'error';
      $cmd{err_cmd}  = $item{command};
      $cmd{app_type} = $item{app_type};
      $cmd{app_name} = $item{app_name};
      $cmd{level}    = $item{level};
      $cmd{message}  = $item{msg};
      $return        = \%cmd;
    }

  refresh    : '(' 'refresh' any_pair(s) ')'
    {
      my %cmd;
      $cmd{command} = 'refresh';
      $cmd{applist} = $item[3];
      $return       = \%cmd;
    }

  discover   : '(' 'discover' ')'
    { my %cmd = ('command'=>'discover'); $return = \%cmd; }

  ack_disc   : '(' 'ack-discover' any_pair(s) ')'
    {
      my %cmd            = ();
      $cmd{command}      = 'ack-discover';
      my $arr            = $item[3];
      my ($k, $v);
      for my $h (@{$arr}){ while(($k, $v) = each %{$h}){ $cmd{$k} = $v; }}
      $return            = \%cmd;
    }

  addr_req   : '(' /address_(request|reply|release)/ app_type app_name 
                   level nodename addr_blk(s) ')'
    {
      my %cmd;
      $cmd{command}  = $item[2];
      $cmd{app_type} = $item{app_type};
      $cmd{app_name} = $item{app_name};
      $cmd{level}    = $item{level};
      $cmd{hostname} = $item{nodename};
      my $addr_blks  = $item[7];
      for my $a (@{$addr_blks}){
        for my $k (keys %{$a}){
          $cmd{blocks}{$k} = $a->{$k};
        }
      }
      $return = \%cmd;
    }

  #- credential -------------------------------------------------------------

  username   : '(' 'user_name'  STRING ')'   { $return = $item[3]; }

  useremail  : '(' 'user_email' STRING ')'   { $return = $item[3]; }

  authtype   : '(' 'auth_type'  STRING ')'   { $return = $item[3]; }

  #- common -----------------------------------------------------------------

  addr_blk   : '(' 'addr-blk' STRING addr_type size(?) addr_range(?) ')'
    {
      my %cmd;
      my $name = $item[3];
      $cmd{$name}{addr_type} = $item{addr_type};
      my $size = $item[5];
      my $blk  = $item[6];
      if(defined $size && @{$size} == 1){
        $cmd{$name}{size} = shift @{$size};
      }
      if(defined $blk && @{$blk} == 1){
        $cmd{$name}{block} = shift @{$blk};
      }
      $return = \%cmd;
    }

  addr_pair  : '(' /(netaddr|linkaddr|physical)/ ip_addr ip_addr netmask(?)
                   ipsec(?) qos(?) ')'
    {
      my %addrpair;
      my $type = $item[2];
      $addrpair{$type}{local}   = $item[3];
      $addrpair{$type}{remote}  = $item[4];
      #$addrpair{$type}{netmask} = $item[5];
      if(@{$item[5]} == 1){
        if(${$item[5]}[0] =~ /(up|down)/i){
          $addrpair{$type}{status} = ${$item[5]}[0];
        }else{
          $addrpair{$type}{netmask} = ${$item[5]}[0];
        }
      }
      $addrpair{$type}{ipsec}   = $item[6];
      if(@{$addrpair{$type}{ipsec}} > 0){
        $addrpair{$type}{ipsec} = $addrpair{$type}{ipsec}[0];
      }else{
        delete $addrpair{$type}{ipsec};
      }

      $addrpair{$type}{qos}   = $item[7];
      if(@{$addrpair{$type}{qos}} > 0){
        $addrpair{$type}{qos} = $addrpair{$type}{qos}[0];
      }else{
        delete $addrpair{$type}{qos};
      }

      my $return = \%addrpair;
    }

  addr_range : '(' 'addr_range' STRING ')'   { $return = $item[3]; }

  addr_type  : '(' 'addr_type'  STRING ')'   { $return = $item[3]; }

  any_pair   : '(' STRING STRING ')'
    {
      my %cmd;
      $cmd{$item[2]} = $item[3];
      $return        = \%cmd;
    }

  app_addr   : '(' 'app_addr'   ip_addr ')'  { $return = $item[3]; }

  app_cmd    : STRING                        { $return = $item[1]; }

  app_deploy : '(' 'app-deploy' app_name any_pair(s?) ')'
    {
      my %cmd;
      my $name = $item{app_name};
      for my $h (@{$item[4]}){
        while(my ($k, $v) = each %{$h}){
          if($k =~ /\b(url|chksum|suid|app_verify|action)\b/){
            $cmd{$name}{$k} = $v;
          }else{
            die 'parser';
          }
        }
      }
      $return = \%cmd;
    }

  app_name   : '(' 'name' STRING ')'         { $return = $item[3]; }

  app_type   : '(' /app(lication|)/ STRING ')' {$return= $item[3]; }

  app_vers   : '(' 'version' STRING ')'      { $return = $item[3]; }

  attr_list  : '(' attributes  STRING(s) ')'
    {
      my %cmd;
      $cmd{$item[2]} = $item[3];
      $return = \%cmd;
    }

  attributes : /((all_|)(virtual|base)_(ip|hostname)|domain|prefix|om|api)/
    { $return = $item[1]; }

  command    : '(' 'command' STRING ')'      { $return = $item[3]; }

  ctl_addr   : '(' 'ctl_addr' ip_addr ')'    { $return = $item[3]; }

  exp_iface  : '(' 'export_if' STRING STRING STRING ')'
    {
      my %h            = ();
      my $i            = $item[3];
      $h{$i}{hostname} = $item[4];
      $h{$i}{phy_ip}   = $item[5];
      $return          = \%h;
    }

  ipsec      : '(' /ipsec/i STRING ipsec_dir(2) ')'
    {
      my %ipsec;
      $ipsec{spi} = $item[3];
      for my $d (@{$item[4]}){
        my ($k, $v) = each %{$d};
        $ipsec{$k} = $v;
      }
      $return         = \%ipsec;
    }

  ipsec_key  : '(' /(auth|encr)/i STRING STRING ')'
    {
      my %key;
      $key{type} = $item[2];
      $key{alg}  = $item[3];
      $key{key}  = $item[4];
      $return    = \%key;
    }

  ipsec_dir  : '(' /(forward|reverse)/i ipsec_key(..2) ')'
    {
      my %key;
      my $dir = $item[2];
      my $arr = $item[3];
      for my $k (@{$arr}){
        $key{$dir}{$k->{type}}{alg} = $k->{alg};
        $key{$dir}{$k->{type}}{key} = $k->{key};
      }
      $return         = \%key;
    }

  ipsec_opt  : '(' /ipsec/i /(yes|no)/i ')'  { $return = $item[3]; }

  qos      : '(' /qos/i qos_args(..4) ')'
    {
      my %qos;
      for my $key (@{$item[3]}){
        $qos{$key->{name}}{value} = $key->{value};
        if (defined $key->{unit}){
          $qos{$key->{name}}{unit} = $key->{unit};
        } else {
          $qos{$key->{name}}{unit} = "";
        }
      }
      $return         = \%qos;
    }

  qos_args  : '(' /(delay|bandwidth|queue|loss_rate)/i STRING STRING(?) ')'
    {
      my %key;
      $key{name} = $item[2];
      $key{value}  = $item[3];
      $key{unit}  = ${$item[4]}[0];
      $return    = \%key;
    }

  level      : '(' 'level' /\d+/ ')'         { $return = $item[3]; }

  link_cmd   : '(' STRING tag addr_pair addr_pair addr_pair ')'
    {
      my %link;
      my $name = $item[2];
      my ($h1, $h2, $h3) = ($item[4], $item[5], $item[6]);
      for my $h ($h1, $h2, $h3){
        while(my ($k, $v) = each %{$h}){ $link{$name}{$k} = $v; }
      }
      $link{$name}{interface} = $item[3];
      $link{$name}{link_up}   = 0;
      $link{$name}{net_up}    = 0;
      $return                 = \%link;
    }

  link_sec   : '(' 'link' link_cmd(s) ')'
    {
      my $link_array = $item[3];
      my %cmd;
      my ($k, $v);
      for my $l (@{$link_array}){
        while(($k, $v) = each %{$l}){ $cmd{$k} = $v; }
      }
      $return = \%cmd;
    }

  msg        : '(' 'message' STRING ')'      { $return = $item[3]; }

  node_cmds  : '(' 'nodecommand' STRING addr_type link_sec route_sec
                   app_deploy(s?) ovl_params(?) ')'
    {
      my %cmd               = ();
      my $vnode             = $item[3];
      $cmd{$vnode}{ipproto} = $item[4];
      $cmd{$vnode}{links}   = $item[5];
      $cmd{$vnode}{routes}  = $item[6];
      for my $h (@{$item[7]}){
        while(my ($k, $v) = each %{$h}){
          $cmd{$vnode}{app_deploy}{$k} = $v;
        }
      }
      for my $o (@{$item[8]}){ $cmd{$vnode}{ovl_params} = $o; }
      $return               = \%cmd;
    }

  node_req   : '(' /(host|router|meta)/ /\d+/ STRING ')'
    {
      my %node        = ();
      $node{type}     = $item[2];
      $node{count}    = $item[3];
      my @os          = split /\|/, lc($item[4]);
      $node{platform} = \@os;
      $return         = \%node;
    }

  node_state : '(' 'vnode' STRING link_sec ')'
    {
      my %cmd;
      $cmd{$item[3]} = $item[4];
      $return = \%cmd;
    }

  nodename   : '(' 'hostname' STRING ')'     { $return = $item[3]; }

  nodetype   : '(' 'type' /(host|router|node|both|meta)/i ')'
    { $return = $item[3]; }

  ovl_params : '('  'ovl-parameters' attr_list(s) ')'
    {
      my %cmd;
      for my $h (@{$item[3]}){
        for my $k (keys %{$h}){
          $cmd{$k} = $h->{$k};
        }
      }
      $return = \%cmd;
    }

  retry      : '('  'retry' /\d+/ ')'        { $return = $item[3]; }

  route_cmd  : '(' /(host|net)/ ip_addr ip_addr netmask(?) ')'
    {
      my %rt;
      $rt{type} = $item[2];
      $rt{dst}  = $item[3];
      $rt{gw}   = $item[4];
      $rt{mask} = $item[5];
      $rt{up}   = 0;
      $return   = \%rt;
    }

  route_sec  : '(' 'route' /(static|dynamic)/ route_cmd(s?) addr_range(s?) ')'
    {
      my %rt;
      $rt{style}       = $item[3];
      $rt{routes}      = $item[4];
      $rt{prefixes} = $item[5];
      $return          = \%rt;
    }

  routing    : '(' 'routing' /(dynamic|static|1|0|yes|no)/i ')' 
    { $return = $item[3]; }

  prop       : '(' /(routing|IPsec|qos_opt|dns|NODEOS|os_vers|kern_vers)/
                   STRING ')'
    {
      my %cmd;
      $cmd{$item[2]} = $item[3];
      $return = \%cmd;
    }

  size       : '(' 'size' /\d+/ ')'          { $return = $item[3]; }

  tag        : '(' 'interface' STRING ')'    { $return = $item[3]; }

  # =====================================================================

  qos_opt        : '(' 'qos'    /(yes|no|1|0)/i ')' { $return = $item[3]; }

  connection : '(' 'persistent_connection' /(yes|no)/i ')'
    { $return = $item[3]; }

  ip_addr    : STRING # TODO match/check both IPv4 and IPv6 address formats
    { $return = $item[1]; }

  netmask    : # TODO should match to netmask format for IPv4 and IPv6
    STRING      { $return = $item[1]; }

  STRING     : # a more general definition than /\S+/
    /"[^"]+"/  { $item[1] =~ s/"//g;  $return = $item[1]; } |
    /'[^']+'/  { $item[1] =~ s/'//g;  $return = $item[1]; } |
    /[^()\s]+/ { $return  = $item[1]; }

  END_OF_CTL: /\Z/ { $return = $item[1]; }

GRAMMAR_RULES

#=> create a parser file

#Parse::RecDescent->Precompile ($XB_CTL_parser::xb_ctl_grammar,
#  "XB_CTL_parser") or die "Bad grammar.";
#exit (1);

#=> create a parser object

$XB_CTL_parser::parser = new Parse::RecDescent($XB_CTL_parser::xb_ctl_grammar);

if($XB_CTL_parser::standalone){

  my $ctl_parser = new Parse::RecDescent ($XB_CTL_parser::xb_ctl_grammar)
    or die "Bad grammar";

  #print ">>>> parser: >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n";
  #print Dumper($parser);
  #print "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n";

  my ($result, $invite, $ack_invite, $select, $ack_select, $release);
  my ($stop, $ack_stop, $dispatch, $ack_dispatch, $config, $ack_config);
  my ($err_msg, $status, $refresh, $ack_status, $discover, $ack_discover);
  my ($new_err, $addr_req, $addr_rep, $addr_rel);

  my $current = time;

  $invite = 
    "(xbone-ctl 1.5 2.3 $current\n".
    "  (credential (user_name 'Yu-Shun Wang')\n".
    "              (user_email yushunwa\@isi.edu)\n".
    "              (auth_type  x509))\n".
    "  (invite     (application overlay)\n".
    "              (name        touch.overlay.xbone)\n".
    "              (version     1.5)\n".
    "              (level       0)\n".
    "              (routing     dynamic)\n".
    "              (IPsec       yes)\n".
    "              (qos         no)\n".
    "              (addr_type   ipv4)\n".
    "              (host        25  FreeBSD|Solaris)\n".
    "              (router      30  MacOSX)\n".
    "              (meta        5   any)\n".
    "              (app-deploy\n".
    "                (name  test-app)\n".
    "                (url http://www.isi.edu/xbone/script/test-app)\n".
    "                (chksum f513efde682155380cca2b09976aa65b)\n".
    "                (suid   root))\n".
    "              (app-deploy\n".
    "                (name  app2)\n".
    "                (url http://www.isi.edu/test-app2))\n".
    "  )\n".
    ")";

  $ack_invite =
    "(xbone-ctl 1.5 2.5 $current\n".
    "  (ack-invite\n".
    "    (app       overlay)\n".
    "    (name      line.overlay.net)\n".
    "    (version   1.6)\n".
    "    (level     0)\n".
    "    (type      meta)\n".
    "    (hostname  add.isi.edu)\n".
    "    (addr_type ipv6)\n".
    "    (ctl_addr  128.9.160.213)\n".
    "    (app_addr  128.9.160.222)\n".
    "    (os        FreeBSD)\n".
    "    (kernel    500001)\n".
    "    (os_ver    5.1-current)\n".
    "    (app-deploy (name test-app)\n".
    "                (app_verify ok))\n".
    "  )\n".
    ")\n";

  $select = "
  (xbonecontrol 1.5 2.5
    (select     (application overlay)
                (name        bigO.xbone.overlay)
                (level 3)(persistent_connection yes)))";

  $ack_select =
    "(xbone-ctl 1.5 2.5\n".
    "  (ack-select\n".
    "    (application overlay)\n".
    "    (name  small.overlay.net)\n".
    "    (level 0)\n".
    "  )\n".
    ")";

  $release = "
  (xbonecontrol 1.5 2.5
    (release    (application overlay)
                (name        big.overlay.network)
                (level 2)))";

  $stop = "
  (xbonecontrol 1.5 2.5
    (stop       (application overlay)
                (name        big.overlay.network)
                (level 2)))";

  $ack_stop = "
  (xbone-ctl 1.5 2.5
    (ack-stop   (application overlay)
                (name small.overlay.net)(level 0)
                (hostname tnn.yahoo.com)
    )
  )";


  $dispatch = "
  (xbonecontrol 1.5 2.3 $current
    (credential (user_name 'Yu-Shun Wang')
                (user_email yushunwa\@isi.edu)
                (auth_type  x509))
    (dispatch   (application overlay)
                (name        touch.overlay.xbone)
                (version     1.5)
                (level       0)
                (retry       3)
      \"(create_overlay  (search_radius 5)
        (xol 1.4
          (class star
            (netprops  (IPsec_authentication  none) (dns  yes)
                       (dynamic_routing  no) (IPsec_encryption  none)
                       (addr_type  ipv4)  )
            (nodelist (node host_0
                        (nodeprops (os  freebsd|kame) )
                        (interfaces (interface if_0) )
                      )
                      (node host_1
                        (nodeprops (os  freebsd|kame) )
                        (interfaces (interface if_0) )
                      )
                      (node router_0
                        (nodeprops (os  linux|kame) )
                        (interfaces (interface if_0) (interface if_1) )
                      ) )
            (linklist (link link_0) (link link_1) )
            (netlist  (host_0.if_0 link_0 router_0.if_0)
                      (host_1.if_0 link_1 router_0.if_1) )
            (exportlist )
          )
          (root star test.xbone.net)
        )
      )\"
    )
  )";

  $ack_dispatch = "
  (xbonecontrol 1.5 2.5
    (ack-dispatch (application overlay)(name small.overlay.net)(level 0)
                  (addr_range 10.194.0.0/24)
                  (addr_range 10.185.0.0/24)
                  (export_if    someif1  amc.isi.edu 128.9.160.170)
                  (export_if    someif2  ifc.isi.edu 128.9.160.180)
                  (export_if    someif3  rfc.isi.edu 128.9.111.222)
                  ))";

  $config =
    "(xbone-ctl 1.5 2.3\n".
    "  (credential\n".
    "    (user_name 'Yu-Shun Wang')\n".
    "    (user_email yushunwa\@isi.edu)\n".
    "    (auth_type  x509))\n".
    "  (config\n".
    "    (application overlay)\n".
    "    (name        touch.overlay.xbone)\n".
    "    (version     1.5)\n".
    "    (level       0)\n".
    "    (nodecommand vnode1\n".
    "      (addr_type ipv6)\n".
    "      (link\n".
    "        (rlink_1\n".
    "          (interface if1)\n".
    "          (netaddr 10.1.2.38 10.1.2.37 255.255.255.252)\n".
    "          (linkaddr 10.7.2.38 10.7.2.37 255.255.255.252)\n".
    "          (physical router_2 router_1))\n".
    "        (rlink_2\n".
    "          (interface if2)\n".
    "          (netaddr 10.1.2.2 10.1.2.1 255.255.255.252)\n".
    "          (linkaddr 10.7.2.2 10.7.2.1 255.255.255.252\n".
    "            (ipsec 0x12204570498\n".
    "              (forward (auth md5  0x1122334455)\n".
    "                       (encr 3des 0x2b2b9c3bd1))\n".
    "              (reverse (auth md5  0x1122334455)\n".
    "                       (encr 3des 0x2b2b9c3bd1)))\n".
    "            (qos\n".
    "              (delay 100)\n".
    "              (bandwidth 10 Kbit/s)\n".
    "              (queue 21 slots)\n".
    "              (loss_rate 0.3)\n".
    "            )\n".
    "          )\n".
    "          (physical router_2 router_3))\n".
    "      )\n".
    "      (route dynamic\n".
    "        (addr_range 10.194.0.0/24)\n".
    "        (addr_range 10.185.0.0/24)\n".
    "      )\n".
    "      (app-deploy\n".
    "        (name app-test1)\n".
    "        (action start))\n".
    "      (app-deploy\n".
    "        (name app-test2)\n".
    "        (action install))\n".
    "      (ovl-parameters\n".
    "        (virtual_ip 10.2.3.4 10.5.6.7)\n".
    "        (base_ip 128.9.160.102)\n".
    "        (virtual_hostname tnn.line.ovl.net)\n".
    "        (base_hostname tnn.isi.edu)\n".
    "        (all_virtual_ip 10.1.1.1 10.2.2.2 10.3.3.3 10.4.4.4)\n".
    "        (all_base_ip 11.11.11.11 11.22.22.22 11.33.33.33 11.4.4.4)\n".
    "        (all_virtual_hostname a.ovl.net b.ovl.net c.ovl.net)\n".
    "        (all_base_hostname    tnn.isi.edu amc.usc.edu nik.yahoo.com)\n".
    "        (domain line.ovl.net)\n".
    "        (prefix 10.2.3.0/24 10.3.3.0/24 fec3:1::0/32 fec4:2::0/32/)\n".
    "        (om     128.9.168.57)\n".
    "        (api    2156)\n".
    "      )\n".
    "    )\n".
    "  )\n".
    ")";

  $ack_config =
    "(xbone-ctl 1.5 2.5\n".
    "  (ack-config\n".
    "    (application overlay)\n".
    "    (name        small.overlay.net)\n".
    "    (level       0)\n".
    "    (hostname    amc.yahoo.com)\n".
    "  )\n".
    ")";

  $err_msg = 
    "(xbone-ctl 1.5 2.5\n".
    "  (error\n".
    "    (command     config)\n".
    "    (application overlay)\n".
    "    (name        m1.xbone.net)\n".
    "    (level       0)\n".
    "    (message     \"bluh bluh < > ;alkdj;aldj\")\n".
    "  )\n".
    ")";

  $new_err = "
(xbone-ctl 1.9 2.9
  (error
    (command     stop)
    (application overlay)
    (name        m1.xbone.net)
    (level       0)
    (message     \"[tcp_ssl_sock] create ssl socket to add.isi.edu:5165 failed:\")  )
)
\n";

  $status =
    "(xbone-ctl 1.5 2.4\n".
    "  (status\n".
    "    (application overlay)\n".
    "    (name        small.overlay.net)\n".
    "    (level       0)\n".
    "  )\n".
    ")";

  $ack_status =
    "(xbone-ctl 1.5 2.3\n".
    "  (ack-status\n".
    "    (application overlay)\n".
    "    (name        touch.overlay.xbone)\n".
    "    (level       0)\n".
    "    (hostname    tnn.isi.edu)\n".
    "    (vnode host_0\n".
    "      (link\n".
    "        (rlink_1 (interface if1)\n".
    "          (netaddr  10.1.2.38   10.1.2.37   up)\n".
    "          (linkaddr 10.7.2.38   10.7.2.37   down)\n".
    "          (physical 128.9.160.1 128.9.160.2 up)\n".
    "        )\n".
    "        (rlink_2 (interface if2)\n".
    "          (netaddr  10.1.2.2  10.1.2.1  up)\n".
    "          (linkaddr 10.7.2.2  10.7.2.1  up)\n".
    "          (physical 198.2.3.4 112.3.4.5 down)\n".
    "        )\n".
    "      )\n".
    "    )\n".
    "  )\n".
    ")\n";

  $refresh =
    "(xbone-ctl 1.5 2.3.3\n".
    "  (refresh\n".
    "    (overlay test.xbone.overlay)\n".
    "    (overlay r1.line.xbone.net)\n".
    "    (peernet testpeernet)\n".
    "  )\n".
    ")";

  $discover =
    "(xbone-ctl 1.5 2.3.3\n".
    "  (credential (user_name 'Yu-Shun Wang')\n".
    "              (user_email yushunwa\@isi.edu)\n".
    "              (auth_type  x509)\n".
    "  )\n".
    "  (discover\n".
    "  )\n".
    ")";

  $ack_discover =
    "(xbone-ctl 1.5 2.5 $current\n".
    "  (ack-discover\n".
    "    (version   1.6)\n".
    "    (type      meta)\n".
    "    (hostname  add.isi.edu)\n".
    "    (addr_type ipv6)\n".
    "    (ctl_addr  128.9.160.213)\n".
    "    (app_addr  128.9.160.222)\n".
    "    (os        FreeBSD)\n".
    "    (kernel    500001)\n".
    "    (os_ver    5.1-current)\n".
    "    (routing   dynamic)\n".
    "    (IPsec     yes)\n".
    "    (qos       yes)\n".
    "    (dns       yes)\n".
    "  )\n".
    ")\n";

  $addr_req =
    "(xbone-ctl 1.5 2.5\n".
    "  (address_request\n".
    "    (application overlay)\n".
    "    (name        line.xb.ovl)\n".
    "    (level       2)\n".
    "    (hostname    add.isi.edu)\n".
    "    (addr-blk    ovl_link\n".
    "                 (addr_type ipv4)\n".
    "                 (size  28))\n".
    "    (addr-blk    ovl_net\n".
    "                 (addr_type ipv6)\n".
    "                 (size  28))\n".
    "  )\n".
    ")\n";

  $addr_rep =
    "(xbone-ctl 1.5 2.5\n".
    "  (address_reply\n".
    "    (application overlay)\n".
    "    (name        line.xb.ovl)\n".
    "    (level       2)\n".
    "    (hostname    add.isi.edu)\n".
    "    (addr-blk    ovl_link\n".
    "                 (addr_type ipv6)\n".
    "                 (addr_range 10.10.20.0/28))\n".
    "    (addr-blk    ovl_net\n".
    "                 (addr_type ipv4)\n".
    "                 (addr_range 10.10.20.0/28))\n".
    "  )\n".
    ")\n";

  $addr_rel =
    "(xbone-ctl 1.5 2.5\n".
    "  (address_release\n".
    "    (application overlay)\n".
    "    (name        line.xb.ovl)\n".
    "    (level       2)\n".
    "    (hostname    add.isi.edu)\n".
    "    (addr-blk    ovl_link\n".
    "                 (addr_type ipv4)\n".
    "                 (size  28))\n".
    "    (addr-blk    ovl_net\n".
    "                 (addr_type ipv6)\n".
    "                 (size  28))\n".
    "  )\n".
    ")\n";


  my $message = $config;

  print "================================================================\n";
  print "MSG>>> $message\n";
  print "================================================================\n";

  $result = $ctl_parser->xb_ctl($message);

  #$result = $parser->XOL_PROGRAM($$msgref);
  #$result = $parser->NET_SERVICES("(services  (manager www.xbone.net)
  #                                            (name_server rum.isi.edu) )");

  if (!defined ($result))
  {
      print "\nSYNTACTIC ERROR\n\n";
      print "Bad program\n";
      exit (1);
  }else{
      print "GOOD PROGRAM\n";
      $result = Dumper($result);
      print "$result\n\n";
  }
} # else done!

1;                            # Insure TRUE return if module is interpreted.