- ($item, $error) = $items->get_next;
- }
- die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
- }
-
- return undef;
-}
-
-sub parse_GET {
- my ($self, $str_ref) = @_;
- my $ref = $self->parse_expr($str_ref);
- $self->throw('parse', "Missing variable name", undef, pos($$str_ref)) if ! defined $ref;
- return $ref;
-}
-
-sub play_GET {
- my ($self, $ident, $node) = @_;
- my $var = $self->play_expr($ident);
- return (! defined $var) ? $self->undefined_get($ident, $node) : $var;
-}
-
-sub parse_IF {
- my ($self, $str_ref) = @_;
- return $self->parse_expr($str_ref);
-}
-
-sub play_IF {
- my ($self, $var, $node, $out_ref) = @_;
-
- my $val = $self->play_expr($var);
- if ($val) {
- my $body_ref = $node->[4] ||= [];
- $self->execute_tree($body_ref, $out_ref);
- return;
- }
-
- while ($node = $node->[5]) { # ELSE, ELSIF's
- if ($node->[0] eq 'ELSE') {
- my $body_ref = $node->[4] ||= [];
- $self->execute_tree($body_ref, $out_ref);
- return;
- }
- my $var = $node->[3];
- my $val = $self->play_expr($var);
- if ($val) {
- my $body_ref = $node->[4] ||= [];
- $self->execute_tree($body_ref, $out_ref);
- return;
- }
- }
- return;
-}
-
-sub parse_INCLUDE { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
-
-sub play_INCLUDE {
- my ($self, $str_ref, $node, $out_ref) = @_;
-
- ### localize the swap
- my $swap = $self->{'_vars'};
- local $self->{'_vars'} = {%$swap};
-
- ### localize the blocks
- my $blocks = $self->{'BLOCKS'};
- local $self->{'BLOCKS'} = {%$blocks};
-
- my $str = $DIRECTIVES->{'PROCESS'}->[1]->($self, $str_ref, $node, $out_ref);
-
- return $str;
-}
-
-sub parse_INSERT { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
-
-sub play_INSERT {
- my ($self, $args, $node, $out_ref) = @_;
-
- my ($named, @files) = @$args;
-
- foreach my $name (@files) {
- my $filename = $self->play_expr($name);
- $$out_ref .= $self->_insert($filename);
- }
-
- return;
-}
-
-sub parse_MACRO {
- my ($self, $str_ref, $node) = @_;
-
- my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $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;
- $self_copy->throw('macro_recurse', "MAX_MACRO_RECURSE $MAX_MACRO_RECURSE reached")
- if ++$self_copy->{'_macro_recurse'} > ($self_copy->{'MAX_MACRO_RECURSE'} || $MAX_MACRO_RECURSE);
-
-
- ### 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_META {
- my ($self, $hash) = @_;
-
- my @keys = keys %$hash;
-
- my $ref;
- if ($self->{'_top_level'}) {
- $ref = $self->{'_template'} ||= {};
- } else {
- $ref = $self->{'_component'} ||= {};
- }
-
- @{ $ref }{ @keys } = @{ $hash }{ @keys };
- return;
-}
-
-sub parse_PERL { shift->{'_in_perl'} = 1; 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::PACKAGE_PERL_HANDLE, $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 parse_PROCESS {
- my ($self, $str_ref) = @_;
-
- return $self->parse_args($str_ref, {
- named_at_front => 1,
- allow_bare_filenames => 1,
- require_arg => 1,
- });
-}
-
-sub play_PROCESS {
- my ($self, $info, $node, $out_ref) = @_;
-
- my ($args, @files) = @$info;
-
- ### set passed args
- # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0]
- $args = $args->[0];
- foreach (my $i = 2; $i < @$args; $i+=2) {
- my $key = $args->[$i];
- my $val = $self->play_expr($args->[$i+1]);
- if (ref($key) && @$key == 2 && $key->[0] eq 'import' && UNIVERSAL::isa($val, 'HASH')) { # import ?! - whatever
- foreach my $key (keys %$val) {
- $self->set_variable([$key,0], $val->{$key});
- }
- next;
- }
- $self->set_variable($key, $val);
- }
-
- ### iterate on any passed block or filename
- foreach my $ref (@files) {
- next if ! defined $ref;
- my $filename = $self->play_expr($ref);
- my $out = ''; # have temp item to allow clear to correctly clear
-
- ### normal blocks or filenames
- if (! ref $filename) {
- eval { $self->_process($filename, $self->{'_vars'}, \$out) }; # restart the swap - passing it our current stash
-
- ### allow for $template which is used in some odd instances
- } else {
- my $doc;
- if ($ref->[0] eq 'template') {
- $doc = $filename;
- } else {
- $doc = $self->play_expr($ref);
- if (ref($doc) ne 'HASH' || ! $doc->{'_tree'}) {
- $self->throw('process', "Passed item doesn't appear to be a valid document");
- }
- }
- $self->throw('process', "Recursion detected in $node->[0] \$template") if $self->{'_process_dollar_template'};
- local $self->{'_process_dollar_template'} = 1;
- local $self->{'_component'} = $filename;
- return if ! $doc->{'_tree'};
-
- ### execute and trim
- eval { $self->execute_tree($doc->{'_tree'}, \$out) };
- if ($self->{'TRIM'}) {
- $out =~ s{ \s+ $ }{}x;
- $out =~ s{ ^ \s+ }{}x;
- }
-
- ### handle exceptions
- if (my $err = $@) {
- $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
- $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc;
- }
-
- }
-
- ### append any output
- $$out_ref .= $out;
- if (my $err = $@) {
- die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/;
- }
- }
-
- 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_SET {
- my ($self, $str_ref, $node, $initial_op, $initial_var) = @_;
- my @SET;
- my $func;
-
- if ($initial_op) {
- if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcx # find a word
- && ((pos($$str_ref) -= length($1)) || 1) # always revert
- && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its a directive - if so set up capturing
- $node->[6] = 1; # set a flag to keep parsing
- my $val = $node->[4] ||= []; # setup storage
- return [[$initial_op, $initial_var, $val]];
- } else { # get a normal variable
- return [[$initial_op, $initial_var, $self->parse_expr($str_ref)]];
- }
- }
-
- while (1) {
- my $set = $self->parse_expr($str_ref);
- last if ! defined $set;
-
- if ($$str_ref =~ m{ \G ($QR_OP_ASSIGN) >? \s* }gcx) {
- my $op = $1;
- if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcx # find a word
- && ((pos($$str_ref) -= length($1)) || 1) # always revert
- && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its a directive - if so set up capturing
- $node->[6] = 1; # set a flag to keep parsing
- my $val = $node->[4] ||= []; # setup storage
- push @SET, [$op, $set, $val];
- last;
- } else { # get a normal variable
- push @SET, [$op, $set, $self->parse_expr($str_ref)];
- }
- } else {
- push @SET, ['=', $set, undef];
- }
- }
-
- return \@SET;
-}
-
-sub play_SET {
- my ($self, $set, $node) = @_;
- foreach (@$set) {
- my ($op, $set, $val) = @$_;
- if (! defined $val) { # not defined
- $val = '';
- } elsif ($node->[4] && $val == $node->[4]) { # a captured directive
- my $sub_tree = $node->[4];
- $sub_tree = $sub_tree->[0]->[4] if $sub_tree->[0] && $sub_tree->[0]->[0] eq 'BLOCK';
- $val = '';
- $self->execute_tree($sub_tree, \$val);
- } else { # normal var
- $val = $self->play_expr($val);
- }
-
- if ($OP_DISPATCH->{$op}) {
- local $^W;
- $val = $OP_DISPATCH->{$op}->($self->play_expr($set), $val);
- }
-
- $self->set_variable($set, $val);
- }
- return;
-}
-
-sub parse_SWITCH { $DIRECTIVES->{'GET'}->[0]->(@_) }
-
-sub play_SWITCH {
- my ($self, $var, $node, $out_ref) = @_;
-
- my $val = $self->play_expr($var);
- $val = '' if ! defined $val;
- ### $node->[4] is thrown away
-
- my $default;
- while ($node = $node->[5]) { # CASES
- my $var = $node->[3];
- if (! defined $var) {
- $default = $node->[4];
- next;
- }
-
- my $val2 = $self->play_expr($var);
- $val2 = [$val2] if ! UNIVERSAL::isa($val2, 'ARRAY');
- for my $test (@$val2) { # find matching values
- next if ! defined $val && defined $test;
- next if defined $val && ! defined $test;
- if ($val ne $test) { # check string-wise first - then numerical
- next if $val !~ m{ ^ -? $QR_NUM $ }ox;
- next if $test !~ m{ ^ -? $QR_NUM $ }ox;
- next if $val != $test;
- }
-
- my $body_ref = $node->[4] ||= [];
- $self->execute_tree($body_ref, $out_ref);
- return;
- }
- }
-
- if ($default) {
- $self->execute_tree($default, $out_ref);
- }
-
- return;
-}
-
-sub parse_THROW {
- my ($self, $str_ref, $node) = @_;
- my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"});
- $self->throw('parse.missing', "Missing name in THROW", $node, pos($$str_ref)) if ! $name;
- my $args = $self->parse_args($str_ref, {named_at_front => 1});
- return [$name, $args];
-}
-
-sub play_THROW {
- my ($self, $ref, $node) = @_;
- my ($name, $args) = @$ref;
-
- $name = $self->play_expr($name);
-
- my $named = shift @$args;
- push @$args, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some
-
- my @args = $args ? map { $self->play_expr($_) } @$args : ();
- $self->throw($name, \@args, $node);
-}
-
-sub play_TRY {
- my ($self, $foo, $node, $out_ref) = @_;
- my $out = '';
-
- my $body_ref = $node->[4];
- eval { $self->execute_tree($body_ref, \$out) };
- my $err = $@;
-
- if (! $node->[5]) { # no catch or final
- if (! $err) { # no final block and no error
- $$out_ref .= $out;
- return;
- }
- $self->throw('parse.missing', "Missing CATCH block", $node);
- }
- if ($err) {
- $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
- if ($err->type =~ /stop|return/) {
- $$out_ref .= $out;
- die $err;
- }
- }
-
- ### loop through the nested catch and final blocks
- my $catch_body_ref;
- my $last_found;
- my $type = $err ? $err->type : '';
- my $final;
- while ($node = $node->[5]) { # CATCH
- if ($node->[0] eq 'FINAL') {
- $final = $node->[4];
- next;
- }
- next if ! $err;
- my $name = $self->play_expr($node->[3]);
- $name = '' if ! defined $name || lc($name) eq 'default';
- if ($type =~ / ^ \Q$name\E \b /x
- && (! defined($last_found) || length($last_found) < length($name))) { # more specific wins
- $catch_body_ref = $node->[4] || [];
- $last_found = $name;
- }
- }
-
- ### play the best catch block
- if ($err) {
- if (! $catch_body_ref) {
- $$out_ref .= $out;
- die $err;
- }
- local $self->{'_vars'}->{'error'} = $err;
- local $self->{'_vars'}->{'e'} = $err;
- eval { $self->execute_tree($catch_body_ref, \$out) };
- if (my $err = $@) {
- $$out_ref .= $out;
- die $err;
- }
- }
-
- ### the final block
- $self->execute_tree($final, \$out) if $final;
-
- $$out_ref .= $out;
-
- return;
-}
-
-sub parse_UNLESS {
- my $ref = $DIRECTIVES->{'IF'}->[0]->(@_);
- return [[undef, '!', $ref], 0];
-}
-
-sub play_UNLESS { return $DIRECTIVES->{'IF'}->[1]->(@_) }
-
-sub parse_USE {
- my ($self, $str_ref) = @_;
-
- 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 = shift @$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;
- my @args = $args ? map { $self->play_expr($_) } @$args : ();
- $obj = $shape->new($context, @args);
- } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine)
- $obj = $PACKAGE_ITERATOR->new($args ? $self->play_expr($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;
- my @args = $args ? map { $self->play_expr($_) } @$args : ();
- $obj = $shape->new($context, @args);
- }
- } elsif ($self->{'LOAD_PERL'}) {
- my $require = "$module.pm";
- $require =~ s|::|/|g;
- if (eval {require $require}) {
- my @args = $args ? map { $self->play_expr($_) } @$args : ();
- $obj = $module->new(@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 parse_VIEW { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
-
-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 parse_WHILE { $DIRECTIVES->{'IF'}->[0]->(@_) }
-
-sub play_WHILE {
- my ($self, $var, $node, $out_ref) = @_;
- return '' if ! defined $var;
-
- my $sub_tree = $node->[4];
-
- ### iterate use the iterator object
- my $count = $WHILE_MAX;
- while (--$count > 0) {
-
- $self->play_expr($var) || last;
-
- ### execute the sub tree
- eval { $self->execute_tree($sub_tree, $out_ref) };
- if (my $err = $@) {
- if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) {
- next if $err->type =~ /next/;
- last if $err->type =~ /last|break/;
- }
- die $err;
- }
- }
- die "WHILE loop terminated (> $WHILE_MAX iterations)\n" if ! $count;
-
- return undef;
-}
-
-sub parse_WRAPPER { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
-
-sub play_WRAPPER {
- my ($self, $args, $node, $out_ref) = @_;
- my $sub_tree = $node->[4] || return;
-
- my ($named, @files) = @$args;
-
- my $out = '';
- $self->execute_tree($sub_tree, \$out);
-
- foreach my $name (reverse @files) {
- local $self->{'_vars'}->{'content'} = $out;
- $out = '';
- $DIRECTIVES->{'INCLUDE'}->[1]->($self, [$named, $name], $node, \$out);
- }
-
- $$out_ref .= $out;
- return;
-}
-
-###----------------------------------------------------------------###
-
-sub _vars {
- my $self = shift;
- $self->{'_vars'} = shift if $#_ == 0;
- return $self->{'_vars'} ||= {};
-}
-
-sub include_filename {
- my ($self, $file) = @_;
- if ($file =~ m|^/|) {
- $self->throw('file', "$file absolute paths are not allowed (set ABSOLUTE option)") if ! $self->{'ABSOLUTE'};
- return $file if -e $file;
- } elsif ($file =~ m{(^|/)\.\./}) {
- $self->throw('file', "$file relative paths are not allowed (set RELATIVE option)") if ! $self->{'RELATIVE'};
- return $file if -e $file;
- }
-
- my $paths = $self->{'INCLUDE_PATHS'} ||= do {
- # TT does this everytime a file is looked up - we are going to do it just in time - the first time
- my $paths = $self->{'INCLUDE_PATH'} || [];
- $paths = $paths->() if UNIVERSAL::isa($paths, 'CODE');
- $paths = $self->split_paths($paths) if ! UNIVERSAL::isa($paths, 'ARRAY');
- $paths; # return of the do
- };
- foreach my $path (@$paths) {
- return "$path/$file" if -e "$path/$file";
- }
-
- $self->throw('file', "$file: not found");
-}
-
-sub split_paths {
- my ($self, $path) = @_;
- return $path if ref $path;
- my $delim = $self->{'DELIMITER'} || ':';
- $delim = ($delim eq ':' && $^O eq 'MSWin32') ? qr|:(?!/)| : qr|\Q$delim\E|;
- return [split $delim, $path];
-}
-
-sub _insert {
- my ($self, $file) = @_;
- return $self->slurp($self->include_filename($file));
-}
-
-sub slurp {
- my ($self, $file) = @_;
- local *FH;
- open(FH, "<$file") || $self->throw('file', "$file couldn't be opened: $!");
- read FH, my $txt, -s $file;
- close FH;
- return $txt;
-}
-
-sub process_simple {
- my $self = shift;
- my $in = shift || die "Missing input";
- my $swap = shift || die "Missing variable hash";
- my $out = shift || die "Missing output string ref";
-
- eval {
- delete $self->{'_debug_off'};
- delete $self->{'_debug_format'};
- local $self->{'_start_top_level'} = 1;
- $self->_process($in, $swap, $out);
- };
- if (my $err = $@) {
- if ($err->type !~ /stop|return|next|last|break/) {
- $self->{'error'} = $err;
- return;
- }
- }
- return 1;
-}
-
-sub process {
- my ($self, $in, $swap, $out, @ARGS) = @_;
- delete $self->{'error'};
-
- my $args;
- $args = ($#ARGS == 0 && UNIVERSAL::isa($ARGS[0], 'HASH')) ? {%{$ARGS[0]}} : {@ARGS} if scalar @ARGS;
- $self->DEBUG("set binmode\n") if $DEBUG && $args->{'binmode'}; # holdover for TT2 tests
-
- ### get the content
- my $content;
- if (ref $in) {
- if (UNIVERSAL::isa($in, 'SCALAR')) { # reference to a string
- $content = $in;
- } elsif (UNIVERSAL::isa($in, 'CODE')) {
- $content = $in->();
- $content = \$content;
- } else { # should be a file handle
- local $/ = undef;
- $content = <$in>;
- $content = \$content;
- }
- } else {
- ### should be a filename
- $content = $in;
- }
-
-
- ### prepare block localization
- my $blocks = $self->{'BLOCKS'} ||= {};
-
-
- ### do the swap
- my $output = '';
- eval {
-
- ### localize the stash
- $swap ||= {};
- my $var1 = $self->{'_vars'} ||= {};
- my $var2 = $self->{'VARIABLES'} || $self->{'PRE_DEFINE'} || {};
- $var1->{'global'} ||= {}; # allow for the "global" namespace - that continues in between processing
- my $copy = {%$var2, %$var1, %$swap};
-
- local $self->{'BLOCKS'} = $blocks = {%$blocks}; # localize blocks - but save a copy to possibly restore
-
- delete $self->{'_debug_off'};
- delete $self->{'_debug_format'};
-
- ### handle pre process items that go before every document
- if ($self->{'PRE_PROCESS'}) {
- foreach my $name (@{ $self->split_paths($self->{'PRE_PROCESS'}) }) {
- my $out = '';
- $self->_process($name, $copy, \$out);
- $output = $out . $output;
- }
- }
-
- ### handle the process config - which loads a template in place of the real one
- if (exists $self->{'PROCESS'}) {
- ### load the meta data for the top document
- my $doc = $self->load_parsed_tree($content) || {};
- my $meta = ($doc->{'_tree'} && ref($doc->{'_tree'}->[0]) && $doc->{'_tree'}->[0]->[0] eq 'META')
- ? $doc->{'_tree'}->[0]->[3] : {};
-
- local $self->{'_template'} = $doc;
- @{ $doc }{keys %$meta} = values %$meta;
-
- ### process any other templates
- foreach my $name (@{ $self->split_paths($self->{'PROCESS'}) }) {
- next if ! length $name;
- $self->_process($name, $copy, \$output);
- }
-
- ### handle "normal" content
- } else {
- local $self->{'_start_top_level'} = 1;
- $self->_process($content, $copy, \$output);
- }
-
-
- ### handle post process items that go after every document
- if ($self->{'POST_PROCESS'}) {
- foreach my $name (@{ $self->split_paths($self->{'POST_PROCESS'}) }) {
- $self->_process($name, $copy, \$output);
- }
- }
-
- };
- if (my $err = $@) {
- $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
- if ($err->type !~ /stop|return|next|last|break/) {
- $self->{'error'} = $err;
- return;
- }
- }
-
-
-
- ### clear blocks as asked (AUTO_RESET) defaults to on
- $self->{'BLOCKS'} = $blocks if exists($self->{'AUTO_RESET'}) && ! $self->{'AUTO_RESET'};
-
- ### send the content back out
- $out ||= $self->{'OUTPUT'};
- if (ref $out) {
- if (UNIVERSAL::isa($out, 'CODE')) {
- $out->($output);
- } elsif (UNIVERSAL::can($out, 'print')) {
- $out->print($output);
- } elsif (UNIVERSAL::isa($out, 'SCALAR')) { # reference to a string
- $$out = $output;
- } elsif (UNIVERSAL::isa($out, 'ARRAY')) {
- push @$out, $output;
- } else { # should be a file handle
- print $out $output;
- }
- } elsif ($out) { # should be a filename
- my $file;
- if ($out =~ m|^/|) {
- if (! $self->{'ABSOLUTE'}) {
- $self->{'error'} = $self->throw('file', "ABSOLUTE paths disabled");
- } else {
- $file = $out;
- }
- } elsif ($out =~ m|^\.\.?/|) {
- if (! $self->{'RELATIVE'}) {
- $self->{'error'} = $self->throw('file', "RELATIVE paths disabled");
- } else {
- $file = $out;
- }
- } else {
- if (! $self->{'OUTPUT_PATH'}) {
- $self->{'error'} = $self->throw('file', "OUTPUT_PATH not set");
- } else {
- $file = $self->{'OUTPUT_PATH'} . '/' . $out;
- }
- }
- if ($file) {
- local *FH;
- if (open FH, ">$file") {
- if (my $bm = $args->{'binmode'}) {
- if (+$bm == 1) { binmode FH }
- else { binmode FH, $bm }
- }
- print FH $output;
- close FH;
- } else {
- $self->{'error'} = $self->throw('file', "$out couldn't be opened for writing: $!");
- }
- }
- } else {
- print $output;
- }
-
- return if $self->{'error'};
- return 1;
-}
-
-sub error { shift->{'error'} }
-
-sub DEBUG {
- my $self = shift;
- print STDERR "DEBUG: ", @_;
-}
-
-###----------------------------------------------------------------###
-
-sub exception {
- my $self = shift;
- my $type = shift;
- my $info = shift;
- return $type if ref($type) =~ /Template::Exception$/;
- if (ref($info) eq 'ARRAY') {
- my $hash = ref($info->[-1]) eq 'HASH' ? pop(@$info) : {};
- if (@$info >= 2 || scalar keys %$hash) {
- my $i = 0;
- $hash->{$_} = $info->[$_] for 0 .. $#$info;
- $hash->{'args'} = $info;
- $info = $hash;
- } elsif (@$info == 1) {
- $info = $info->[0];
- } else {
- $info = $type;
- $type = 'undef';
- }
- }
- return $PACKAGE_EXCEPTION->new($type, $info, @_);
-}
-
-sub throw { die shift->exception(@_) }
-
-sub context {
- my $self = shift;
- return bless {_template => $self}, $PACKAGE_CONTEXT; # a fake context
-}
-
-sub undefined_get {
- my ($self, $ident, $node) = @_;
- return $self->{'UNDEFINED_GET'}->($self, $ident, $node) if $self->{'UNDEFINED_GET'};
- return '';
-}
-
-sub undefined_any {
- my ($self, $ident) = @_;
- return $self->{'UNDEFINED_ANY'}->($self, $ident) if $self->{'UNDEFINED_ANY'};
- return;
-}
-
-sub list_filters {
- my $self = shift;
- return $self->{'_filters'} ||= eval { require Template::Filters; $Template::Filters::FILTERS } || {};
-}
-
-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
- };
-}
-
-sub debug_node {
- my ($self, $node) = @_;
- my $info = $self->node_info($node);
- my $format = $self->{'_debug_format'} || $self->{'DEBUG_FORMAT'} || "\n## \$file line \$line : [% \$text %] ##\n";
- $format =~ s{\$(file|line|text)}{$info->{$1}}g;
- return $format;
-}
-
-sub node_info {
- my ($self, $node) = @_;
- my $doc = $self->{'_component'};
- my $i = $node->[1];
- my $j = $node->[2] || return ''; # META can be 0
- $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \$s };
- my $s = substr(${ $doc->{'_content'} }, $i, $j - $i);
- $s =~ s/^\s+//;
- $s =~ s/\s+$//;
- return {
- file => $doc->{'name'},
- line => $self->get_line_number_by_index($doc, $i),
- text => $s,
- };
-}
-
-sub get_line_number_by_index {
- my ($self, $doc, $index, $include_char) = @_;
- return 1 if $index <= 0;
-
- ### get the line offsets for the doc
- my $lines = $doc->{'_line_offsets'} ||= do {
- $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \$s };
- my $i = 0;
- my @lines = (0);
- while (1) {
- $i = index(${ $doc->{'_content'} }, "\n", $i) + 1;
- last if $i == 0;
- push @lines, $i;
- }
- \@lines;
- };
-
- ### binary search them (this is fast even on big docs)
- my ($i, $j) = (0, $#$lines);
- if ($index > $lines->[-1]) {
- $i = $j;
- } else {
- while (1) {
- last if abs($i - $j) <= 1;
- my $k = int(($i + $j) / 2);
- $j = $k if $lines->[$k] >= $index;
- $i = $k if $lines->[$k] <= $index;
- }
- }
- return $include_char ? ($i + 1, $index - $lines->[$i]) : $i + 1;
-}
-
-###----------------------------------------------------------------###
-### long virtual methods or filters
-### many of these vmethods have used code from Template/Stash.pm to
-### assure conformance with the TT spec.
-
-sub define_vmethod {
- my ($self, $type, $name, $sub) = @_;
- if ( $type =~ /scalar|item/i) { $SCALAR_OPS->{$name} = $sub }
- elsif ($type =~ /array|list/i ) { $LIST_OPS->{ $name} = $sub }
- elsif ($type =~ /hash/i ) { $HASH_OPS->{ $name} = $sub }
- elsif ($type =~ /filter/i ) { $FILTER_OPS->{$name} = $sub }
- else {
- die "Invalid type vmethod type $type";
- }
- return 1;
-}
-
-sub vmethod_fmt_scalar {
- my $str = shift; $str = '' if ! defined $str;
- my $pat = shift; $pat = '%s' if ! defined $pat;
- local $^W;
- return @_ ? sprintf($pat, $_[0], $str)
- : sprintf($pat, $str);
-}
-
-sub vmethod_fmt_list {
- my $ref = shift || return '';
- my $pat = shift; $pat = '%s' if ! defined $pat;
- my $sep = shift; $sep = ' ' if ! defined $sep;
- local $^W;
- return @_ ? join($sep, map {sprintf $pat, $_[0], $_} @$ref)
- : join($sep, map {sprintf $pat, $_} @$ref);
-}
-
-sub vmethod_fmt_hash {
- my $ref = shift || return '';
- my $pat = shift; $pat = "%s\t%s" if ! defined $pat;
- my $sep = shift; $sep = "\n" if ! defined $sep;
- local $^W;
- return ! @_ ? join($sep, map {sprintf $pat, $_, $ref->{$_}} sort keys %$ref)
- : @_ == 1 ? join($sep, map {sprintf $pat, $_[0], $_, $ref->{$_}} sort keys %$ref) # don't get to pick - it applies to the key
- : join($sep, map {sprintf $pat, $_[0], $_, $_[1], $ref->{$_}} sort keys %$ref);
-}
-
-sub vmethod_chunk {
- my $str = shift;
- my $size = shift || 1;
- my @list;
- if ($size < 0) { # chunk from the opposite end
- $str = reverse $str;
- $size = -$size;
- unshift(@list, scalar reverse $1) while $str =~ /( .{$size} | .+ )/xg;
- } else {
- push(@list, $1) while $str =~ /( .{$size} | .+ )/xg;
- }
- return \@list;
-}
-
-sub vmethod_indent {
- my $str = shift; $str = '' if ! defined $str;
- my $pre = shift; $pre = 4 if ! defined $pre;
- $pre = ' ' x $pre if $pre =~ /^\d+$/;
- $str =~ s/^/$pre/mg;
- return $str;
-}
-
-sub vmethod_format {
- my $str = shift; $str = '' if ! defined $str;
- my $pat = shift; $pat = '%s' if ! defined $pat;
- if (@_) {
- return join "\n", map{ sprintf $pat, $_[0], $_ } split(/\n/, $str);
- } else {
- return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
- }
-}
-
-sub vmethod_list_hash {
- my ($hash, $what) = @_;
- $what = 'pairs' if ! $what || $what !~ /^(keys|values|each|pairs)$/;
- return $HASH_OPS->{$what}->($hash);
-}
-
-
-sub vmethod_match {
- my ($str, $pat, $global) = @_;
- return [] if ! defined $str || ! defined $pat;
- my @res = $global ? ($str =~ /$pat/g) : ($str =~ /$pat/);
- return @res ? \@res : '';
-}
-
-sub vmethod_nsort {
- my ($list, $field) = @_;
- return defined($field)
- ? [map {$_->[0]} sort {$a->[1] <=> $b->[1]} map {[$_, (ref $_ eq 'HASH' ? $_->{$field}
- : UNIVERSAL::can($_, $field) ? $_->$field()
- : $_)]} @$list ]
- : [sort {$a <=> $b} @$list];
-}
-
-sub vmethod_pick {
- my $ref = shift;
- no warnings;
- my $n = int(shift);
- $n = 1 if $n < 1;
- my @ind = map { $ref->[ rand @$ref ] } 1 .. $n;
- return $n == 1 ? $ind[0] : \@ind;
-}
-
-sub vmethod_repeat {
- my ($str, $n, $join) = @_;
- return '' if ! defined $str || ! length $str;
- $n = 1 if ! defined($n) || ! length $n;
- $join = '' if ! defined $join;
- return join $join, ($str) x $n;
-}
-
-### This method is a combination of my submissions along
-### with work from Andy Wardley, Sergey Martynoff, Nik Clayton, and Josh Rosenbaum
-sub vmethod_replace {
- my ($text, $pattern, $replace, $global) = @_;
- $text = '' unless defined $text;
- $pattern = '' unless defined $pattern;
- $replace = '' unless defined $replace;
- $global = 1 unless defined $global;
- my $expand = sub {
- my ($chunk, $start, $end) = @_;
- $chunk =~ s{ \\(\\|\$) | \$ (\d+) }{
- $1 ? $1
- : ($2 > $#$start || $2 == 0) ? ''
- : substr($text, $start->[$2], $end->[$2] - $start->[$2]);
- }exg;
- $chunk;
- };
- if ($global) {
- $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }eg;
- } else {
- $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }e;
- }
- return $text;
-}
-
-sub vmethod_sort {
- my ($list, $field) = @_;
- return defined($field)
- ? [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc(ref $_ eq 'HASH' ? $_->{$field}
- : UNIVERSAL::can($_, $field) ? $_->$field()
- : $_)]} @$list ]
- : [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc $_]} @$list ]; # case insensitive
-}
-
-sub vmethod_splice {
- my ($ref, $i, $len, @replace) = @_;
- @replace = @{ $replace[0] } if @replace == 1 && ref $replace[0] eq 'ARRAY';
- if (defined $len) {
- return [splice @$ref, $i || 0, $len, @replace];
- } elsif (defined $i) {
- return [splice @$ref, $i];
- } else {
- return [splice @$ref];
- }
-}
-
-sub vmethod_split {
- my ($str, $pat, $lim) = @_;
- $str = '' if ! defined $str;
- if (defined $lim) { return defined $pat ? [split $pat, $str, $lim] : [split ' ', $str, $lim] }
- else { return defined $pat ? [split $pat, $str ] : [split ' ', $str ] }
-}
-
-sub vmethod_substr {
- my ($str, $i, $len, $replace) = @_;
- $i ||= 0;
- return substr($str, $i) if ! defined $len;
- return substr($str, $i, $len) if ! defined $replace;
- substr($str, $i, $len, $replace);
- return $str;
-}
-
-sub vmethod_uri {
- my $str = shift;
- utf8::encode($str) if defined &utf8::encode;
- $str =~ s/([^A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg;
- return $str;
-}
-
-sub vmethod_url {
- my $str = shift;
- utf8::encode($str) if defined &utf8::encode;
- $str =~ s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg;
- return $str;
-}
-
-sub filter_eval {
- my $context = shift;
-
- return sub {
- ### prevent recursion
- my $t = $context->_template;
- local $t->{'_eval_recurse'} = $t->{'_eval_recurse'} || 0;
- $context->throw('eval_recurse', "MAX_EVAL_RECURSE $MAX_EVAL_RECURSE reached")
- if ++$t->{'_eval_recurse'} > ($t->{'MAX_EVAL_RECURSE'} || $MAX_EVAL_RECURSE);
-
-
- my $text = shift;
- return $context->process(\$text);
- };
-}
-
-sub filter_redirect {
- my ($context, $file, $options) = @_;
- my $path = $context->config->{'OUTPUT_PATH'} || $context->throw('redirect', 'OUTPUT_PATH is not set');
- $context->throw('redirect', 'Invalid filename - cannot include "/../"')
- if $file =~ m{(^|/)\.\./};
-
- return sub {
- my $text = shift;
- if (! -d $path) {
- require File::Path;
- File::Path::mkpath($path) || $context->throw('redirect', "Couldn't mkpath \"$path\": $!");
- }
- local *FH;
- open (FH, ">$path/$file") || $context->throw('redirect', "Couldn't open \"$file\": $!");
- if (my $bm = (! $options) ? 0 : ref($options) ? $options->{'binmode'} : $options) {
- if (+$bm == 1) { binmode FH }
- else { binmode FH, $bm}
- }
- print FH $text;
- close FH;
- return '';
- };
-}
-
-###----------------------------------------------------------------###
-
-sub dump_parse {
- my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
- my $str = shift;
- require Data::Dumper;
- return Data::Dumper::Dumper($obj->parse_tree(\$str));
-}
-
-sub dump_parse_expr {
- my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
- my $str = shift;
- require Data::Dumper;
- return Data::Dumper::Dumper($obj->parse_expr(\$str));
-}
-
-###----------------------------------------------------------------###
-
-package CGI::Ex::Template::Exception;
-
-use overload
- '""' => \&as_string,
- bool => sub { defined shift },
- fallback => 1;
-
-sub new {
- my ($class, $type, $info, $node, $pos, $doc) = @_;
- return bless [$type, $info, $node, $pos, $doc], $class;
-}
-
-sub type { shift->[0] }
-
-sub info { shift->[1] }
-
-sub node {
- my $self = shift;
- $self->[2] = shift if @_;
- $self->[2];
-}
-
-sub offset {
- my $self = shift;
- $self->[3] = shift if @_;
- $self->[3];
-}
-
-sub doc {
- my $self = shift;
- $self->[4] = shift if @_;
- $self->[4];
-}
-
-sub as_string {
- my $self = shift;
- if ($self->type =~ /^parse/) {
- if (my $doc = $self->doc) {
- my ($line, $char) = CGI::Ex::Template->get_line_number_by_index($doc, $self->offset, 'include_char');
- return $self->type ." error - $doc->{'name'} line $line char $char: ". $self->info;
- } else {
- return $self->type .' error - '. $self->info .' (At char '. $self->offset .')';
- }
- } else {
- return $self->type .' error - '. $self->info;
- }
-}
-
-###----------------------------------------------------------------###
-
-package CGI::Ex::Template::Iterator;
-
-sub new {
- my ($class, $items) = @_;
- $items = [] if ! defined $items;
- if (UNIVERSAL::isa($items, 'HASH')) {
- $items = [ map { {key => $_, value => $items->{ $_ }} } sort keys %$items ];
- } elsif (UNIVERSAL::can($items, 'as_list')) {
- $items = $items->as_list;
- } elsif (! UNIVERSAL::isa($items, 'ARRAY')) {
- $items = [$items];
- }
- return bless [$items, 0], $class;
-}
-
-sub get_first {
- my $self = shift;
- return (undef, 3) if ! @{ $self->[0] };
- return ($self->[0]->[$self->[1] = 0], undef);
-}
-
-sub get_next {
- my $self = shift;
- return (undef, 3) if ++ $self->[1] > $#{ $self->[0] };
- return ($self->items->[$self->[1]], undef);
-}
-
-sub items { shift->[0] }
-
-sub index { shift->[1] }
-
-sub max { $#{ shift->[0] } }
-
-sub size { shift->max + 1 }
-
-sub count { shift->index + 1 }
-
-sub number { shift->index + 1 }
-
-sub first { (shift->index == 0) || 0 }
-
-sub last { my $self = shift; return ($self->index == $self->max) || 0 }
-
-sub prev {
- my $self = shift;
- return undef if $self->index <= 0;
- return $self->items->[$self->index - 1];
-}
-
-sub next {
- my $self = shift;
- return undef if $self->index >= $self->max;
- return $self->items->[$self->index + 1];
-}
-
-###----------------------------------------------------------------###
-
-package CGI::Ex::Template::_Context;
-
-use vars qw($AUTOLOAD);
-
-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::PACKAGE_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;