--- /dev/null
+package CGI::Ex::Template::Extra;
+
+=head1 NAME
+
+CGI::Ex::Template::Extra - load extra and advanced features that aren't as commonly used
+
+=head1 DESCRIPTION
+
+Provides for extra or extended features that may not be as commonly used.
+This module should not normally be used by itself.
+
+=head1 AUTHOR
+
+Paul Seamons <paul at seamons dot com>
+
+=head1 LICENSE
+
+This module may be distributed under the same terms as Perl itself.
+
+=cut
+
+use strict;
+use warnings;
+
+our $VERSION = '2.13';
+
+sub parse_CONFIG {
+ my ($self, $str_ref) = @_;
+
+ my %ctime = map {$_ => 1} @CGI::Ex::Template::CONFIG_COMPILETIME;
+ my %rtime = map {$_ => 1} @CGI::Ex::Template::CONFIG_RUNTIME;
+
+ my $config = $self->parse_args($str_ref, {named_at_front => 1, is_parened => 1});
+ my $ref = $config->[0]->[0];
+ for (my $i = 2; $i < @$ref; $i += 2) {
+ my $key = $ref->[$i] = uc $ref->[$i];
+ my $val = $ref->[$i + 1];
+ if ($ctime{$key}) {
+ $self->{$key} = $self->play_expr($val);
+ } elsif (! $rtime{$key}) {
+ $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
+ }
+ }
+ for (my $i = 1; $i < @$config; $i++) {
+ my $key = $config->[$i] = uc $config->[$i]->[0];
+ if ($ctime{$key}) {
+ $config->[$i] = "CONFIG $key = ".(defined($self->{$key}) ? $self->{$key} : 'undef');
+ } elsif (! $rtime{$key}) {
+ $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
+ }
+ }
+ return $config;
+}
+
+sub play_CONFIG {
+ my ($self, $config, $node, $out_ref) = @_;
+
+ my %rtime = map {$_ => 1} @CGI::Ex::Template::CONFIG_RUNTIME;
+
+ ### do runtime config - not many options get these
+ my ($named, @the_rest) = @$config;
+ $named = $self->play_expr($named);
+ @{ $self }{keys %$named} = @{ $named }{keys %$named};
+
+ ### show what current values are
+ $$out_ref .= join("\n", map { $rtime{$_} ? ("CONFIG $_ = ".(defined($self->{$_}) ? $self->{$_} : 'undef')) : $_ } @the_rest);
+ return;
+}
+
+sub parse_DEBUG {
+ my ($self, $str_ref) = @_;
+ $$str_ref =~ m{ \G ([Oo][Nn] | [Oo][Ff][Ff] | [Ff][Oo][Rr][Mm][Aa][Tt]) \s* }gcx
+ || $self->throw('parse', "Unknown DEBUG option", undef, pos($$str_ref));
+ my $ret = [lc($1)];
+ if ($ret->[0] eq 'format') {
+ $$str_ref =~ m{ \G ([\"\']) (|.*?[^\\]) \1 \s* }gcxs
+ || $self->throw('parse', "Missing format string", undef, pos($$str_ref));
+ $ret->[1] = $2;
+ }
+ return $ret;
+}
+
+sub play_DEBUG {
+ my ($self, $ref) = @_;
+ if ($ref->[0] eq 'on') {
+ delete $self->{'_debug_off'};
+ } elsif ($ref->[0] eq 'off') {
+ $self->{'_debug_off'} = 1;
+ } elsif ($ref->[0] eq 'format') {
+ $self->{'_debug_format'} = $ref->[1];
+ }
+ return;
+}
+
+sub play_DUMP {
+ my ($self, $dump, $node, $out_ref) = @_;
+
+ my $conf = $self->{'DUMP'};
+ return if ! $conf && defined $conf; # DUMP => 0
+ $conf = {} if ref $conf ne 'HASH';
+
+ ### allow for handler override
+ my $handler = $conf->{'handler'};
+ if (! $handler) {
+ require Data::Dumper;
+ my $obj = Data::Dumper->new([]);
+ my $meth;
+ foreach my $prop (keys %$conf) { $obj->$prop($conf->{$prop}) if $prop =~ /^\w+$/ && ($meth = $obj->can($prop)) }
+ my $sort = defined($conf->{'Sortkeys'}) ? $obj->Sortkeys : 1;
+ $obj->Sortkeys(sub { my $h = shift; [grep {$_ !~ $CGI::Ex::Template::QR_PRIVATE} ($sort ? sort keys %$h : keys %$h)] });
+ $handler = sub { $obj->Values([@_]); $obj->Dump }
+ }
+
+ my ($named, @dump) = @$dump;
+ push @dump, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some
+ $_ = $self->play_expr($_) foreach @dump;
+
+ ### look for the text describing what to dump
+ my $info = $self->node_info($node);
+ my $out;
+ if (@dump) {
+ $out = $handler->(@dump && @dump == 1 ? $dump[0] : \@dump);
+ my $name = $info->{'text'};
+ $name =~ s/^[+=~-]?\s*DUMP\s+//;
+ $name =~ s/\s*[+=~-]?$//;
+ $out =~ s/\$VAR1/$name/;
+ } elsif (defined($conf->{'EntireStash'}) && ! $conf->{'EntireStash'}) {
+ $out = '';
+ } else {
+ $out = $handler->($self->{'_vars'});
+ $out =~ s/\$VAR1/EntireStash/g;
+ }
+
+ if ($conf->{'html'} || (! defined($conf->{'html'}) && $ENV{'REQUEST_METHOD'})) {
+ $out = $CGI::Ex::Template::SCALAR_OPS->{'html'}->($out);
+ $out = "<pre>$out</pre>";
+ $out = "<b>DUMP: File \"$info->{file}\" line $info->{line}</b>$out" if $conf->{'header'} || ! defined $conf->{'header'};
+ } else {
+ $out = "DUMP: File \"$info->{file}\" line $info->{line}\n $out" if $conf->{'header'} || ! defined $conf->{'header'};
+ }
+
+ $$out_ref .= $out;
+ return;
+}
+
+sub parse_FILTER {
+ my ($self, $str_ref) = @_;
+ my $name = '';
+ if ($$str_ref =~ m{ \G ([^\W\d]\w*) \s* = \s* }gcx) {
+ $name = $1;
+ }
+
+ my $filter = $self->parse_expr($str_ref);
+ $filter = '' if ! defined $filter;
+
+ return [$name, $filter];
+}
+
+sub play_FILTER {
+ my ($self, $ref, $node, $out_ref) = @_;
+ my ($name, $filter) = @$ref;
+
+ return '' if ! @$filter;
+
+ $self->{'FILTERS'}->{$name} = $filter if length $name;
+
+ my $sub_tree = $node->[4];
+
+ ### play the block
+ my $out = '';
+ eval { $self->execute_tree($sub_tree, \$out) };
+ die $@ if $@ && ref($@) !~ /Template::Exception$/;
+
+ my $var = [[undef, '~', $out], 0, '|', @$filter]; # make a temporary var out of it
+
+ return $CGI::Ex::Template::DIRECTIVES->{'GET'}->[1]->($self, $var, $node, $out_ref);
+}
+
+sub parse_LOOP {
+ my ($self, $str_ref, $node) = @_;
+ return $self->parse_expr($str_ref)
+ || $self->throw('parse', 'Missing variable on LOOP directive', undef, pos($$str_ref));
+}
+
+sub play_LOOP {
+ my ($self, $ref, $node, $out_ref) = @_;
+
+ my $var = $self->play_expr($ref);
+ my $sub_tree = $node->[4];
+
+ my $global = ! $self->{'SYNTAX'} || $self->{'SYNTAX'} ne 'ht' || $self->{'GLOBAL_VARS'};
+
+ my $items = ref($var) eq 'ARRAY' ? $var : ! defined($var) ? [] : [$var];
+
+ my $i = 0;
+ for my $ref (@$items) {
+ ### setup the loop
+ $self->throw('loop', 'Scalar value used in LOOP') if $ref && ref($ref) ne 'HASH';
+ local $self->{'_vars'} = (! $global) ? ($ref || {}) : (ref($ref) eq 'HASH') ? {%{ $self->{'_vars'} }, %$ref} : $self->{'_vars'};
+ if ($self->{'LOOP_CONTEXT_VARS'} && ! $CGI::Ex::Template::QR_PRIVATE) {
+ $self->{'_vars'}->{'__counter__'} = ++$i;
+ $self->{'_vars'}->{'__first__'} = $i == 1 ? 1 : 0;
+ $self->{'_vars'}->{'__last__'} = $i == @$items ? 1 : 0;
+ $self->{'_vars'}->{'__inner__'} = $i == 1 || $i == @$items ? 0 : 1;
+ $self->{'_vars'}->{'__odd__'} = ($i % 2) ? 1 : 0;
+ }
+
+ ### execute the sub tree
+ eval { $self->execute_tree($sub_tree, $out_ref) };
+ if (my $err = $@) {
+ if (UNIVERSAL::isa($err, $CGI::Ex::Template::PACKAGE_EXCEPTION)) {
+ next if $err->type eq 'next';
+ last if $err->type =~ /last|break/;
+ }
+ die $err;
+ }
+ }
+
+ return;
+}
+
+sub parse_MACRO {
+ my ($self, $str_ref, $node) = @_;
+
+ my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $CGI::Ex::Template::QR_COMMENTS"});
+ $self->throw('parse', "Missing macro name", undef, pos($$str_ref)) if ! defined $name;
+ if (! ref $name) {
+ $name = [ $name, 0 ];
+ }
+
+ my $args;
+ if ($$str_ref =~ m{ \G \( \s* }gcx) {
+ $args = $self->parse_args($str_ref, {positional_only => 1});
+ $$str_ref =~ m{ \G \) \s* }gcx || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
+ }
+
+ $node->[6] = 1; # set a flag to keep parsing
+ return [$name, $args];
+}
+
+sub play_MACRO {
+ my ($self, $ref, $node, $out_ref) = @_;
+ my ($name, $args) = @$ref;
+
+ ### get the sub tree
+ my $sub_tree = $node->[4];
+ if (! $sub_tree || ! $sub_tree->[0]) {
+ $self->set_variable($name, undef);
+ return;
+ } elsif ($sub_tree->[0]->[0] eq 'BLOCK') {
+ $sub_tree = $sub_tree->[0]->[4];
+ }
+
+ my $self_copy = $self;
+ eval {require Scalar::Util; Scalar::Util::weaken($self_copy)};
+
+ ### install a closure in the stash that will handle the macro
+ $self->set_variable($name, sub {
+ ### macros localize
+ my $copy = $self_copy->{'_vars'};
+ local $self_copy->{'_vars'}= {%$copy};
+
+ ### prevent recursion
+ local $self_copy->{'_macro_recurse'} = $self_copy->{'_macro_recurse'} || 0;
+ my $max = $self_copy->{'MAX_MACRO_RECURSE'} || $CGI::Ex::Template::MAX_MACRO_RECURSE;
+ $self_copy->throw('macro_recurse', "MAX_MACRO_RECURSE $max reached")
+ if ++$self_copy->{'_macro_recurse'} > $max;
+
+ ### set arguments
+ my $named = pop(@_) if $_[-1] && UNIVERSAL::isa($_[-1],'HASH') && $#_ > $#$args;
+ my @positional = @_;
+ foreach my $var (@$args) {
+ $self_copy->set_variable($var, shift(@positional));
+ }
+ foreach my $name (sort keys %$named) {
+ $self_copy->set_variable([$name, 0], $named->{$name});
+ }
+
+ ### finally - run the sub tree
+ my $out = '';
+ $self_copy->execute_tree($sub_tree, \$out);
+ return $out;
+ });
+
+ return;
+}
+
+sub play_PERL {
+ my ($self, $info, $node, $out_ref) = @_;
+ $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
+
+ ### fill in any variables
+ my $perl = $node->[4] || return;
+ my $out = '';
+ $self->execute_tree($perl, \$out);
+ $out = $1 if $out =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
+
+ ### try the code
+ my $err;
+ eval {
+ package CGI::Ex::Template::Perl;
+
+ my $context = $self->context;
+ my $stash = $context->stash;
+
+ ### setup a fake handle
+ local *PERLOUT;
+ tie *PERLOUT, 'CGI::Ex::Template::EvalPerlHandle', $out_ref;
+ my $old_fh = select PERLOUT;
+
+ eval $out;
+ $err = $@;
+
+ ### put the handle back
+ select $old_fh;
+
+ };
+ $err ||= $@;
+
+
+ if ($err) {
+ $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+
+ return;
+}
+
+sub play_RAWPERL {
+ my ($self, $info, $node, $out_ref) = @_;
+ $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
+
+ ### fill in any variables
+ my $tree = $node->[4] || return;
+ my $perl = '';
+ $self->execute_tree($tree, \$perl);
+ $perl = $1 if $perl =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
+
+ ### try the code
+ my $err;
+ my $output = '';
+ eval {
+ package CGI::Ex::Template::Perl;
+
+ my $context = $self->context;
+ my $stash = $context->stash;
+
+ eval $perl;
+ $err = $@;
+ };
+ $err ||= $@;
+
+ $$out_ref .= $output;
+
+ if ($err) {
+ $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+
+ return;
+}
+
+sub parse_USE {
+ my ($self, $str_ref) = @_;
+
+ my $QR_COMMENTS = $CGI::Ex::Template::QR_COMMENTS;
+
+ my $var;
+ my $mark = pos $$str_ref;
+ if (defined(my $_var = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))
+ && ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo # make sure there is assignment
+ || ((pos($$str_ref) = $mark) && 0)) # otherwise we need to rollback
+ ) {
+ $var = $_var;
+ }
+
+ my $module = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: (?:\\.|::) \\w+\\b)*) (?! \\.) \\s* $QR_COMMENTS"});
+ $self->throw('parse', "Missing plugin name while parsing $$str_ref", undef, pos($$str_ref)) if ! defined $module;
+ $module =~ s/\./::/g;
+
+ my $args;
+ my $open = $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo;
+ $args = $self->parse_args($str_ref, {is_parened => $open, named_at_front => 1});
+
+ if ($open) {
+ $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
+ }
+
+ return [$var, $module, $args];
+}
+
+sub play_USE {
+ my ($self, $ref, $node, $out_ref) = @_;
+ my ($var, $module, $args) = @$ref;
+
+ ### get the stash storage location - default to the module
+ $var = $module if ! defined $var;
+ my @var = map {($_, 0, '.')} split /(?:\.|::)/, $var;
+ pop @var; # remove the trailing '.'
+
+ my ($named, @args) = @$args;
+ push @args, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some
+
+ ### look for a plugin_base
+ my $BASE = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
+ my $obj;
+
+ foreach my $base (ref($BASE) eq 'ARRAY' ? @$BASE : $BASE) {
+ my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
+ : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
+ : "${base}::${module}";
+ my $require = "$package.pm";
+ $require =~ s|::|/|g;
+
+ ### try and load the module - fall back to bare module if allowed
+ if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
+ my $shape = $package->load;
+ my $context = $self->context;
+ $obj = $shape->new($context, map { $self->play_expr($_) } @args);
+ } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine)
+ $obj = $self->iterator($args[0]);
+ } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) {
+ foreach my $package (@packages) {
+ my $require = "$package.pm";
+ $require =~ s|::|/|g;
+ eval {require $require} || next;
+ my $shape = $package->load;
+ my $context = $self->context;
+ $obj = $shape->new($context, map { $self->play_expr($_) } @args);
+ }
+ } elsif ($self->{'LOAD_PERL'}) {
+ my $require = "$module.pm";
+ $require =~ s|::|/|g;
+ if (eval {require $require}) {
+ $obj = $module->new(map { $self->play_expr($_) } @args);
+ }
+ }
+ }
+ if (! defined $obj) {
+ my $err = "$module: plugin not found";
+ $self->throw('plugin', $err);
+ }
+
+ ### all good
+ $self->set_variable(\@var, $obj);
+
+ return;
+}
+
+sub parse_VIEW {
+ my ($self, $str_ref) = @_;
+
+ my $ref = $self->parse_args($str_ref, {
+ named_at_front => 1,
+ require_arg => 1,
+ });
+
+ return $ref;
+}
+
+sub play_VIEW {
+ my ($self, $ref, $node, $out_ref) = @_;
+
+ my ($blocks, $args, $name) = @$ref;
+
+ ### get args ready
+ # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0]
+ $args = $args->[0];
+ my $hash = {};
+ foreach (my $i = 2; $i < @$args; $i+=2) {
+ my $key = $args->[$i];
+ my $val = $self->play_expr($args->[$i+1]);
+ if (ref $key) {
+ if (@$key == 2 && ! ref($key->[0]) && ! $key->[1]) {
+ $key = $key->[0];
+ } else {
+ $self->set_variable($key, $val);
+ next; # what TT does
+ }
+ }
+ $hash->{$key} = $val;
+ }
+
+ ### prepare the blocks
+ my $prefix = $hash->{'prefix'} || (ref($name) && @$name == 2 && ! $name->[1] && ! ref($name->[0])) ? "$name->[0]/" : '';
+ foreach my $key (keys %$blocks) {
+ $blocks->{$key} = {name => "${prefix}${key}", _tree => $blocks->{$key}};
+ }
+ $hash->{'blocks'} = $blocks;
+
+ ### get the view
+ if (! eval { require Template::View }) {
+ $self->throw('view', 'Could not load Template::View library');
+ }
+ my $view = Template::View->new($self->context, $hash)
+ || $self->throw('view', $Template::View::ERROR);
+
+ ### 'play it'
+ my $old_view = $self->play_expr(['view', 0]);
+ $self->set_variable($name, $view);
+ $self->set_variable(['view', 0], $view);
+
+ if ($node->[4]) {
+ my $out = '';
+ $self->execute_tree($node->[4], \$out);
+ # throw away $out
+ }
+
+ $self->set_variable(['view', 0], $old_view);
+ $view->seal;
+
+ return;
+}
+
+###----------------------------------------------------------------###
+
+sub list_plugins {
+ my $self = shift;
+ my $args = shift || {};
+ my $base = $args->{'base'} || '';
+
+ return $self->{'_plugins'}->{$base} ||= do {
+ my @plugins;
+
+ $base =~ s|::|/|g;
+ my @dirs = grep {-d $_} map {"$_/$base"} @INC;
+
+ foreach my $dir (@dirs) {
+ require File::Find;
+ File::Find::find(sub {
+ my $mod = $base .'/'. ($File::Find::name =~ m|^ $dir / (.*\w) \.pm $|x ? $1 : return);
+ $mod =~ s|/|::|g;
+ push @plugins, $mod;
+ }, $dir);
+ }
+
+ \@plugins; # return of the do
+ };
+}
+
+###----------------------------------------------------------------###
+
+package CGI::Ex::Template::Context;
+
+use vars qw($AUTOLOAD);
+
+sub new {
+ my $class = shift;
+ my $self = shift || {};
+ die "Missing _template" if ! $self->{'_template'};
+ return bless $self, $class;
+}
+
+sub _template { shift->{'_template'} || die "Missing _template" }
+
+sub template {
+ my ($self, $name) = @_;
+ return $self->_template->{'BLOCKS'}->{$name} || $self->_template->load_parsed_tree($name);
+}
+
+sub config { shift->_template }
+
+sub stash {
+ my $self = shift;
+ return $self->{'stash'} ||= bless {_template => $self->_template}, 'CGI::Ex::Template::_Stash';
+}
+
+sub insert { shift->_template->_insert(@_) }
+
+sub eval_perl { shift->_template->{'EVAL_PERL'} }
+
+sub process {
+ my $self = shift;
+ my $ref = shift;
+ my $args = shift || {};
+
+ $self->_template->set_variable($_, $args->{$_}) for keys %$args;
+
+ my $out = '';
+ $self->_template->_process($ref, $self->_template->_vars, \$out);
+ return $out;
+}
+
+sub include {
+ my $self = shift;
+ my $ref = shift;
+ my $args = shift || {};
+
+ my $t = $self->_template;
+
+ my $swap = $t->{'_vars'};
+ local $t->{'_vars'} = {%$swap};
+
+ $t->set_variable($_, $args->{$_}) for keys %$args;
+
+ my $out = ''; # have temp item to allow clear to correctly clear
+ eval { $t->_process($ref, $t->_vars, \$out) };
+ if (my $err = $@) {
+ die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/;
+ }
+
+ return $out;
+}
+
+sub define_filter {
+ my ($self, $name, $filter, $is_dynamic) = @_;
+ $filter = [ $filter, 1 ] if $is_dynamic;
+ $self->define_vmethod('filter', $name, $filter);
+}
+
+sub filter {
+ my ($self, $name, $args, $alias) = @_;
+ my $t = $self->_template;
+
+ my $filter;
+ if (! ref $name) {
+ $filter = $t->{'FILTERS'}->{$name} || $CGI::Ex::Template::FILTER_OPS->{$name} || $CGI::Ex::Template::SCALAR_OPS->{$name};
+ $t->throw('filter', $name) if ! $filter;
+ } elsif (UNIVERSAL::isa($name, 'CODE') || UNIVERSAL::isa($name, 'ARRAY')) {
+ $filter = $name;
+ } elsif (UNIVERSAL::can($name, 'factory')) {
+ $filter = $name->factory || $t->throw($name->error);
+ } else {
+ $t->throw('undef', "$name: filter not found");
+ }
+
+ if (UNIVERSAL::isa($filter, 'ARRAY')) {
+ $filter = ($filter->[1]) ? $filter->[0]->($t->context, @$args) : $filter->[0];
+ } elsif ($args && @$args) {
+ my $sub = $filter;
+ $filter = sub { $sub->(shift, @$args) };
+ }
+
+ $t->{'FILTERS'}->{$alias} = $filter if $alias;
+
+ return $filter;
+}
+
+sub define_vmethod { shift->_template->define_vmethod(@_) }
+
+sub throw {
+ my ($self, $type, $info) = @_;
+
+ if (UNIVERSAL::isa($type, $CGI::Ex::Template::PACKAGE_EXCEPTION)) {
+ die $type;
+ } elsif (defined $info) {
+ $self->_template->throw($type, $info);
+ } else {
+ $self->_template->throw('undef', $type);
+ }
+}
+
+sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
+
+sub DESTROY {}
+
+###----------------------------------------------------------------###
+
+package CGI::Ex::Template::_Stash;
+
+use vars qw($AUTOLOAD);
+
+sub _template { shift->{'_template'} || die "Missing _template" }
+
+sub get {
+ my ($self, $var) = @_;
+ if (! ref $var) {
+ if ($var =~ /^\w+$/) { $var = [$var, 0] }
+ else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) }
+ }
+ return $self->_template->play_expr($var, {no_dots => 1});
+}
+
+sub set {
+ my ($self, $var, $val) = @_;
+ if (! ref $var) {
+ if ($var =~ /^\w+$/) { $var = [$var, 0] }
+ else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) }
+ }
+ $self->_template->set_variable($var, $val, {no_dots => 1});
+ return $val;
+}
+
+sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
+
+sub DESTROY {}
+
+###----------------------------------------------------------------###
+
+package CGI::Ex::Template::EvalPerlHandle;
+
+sub TIEHANDLE {
+ my ($class, $out_ref) = @_;
+ return bless [$out_ref], $class;
+}
+
+sub PRINT {
+ my $self = shift;
+ ${ $self->[0] } .= $_ for grep {defined && length} @_;
+ return 1;
+}
+
+###----------------------------------------------------------------###
+
+1;
projects / chaz / p5-CGI-Ex / blobdiff