#============================================================= -*-Perl-*-
#
# Parser.yp
#
# DESCRIPTION
#   Definition of the parser grammar for the Template Toolkit language.
#
# AUTHOR
#   Andy Wardley <abw@wardley.org> 
#
# HISTORY
#   Totally re-written for version 2, based on Doug Steinwand's 
#   implementation which compiles templates to Perl code.  The generated
#   code is _considerably_ faster, more portable and easier to process.
#
# WARNINGS
#   Expect 1 reduce/reduce conflict.  This can safely be ignored.
#   Now also expect 1 shift/reduce conflict, created by adding a rule
#   to 'args' to allow assignments of the form 'foo.bar = baz'.  It
#   should be possible to fix the problem by rewriting some rules, but
#   I'm loathed to hack it up too much right now.  Maybe later.
#
# COPYRIGHT
#   Copyright (C) 1996-2004 Andy Wardley.  All Rights Reserved.
#   Copyright (C) 1998-2004 Canon Research Centre Europe Ltd.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
#------------------------------------------------------------------------
#
# NOTE: this module is constructed from the parser/Grammar.pm.skel
# file by running the parser/yc script.  You only need to do this if 
# you have modified the grammar in the parser/Parser.yp file and need
# to-recompile it.  See the README in the 'parser' directory for more
# information (sub-directory of the Template distribution).
#
#------------------------------------------------------------------------
#
# $Id: Parser.yp,v 2.20 2004/01/13 15:32:22 abw Exp $
#
#========================================================================

%right ASSIGN
%right '?' ':'
%left COMMA
%left AND OR
%left NOT
%left CAT
%left DOT
%left CMPOP
%left BINOP
%left '+'
%left '/'
%left DIV
%left MOD
%left TO 
%%

#--------------------------------------------------------------------------
# START AND TOP-LEVEL RULES
#--------------------------------------------------------------------------

template:   block		    { $factory->template($_[1])           }
;

block:	    chunks		    { $factory->block($_[1])              }
	|   /* NULL */		    { $factory->block()                   }
;

chunks:	    chunks chunk	    { push(@{$_[1]}, $_[2]) 
					if defined $_[2]; $_[1]           }
    |   chunk		    { defined $_[1] ? [ $_[1] ] : [ ]     }
;

chunk:  TEXT             { $factory->textblock($_[1])          }
    |   statement ';'    { return '' unless $_[1];
                           $_[0]->location() . $_[1];
                         }
;

statement:  directive
    |   defblock
	|   anonblock
	|   capture
	|   macro
	|   use       
	|   view       
	|   rawperl
	|   expr		    { $factory->get($_[1])                }
	|   META metadata 	    { $_[0]->add_metadata($_[2]);         }
	|   /* empty statement */
;

directive:  setlist		    { $factory->set($_[1])                }
	|   atomdir
	|   condition
	|   switch
	|   loop
	|   try
	|   perl
;


#--------------------------------------------------------------------------
# DIRECTIVE RULES
#--------------------------------------------------------------------------

atomexpr:   expr		    { $factory->get($_[1])                }
	|   atomdir
;

atomdir:    GET expr		    { $factory->get($_[2])                }
	|   CALL expr		    { $factory->call($_[2])               }
	|   SET setlist    	    { $factory->set($_[2])                }
	|   DEFAULT setlist         { $factory->default($_[2])            }
	|   INSERT nameargs         { $factory->insert($_[2])             }
	|   INCLUDE nameargs	    { $factory->include($_[2])            }
	|   PROCESS nameargs	    { $factory->process($_[2])            }
	|   THROW nameargs          { $factory->throw($_[2])              }
	|   RETURN		    { $factory->return()                  }
	|   STOP		    { $factory->stop()                    }
	|   CLEAR                   { "\$output = '';";                   }
	|   LAST                    { $_[0]->{ INFOR } || $_[0]->{ INWHILE }
                                        ? 'last LOOP;'
                                        : 'last;'                         }
	|   NEXT		    { $_[0]->{ INFOR }
					? $factory->next()
				        : ($_[0]->{ INWHILE }
                                           ? 'next LOOP;'
                                           : 'next;')                     }
	|   DEBUG nameargs          { if ($_[2]->[0]->[0] =~ /^'(on|off)'$/) {
				          $_[0]->{ DEBUG_DIRS } = ($1 eq 'on');
					  $factory->debug($_[2]);
				      }
				      else {
					  $_[0]->{ DEBUG_DIRS } ? $factory->debug($_[2]) : '';
				      }
				    }
        |   wrapper
	|   filter
