[Templates-cvs] cvs commit: TT3/lib/Template Tag.pm Tagset.pm
cvs@template-toolkit.org
cvs@template-toolkit.org
Mon, 08 Nov 2004 18:47:00 +0000
cvs 04/11/08 18:47:00
Added: lib/Template Tag.pm Tagset.pm
Log:
* added Template::Tag and Template::Tagset
Revision Changes Path
1.1 TT3/lib/Template/Tag.pm
Index: Tag.pm
===================================================================
#========================================================================
#
# Template::Tag
#
# DESCRIPTION
# Module implementing a base class tag object which is used to scan
# embedded tags within a template.
#
# AUTHOR
# Andy Wardley <abw@wardley.org>
#
# COPYRIGHT
# Copyright (C) 1996-2004 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.
#
# REVISION
# $Id: Tag.pm,v 1.1 2004/11/08 18:46:59 abw Exp $
#
#========================================================================
package Template::Tag;
use strict;
use warnings;
use Template::Base;
use vars qw( $VERSION $DEBUG $ERROR $TAG );
use base qw( Template::Base );
$VERSION = sprintf("%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);
$DEBUG = 0 unless defined $DEBUG;
$ERROR = '';
$TAG = {
start => '[%',
end => '%]',
};
#------------------------------------------------------------------------
# init(\%config)
#
# Initialiser method called by base class new() method.
#------------------------------------------------------------------------
sub init {
my ($self, $config) = @_;
# merge any $config items with $TAG package variable, then merge
# into self
my $pkgtag = $self->pkgvar( TAG => $TAG );
my $tagdef = { %$pkgtag, %$config };
@$self{ keys %$tagdef } = values %$tagdef;
# allow 'disabled' to be used as opposite of 'enabled'
$self->{ enabled } = 0
if $self->{ disabled };
# default is for tag to be enabled, if not explicitly set already
$self->{ enabled } = 1
unless defined $self->{ enabled };
return $self;
}
#------------------------------------------------------------------------
# scan($textref, $handler, $match)
#
# Default scan method which looks to see if an end token is defined or
# not, and then calls scan_open() or scan_closed() as appropriate.
#------------------------------------------------------------------------
sub scan {
my $self = shift;
my $end;
$self->debug("scan()\n") if $DEBUG;
if (defined ($end = $self->{ end }) && length($end)) {
return $self->scan_closed(@_);
}
else {
return $self->scan_open(@_);
}
}
#------------------------------------------------------------------------
# scan_open($textref, $handler, $match)
#
# Method to scan the text of an open tag that has a start token but no
# pre-defined end token.
#------------------------------------------------------------------------
sub scan_open {
my ($self, $textref, $handler, $match) = @_;
$self->debug("scan_open()\n") if $DEBUG;
# save match info locally to make protect re-entrancy
local $self->{ match } = $match;
# call parse() method to parse forwards, scanning whatever it wants.
# errors can be thrown as exceptions (hence the eval) or set via
# $self->error(), returning an undef value for $handler
eval {
$handler = $self->parse($textref, $handler, $match);
};
# count any newlines consumed by parser between start and end positions
my $start_pos = $match->{ offset };
my $end_pos = pos $$textref || 0;
my $substr = substr($$textref, $start_pos, $end_pos - $start_pos);
$match->{ lines } = ($substr =~ tr/\n//);
return $@ ? $self->error($@) : $handler;
}
#------------------------------------------------------------------------
# scan_closed($textref, $handler, $match)
#
# Method to scan the text of an open tag that has both start and end
# tokens defined.
#------------------------------------------------------------------------
sub scan_closed {
my ($self, $textref, $handler, $match) = @_;
$self->debug("scan_closed()\n") if $DEBUG;
# save match info locally to make protect re-entrancy
local $self->{ match } = $match;
my $endtag = $self->{ end };
return $self->tag_error('no end token defined for tag')
unless defined $endtag and length $endtag;
# compile regex to match end tag
my $regex = $self->{ end_regex } ||= do {
$endtag = ref $endtag eq 'Regexp' ? $endtag : quotemeta($endtag);
qr/ \G (.*?) ($endtag) /sx;
};
$self->debug("scanning for end with $regex\n") if $DEBUG;
# scan for closing tag and report error if not found
return $self->error("no closing tag to match $match->{ start }")
unless $$textref =~ /$regex/gc;
# TODO: change 'size' to 'length', 'lines', etc.
my ($body, $end) = ($1, $2);
$match->{ text } = \$body;
$match->{ end } = $end;
$match->{ lines } =
( $match->{ start } =~ tr/\n// )
+ ( $body =~ tr/\n// )
+ ( $end =~ tr/\n// );
# call parse() method, catching errors thrown or reported via error()
eval {
$handler = $self->parse(\$body, $handler, $match);
};
return $@ ? $self->error($@) : $handler;
}
#------------------------------------------------------------------------
# parse($textref, $handler, $match)
#
# Stub method for redefinition by subclasses.
#------------------------------------------------------------------------
sub parse {
my ($self, $textref, $handler, $match) = @_;
if (my $parse = $self->{ parse }) {
# call custom parse handler
eval {
$handler = &$parse($self, $textref, $handler, $match);
};
return $self->error($@) if $@;
}
return $handler;
}
#------------------------------------------------------------------------
# tagmap()
# tagmap($tagmap)
#
# Create a new tagset information map, or augment one passed by
# reference as the first argument, which contains information
# pertaining to the tag that can be used by a parent tagset to
# construct a combined regex for matching multiple tags.
#------------------------------------------------------------------------
sub tagmap {
my $self = shift;
my $tagmap = shift
|| return $self->error("no tagmap provided to augment");
# do nothing if the tag isn't enabled
unless ($self->{ enabled }) {
$self->debug("tag is disabled\n") if $DEBUG;
return $tagmap;
}
my $start = $self->{ start };
if (UNIVERSAL::isa($start, 'Regexp')) {
$self->debug("start token is a regex: $start\n") if $DEBUG;
# push start regex and tag object onto list of regex-based tags
# for sequential matching
push(@{ $tagmap->{ regex_start } }, {
regex => $start,
tag => $self,
});
}
else {
$self->debug("start token is fixed: $start\n") if $DEBUG;
# add fixed start token to lookup hash for direct matching
$tagmap->{ fixed_start }->{ $start } = $self;
}
# add start token/regex to list of all start tokens to match
push(@{ $tagmap->{ every_start } }, $start);
return $tagmap;
}
#------------------------------------------------------------------------
# start()
# start($token)
# end()
# end($token)
#
# Accessor methods to get/set the start and end tokens.
#------------------------------------------------------------------------
sub start {
my $self = shift;
return @_ ? ($self->{ start } = shift) : $self->{ start };
}
sub end {
my $self = shift;
if (@_) {
$self->{ end } = shift;
delete $self->{ end_regex };
}
return $self->{ end };
}
#------------------------------------------------------------------------
# enable()
# disable()
#
# Methods to enable or disable the tag.
#------------------------------------------------------------------------
sub enable {
$_[0]->{ enabled } = 1;
return $_[0];
}
sub disable {
$_[0]->{ enabled } = 0;
return $_[0];
}
#------------------------------------------------------------------------
# enabled()
# disabled()
#
# Accessor method to determine id the tag is enabled or disabled.
#------------------------------------------------------------------------
sub enabled {
return $_[0]->{ enabled };
}
sub disabled {
return $_[0]->{ enabled } ? 0 : 1;
}
#------------------------------------------------------------------------
# match()
#
# Accessor method to get the current match.
#------------------------------------------------------------------------
sub match {
my $self = shift;
return $self->{ match };
}
#------------------------------------------------------------------------
# location()
#
# Error reporting method which uses the current internal match data
# structure (set locally by the scan() method), or one passed in as an
# argument, to generate a string of the form "line n" or "lines n-m"
# if the current match covers multiple lines or not (i.e. size is set)
#------------------------------------------------------------------------
sub location {
my $self = shift;
my $match = shift || $self->{ match }
|| return $self->error('no current match');
my $scanner = $match->{ scanner }
|| return $self->error('no scanner defined in current match');
return $scanner->location($match);
}
#------------------------------------------------------------------------
# pkgtag()
#
# Return the $TAG hash reference in the subclass package if defined, or
# in the base class package if not.
#------------------------------------------------------------------------
sub pkgtag {
my $self = shift;
return $self->pkgvar( TAG => $TAG );
}
1;
__END__
# TODO: fix up all the docs
=head1 NAME
Template::TT3::Tag - base class for embedded templates tags
=head1 SYNOPSIS
Using the base class tag type:
use Template::TT3::Tag;
use Template::TT3::Scanner;
# use default options
my $tag1 = Template::TT3::Tag->new();
# set custom options
my $tag2 = Template::TT3::Tag->new(
start => '<%',
end => '%>',
);
my $scanner = Template::TT3::Scanner->new(
tags => [ $tag1, $tag2 ],
);
Subclassing the base class tag:
package My::Tag;
use Template::TT3::Tag;
use base qw( Template::TT3::Tag );
use vars qw( $TAG );
# default tag options
$TAG = {
name => 'mytag',
start => '[%',
end => '%]',
};
# define parse() method to parse inside of tag
sub parse {
my ($self, $textref, $handler, $match) = @_;
while ($$textref =~ / your parsing regex /) {
$handler = $handler->directive( dirname => @args )
|| return $self->error($handler->error());
}
return $handler;
}
Using the subclassed tag module:
use Template::TT3::Scanner;
# use default options
my $tag1 = My::Tag->new();
# set custom options
my $tag2 = My::Tag->new(
name => 'mytag',
start => '<%',
end => '%>',
);
my $scanner = Template::TT3::Scanner->new(
tags => [ $tag1, $tag2 ],
);
=head1 DESCRIPTION
This module implements a base class object for representing embedded
tags in a template document.
Tags are identified in the source of a template by a literal string or
regular expression which marks its I<start>. The default start token
is C<[%>. A tag may also define a literal string or regular
expression which marks its C<end>. The default end token is C<%]>.
use Template::TT3::Tag;
my $tag = Template::TT3::Tag->new();
print $tag->start(); # [%
print $tag->end(); # %]
The C<start> and C<end> tokens can be provided as named parameters
to the new() constructor method.
my $tag = Template::TT3::Tag->new(
start => '<*',
end => '*>',
);
print $tag->start(); # <*
print $tag->end(); # *>
Here's another example showing how regular expressions can be used
to define the C<start> and C<end> of the tag.
my $tag = Template::TT3::Tag->new(
start => qr/ < (?i:tt) [23]? : /x,
end => qr/ \/? > /x,
);
print $tag->start(); # (?x-ism: < (?i:tt) [23]? : )
print $tag->end(); # (?x-ism: /? > )
Here we define the C<start> token as a regular expression which
matches a left angle bracket, following by C<TT> in any case (thanks
to the C<(?i: ... )> construct around it), then an optional C<2> or
C<3>, and finally a colon. The C<end> token permits an optional slash
character C</> followed by a mandatory right angle bracket. Here are
some examples of embedded tags that will be matched by this
configuration. The tag content is shown as the simple string C<foo>
but could contain any text not matching the C<end> regular expression.
<tt:foo>
<TT:foo>
<tt:foo/>
<TT:foo/>
<tt2:foo>
<TT2:foo/>
<tt2:foo>
<TT3:foo/>
If you're using a number of different tags in a document, then you
might also want to provide a C<name> for each tag so that you can
uniquely identify each one.
my $tag1 = Template::TT3::Tag->new(
name => 'tt3dir',
start => '[%',
end => '%]',
);
my $tag2 = Template::TT3::Tag->new(
name => 'tt3var',
start => '$',
);
The Template::TT3::Tagset module implements a collection of tags.
It uses the tag name to identify each tag in the set. Here's an
example of it being used.
my $tagset = Template::TT3::Tagset->new(
tags => [ $tag1, $tag2 ],
);
my $dirtag = $tagset->tag( name => 'tt3dir' );
This feature is used by directives like TAGS and INTERPOLATE that
modify the tags at parse time. See L<Template::TT3::Tagset> for further
details.
You can also subclass the Template::TT3::Tag module to create
your own custom tags. The default C<start>, C<end> and a simple
C<name> to identify your tag style can be defined in a hash array
referenced by the C<$TAG> package variable.
package My::Custom::Tag;
use base qw( Template::TT3::Tag );
use vars qw( $DEBUG $TAG );
$TAG = {
start => '<%',
end => '%>',
name => 'mytag',
};
package main;
my $tag = My::Custom::Tag->new();
print $tag->start(); # <%
print $tag->end(); # %>
The C<$TAG> package variable defines the default start and end tokens,
but you can still provide alternate values as configuration options.
my $tag = My::Custom::Tag->new( start => '[%',
end => '%]' );
print $tag->start(); # [%
print $tag->end(); # %]
=head2 Scanning for Tags
This section describes how the scanner interacts with the
tag objects in exruciating detail. You only need to worry
about this if you're planning on writing your own tags, and
even then, there's a good chance you'll only need to provide
your own parse() method and not have to worry about any of
the steps in between.
NOTE: this documentation needs updating to mention that
Template::TT3::Tagset is now the container for tags and does
the regex compilation, etc.
The job of matching tags in the source of a template document is
handled by the Template::TT3::Scanner module. This accepts a list
of any number of Template::TT3::Tag objects, or subclasses thereof,
and constructs a single regular expression that matches any of the
C<start> markers for the tags.
my $tag1 = Template::TT3::Tag->new(
start => '[%',
end => '%]',
name => 'tt3tag',
);
my $tag2 = Template::TT3::Tag->new(
start => qr/(?m:^)=/,
end => qr/(?m:$)/,
name => 'podcmd',
);
my $scanner = Template::TT3::Scanner->new(
tags => [ $tag1, $tag2 ],
);
my $handler = Template::TT3::Handler->new();
# TODO: currently need to call $handler->start(), but that
# probably won't be the case for very long....
$scanner->scan($text, $handler)
|| die $scanner->error();
When the scanner identifies a tag, it calls the scan() method for the
relevant tag object, passing a number of arguments. The first is a
reference to the input text with the global matching regex position
set to the current scanning position marking the start of the tag
content. The second is a reference to the current handler object.
The third is a reference to a hash array containing various useful
bits of information relating to the current match made by the scanner.
The base class scan() method first looks to see if the tag defines
an C<end> token or not. Tags that define an end token are called
I<closed tags>, and those that don't are called I<open tags>. It
then calls either the scan_open() or scan_closed() method as
appropriate.
The Template::TT3::Tag::Open and Template::TT3::Tag::Closed modules
implement more specific subclasses for open and closed tags. These
alias the scan() method directly to the scan_open() or scan_closed()
methods, respectively. In general you should create new tags as
subclasses of one or other of these modules.
=head3 Closed Tags
Tags that define both a C<start> and C<end> are known as I<closed
tags>. The scan_closed() method scans forward in the input text to
find the end token, and takes a copy of everything in between. It
then calls the parse() method to handle the tag content properly.
The first argument passed to the parse() method is a reference to the
text identified between the start and end tokens. The second is a
reference to the current handler object. The third is a reference to
the hash array contain information relating to the current match.
The parse() method is what you would normally subclass to implement
your own tag styles.
sub parse {
my ($self, $textref, $handler, $match) = @_;
# your code here to parse text...
while ($$textref =~ / your parsing regex /) {
# call handler to add content
$handler = $handler->directive( dirname => @args )
|| return $self->error($handler->error());
}
return $handler;
}
You don't need to worry about global matching regex positions or
anything like that. Just munge away on the text referenced by the
first argument (do remember it's always a reference to text - they're
much more efficient to pass around). Then call the text() or
directive() methods on the handler object referenced by the second
argument to notify it of the text or directives that you've
identified.
Remember that the handler methods can return a new handler for you
to use, if they feel so inclined. So always assign the return value
from a text() or directive() handler method back to the $handler variable,
checking for errors along the way, of course:
$handler = $handler->directive( dirname => @args )
|| return $self->error($handler->error());
Also remember to send the handler back as the return argument from
the parse() method:
return $handler
=head2 Open Tags
It is also possible to define a tag which has no C<end> marker defined.
This is known as an I<open tag>. The most commonly encountered open
tag is an interpolated variable, enabled with the INTERPOLATE option:
blah blah $foo blah
^
The C<$> character marks the start of the tag, but there is nothing
to explicitly mark the end of the tag. It might be sufficient for
certain purposes to use whitespace to indicate the end of the tag.
However, this would preclude the use of variables that included
arguments containing spaces:
blah blah $bar.join(', ') blah
^
The scan_open() method does not scan forwards to the end of the tag
but instead passes the complete text buffer to the tag parse() method
for further processing. The current regex position marks the first
character in the string immediately after the start token in question.
The parse() methods should parse as much of the string as required
from the current position (C<\G>) onwards. The C</cg> flags are
required on the regular expression to enable global matching (C</g>)
and to prevent Perl from automatically resetting the regex position on
a failed match (C</c>). The C</x> flag is also useful for improving
the legibility of regular expressions by allowing whitespace and
comments to be included (and ignored).
sub parse {
my ($self, $textref, $handler, $match) = @_;
my ($var, $args);
if ($$textref =~ / \G ( \w+ ) /cgx) {
# found an identifier, now look for args
$var = $1;
if ($$textref =~ / \G \( /cgx) {
$args = $self->parse_args($content) || return;
}
else {
$args = 0;
}
return $handler->directive( var => $var, $args )
|| $self->error($handler->error());
}
else {
return $self->error("no variable after $match->{ start }")
}
}
You have to be more careful when you're working with open tags,
but that's generally not very often.
=head1 METHODS
=head2 new()
Constructor method used to instantiate a new tag object. Accepts
a list or reference to a hash array of named parameters.
use Template::TT3::Tag;
my $tag = Template::TT3::Tag->new({
start => '<%'
end => '%>',
name => 'mytag',
});
=head2 scan($textref, $handler, $match)
Method called by the scanner when a tag has been identified in the
template source text. The first argument, C<$textref>, contains a
reference to a text string which contains the content of the tag. The
second argument, C<$handler>, is a reference to a document handler
object which constructs the content of the template from messages sent
to it by the scanner and tags. The third argument is a reference to
a hash array containing various bits of information relating to the
current match for the tag in a source document.
=over 4
=item start
The start token that matched for this tag.
=item line
The line number in the source document where the start token began.
=item char
The character offset in the source document where the tag content
begins.
=item scanner
A reference to the scanner object that matched the tag.
=back
For closed tags, the following two items are also added:
=over 4
=item end
The end token matched for this tag.
=item size
The number of newline that the directive spans. Note that this is one
less than the total number of lines. So a tag that is all on one line
has a size of 0, a tag that spans two lines has a size of 1, and so
on. It is effectively the number that must be added to the current
line number to update it accordingly.
=back
If the tag has an end token defined then the scan() method calls
scan_closed() to scan the closed tag. Otherwise it calls scan_open().
All arguments are forwarded to these methods.
The scan() method should return a reference to the original
C<$handler>, or a new one returned by a hander method.
=head2 scan_closed($textref, $handler, $match)
This method scans a closed tag. It extracts a copy of the text
between the start and end tokens and then calls the parse() method,
passing a reference to it as the first argument, along with the
current $handler and $match hash array. It also counts the number
of newlines in the enclosed text and updates the C<size> item in
the $match hash array as notification to the calling scanner.
The Template::TT3::Tag::Closed module aliases the scan() method
directly to scan_close() for greater efficiency. Any subclass tag
modules you create that you know will always be closed (tags are
generally one or the other, but not both) should generally be
subclassed from Template::TT3::Tag::Closed rather than
Template::TT3::Tag.
=head2 scan_open($textref, $handler, $match)
This method scans an open tag. It calls its own parse() method
passing all three arguments and waits for the method to return. It
then examines the resulting regex match position and counts the number
of newlines consumed between the starting and ending positions. This
value is added to the $match hash as the C<size> item for notifcation
to the calling scanner.
The Template::TT3::Tag::Open module aliases the scan() method directly
to scan_open() for greater efficiency. Any subclass tag modules you
create that you know will always be open should generally be
subclassed from Template::TT3::Tag::Open rather than
Template::TT3::Tag.
=head2 parse($textref, $handler, $match)
Method called by the base class scan() method to parse the contents
of the tag. This is usually re-defined by subclasses to do something
useful.
The parse() method should return a reference to the C<$handler> object
or an alternate one, as per scan().
=head2 name()
Accessor method used to get/set the tag name.
$tag->name('foo');
print $tag->name(); # foo
=head2 start()
Accessor method used to get/set the literal string or regular expression
used to mark the start of the tag.
$tag->start('<*');
print $tag->start(); # <*
Literal strings may safely contain regular expression metacharacters
(e.g. C<*> in the example above). Regular expression should be specified
using the C<qr/ ... /> construct to pre-compile them into references.
In this case any metacharacters should of course be escaped.
$tag->start(qr/<\*/);
print $tag->start(); # (?-xism:<\*)
=head2 end()
Accessor method used to get/set the literal string or regular expression
used to mark the end of the tag. An argument passed to set a new
value should be a literal string or regular expression as per start().
$tag->end('%>');
print $tag->end(); # %>
=head2 match()
Returns a reference to a hash array containing information about the
current match.
=head1 AUTHOR
Andy Wardley E<lt>abw@wardley.orgE<gt>
=head1 VERSION
$Revision: 1.1 $
=head1 COPYRIGHT
Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved.
Copyright (C) 1998-2002 Canon Research Centre Europe Ltd.
Copyright (C) 2003-2004 Fotango Ltd.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
For examples of tag subclasses that perform more specific processing,
see L<Template::TT3::Tag::Comment>, L<Template::TT3::Tag::Escape>,
L<Template::TT3::Tag::Variable>, and L<Template::TT3::Tag::Directive>.
For more information about the scanner and document classes, see
L<Template::TT3::Scanner> and L<Template::TT3::Document> respectively.
=cut
# Local Variables:
# mode: perl
# perl-indent-level: 4
# indent-tabs-mode: nil
# End:
#
# vim: expandtab shiftwidth=4:
1.1 TT3/lib/Template/Tagset.pm
Index: Tagset.pm
===================================================================
#========================================================================
#
# Template::Tagset
#
# DESCRIPTION
# A tagset is a named collection of individual tags (Template::Tag
# objects) and/or other nested tagsets.
#
# AUTHOR
# Andy Wardley <abw@wardley.org>
#
# COPYRIGHT
# Copyright (C) 1996-2004 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.
#
# REVISION
# $Id: Tagset.pm,v 1.1 2004/11/08 18:46:59 abw Exp $
#
#========================================================================
package Template::Tagset;
use strict;
use warnings;
use Template::Base;
use vars qw( $VERSION $DEBUG $ERROR $TAGS );
use base qw( Template::Base );
$VERSION = sprintf("%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);
$DEBUG = 0 unless defined $DEBUG;
$ERROR = '';
$TAGS = { };
# alias tag() to tags()
*tag = \&tags;
#------------------------------------------------------------------------
# init(\%config)
#
# Initialiser method called by base class new() method.
#------------------------------------------------------------------------
sub init {
my ($self, $config) = @_;
my $pkgtags = $self->pkgvar( TAGS => $TAGS );
my $cfgtags = $config->{ tags };
$self->debug("init() { ", join(', ', %$config), " }\n")
if $DEBUG;
# if a 'tags' items isn't specified explicitly in the config hash
# then we assume the entire config hash is the tags definition
unless ($cfgtags) {
$self->debug("no 'tags' item specified, using entire hash\n") if $DEBUG;
$cfgtags = $config;
$config = { };
}
# In some cases it is necessary to specify an order for the tags.
# This is used when constructing a regex to match the tags' start
# tokens to ensure that one tag appears in the regex before
# another, e.g. Template::Tag::Escape (\$) must appear before
# T::T::Variable ($). The $TAGS package variable and 'tags'
# config can both be specified as a reference to a list to
# indicate an implicit order, or as a reference to a hash when
# order is insignificant. A separate 'order' config item can be
# provided to indicate a desired order for some or all of the tags.
my $tags = { };
my $order = $config->{ order } || [ ];
# order can be a string of non-word character separated tag names
$order = [ split(/\W+/, $order) ]
unless UNIVERSAL::isa($order, 'ARRAY');
# process package tags first, config tags second
foreach my $tagset ($pkgtags, $cfgtags) {
if (UNIVERSAL::isa($tagset, 'ARRAY')) {
# extract every other item from the list (0, 2, 4, etc.)
# to get the tag keys in order, then merge the list into
# the $tags hash
push(@$order, map { $tagset->[$_*2] } 0..$#$tagset/2);
$tags = { %$tags, @$tagset };
}
elsif (UNIVERSAL::isa($tagset, 'HASH')) {
# push hash keys in non-deterministic order onto $order
# list and merge items into $tags hash
push(@$order, keys %$tagset);
@$tags{ keys %$tagset } = values %$tagset;
}
else {
return $self->error("invalid tags (not a list or hash ref): $tagset");
}
}
$self->debug("tags: {\n",
join(",\n", map { " $_ => $tags->{ $_ }" } keys %$tags),
"\n}\n")
if $DEBUG;
# add all $tags keys to the end of the $order list, check they're
# all valid and remove duplicates
my %seen;
@$order = map {
# check each item in the order is a valid tag key
return $self->error("unknown tag specified in order: $_")
unless defined $tags->{ $_ };
# remove duplicates by ignoring tag keys we've already seen
$seen{$_}++ ? () : $_;
} @$order, keys %$tags;
$self->debug('order: ', join(', ', @$order), "\n") if $DEBUG;
# set tags and order internally
$self->{ tags } = $tags;
$self->{ order } = $order;
# look for the 'disabled' or 'enabled' flags in the config
# or assume the tag is enabled by default
if (defined $config->{ disabled }) {
$self->{ enabled } = $config->{ disabled } ? 0 : 1;
}
elsif (defined $config->{ enabled }) {
$self->{ enabled } = $config->{ enabled } ? 1 : 0;
}
else {
$self->{ enabled } = 1;
}
# call the order() method to compute the
return $self;
}
#------------------------------------------------------------------------
# tags() # return complete hash of tags
# tags($name) # return specific tag, e.g. 'foo' or 'foo.bar.baz'
# tags(\@name) # alternate name specification, e.g. ['foo', 'bar', 'baz']
#
# TODO: set new tag: tags($name => $tag)
#
# Accessor method to return details of tags defined within this tagset.
#------------------------------------------------------------------------
sub tags {
my $self = shift;
# return reference to tags hash if called without args
return $self->{ tags } unless @_;
# delete any cached tagset to ensure it is re-computed on next
# call to tagset(), given that the tags may have changed
delete $self->{ tagmap };
# $name argument can be a dotted, slashed or otherwise delimited
# string of nested tags (e.g. 'a.b.c', 'a/b/c' or 'a b c')
# or a reference to an array of such (e.g. ['a', 'b', 'c']).
my $name = shift;
$name = [ split(/\W+/, $name) ]
unless UNIVERSAL::isa($name, 'ARRAY');
$self->debug("tags() name: [ ", join(', ', @$name), " ]\n") if $DEBUG;
# resolve the first (possibly only) component of the name
my $key = shift @$name;
my $tag = $self->{ tags }->{ $key }
|| return $self->error("no such tag defined: $key");
$self->debug("tags() name $key => $tag\n") if $DEBUG;
# pass any remaining name components onto tags() method of matched
# $tag, or return $tag itself if the complete name is resolved
return @$name ? $tag->tags($name) : $tag;
}
#------------------------------------------------------------------------
# tagmap()
#
# Construct unified data set mapping out the tags in this tagset and any
# nested tagsets.
#------------------------------------------------------------------------
sub tagmap {
my $self = shift;
my $tagmap;
# if a tagset is passed in as an argument then we fill it with our
# details and pass it back, otherwise we return a cached copy of the
# tagmap from a previous call to tagmap() or we create a new one.
if (@_) {
# use tagmap passed as argument and delete any internal cache
$tagmap = shift;
delete $self->{ tagmap };
}
elsif ($self->{ tagmap }) {
# return previously cached copy of tagmap
return $self->{ tagmap };
}
else {
# create new tagmap and cache internally
$tagmap = $self->{ tagmap } = {
every_start => [ ], # list of start tokens for all tags
regex_start => [ ], # list of regex-based start tokens and tags
fixed_start => { }, # hash mapping fixed start tokens to tags
};
};
# if the tagset is enabled then call each tag contained within to
# contribute its tagset details, otherwise do nothing
if ($self->{ enabled }) {
foreach my $name (@{ $self->{ order } }) {
$self->debug("tagset asking $name for tagmap info\n") if $DEBUG;
my $tag = $self->{ tags }->{ $name }
|| return $self->error("invalid tag name in order: $name");
$tag->tagmap($tagmap)
|| return $self->error( "$name tag failed to provide tagmap info: ",
$tag->error() );
}
}
if ($self->{ tagmap }) {
# we created this tagmap so we're responsible for finalising
# it by merging the various start tokens/regexen into one
# combined regex to match them all.
my @regex = map {
UNIVERSAL::isa($_, 'Regexp') ? $_ : quotemeta($_);
} @{ $tagmap->{ every_start } };
my $regex = join( '|', @regex);
$tagmap->{ regex } = qr/ \G (.*?) ($regex) /sx;
$self->debug("tagmap regex: $regex\n") if $DEBUG;
}
return $tagmap;
}
#------------------------------------------------------------------------
# regex()
#
# Return a regular expression to match all the start tokens in the tagset.
#------------------------------------------------------------------------
sub regex {
my $self = shift;
# fetch cached tagmap or compute new one
my $tagmap = $self->{ tagmap } || $self->tagmap() || return;
return $tagmap->{ regex };
}
#------------------------------------------------------------------------
# match($token)
#
# Returns the tag which starts with the token passed as an argument.
# The token will be correctly matched with tags with defined regular
# expressions as start tokens, as well as those that define simple static
# strings.
#------------------------------------------------------------------------
sub match {
my ($self, $token) = @_;
# fetch cached tagmap or go off and compute it
my $tagmap = $self->{ tagmap } || $self->tagmap();
my $tag;
if ($tag = $tagmap->{ fixed_start }->{ $token }) {
return $tag;
}
else {
# if the start token doesn't directly correspond to a tag
# then we try each regex-based match in turn
$self->debug("matching '$token' against regexen\n") if $DEBUG;
foreach my $match (@{ $tagmap->{ regex_start } }) {
if ($token =~ $match->{ regex }) {
$self->debug("OK matched '$token' against $match->{ regex }\n")
if $DEBUG;
# create direct lookup entry for next time
return $tagmap->{ fixed_start }->{ $token } = $match->{ tag };
}
}
}
return $self->error("no tag matches start token: $token");
}
#------------------------------------------------------------------------
# enable()
# disable()
#
# Methods to enable or disable the tagset.
#------------------------------------------------------------------------
sub enable {
$_[0]->{ enabled } = 1;
return $_[0];
}
sub disable {
$_[0]->{ enabled } = 0;
return $_[0];
}
#------------------------------------------------------------------------
# enabled()
# disabled()
#
# Accessor method to determine if the tagset is enabled or disabled.
#------------------------------------------------------------------------
sub enabled {
return $_[0]->{ enabled };
}
sub disabled {
return $_[0]->{ enabled } ? 0 : 1;
}
#------------------------------------------------------------------------
# order()
#
# Return a reference to a list containing the tag names in the order in
# which they are used to construct a composite regex.
#------------------------------------------------------------------------
sub order {
return $_[0]->{ order };
}
#------------------------------------------------------------------------
# pkgtags()
#
# Return the $TAGS hash reference in the subclass package if defined, or
# in the base class package if not.
#------------------------------------------------------------------------
sub pkgtags {
my $self = shift;
return $self->pkgvar( TAGS => $TAGS );
}
1;
__END__
=head1 NAME
Template::Tagset - a collection of tag objects
=head1 SYNOPSIS
TODO: fix all these docs - spec has changed
Creating a tagset object:
use Template::TT3::Tagset;
my $tagsset = Template::TT3::Tagset->new({
tags => [
# tags can be hash arrays
{ name => 'ttdir', start => '[%', end => '%]' },
{ name => 'ttemb', start => '${', end => '}' },
{ name => 'ttvar', start => '$' },
{ name => 'ttpod', start => qr/(?m:^)=/ },
# and/or tag objects
My::First::Tag->new(),
My::Second::Tag->new(),
},
});
# fetch tag from tagset by name
$tag = $tagset->tag_named( 'ttdir' );
$tag = $tagset->tag( name => 'ttdir' ); # same
# fetch tag from tagset by start token
$tag = $tagset->tag_starting( '[%' );
$tag = $tagset->tag( start => '[%' );
# also works with tags that define regexes for start tokens
my $tag = $tagset->tag( start => '=head1 TITLE' ); # ttpod
# construct composite regex to match all start tokens
my $regex = $tagset->regex();
=head1 DESCRIPTION
# TODO
=head1 METHODS
=head2 new()
# TODO
=head1 AUTHOR
Andy Wardley E<lt>abw@wardley.orgE<gt>
=head1 VERSION
$Revision: 1.1 $
=head1 COPYRIGHT
Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved.
Copyright (C) 1998-2002 Canon Research Centre Europe Ltd.
Copyright (C) 2003-2004 Fotango Ltd.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
# Local Variables:
# mode: perl
# perl-indent-level: 4
# indent-tabs-mode: nil
# End:
#
# vim: expandtab shiftwidth=4: