#============================================================= -*-Perl-*-
#
# Template::Parser
#
# DESCRIPTION
#   This module implements a LALR(1) parser and assocated support 
#   methods to parse template documents into the appropriate "compiled"
#   format.  Much of the parser DFA code (see _parse() method) is based 
#   on Francois Desarmenien's Parse::Yapp module.  Kudos to him.
# 
# AUTHOR
#   Andy Wardley <abw@wardley.org>
#
# COPYRIGHT
#   Copyright (C) 1996-2007 Andy Wardley.  All Rights Reserved.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
#   The following copyright notice appears in the Parse::Yapp 
#   documentation.  
#
#      The Parse::Yapp module and its related modules and shell
#      scripts are copyright (c) 1998 Francois Desarmenien,
#      France. All rights reserved.
#
#      You may use and distribute them under the terms of either
#      the GNU General Public License or the Artistic License, as
#      specified in the Perl README file.
# 
#============================================================================
package Template::Parser;use strict;use warnings;use base 'Template::Base';use Template::Constants qw(:status :chomp);use Template::Directive;use Template::Grammar;use constant CONTINUE=>0;use constant ACCEPT=>1;use constant ERROR=>2;use constant ABORT=>3;our$VERSION=2.89;our$DEBUG=0 unless defined$DEBUG;our$ERROR='';our$TAG_STYLE={'default'=>['\[%','%\]'],'template1'=>['[\[%]%','%[\]%]'],'metatext'=>['%%','%%'],'html'=>['<!--','-->'],'mason'=>['<%','>'],'asp'=>['<%','%>'],'php'=>['<\?','\?>'],'star'=>['\[\*','\*\]'],};$TAG_STYLE->{template}=$TAG_STYLE->{tt2}=$TAG_STYLE->{default};our$DEFAULT_STYLE={START_TAG=>$TAG_STYLE->{default}->[0],END_TAG=>$TAG_STYLE->{default}->[1],ANYCASE=>0,INTERPOLATE=>0,PRE_CHOMP=>0,POST_CHOMP=>0,V1DOLLAR=>0,EVAL_PERL=>0,};our$QUOTED_ESCAPES={n=>"\n",r=>"\r",t=>"\t",};our$CHOMP_FLAGS=qr/[-=~+]/;sub new{my$class=shift;my$config=$_[0]&&ref($_[0])eq 'HASH'?shift(@_):{@_};my($tagstyle,$debug,$start,$end,$defaults,$grammar,$hash,$key,$udef);my$self=bless{START_TAG=>undef,END_TAG=>undef,TAG_STYLE=>'default',ANYCASE=>0,INTERPOLATE=>0,PRE_CHOMP=>0,POST_CHOMP=>0,V1DOLLAR=>0,EVAL_PERL=>0,FILE_INFO=>1,GRAMMAR=>undef,_ERROR=>'',IN_BLOCK=>[],TRACE_VARS=>$config->{TRACE_VARS},FACTORY=>$config->{FACTORY}||'Template::Directive',},$class;foreach$key(keys%$self){$self->{$key}=$config->{$key}if defined$config->{$key};}$self->{FILEINFO}=[];if(defined($debug=$config->{DEBUG})){$self->{DEBUG}=$debug&(Template::Constants::DEBUG_PARSER|Template::Constants::DEBUG_FLAGS);$self->{DEBUG_DIRS}=$debug&Template::Constants::DEBUG_DIRS;}elsif($DEBUG==1){$self->{DEBUG}=Template::Constants::DEBUG_PARSER;$self->{DEBUG_DIRS}=0;}else{$self->{DEBUG}=$DEBUG&(Template::Constants::DEBUG_PARSER|Template::Constants::DEBUG_FLAGS);$self->{DEBUG_DIRS}=$DEBUG&Template::Constants::DEBUG_DIRS;}$grammar=$self->{GRAMMAR}||=do{require Template::Grammar;Template::Grammar->new();};unless(ref$self->{FACTORY}){my$fclass=$self->{FACTORY};$self->{FACTORY}=$self->{FACTORY}->new(NAMESPACE=>$config->{NAMESPACE})||return$class->error($self->{FACTORY}->error());}@$self{qw(LEXTABLE STATES RULES)}=@$grammar{qw(LEXTABLE STATES RULES)};$self->new_style($config)||return$class->error($self->error());return$self;}sub enter_block{my($self,$name)=@_;my$blocks=$self->{IN_BLOCK};push(@{$self->{IN_BLOCK}},$name);}sub leave_block{my$self=shift;my$label=$self->block_label;pop(@{$self->{IN_BLOCK}});return$label;}sub in_block{my($self,$name)=@_;my$blocks=$self->{IN_BLOCK};return@$blocks&&$blocks->[-1]eq$name;}sub block_label{my($self,$prefix,$suffix)=@_;my$blocks=$self->{IN_BLOCK};my$name=@$blocks?$blocks->[-1].scalar@$blocks:undef;return join('',grep{defined$_}$prefix,$name,$suffix);}sub new_style{my($self,$config)=@_;my$styles=$self->{STYLE}||=[];my($tagstyle,$tags,$start,$end,$key);my$style={%{$styles->[-1]||$DEFAULT_STYLE}};if($tagstyle=$config->{TAG_STYLE}){return$self->error("Invalid tag style: $tagstyle")unless defined($tags=$TAG_STYLE->{$tagstyle});($start,$end)=@$tags;$config->{START_TAG}||=$start;$config->{END_TAG}||=$end;}foreach$key(keys%$DEFAULT_STYLE){$style->{$key}=$config->{$key}if defined$config->{$key};}push(@$styles,$style);return$style;}sub old_style{my$self=shift;my$styles=$self->{STYLE};return$self->error('only 1 parser style remaining')unless(@$styles>1);pop@$styles;return$styles->[-1];}sub parse{my($self,$text,$info)=@_;my($tokens,$block);$info->{DEBUG}=$self->{DEBUG_DIRS}unless defined$info->{DEBUG};my$defblock=$self->{DEFBLOCK}={};my$metadata=$self->{METADATA}=[];my$variables=$self->{VARIABLES}={};$self->{DEFBLOCKS}=[];$self->{_ERROR}='';$tokens=$self->split_text($text)||return undef;push(@{$self->{FILEINFO}},$info);$block=$self->_parse($tokens,$info);pop(@{$self->{FILEINFO}});return undef unless$block;$self->debug("compiled main template document block:\n$block")if$self->{DEBUG}&Template::Constants::DEBUG_PARSER;return{BLOCK=>$block,DEFBLOCKS=>$defblock,VARIABLES=>$variables,METADATA=>{@$metadata},};}sub split_text{my($self,$text)=@_;my($pre,$dir,$prelines,$dirlines,$postlines,$chomp,$tags,@tags);my$style=$self->{STYLE}->[-1];my($start,$end,$prechomp,$postchomp,$interp)=@$style{qw(START_TAG END_TAG PRE_CHOMP POST_CHOMP INTERPOLATE)};my$tags_dir=$self->{ANYCASE}?qr<TAGS>i:qr<TAGS>;my@tokens=();my$line=1;return\@tokens unless defined$text&&length$text;while($text=~s/^(.*?)(?:$start(.*?)$end)//sx){($pre,$dir)=($1,$2);$pre=''unless defined$pre;$dir=''unless defined$dir;$prelines=($pre=~tr/\n//);$dirlines=($dir=~tr/\n//);$postlines=0;for($dir){if(/^\#/){$dir=($dir=~/($CHOMP_FLAGS)$/o)?$1:'';}else{s/^($CHOMP_FLAGS)?\s*//os;$chomp=$1?$1:$prechomp;$chomp=~tr/-=~+/1230/;if($chomp&&$pre){if($chomp==CHOMP_ALL){$pre=~s{(\r?\n|^)[^\S\n]*\z}{}mx;}elsif($chomp==CHOMP_COLLAPSE){$pre=~s{(\s+)\z}{ }x;}elsif($chomp==CHOMP_GREEDY){$pre=~s{(\s+)\z}{}x;}}}s/\s*($CHOMP_FLAGS)?\s*$//os;$chomp=$1?$1:$postchomp;$chomp=~tr/-=~+/1230/;if($chomp){if($chomp==CHOMP_ALL){$text=~s{^([^\S\n]*\n)}{}x&&$postlines++;}elsif($chomp==CHOMP_COLLAPSE){$text=~s{^(\s+)}{ }x&&($postlines+=$1=~y/\n//);}elsif($chomp==CHOMP_GREEDY){$text=~s{^(\s+)}{}x&&($postlines+=$1=~y/\n//);}}}if(length$pre){push(@tokens,$interp?[$pre,$line,'ITEXT']:('TEXT',$pre));}$line+=$prelines;if(length$dir){if($dir=~/^$tags_dir\s+(.*)/){my@tags=split(/\s+/,$1);if(scalar@tags>1){($start,$end)=map{quotemeta($_)}@tags;}elsif($tags=$TAG_STYLE->{$tags[0]}){($start,$end)=@$tags;}else{warn"invalid TAGS style: $tags[0]\n";}}else{push(@tokens,[$dir,($dirlines?sprintf("%d-%d",$line,$line+$dirlines):$line),$self->tokenise_directive($dir)]);}}$line+=$dirlines+$postlines;}push(@tokens,$interp?[$text,$line,'ITEXT']:('TEXT',$text))if length$text;return\@tokens;}sub interpolate_text{my($self,$text,$line)=@_;my@tokens=();my($pre,$var,$dir);while($text=~/((?:\\.|[^\$]){1,3000})|(\$(?:(?:\{([^\}]*)\})|([\w\.]+)))/gx){($pre,$var,$dir)=($1,$3||$4,$2);if(defined($pre)&&length($pre)){$line+=$pre=~tr/\n//;$pre=~s/\\\$/\$/g;push(@tokens,'TEXT',$pre);}if($var){$line+=$dir=~tr/\n/ /;push(@tokens,[$dir,$line,$self->tokenise_directive($var)]);}elsif($dir){$line+=$dir=~tr/\n//;push(@tokens,'TEXT',$dir);}}return\@tokens;}sub tokenise_directive{my($self,$text,$line)=@_;my($token,$uctoken,$type,$lookup);my$lextable=$self->{LEXTABLE};my$style=$self->{STYLE}->[-1];my($anycase,$start,$end)=@$style{qw(ANYCASE START_TAG END_TAG)};my@tokens=();while($text=~/(\#[^\n]*)|(["'])((?:\\\\ |\\\2|.|\n)*?)\2|(-?\d+(?:\.\d+)?)|(\/?\w+(?:(?:\/|::?)\w*)+|\/\w+)|(\w+)|([(){}\[\]:;,\/\\]|[+\-*]|\$\{?|=>|[=!<>]?=|[!<>]|&&?|\|\|?|\.\.?|\S+)/gmox){next if$1;if(defined($token=$3)){if($2 eq '"'){if($token=~/[\$\\]/){$type='QUOTED';for($token){s/\\([^\$nrt])/$1/g;s/\\([nrt])/$QUOTED_ESCAPES->{$1}/eg;}push(@tokens,('"')x 2,@{$self->interpolate_text($token)},('"')x 2);next;}else{$type='LITERAL';$token=~s['][\\']g;$token="'$token'";}}else{$type='LITERAL';$token="'$token'";}}elsif(defined($token=$4)){$type='NUMBER';}elsif(defined($token=$5)){$type='FILENAME';}elsif(defined($token=$6)){$uctoken=($anycase&&(!@tokens||$tokens[-2]ne 'DOT'))?uc$token:$token;if(defined($type=$lextable->{$uctoken})){$token=$uctoken;}else{$type='IDENT';}}elsif(defined($token=$7)){$uctoken=$anycase?uc$token:$token;unless(defined($type=$lextable->{$uctoken})){$type='UNQUOTED';}}push(@tokens,$type,$token);}return\@tokens;}sub define_block{my($self,$name,$block)=@_;my$defblock=$self->{DEFBLOCK}||return undef;$self->debug("compiled block '$name':\n$block")if$self->{DEBUG}&Template::Constants::DEBUG_PARSER;$defblock->{$name}=$block;return undef;}sub push_defblock{my$self=shift;my$stack=$self->{DEFBLOCK_STACK}||=[];push(@$stack,$self->{DEFBLOCK});$self->{DEFBLOCK}={};}sub pop_defblock{my$self=shift;my$defs=$self->{DEFBLOCK};my$stack=$self->{DEFBLOCK_STACK}||return$defs;return$defs unless@$stack;$self->{DEFBLOCK}=pop@$stack;return$defs;}sub add_metadata{my($self,$setlist)=@_;my$metadata=$self->{METADATA}||return undef;push(@$metadata,@$setlist);return undef;}sub location{my$self=shift;return"\n"unless$self->{FILE_INFO};my$line=${$self->{LINE}};my$info=$self->{FILEINFO}->[-1];my$file=$info->{path}||$info->{name}||'(unknown template)';$line=~s/\-.*$//;$line||=1;return"#line $line \"$file\"\n";}sub _parse{my($self,$tokens,$info)=@_;my($token,$value,$text,$line,$inperl);my($state,$stateno,$status,$action,$lookup,$coderet,@codevars);my($lhs,$len,$code);my$stack=[[0,undef]];my($states,$rules)=@$self{qw(STATES RULES)};$self->{FACTORY}->trace_vars($self->{VARIABLES})if$self->{TRACE_VARS};$self->{GRAMMAR}->install_factory($self->{FACTORY});$line=$inperl=0;$self->{LINE}=\$line;$self->{FILE}=$info->{name};$self->{INPERL}=\$inperl;$status=CONTINUE;my$in_string=0;while(1){$stateno=$stack->[-1]->[0];$state=$states->[$stateno];if(exists$state->{'ACTIONS'}){while(!defined$token&&@$tokens){$token=shift(@$tokens);if(ref$token){($text,$line,$token)=@$token;if(ref$token){if($info->{DEBUG}&&!$in_string){my$dtext=$text;$dtext=~s[(['\\])][\\$1]g;unshift(@$tokens,DEBUG=>'DEBUG',IDENT=>'msg',IDENT=>'line',ASSIGN=>'=',LITERAL=>"'$line'",IDENT=>'text',ASSIGN=>'=',LITERAL=>"'$dtext'",IDENT=>'file',ASSIGN=>'=',LITERAL=>"'$info->{ name }'",(';')x 2,@$token,(';')x 2);}else{unshift(@$tokens,@$token,(';')x 2);}$token=undef;}elsif($token eq 'ITEXT'){if($inperl){$token='TEXT';$value=$text;}else{unshift(@$tokens,@{$self->interpolate_text($text,$line)});$token=undef;}}}else{$in_string=!$in_string if$token eq '"';$value=shift(@$tokens);}};$token=''unless defined$token;$action=defined($lookup=$state->{'ACTIONS'}->{$token})?$lookup:defined($lookup=$state->{'DEFAULT'})?$lookup:undef;}else{$action=$state->{'DEFAULT'};}last unless defined$action;if($action>0){push(@$stack,[$action,$value]);$token=$value=undef;redo;};($lhs,$len,$code)=@{$rules->[-$action]};$action or$status=ACCEPT;$code=sub{$_[1]}unless$code;@codevars=$len?map{$_->[1]}@$stack[-$len..-1]:();eval{$coderet=&$code($self,@codevars);};if($@){my$err=$@;chomp$err;return$self->_parse_error($err);}splice(@$stack,-$len,$len);return$coderet if$status==ACCEPT;return undef if$status==ABORT;last if$status==ERROR;}continue{push(@$stack,[$states->[$stack->[-1][0]]->{'GOTOS'}->{$lhs},$coderet]),}return$self->_parse_error('unexpected end of input')unless defined$value;return$self->_parse_error("unexpected end of directive",$text)if$value eq ';';return$self->_parse_error("unexpected token ($value)",$text);}sub _parse_error{my($self,$msg,$text)=@_;my$line=$self->{LINE};$line=ref($line)?$$line:$line;$line='unknown'unless$line;$msg.="\n  [% $text %]"if defined$text;return$self->error("line $line: $msg");}sub _dump{my$self=shift;my$output="[Template::Parser] {\n";my$format="    %-16s => %s\n";my$key;foreach$key(qw(START_TAG END_TAG TAG_STYLE ANYCASE INTERPOLATE PRE_CHOMP POST_CHOMP V1DOLLAR)){my$val=$self->{$key};$val='<undef>'unless defined$val;$output.=sprintf($format,$key,$val);}$output.='}';return$output;}1;__END__