;

condition:  IF expr ';' 
	      block else END	    { $factory->if(@_[2, 4, 5])           }
	|   atomexpr IF expr	    { $factory->if(@_[3, 1])              }
	|   UNLESS expr ';'
	      block else END	    { $factory->if("!($_[2])", @_[4, 5])  }
	|   atomexpr UNLESS expr    { $factory->if("!($_[3])", $_[1])     }
;

else:	    ELSIF expr ';' 
	      block else	    { unshift(@{$_[5]}, [ @_[2, 4] ]);
				      $_[5];                              }
	|   ELSE ';' block	    { [ $_[3] ]                           }
	|   /* NULL */              { [ undef ]                           }
;

switch:	    SWITCH expr ';' 
	      block case END	    { $factory->switch(@_[2, 5])          } 
;

case:	    CASE term ';' block
	      case		    { unshift(@{$_[5]}, [ @_[2, 4] ]); 
				      $_[5];                              }
	|   CASE DEFAULT ';' block  { [ $_[4] ]                           }
	|   CASE ';' block	    { [ $_[3] ]                           }
	|   /* NULL */		    { [ undef ]                           }
;

loop:	    FOR loopvar ';'         { $_[0]->{ INFOR }++                  }
		block END	    { $_[0]->{ INFOR }--;
				      $factory->foreach(@{$_[2]}, $_[5])  }
#loop:	    FOR loopvar ';'
#		block END	    { $factory->foreach(@{$_[2]}, $_[4])  }
	|   atomexpr FOR loopvar    { $factory->foreach(@{$_[3]}, $_[1])  }
	|   WHILE expr ';'          { $_[0]->{ INWHILE }++                }
	      block END		    { $_[0]->{ INWHILE }--;
                                      $factory->while(@_[2, 5])           }
	|   atomexpr WHILE expr	    { $factory->while(@_[3, 1])           }
;

loopvar:    IDENT ASSIGN term args  { [ @_[1, 3, 4] ]                     }
        |   IDENT IN term args      { [ @_[1, 3, 4] ]                     }
	|   term args               { [ 0, @_[1, 2] ]                     }
;

wrapper:    WRAPPER nameargs ';'
	      block END		    { $factory->wrapper(@_[2, 4])         }
	|   atomexpr 
	      WRAPPER nameargs	    { $factory->wrapper(@_[3, 1])         }
;

try:	    TRY ';' 
	      block final END	    { $factory->try(@_[3, 4])             }
;

final:	    CATCH filename ';'	
	      block final	    { unshift(@{$_[5]}, [ @_[2,4] ]);
				      $_[5];                              }
	|   CATCH DEFAULT ';'
	      block final	    { unshift(@{$_[5]}, [ undef, $_[4] ]);
				      $_[5];                              }
	|   CATCH ';'
	      block final	    { unshift(@{$_[4]}, [ undef, $_[3] ]);
				      $_[4];                              }
	|    FINAL ';' block	    { [ $_[3] ]                           }
	|   /* NULL */		    { [ 0 ] } # no final
;

use:	    USE lnameargs	    { $factory->use($_[2])                }
;

view:	    VIEW nameargs ';'	    { $_[0]->push_defblock();		  }
	      block END             { $factory->view(@_[2,5], 
						     $_[0]->pop_defblock) }
;

perl:	    PERL ';'                { ${$_[0]->{ INPERL }}++;             }
	      block END		    { ${$_[0]->{ INPERL }}--;
				      $_[0]->{ EVAL_PERL } 
				      ? $factory->perl($_[4])             
				      : $factory->no_perl();              }
;

rawperl:    RAWPERL                 { ${$_[0]->{ INPERL }}++; 
				      $rawstart = ${$_[0]->{'LINE'}};     }
	    ';' TEXT END	    { ${$_[0]->{ INPERL }}--;
				      $_[0]->{ EVAL_PERL } 
				      ? $factory->rawperl($_[4], $rawstart)
				      : $factory->no_perl();              }
;

filter:	    FILTER lnameargs ';' 
	      block END		    { $factory->filter(@_[2,4])           }
	|   atomexpr FILTER 
	      lnameargs		    { $factory->filter(@_[3,1])           }
;

defblock: defblockname 
          blockargs ';' 
          template END		    { my $name = join('/', @{ $_[0]->{ DEFBLOCKS } });
				      pop(@{ $_[0]->{ DEFBLOCKS } });
				      $_[0]->define_block($name, $_[4]); 
				      undef
				    }
;

defblockname: BLOCK blockname       { push(@{ $_[0]->{ DEFBLOCKS } }, $_[2]);
				      $_[2];
				    }
;

blockname:  filename 
        |   LITERAL		    { $_[1] =~ s/^'(.*)'$/$1/; $_[1]      }
;

blockargs:  metadata 
	|   /* NULL */
;

anonblock:  BLOCK blockargs ';' block END	    
				    { local $" = ', ';
				      print STDERR "experimental block args: [@{ $_[2] }]\n"
					  if $_[2];
				      $factory->anon_block($_[4])         }
;

capture:    ident ASSIGN mdir	    { $factory->capture(@_[1, 3])         }
;

macro:      MACRO IDENT '(' margs ')'
		mdir                { $factory->macro(@_[2, 6, 4])        }
	|   MACRO IDENT mdir        { $factory->macro(@_[2, 3])           }
;

mdir:	    directive
	|   BLOCK ';' block END	    { $_[3]                               }
;

margs:	    margs IDENT		    { push(@{$_[1]}, $_[2]); $_[1]        }
	|   margs COMMA             { $_[1]                               }
	|   IDENT                   { [ $_[1] ]                           }
;

metadata:   metadata meta	    { push(@{$_[1]}, @{$_[2]}); $_[1]     }
	|   metadata COMMA
	|   meta
;

meta:	    IDENT ASSIGN LITERAL       { for ($_[3]) { s/^'//; s/'$//; 
						       s/\\'/'/g  }; 
					 [ @_[1,3] ] }
	|   IDENT ASSIGN '"' TEXT '"'  { [ @_[1,4] ] } 
	|   IDENT ASSIGN NUMBER        { [ @_[1,3] ] }
;


#--------------------------------------------------------------------------
# FUNDAMENTAL ELEMENT RULES
#--------------------------------------------------------------------------

term:	    lterm
	|   sterm
;

lterm:	    '[' list  ']'	    { "[ $_[2] ]"                         }
	|   '[' range ']'           { "[ $_[2] ]"                         }
	|   '['       ']'           { "[ ]"                               }
	|   '{' hash  '}'	    { "{ $_[2]  }"                        }
;

sterm:	    ident		    { $factory->ident($_[1])              }
	|   REF ident               { $factory->identref($_[2])           }
	|   '"' quoted '"'	    { $factory->quoted($_[2])             }
	|   LITERAL
	|   NUMBER
;

list:	    list term		    { "$_[1], $_[2]"                      }
	|   list COMMA
	|   term
;

range:	    sterm TO sterm	    { $_[1] . '..' . $_[3]                }
;


hash:	    params
	|   /* NULL */		    { "" }
;

params:	    params param	    { "$_[1], $_[2]"                      }
	|   params COMMA
	|   param
;

param:      LITERAL ASSIGN expr     { "$_[1] => $_[3]"                    }
        |   item ASSIGN expr        { "$_[1] => $_[3]"                    }
;

ident:      ident DOT node	    { push(@{$_[1]}, @{$_[3]}); $_[1]     }
	|   ident DOT NUMBER	    { push(@{$_[1]}, 
					   map {($_, 0)} split(/\./, $_[3]));
				      $_[1];			          }
	|   node     
;

node:	    item		    { [ $_[1], 0 ]                        }
	|   item '(' args ')'	    { [ $_[1], $factory->args($_[3]) ]    }
;

item:	    IDENT		    { "'$_[1]'"                           }
	|   '${' sterm '}'	    { $_[2]                               }
	|   '$' IDENT		    { $_[0]->{ V1DOLLAR }
				       ? "'$_[2]'" 
				       : $factory->ident(["'$_[2]'", 0])  }
