diff options
| -rw-r--r-- | perllib/Template/Document.pm | 539 |
1 files changed, 539 insertions, 0 deletions
diff --git a/perllib/Template/Document.pm b/perllib/Template/Document.pm new file mode 100644 index 000000000..8fc66deea --- /dev/null +++ b/perllib/Template/Document.pm @@ -0,0 +1,539 @@ +##============================================================= -*-Perl-*- +# +# Template::Document +# +# DESCRIPTION +# Module defining a class of objects which encapsulate compiled +# templates, storing additional block definitions and metadata +# as well as the compiled Perl sub-routine representing the main +# template content. +# +# 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. +# +#============================================================================ + +package Template::Document; + +use strict; +use warnings; +use base 'Template::Base'; +use Template::Constants; + +our $VERSION = 2.79; +our $DEBUG = 0 unless defined $DEBUG; +our $ERROR = ''; +our ($COMPERR, $AUTOLOAD, $UNICODE); + +BEGIN { + # UNICODE is supported in versions of Perl from 5.008 onwards + if ($UNICODE = $] > 5.007 ? 1 : 0) { + if ($] > 5.008) { + # utf8::is_utf8() available from Perl 5.8.1 onwards + *is_utf8 = \&utf8::is_utf8; + } + elsif ($] == 5.008) { + # use Encode::is_utf8() for Perl 5.8.0 + require Encode; + *is_utf8 = \&Encode::is_utf8; + } + } +} + + +#======================================================================== +# ----- PUBLIC METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# new(\%document) +# +# Creates a new self-contained Template::Document object which +# encapsulates a compiled Perl sub-routine, $block, any additional +# BLOCKs defined within the document ($defblocks, also Perl sub-routines) +# and additional $metadata about the document. +#------------------------------------------------------------------------ + +sub new { + my ($class, $doc) = @_; + my ($block, $defblocks, $variables, $metadata) = @$doc{ qw( BLOCK DEFBLOCKS VARIABLES METADATA ) }; + $defblocks ||= { }; + $metadata ||= { }; + + # evaluate Perl code in $block to create sub-routine reference if necessary + unless (ref $block) { + local $SIG{__WARN__} = \&catch_warnings; + $COMPERR = ''; + + # DON'T LOOK NOW! - blindly untainting can make you go blind! + $block =~ /(.*)/s; + $block = $1; + + $block = eval $block; + return $class->error($@) + unless defined $block; + } + + # same for any additional BLOCK definitions + @$defblocks{ keys %$defblocks } = + # MORE BLIND UNTAINTING - turn away if you're squeamish + map { + ref($_) + ? $_ + : ( /(.*)/s && eval($1) or return $class->error($@) ) + } values %$defblocks; + + bless { + %$metadata, + _BLOCK => $block, + _DEFBLOCKS => $defblocks, + _VARIABLES => $variables, + _HOT => 0, + }, $class; +} + + +#------------------------------------------------------------------------ +# block() +# +# Returns a reference to the internal sub-routine reference, _BLOCK, +# that constitutes the main document template. +#------------------------------------------------------------------------ + +sub block { + return $_[0]->{ _BLOCK }; +} + + +#------------------------------------------------------------------------ +# blocks() +# +# Returns a reference to a hash array containing any BLOCK definitions +# from the template. The hash keys are the BLOCK nameand the values +# are references to Template::Document objects. Returns 0 (# an empty hash) +# if no blocks are defined. +#------------------------------------------------------------------------ + +sub blocks { + return $_[0]->{ _DEFBLOCKS }; +} + + +#----------------------------------------------------------------------- +# variables() +# +# Returns a reference to a hash of variables used in the template. +# This requires the TRACE_VARS option to be enabled. +#----------------------------------------------------------------------- + +sub variables { + return $_[0]->{ _VARIABLES }; +} + +#------------------------------------------------------------------------ +# process($context) +# +# Process the document in a particular context. Checks for recursion, +# registers the document with the context via visit(), processes itself, +# and then unwinds with a large gin and tonic. +#------------------------------------------------------------------------ + +sub process { + my ($self, $context) = @_; + my $defblocks = $self->{ _DEFBLOCKS }; + my $output; + + + # check we're not already visiting this template + return $context->throw(Template::Constants::ERROR_FILE, + "recursion into '$self->{ name }'") + if $self->{ _HOT } && ! $context->{ RECURSION }; ## RETURN ## + + $context->visit($self, $defblocks); + + $self->{ _HOT } = 1; + eval { + my $block = $self->{ _BLOCK }; + $output = &$block($context); + }; + $self->{ _HOT } = 0; + + $context->leave(); + + die $context->catch($@) + if $@; + + return $output; +} + + +#------------------------------------------------------------------------ +# AUTOLOAD +# +# Provides pseudo-methods for read-only access to various internal +# members. +#------------------------------------------------------------------------ + +sub AUTOLOAD { + my $self = shift; + my $method = $AUTOLOAD; + + $method =~ s/.*:://; + return if $method eq 'DESTROY'; +# my ($pkg, $file, $line) = caller(); +# print STDERR "called $self->AUTOLOAD($method) from $file line $line\n"; + return $self->{ $method }; +} + + +#======================================================================== +# ----- PRIVATE METHODS ----- +#======================================================================== + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which returns a string representing the internal state +# of the object. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $dblks; + my $output = "$self : $self->{ name }\n"; + + $output .= "BLOCK: $self->{ _BLOCK }\nDEFBLOCKS:\n"; + + if ($dblks = $self->{ _DEFBLOCKS }) { + foreach my $b (keys %$dblks) { + $output .= " $b: $dblks->{ $b }\n"; + } + } + + return $output; +} + + +#======================================================================== +# ----- CLASS METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# as_perl($content) +# +# This method expects a reference to a hash passed as the first argument +# containing 3 items: +# METADATA # a hash of template metadata +# BLOCK # string containing Perl sub definition for main block +# DEFBLOCKS # hash containing further subs for addional BLOCK defs +# It returns a string containing Perl code which, when evaluated and +# executed, will instantiate a new Template::Document object with the +# above data. On error, it returns undef with an appropriate error +# message set in $ERROR. +#------------------------------------------------------------------------ + +sub as_perl { + my ($class, $content) = @_; + my ($block, $defblocks, $metadata) = @$content{ qw( BLOCK DEFBLOCKS METADATA ) }; + + #$block =~ s/\n(?!#line)/\n /g; + $block =~ s/\s+$//; + + $defblocks = join('', map { + my $code = $defblocks->{ $_ }; + # $code =~ s/\n(?!#line)/\n /g; + $code =~ s/\s*$//; + " '$_' => $code,\n"; + } keys %$defblocks); + $defblocks =~ s/\s+$//; + + $metadata = join('', map { + my $x = $metadata->{ $_ }; + $x =~ s/(['\\])/\\$1/g; + " '$_' => '$x',\n"; + } keys %$metadata); + $metadata =~ s/\s+$//; + + return <<EOF +#------------------------------------------------------------------------ +# Compiled template generated by the Template Toolkit version $Template::VERSION +#------------------------------------------------------------------------ + +$class->new({ + METADATA => { +$metadata + }, + BLOCK => $block, + DEFBLOCKS => { +$defblocks + }, +}); +EOF +} + + +#------------------------------------------------------------------------ +# write_perl_file($filename, \%content) +# +# This method calls as_perl() to generate the Perl code to represent a +# compiled template with the content passed as the second argument. +# It then writes this to the file denoted by the first argument. +# +# Returns 1 on success. On error, sets the $ERROR package variable +# to contain an error message and returns undef. +#------------------------------------------------------------------------ + +sub write_perl_file { + my ($class, $file, $content) = @_; + my ($fh, $tmpfile); + + return $class->error("invalid filename: $file") + unless $file =~ /^(.+)$/s; + + eval { + require File::Temp; + require File::Basename; + ($fh, $tmpfile) = File::Temp::tempfile( + DIR => File::Basename::dirname($file) + ); + my $perlcode = $class->as_perl($content) || die $!; + + if ($UNICODE && is_utf8($perlcode)) { + $perlcode = "use utf8;\n\n$perlcode"; + binmode $fh, ":utf8"; + } + print $fh $perlcode; + close($fh); + }; + return $class->error($@) if $@; + return rename($tmpfile, $file) + || $class->error($!); +} + + +#------------------------------------------------------------------------ +# catch_warnings($msg) +# +# Installed as +#------------------------------------------------------------------------ + +sub catch_warnings { + $COMPERR .= join('', @_); +} + + +1; + +__END__ + +=head1 NAME + +Template::Document - Compiled template document object + +=head1 SYNOPSIS + + use Template::Document; + + $doc = Template::Document->new({ + BLOCK => sub { # some perl code; return $some_text }, + DEFBLOCKS => { + header => sub { # more perl code; return $some_text }, + footer => sub { # blah blah blah; return $some_text }, + }, + METADATA => { + author => 'Andy Wardley', + version => 3.14, + } + }) || die $Template::Document::ERROR; + + print $doc->process($context); + +=head1 DESCRIPTION + +This module defines an object class whose instances represent compiled +template documents. The L<Template::Parser> module creates a +C<Template::Document> instance to encapsulate a template as it is compiled +into Perl code. + +The constructor method, L<new()>, expects a reference to a hash array +containing the C<BLOCK>, C<DEFBLOCKS> and C<METADATA> items. + +The C<BLOCK> item should contain a reference to a Perl subroutine or a textual +representation of Perl code, as generated by the L<Template::Parser> module. +This is then evaluated into a subroutine reference using C<eval()>. + +The C<DEFLOCKS> item should reference a hash array containing further named +C<BLOCK>s which may be defined in the template. The keys represent C<BLOCK> +names and the values should be subroutine references or text strings of Perl +code as per the main C<BLOCK> item. + +The C<METADATA> item should reference a hash array of metadata items relevant +to the document. + +The L<process()> method can then be called on the instantiated +C<Template::Document> object, passing a reference to a L<Template::Context> +object as the first parameter. This will install any locally defined blocks +(C<DEFBLOCKS>) in the C<BLOCKS> cache in the context (via a call to +L<visit()|Template::Context#visit()>) so that they may be subsequently +resolved by the context. The main C<BLOCK> subroutine is then executed, +passing the context reference on as a parameter. The text returned from the +template subroutine is then returned by the L<process()> method, after calling +the context L<leave()|Template::Context#leave()> method to permit cleanup and +de-registration of named C<BLOCKS> previously installed. + +An C<AUTOLOAD> method provides access to the C<METADATA> items for the +document. The L<Template::Service> module installs a reference to the main +C<Template::Document> object in the stash as the C<template> variable. This allows +metadata items to be accessed from within templates, including C<PRE_PROCESS> +templates. + +header: + + <html> + <head> + <title>[% template.title %] + </head> + ... + +C<Template::Document> objects are usually created by the L<Template::Parser> +but can be manually instantiated or sub-classed to provide custom +template components. + +=head1 METHODS + +=head2 new(\%config) + +Constructor method which accept a reference to a hash array containing the +structure as shown in this example: + + $doc = Template::Document->new({ + BLOCK => sub { # some perl code; return $some_text }, + DEFBLOCKS => { + header => sub { # more perl code; return $some_text }, + footer => sub { # blah blah blah; return $some_text }, + }, + METADATA => { + author => 'Andy Wardley', + version => 3.14, + } + }) || die $Template::Document::ERROR; + +C<BLOCK> and C<DEFBLOCKS> items may be expressed as references to Perl subroutines +or as text strings containing Perl subroutine definitions, as is generated +by the L<Template::Parser> module. These are evaluated into subroutine references +using C<eval()>. + +Returns a new C<Template::Document> object or C<undef> on error. The +L<error()|Template::Base#error()> class method can be called, or the C<$ERROR> +package variable inspected to retrieve the relevant error message. + +=head2 process($context) + +Main processing routine for the compiled template document. A reference to a +L<Template::Context> object should be passed as the first parameter. The +method installs any locally defined blocks via a call to the context +L<visit()|Template::Context#visit()> method, processes its own template, +(passing the context reference as a parameter) and then calls +L<leave()|Template::Context#leave()> in the context to allow cleanup. + + print $doc->process($context); + +Returns a text string representing the generated output for the template. +Errors are thrown via C<die()>. + +=head2 block() + +Returns a reference to the main C<BLOCK> subroutine. + +=head2 blocks() + +Returns a reference to the hash array of named C<DEFBLOCKS> subroutines. + +=head2 variables() + +Returns a reference to a hash of variables used in the template. +This requires the L<TRACE_VARS|Template::Manual::Config#TRACE_VARS> +option to be enabled. + +=head2 AUTOLOAD + +An autoload method returns C<METADATA> items. + + print $doc->author(); + +=head1 CLASS METHODS + +These methods are used internally. + +=head2 as_perl($content) + +This method generate a Perl representation of the template. + + my $perl = Template::Document->as_perl({ + BLOCK => $main_block, + DEFBLOCKS => { + foo => $foo_block, + bar => $bar_block, + }, + METADATA => { + name => 'my_template', + } + }); + +=head2 write_perl_file(\%config) + +This method is used to write compiled Perl templates to disk. If the +C<COMPILE_EXT> option (to indicate a file extension for saving compiled +templates) then the L<Template::Parser> module calls this subroutine before +calling the L<new()> constructor. At this stage, the parser has a +representation of the template as text strings containing Perl code. We can +write that to a file, enclosed in a small wrapper which will allow us to +susequently C<require()> the file and have Perl parse and compile it into a +C<Template::Document>. Thus we have persistence of compiled templates. + +=head1 INTERNAL FUNCTIONS + +=head2 catch_warnings() + +This is a simple handler used to catch any errors that arise when the +compiled Perl template is first evaluated (that is, evaluated by Perl to +create a template subroutine at compile, rather than the template being +processed at runtime). + +=head2 is_utf8() + +This is mapped to C<utf8::is_utf8> for versions of Perl that have it (> 5.008) +or to C<Encode::is_utf8> for Perl 5.008. Earlier versions of Perl are not +supported. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> + +=head1 COPYRIGHT + +Copyright (C) 1996-2012 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. + +=head1 SEE ALSO + +L<Template>, L<Template::Parser> + +=cut + +# Local Variables: +# mode: perl +# perl-indent-level: 4 +# indent-tabs-mode: nil +# End: +# +# vim: expandtab shiftwidth=4: |