##
## Source for PICA objects file parser
## $Id: objects.yp,v 1.7.2.10 2002/06/04 23:02:43 cvs Exp $
##

##
## PICA Config File Grammar
##

## Perl Instaler and Configuration Agent (PICA)
## or
## PICA Is for C{ompetent,ompulsive,razy} Admins
##
##   Copyright (C) 2001,2002  Miguel Armas, Esteban Manchado
##
##   This program is free software; you can redistribute it and/or modify
##   it under the terms of the GNU General Public License as published by
##   the Free Software Foundation; either version 2 of the License, or
##   (at your option) any later version.
##
##   This program is distributed in the hope that it will be useful,
##   but WITHOUT ANY WARRANTY; without even the implied warranty of
##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##   GNU General Public License for more details.
##
##   You should have received a copy of the GNU General Public License
##   along with this program; if not, write to the Free Software
##   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA


%{
use Data::Dumper;
my %attributes;
my %alarmattributes;
my @currentgroup;
my (%vars, %groupvars);

use vars qw($objref $currentline);

*objref = *main::objref;
$currentline = 1;

my @objectattrs = ('uid', 'gid', 'perms', 'verbatim', 'path', 'source', 'priority');
%}

%%

config_file:   statements
      {
         return 'ok';
      }
   ;

statements:    statement
               | statements statement
   ;

statement:     defaults
               | object
               | group
   ;

defaults:      'defaults' '{' attributes '}'
      {
         $objref->{'defaults'} = { %attributes };
         %attributes = ();
      }
   ;

##
## File Object Definition
##
file:          'file' literal '{' attributes '}'
      {
         $attributes{'type'} = 'file';
         if (scalar @currentgroup) {
            push @{$currentgroup[0]}, $_[2];
            $attributes{'group'} = ${$currentgroup[0]}[0];
         }
         # Check if already exists!
         die "Duplicated object '$_[2]' in line ", $currentline, "\n"
               if exists $objref->{$_[2]};
         $objref->{$_[2]} = { %attributes };
         %attributes = ();
      }
   ;