;

expr:	    expr BINOP expr	    { "$_[1] $_[2] $_[3]"                 }
	|   expr '/' expr	    { "$_[1] $_[2] $_[3]"                 }
	|   expr '+' expr	    { "$_[1] $_[2] $_[3]"                 }
	|   expr DIV expr	    { "int($_[1] / $_[3])"                }
	|   expr MOD expr	    { "$_[1] % $_[3]"                     }
	|   expr CMPOP expr	    { "$_[1] $CMPOP{ $_[2] } $_[3]"       }
	|   expr CAT expr	    { "$_[1]  . $_[3]"                    }
	|   expr AND expr	    { "$_[1] && $_[3]"                    }
	|   expr OR expr	    { "$_[1] || $_[3]"                    }
	|   NOT expr		    { "! $_[2]"                           }
	|   expr '?' expr ':' expr  { "$_[1] ? $_[3] : $_[5]"             }
	|   '(' assign ')'	    { $factory->assign(@{$_[2]})          }
	|   '(' expr ')'	    { "($_[2])"                           }
	|   term		
;

setlist:    setlist assign	    { push(@{$_[1]}, @{$_[2]}); $_[1]     }
	|   setlist COMMA
	|   assign
;


assign:	    ident ASSIGN expr	    { [ $_[1], $_[3] ]                    }
	|   LITERAL ASSIGN expr	    { [ @_[1,3] ]                         }
;

# The 'args' production constructs a list of named and positional 
# parameters.  Named parameters are stored in a list in element 0 
# of the args list.  Remaining elements contain positional parameters

args:	    args term		    { push(@{$_[1]}, $_[2]); $_[1]        }
	|   args param              { push(@{$_[1]->[0]}, $_[2]); $_[1]   }
	|   args ident ASSIGN expr  { push(@{$_[1]->[0]}, "'', " . 
				      $factory->assign(@_[2,4])); $_[1]  }
	|   args COMMA		    { $_[1]                               }
	|   /* init */		    { [ [ ] ]                             }
;


# These are special case parameters used by INCLUDE, PROCESS, etc., which 
# interpret barewords as quoted strings rather than variable identifiers;
# a leading '$' is used to explicitly specify a variable.  It permits '/',
# '.' and '::' characters, allowing it to be used to specify filenames, etc.
# without requiring quoting.

lnameargs:  lvalue ASSIGN nameargs  { push(@{$_[3]}, $_[1]); $_[3]        }
	|   nameargs
;

lvalue:	    item
	|   '"' quoted '"'	    { $factory->quoted($_[2])             }
	|   LITERAL
;

nameargs:   '$' ident args	    { [ [$factory->ident($_[2])], $_[3] ]   }
	|   names args		    { [ @_[1,2] ] }
	|   names '(' args ')'	    { [ @_[1,3] ] }
;

names:	    names '+' name	    { push(@{$_[1]}, $_[3]); $_[1] }
	|   name		    { [ $_[1] ]                    }
;

name:       '"' quoted '"'	    { $factory->quoted($_[2])  }
	|   filename 	            { "'$_[1]'" }
	|    LITERAL
;

#nameargs:   literal args	    { [ @_[1,2] ] }
#	|   literal '(' args ')'    { [ @_[1,3] ] }
#	|   '$' ident
#;

#namesargs:  names args		    { [ @_[1,2] ] }
#;

filename:   filename DOT filepart   { "$_[1].$_[3]" }
	|   filepart
;

filepart: FILENAME | IDENT | NUMBER 
;


# The 'quoted' production builds a list of 'quotable' items that might
# appear in a quoted string, namely text and identifiers.  The lexer
# adds an explicit ';' after each directive it finds to help the
# parser identify directive/text boundaries; we're not interested in
# them here so we can simply accept and ignore by returning undef

quoted:	    quoted quotable	    { push(@{$_[1]}, $_[2]) 
				          if defined $_[2]; $_[1]         }
	|   /* NULL */		    { [ ]                                 }
;

quotable:   ident		    { $factory->ident($_[1])              }
	|   TEXT		    { $factory->text($_[1])               }
	|   ';'		            { undef                               }
;


%%



