[Templates-cvs] cvs commit: TT3/lib/Template/Tag Directive.pm
cvs@template-toolkit.org
cvs@template-toolkit.org
Wed, 17 Nov 2004 14:50:24 +0000
cvs 04/11/17 14:50:23
Modified: lib/Template/Tag Directive.pm
Log:
* added directives configuration parameter
* now delegates most matching efforts to the parser
* fixed up side-effect and multi-line directives
* added line number reporting
Revision Changes Path
1.6 +238 -116 TT3/lib/Template/Tag/Directive.pm
Index: Directive.pm
===================================================================
RCS file: /template-toolkit/TT3/lib/Template/Tag/Directive.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- Directive.pm 2004/11/15 19:33:20 1.5
+++ Directive.pm 2004/11/17 14:50:23 1.6
@@ -16,7 +16,7 @@
# modify it under the same terms as Perl itself.
#
# REVISION
-# $Id: Directive.pm,v 1.5 2004/11/15 19:33:20 abw Exp $
+# $Id: Directive.pm,v 1.6 2004/11/17 14:50:23 abw Exp $
#
#========================================================================
@@ -25,21 +25,20 @@
use strict;
use warnings;
use Template::Constants qw( :chomp );
+use Template::Directives::TT;
use Template::Parser;
use Template::Tag;
use base qw( Template::Tag );
-our $VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/);
+our $VERSION = sprintf("%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/);
our $DEBUG = 0 unless defined $DEBUG;
our $ERROR = '';
-our $PARSER = 'Template::Parser';
-our $WHITESPACE = $Template::Parser::WSPACE
- unless defined $WHITESPACE;
+# default parser and directives classes
+our $PARSER = 'Template::Parser' unless defined $PARSER;
+our $DIRECTIVES = 'Template::Directives::TT' unless defined $DIRECTIVES;
-our $DELIMITER = qr/ (?: $WHITESPACE ; $WHITESPACE )+ /sox
- unless defined $DELIMITER;
-
+# define various tag styles
our $TAG_STYLES = {
# special controls
off => { enabled => 0 },
@@ -70,23 +69,23 @@
$TAG_STYLES->{ tt2 } =
$TAG_STYLES->{ square };
+# define default tag
our $TAG = {
- style => 'default',
- styles => $TAG_STYLES,
- start => $TAG_STYLES->{ default }->[0],
- end => $TAG_STYLES->{ default }->[1],
- pre_chomp => 0,
- post_chomp => 0,
- side_effect => 1,
- multi_dirs => 1,
- comment => 1,
- ignore => $WHITESPACE, # TODO: remove this
- delimiter => $DELIMITER,
+ style => 'default',
+ styles => $TAG_STYLES,
+ start => $TAG_STYLES->{ default }->[0],
+ end => $TAG_STYLES->{ default }->[1],
+ pre_chomp => 0,
+ post_chomp => 0,
+ side_effect => 1,
+ multi_dirs => 1,
+ comment => 1,
+ implicit_get => 1,
+ implicit_set => 1,
} unless defined $TAG;
+
-# TODO: should upgrade ignore (or rename as whitespace?) and delimiter
-# to regexen if not already so?
sub init {
my ($self, $config) = @_;
@@ -125,6 +124,83 @@
unless defined $config->{ $key };
}
+ # TODO: directives should happen first if we want to pass keywords to
+ # parser
+
+ # fetch $DIRECTIVES package var and look for 'directives' or 'dirs' in
+ # config hash, accept undef for default behaviour
+ my $pkgdirs = $self->pkgvar( DIRECTIVES => $DIRECTIVES );
+ my $cfgdirs = defined $config->{ directives } ? delete $config->{ directives }
+ : delete $config->{ dirs };
+ my $dirs;
+
+ if (defined $cfgdirs) {
+ $self->debug("config directives: $cfgdirs\n") if $DEBUG;
+
+ if ($cfgdirs) {
+ if (UNIVERSAL::can($cfgdirs, 'directives')) {
+ # if the directives defined in the config is an object or
+ # class that has a directives() method, then we call it
+ $self->{ directives } = $dirs = $cfgdirs->directives()
+ || return $self->error($cfgdirs->error());
+ }
+ elsif (ref $cfgdirs eq 'HASH') {
+ # if its a hash of directives then we pass them as
+ # constructor parameters to the directives class defined
+ # in the $DIRECTIVES package variable, then we call its
+ # directives() method
+ $self->debug("passing hash to $pkgdirs\n") if $DEBUG;
+ $dirs = $pkgdirs->new({ directives => $cfgdirs })
+ || return $self->error($pkgdirs->error());
+ $self->{ directives } = $dirs->directives()
+ || return $self->error($dirs->error());
+ $dirs = $self->{ directives };
+ $self->debug("dirs: { ", $self->dump_hash($dirs), " }\n") if $DEBUG;
+ }
+ else {
+ return $self->error("invalid directives: $cfgdirs");
+ }
+ }
+ else {
+ # directives => 0 indicate no directives at all, thank you very much
+ $self->{ directives } = { };
+ }
+ }
+ else {
+ $self->debug("no config directives, using $pkgdirs\n") if $DEBUG;
+
+ # call directives() method on default class
+ $self->{ directives } = $pkgdirs->directives()
+ || return $self->error($pkgdirs->error());
+ }
+
+ # initialise a parser from the object or class name passed as 'parser'
+ # item, or defined in the $PARSER package variable. define tag_end
+ # for parser to match as closing flags followed by tag 'end' token.
+ my $parser = $config->{ parser } || $self->pkgvar( PARSER => $PARSER );
+ my $endtag = $config->{ end };
+ $endtag = ref $endtag eq 'Regexp' ? $endtag : quotemeta($endtag);
+ $endtag = qr/ ([-=+]?) ($endtag) /x;
+
+ if (ref $parser && UNIVERSAL::can($parser, 'clone')) {
+ # $parser is an object. we call its clone() method
+ # to allow it to construct new regexen to detect the tag.
+ $config->{ parser } = $parser->clone({
+ tag_end => $endtag,
+ directives => $dirs,
+ }) || return $self->error('failed to clone parser: ', $parser->error());
+ }
+ elsif (ref $parser) {
+ return $self->error("invalid parser reference: $parser");
+ }
+ else {
+ # parser is a class name so we call the new() method
+ $config->{ parser } = $parser->new({
+ tag_end => $endtag,
+ directives => $dirs,
+ }) || return $self->error('failed to create parser: ', $parser->error());
+ }
+
return $self->SUPER::init($config);
}
@@ -132,7 +208,7 @@
sub scan {
my ($self, $textref, $handler, $match) = @_;
my ($flag, $comment, $error);
- my $ignore = $self->{ ignore } || '';
+ my $parser = $self->{ parser };
my $endtag = $self->{ end };
$self->debug("scan()\n") if $DEBUG;
@@ -140,61 +216,25 @@
# save match info locally to make protect re-entrancy
local $self->{ match } = $match;
$match->{ lines } = 0;
- $match->{ ignore } = $ignore;
$match->{ end } = $endtag;
+ $match->{ parser } = $parser;
# we must have an end tag defined
return $self->error('no end token defined for tag')
unless defined $endtag and length $endtag;
- # compile regex to match end token and any flag that comes
- # immediately before it. Any leading whitespace is ignored, but
- # we keep an eye open for any other text coming before the end
- # flag/token that shouldn't be there. We also compile a regex
- # which looks ahead for the end tag (no intermediate text) but
- # doesn't consume it (a negative width positive lookahead assertion).
- # This is set in the $match hash for the parser to use to detect the
- # end of a tag
-
+ # compile regex to match end of tag and capture anything before it
my $regex = $self->{ end_regex } ||= do {
- $self->debug("compiling new end_regex ($endtag)\n") if $DEBUG;
$endtag = ref $endtag eq 'Regexp' ? $endtag : quotemeta($endtag);
-
- # TODO: don't need this - now done in the parser
- $ignore = qr/ # compile regex to ignore comments, whitespace, etc.
- \s* # ignore any leading whitespace
- (?: # repeat block for multiple comments
- \# .*? # capture everything after '#', but non-greedily
- (?: # group of end tokens to terminate comment, either:
- \n # a newline character, which is consumed
- | # or:
- (?= # look ahead for, but don't consume
- [-=+]? # any optional closing flag
- $endtag # token or regex marking end of tag
- )
- )
- \s* # trailing whitespace after comment
- )*
- /sx;
-
- $self->{ match_end_regex } = qr/ (?= \G $ignore [-=+]? $endtag ) /sx;
- $self->{ match_ignore } = qr/ \G $ignore /sx;
- qr/ \G $ignore (.*?) $ignore ([-=+])? ($endtag) /sx;
+ qr/ \G (.*?) ([-=+])? ($endtag) /sx;
};
- $match->{ end_regex } = $self->{ match_end_regex };
- $match->{ ignore } = $self->{ ignore };
- # check for opening comment/chomp flag and remove leading whitespace
- # or anything else deemed ignorable
- $$textref =~ / \G ([-=+\#])? /cgsx;
+ # check for opening flag and/or comment marker
+ $$textref =~ / \G ([-=+])? (\#)? /cgsx;
$match->{ start_flag } = $flag = $1 || '';
- $$textref =~ / \G $ignore /sx;
-
- # TODO: other options to enable/disable flags: comment_flag,
- # chomp_flag, etc?
# examine opening flag and pre_chomp options
- if ($flag eq '#') {
+ if ($2) {
# if the comment option is set then we comment out the entire
# directive, otherwise we treat it as a single line comment
if ($self->{ comment }) {
@@ -202,11 +242,12 @@
$comment = 1;
}
else {
- # scan to start of next line
- $$textref =~ / \G [^\n]*\n /x;
+ $parser->parse_end_of_line($textref)
+ || return $self->error($parser->error());
}
}
- elsif ($flag eq '+') {
+
+ if ($flag eq '+') {
# do nothing - leave whitespace alone
}
elsif ($flag eq '=' || $self->{ pre_chomp } == CHOMP_COLLAPSE) {
@@ -218,6 +259,16 @@
$handler->prev_text( \&chomp_trailing, CHOMP_REMOVE );
}
+ if ($self->{ line_info }) {
+ # notify handler of current line (also commits)
+ $handler->line($match->{ line });
+ }
+ else {
+ # flush any pending item at the start of a new tag - we don't want
+ # side-effects across tag boundaries
+ $handler->commit();
+ }
+
eval {
# call parse() method, or do nothing if this is a comment
$handler = $self->parse($textref, $handler, $match)
@@ -226,20 +277,21 @@
$error = $@;
if ($handler && ! $error) {
- $self->debug("scanning for end of directive tag: $regex\n") if $DEBUG;
+ $self->debug("scanning for end of directive tag\n") if $DEBUG;
+ $self->debug("regex[ $regex ]\ntext[ ",
+ $parser->next_text($textref, 32), "]\n") if $DEBUG;
# scan for end token, noting error if not found
- if ($$textref =~ /$regex/gc) {
- if (defined($1) && length($1)) {
- # any text coming before end token shouldn't be there unless
- # the entire directed is commented out
- $error = "unexpected text in tag: $1"
- unless $comment;
- }
-
+ if ($$textref =~ /$regex/cg) {
# save end token and flag in $match data
$match->{ end_flag } = $flag = $2 || '';
$match->{ end } = $3;
+ $self->debug("end flag($flag) token($3)\n") if $DEBUG;
+
+ # report any text in the tag coming before the end of tag token
+ if (! $comment && defined $1 && length $1) {
+ return $self->error("unexpected text in directive tag: $1");
+ }
# examine closing flag and post_chomp options
if ($flag eq '+') {
@@ -253,7 +305,6 @@
# remove all following whitespace
$handler->next_text( \&chomp_leading, CHOMP_REMOVE ),
}
-
}
else {
$error = "no closing tag to match $match->{ start }";
@@ -279,78 +330,144 @@
sub parse {
my ($self, $textref, $handler, $match) = @_;
- my ($directive, $start_pos, $end_pos, $substr, $sublines);
+ my ($result, $start_pos, $end_pos, $substr, $sublines, $commit, $done);
my $lines = 0;
my $parser = $match->{ parser }
- ||= $self->{ parser }
-# || $handler->parser()
- || return $self->error('no parser defined for directive tag');
-
- # TODO: flush any pending items
- # $handler->commit();
-
- while ($directive = $parser->parse_directive($textref, $handler, $match)) {
- $handler = $directive;
-# $handler->expr($directive);
-
-# $self->debug("got directive: $directive\n");
-# $handler = $handler->directive($directive)
-# || return $self->error($handler->error());
-
- if ($self->{ delimiter } && $$textref =~ / \G $self->{ delimiter } /cogx) {
- # we found a directive delimiter (e.g. /\s*;\s*/) so
- # we commit the previous directive and loop around
- # for the next.
+ ||= $self->{ parser }
+ || return $self->error('no parser defined for directive tag');
+
+ while ($result = $self->parse_directive($textref, $handler, $match)) {
+ if ($parser->parse_semicolon($textref)) {
+ # we found a semicolon directive delimiter so commit the
+ # previous directive and loop around for the next.
$self->debug("found directive delimiter, looping...\n") if $DEBUG;
- $handler->commit();
+ $commit = 1;
}
elsif ($self->{ side_effect }) {
- # if side-effect processing is enabled then we loop
- # around without committing the previous directive.
- # if the next directive is an appropriate block directive
- # (e.g. IF, FOREACH, etc.) then the handler will attach
- # the uncommited previous directive to it
+ # if side-effect processing is enabled then we loop around without
+ # committing the previous directive, allowing it to be used by a
+ # subsequent side-effect directive
$self->debug("no delimiter, possible side-effect...\n") if $DEBUG;
+ $commit = 0;
}
elsif ($self->{ multiple }) {
- # if multiple directives are supported but not side-effect processing
- # then we implicity add a delimiter (e.g. call commit()) even if
- # there isn't one there.
+ # if multiple directives are supported but not side-effect processing,
+ # so we call commit() as if we had seen a delimiter
+ $parser->parse_whitespace($textref);
$self->debug("no delimiter, multiple statement...\n") if $DEBUG;
- $handler->commit();
+ $commit = 1;
}
- elsif ($self->{ ignore } && $$textref =~ / \G $self->{ ignore } (.*) /cogx) {
- return $self->error("unexpected text following directive: $1");
+ else {
+ $parser->parse_whitespace($textref);
+ $done = $commit = 1;
}
+ # update $handler to new result
+ $handler = $result;
+
# count any newlines consumed by previous and current positions
$start_pos = $match->{ offset };
$end_pos = $match->{ offset } = pos $$textref || 0;
$substr = substr($$textref, $start_pos, $end_pos - $start_pos);
+
if ($sublines = ($substr =~ tr/\n//)) {
$lines += $sublines;
$match->{ line } += $sublines;
+
+ # call handler to notify of new line number but only if $commit
+ # flag is set, otherwise we might trample a pending directive
+ $handler->line($match->{ line })
+ if $commit;
+ }
+ else {
+ # call commit if $commit flag set to prevent the previous directive
+ # being chained onto the next in side-effect notation
+ $handler->commit()
+ if $commit;
}
+
+ last if $done;
}
# update match with total line count for reporting back to scanner
$match->{ lines } = $lines;
- # while loop exits with an error (undef) or when parser runs out of
- # text and declines (0) - the latter case is OK
- return $self->error($parser->error())
- unless $parser->declined();
-
# commit all directives to prevent any undesired side-effects between
# directives in separate tags
$handler->commit();
+
+ # we expect $result to be 0 (defined but false) to indicate that
+ # parse_directive() declined to parse any more directives, in which case,
+ # we can return the current $handler. If $result is undef then an error
+ # occurred and has already been set internally by a call to error(), so
+ # we can return the undef as a result
- return $handler;
+ return defined $result ? $handler : undef;
}
+sub parse_directive {
+ my ($self, $textref, $handler, $match) = @_;
+ my ($directive, $keyword, $expr);
+ my $parser = $self->{ parser };
+
+ $self->debug("parse_directive()\n") if $DEBUG;
+
+ # skip any leading whitespace, comments, etc.
+ $parser->parse_whitespace($textref);
+
+ # save text position
+ my $pos = pos $$textref;
+
+ # TODO: parser should provide parse_keyword() to match any keyword and
+ # parse_directive() to match a keyword mapping to a directive, or rewinding
+
+ # look for a keyword that may be the start of a directive
+ if ($$textref =~ / \G ( \w+ ) \b /cgx) {
+ $keyword = $1;
+
+ if ($directive = $self->{ directives }->{ $keyword }) {
+ $self->debug("directive: $keyword => $directive\n") if $DEBUG;
+ local $match->{ keyword } = $keyword;
+
+ # parse any whitespace, comments, etc,
+ $parser->parse_whitespace($textref);
+
+ # call delegate to parse rest of directive
+ return $directive->parse($textref, $handler, $match)
+ || $self->error($directive->error());
+ }
+ else {
+ $self->debug("no directive for keyword: $keyword\n") if $DEBUG;
+ # restore text position
+ pos $$textref = $pos;
+ }
+ }
+ else {
+ $self->debug("didn't match keyword: ", $parser->next_token($textref), "\n")
+ if $DEBUG;
+ }
+
+
+ # see if it looks like an assignment
+ if ($self->{ implicit_set }
+ && ($expr = $parser->parse_assign($textref, $match))) {
+ $self->debug("implicit SET\n") if $DEBUG;
+ return $handler->expr([ set => $expr ]);
+ }
+ elsif ($self->{ implicit_get }
+ && ($expr = $parser->parse_expression($textref, $match))) {
+ $self->debug("implicit GET\n") if $DEBUG;
+ return $handler->expr([ get => $expr ]);
+ }
+
+ # defined but false
+ return 0; $self->decline('not a directive');
+}
+
+
sub parser {
my $self = shift;
return @_ ? ($self->{ parser } = shift) : $self->{ parser };
@@ -403,6 +520,11 @@
}
+sub directives {
+ my $self = shift;
+ return $self->{ directives };
+}
+
1;
__END__
@@ -432,7 +554,7 @@
=head1 VERSION
-$Revision: 1.5 $
+$Revision: 1.6 $
=head1 COPYRIGHT