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//); # newlines in preceeding text
$dirlines = ($dir =~ tr/\n//); # newlines in directive tag
$postlines = 0;
for ($dir) {
if (/^\ $dir = ($dir =~ /($CHOMP_FLAGS)$/o) ? $1 : '';
}
else {
s/^($CHOMP_FLAGS)?\s*//so;
$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*$//so;
$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 =~
/
(\ |
(["']) # $2 - opening quote, ' or "
( (?: \\\\ | \\\2 | . | \n
)*? ) \2 |
(-?\d+(?:\.\d+)?) |
( \/?\w+(?:(?:\/|::?)\w*)+ | \/\w+)
|
(\w+) |
( [(){}\[\]:;,\/\\] | [+\-*] | \$\{? | => | [=!<>]?= | [!<>] | &&? | \|\|? | \.\.? | \S+ ) /gmxo) {
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 }/ge;
}
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/\-.*$//; # might be 'n-n'
$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; # force redo
}
elsif ($token eq 'ITEXT') {
if ($inperl) {
# don't perform interpolation in PERL blocks
$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__
=head1 NAME
Template::Parser - LALR(1) parser for compiling template documents
=head1 SYNOPSIS
use Template::Parser;
$parser = Template::Parser->new(\%config);
$template = $parser->parse($text)
|| die $parser->error(), "\n";
=head1 DESCRIPTION
The C<Template::Parser> module implements a LALR(1) parser and associated
methods for parsing template documents into Perl code.
=head1 PUBLIC METHODS
=head2 new(\%params)
The C<new()> constructor creates and returns a reference to a new
C<Template::Parser> object.
A reference to a hash may be supplied as a parameter to provide configuration values.
See L<CONFIGURATION OPTIONS> below for a summary of these options and
L<Template::Manual::Config> for full details.
my $parser = Template::Parser->new({
START_TAG => quotemeta('<+'),
END_TAG => quotemeta('+>'),
});
=head2 parse($text)
The C<parse()> method parses the text passed in the first parameter and
returns a reference to a hash array of data defining the compiled
representation of the template text, suitable for passing to the
L<Template::Document> L<new()|Template::Document#new()> constructor method. On
error, undef is returned.
$data = $parser->parse($text)
|| die $parser->error();
The C<$data> hash reference returned contains a C<BLOCK> item containing the
compiled Perl code for the template, a C<DEFBLOCKS> item containing a
reference to a hash array of sub-template C<BLOCK>s defined within in the
template, and a C<METADATA> item containing a reference to a hash array
of metadata values defined in C<META> tags.
=head1 CONFIGURATION OPTIONS
The C<Template::Parser> module accepts the following configuration
options. Please see L<Template::Manual::Config> for futher details
on each option.
=head2 START_TAG, END_TAG
The L<START_TAG|Template::Manual::Config#START_TAG_END_TAG> and
L<END_TAG|Template::Manual::Config#START_TAG_END_TAG> options are used to
specify character sequences or regular expressions that mark the start and end
of a template directive.
my $parser = Template::Parser->new({
START_TAG => quotemeta('<+'),
END_TAG => quotemeta('+>'),
});
=head2 TAG_STYLE
The L<TAG_STYLE|Template::Manual::Config#TAG_STYLE> option can be used to set
both L<START_TAG> and L<END_TAG> according to pre-defined tag styles.
my $parser = Template::Parser->new({
TAG_STYLE => 'star', # [* ... *]
});
=head2 PRE_CHOMP, POST_CHOMP
The L<PRE_CHOMP|Template::Manual::Config#PRE_CHOMP_POST_CHOMP> and
L<POST_CHOMP|Template::Manual::Config#PRE_CHOMP_POST_CHOMP> can be set to remove
any whitespace before or after a directive tag, respectively.
my $parser = Template::Parser-E<gt>new({
PRE_CHOMP => 1,
POST_CHOMP => 1,
});
=head2 INTERPOLATE
The L<INTERPOLATE|Template::Manual::Config#INTERPOLATE> flag can be set
to allow variables to be embedded in plain text blocks.
my $parser = Template::Parser->new({
INTERPOLATE => 1,
});
Variables should be prefixed by a C<$> to identify them, using curly braces
to explicitly scope the variable name where necessary.
Hello ${name},
The day today is ${day.today}.
=head2 ANYCASE
The L<ANYCASE|Template::Manual::Config#ANYCASE> option can be set
to allow directive keywords to be specified in any case.
# with ANYCASE set to 1
[% INCLUDE foobar %] # OK
[% include foobar %] # OK
[% include = 10 %] # ERROR, 'include' is a reserved word
=head2 GRAMMAR
The L<GRAMMAR|Template::Manual::Config#GRAMMAR> configuration item can be used
to specify an alternate grammar for the parser. This allows a modified or
entirely new template language to be constructed and used by the Template
Toolkit.
use MyOrg::Template::Grammar;
my $parser = Template::Parser->new({
GRAMMAR = MyOrg::Template::Grammar->new();
});
By default, an instance of the default L<Template::Grammar> will be
created and used automatically if a C<GRAMMAR> item isn't specified.
=head2 DEBUG
The L<DEBUG|Template::Manual::Config#DEBUG> option can be used to enable
various debugging features of the C<Template::Parser> module.
use Template::Constants qw( :debug );
my $template = Template->new({
DEBUG => DEBUG_PARSER | DEBUG_DIRS,
});
=head1 AUTHOR
Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/>
=head1 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 main parsing loop of the C<Template::Parser> module was derived from a
standalone parser generated by version 0.16 of the C<Parse::Yapp> module. The
following copyright notice appears in the C<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.
=head1 SEE ALSO
L<Template>, L<Template::Grammar>, L<Template::Directive>