##
## Alarm Object Definition
##
alarm:          'alarm' literal { unshift @currentgroup, [ ($_[2]) ]; }
                        '{' alarm_attributes '}'
      {
         $attributes{'type'} = 'alarm';
         # Add all the members to the 'members' attribute and delete the
         # temporary list
         $attributes{'members'} = [ @{$currentgroup[0]}[1 .. 
	                            $#{$currentgroup[0]}] ];
         shift @currentgroup;
         # Add ourselves to the current group, if any
         if (scalar @currentgroup) {
            push @{$currentgroup[0]}, $_[2];
            $attributes{'group'} = ${$currentgroup[0]}[0];
         }
         # Check if already exists!
         die "Duplicated alarm '$_[2]' in line ", $currentline, "\n"
               if exists $objref->{$_[2]};
         # Add the alarm entry to $objref
         $objref->{$_[2]} = { %attributes };
         %attributes = ();
      }
   ;


alarm_attributes: # Empty
                  | alarm_attributes attribute
                  | alarm_attributes vars_env
                  | alarm_attributes uses_env
   ;

uses_env:      'uses' '{'  { %alarmattributes = %attributes;
                             %attributes = (); }
                      deps { %attributes = %alarmattributes;
                             %alarmattributes = (); }
                      '}'
   ;

deps:          # Empty
               | deps file
   ;

##
## Group Object Definition
##
group:     'group' literal { unshift @currentgroup, [ ($_[2]) ]; }
                  '{' group_attributes '}'
      {
         $attributes{'vars'} = { %groupvars };
         $attributes{'type'} = 'group';
         # The group is ended. Store all the members (the second to last
         # elements, first is the group name) in the attribute 'members', and
         # delete the members list
         $attributes{'members'} = [ @{$currentgroup[0]}[1 .. 
	                            $#{$currentgroup[0]}] ];
         shift @currentgroup;
         # If there is any group out there, add ourselves to its member list
         if (scalar @currentgroup) {
            push @{$currentgroup[0]}, $_[2];
            $attributes{'group'} = ${$currentgroup[0]}[0];
         }
         # Check if already exists!
         die "Duplicated group '$_[2]' in line ", $currentline, "\n"
               if exists $objref->{$_[2]};
         # Add group entry to $objref
         $objref->{$_[2]} = { %attributes };
         %attributes = ();
         %groupvars = ();
      }
   ;

group_attributes:      # Empty
               | group_attributes object
	       | group_attributes attribute
               | group_attributes vars_env
      {
         %groupvars = %{ $attributes{'vars'} };
         delete $attributes{'vars'};
      }
   ;

object:          file
	       | alarm
   ;

attributes:    # Empty
               | attributes vars_env
               | attributes attribute
   ;

attribute:     WORD '=' literal ';'
      {
         grep /^$_[1]$/, @objectattrs or die "Unkown object property $_[1]\n";
         $attributes{$_[1]} = $_[3];
      }
   ;

vars_env:          'vars' '{' vars '}'
      {
         # print 'variables ', $_[1], "\n";
	 $attributes{'vars'} = { %vars };
	 %vars = ();
      }
   ;

vars: # Empty
      | vars var
   ;

var:  WORD '=' literal ';'
      {
         $vars{$_[1]} = $_[3];
      }
   ;

literal:       WORD
               | SQUOTED
               | DQUOTED
   ;

%%

use vars   qw($inputfile);

sub _Error {
        exists $_[0]->YYData->{ERRMSG}
    and do {
        print $_[0]->YYData->{ERRMSG};
        delete $_[0]->YYData->{ERRMSG};
        die;
    };
    print STDERR "Syntax error reading objects file at line ", $currentline, ": expecting ";
    # Expected tokens
    my @exptoks;
    foreach my $i ($_[0]->YYExpect) {
       push @exptoks, tokname($i);
    }
    if (scalar @exptoks > 1) {
       print STDERR "one of ", join (',', @exptoks), ", ";
    } else {
       print STDERR $exptoks[0], ', ';
    }
    # Found token
    print STDERR "found ", tokname($_[0]->YYCurtok), ".\n";
}

sub tokname {
   my $token = shift ;

   if ($token eq 'SQUOTED') {
      return 'single quote';
   } elsif ($token eq 'DQUOTED') {
      return 'double quote';
   } elsif ($token eq 'WORD') {
      return 'word';
   }

   return "'$token'";
}

sub _Lexer {
   my $parser = shift;

   if (! $parser->YYData->{INPUT}) {
      if ($inputfile) {
         open F, $inputfile or die "Can't open config file $inputfile";
         $inputfile = "";
      }

      $parser->YYData->{INPUT} or $parser->YYData->{INPUT} = join '', <F>
         or return ('', undef);
   }

   while ($parser->YYData->{INPUT} =~ /^[ \t\n]+/ or
		   $parser->YYData->{INPUT} =~ /^#.*/) {
	   $parser->YYData->{INPUT} =~ s/^(\n+)//;
	   $currentline += length ($1 or "");
	   $parser->YYData->{INPUT} =~ s/^[ \t]+//;
	   $parser->YYData->{INPUT} =~ s/^#.*//;
   }

   for ($parser->YYData->{INPUT}) {
      if (s:^((\w|/|\.|-)+)::) {
         ($1 eq 'defaults') and return ('defaults', 'defaults');
         ($1 eq 'file') and return ('file', 'file');
         ($1 eq 'alarm') and return ('alarm', 'alarm');
         ($1 eq 'group') and return ('group', 'group');
         ($1 eq 'vars') and return ('vars', 'vars');
         ($1 eq 'uses') and return ('uses', 'uses');
         return ('WORD', $1);
      }
      s/^"(([^"]|\\")*)"//
         and return ('DQUOTED', $1);
      s/^'(([^']|\\')*)'//
         and return ('SQUOTED', $1);
      s/^(.)//
         and return($1,$1);
   }
}

sub fillObjRef {
   my $self;
   ($self, $inputfile) = (shift, shift);

   return ($self->YYParse (yylex => \&_Lexer, yyerror => \&_Error))?1:0;
}