+sub parse_FOREACH {
+ my ($self, $str_ref) = @_;
+ my $items = $self->parse_expr($str_ref);
+ my $var;
+ if ($$str_ref =~ m{ \G (= | [Ii][Nn]\b) \s* }gcx) {
+ $var = [@$items];
+ $items = $self->parse_expr($str_ref);
+ }
+ return [$var, $items];
+}
+
+sub play_FOREACH {
+ my ($self, $ref, $node, $out_ref) = @_;
+
+ ### get the items - make sure it is an arrayref
+ my ($var, $items) = @$ref;
+
+ $items = $self->play_expr($items);
+ return '' if ! defined $items;
+
+ if (ref($items) !~ /Iterator$/) {
+ $items = $self->iterator($items);
+ }
+
+ my $sub_tree = $node->[4];
+
+ local $self->{'_vars'}->{'loop'} = $items;
+
+ ### if the FOREACH tag sets a var - then nothing but the loop var gets localized
+ if (defined $var) {
+ my ($item, $error) = $items->get_first;
+ while (! $error) {
+
+ $self->set_variable($var, $item);
+
+ ### execute the sub tree
+ eval { $self->execute_tree($sub_tree, $out_ref) };
+ if (my $err = $@) {
+ if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) {
+ if ($err->type eq 'next') {
+ ($item, $error) = $items->get_next;
+ next;
+ }
+ last if $err->type =~ /last|break/;
+ }
+ die $err;
+ }
+
+ ($item, $error) = $items->get_next;
+ }
+ die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
+ ### if the FOREACH tag doesn't set a var - then everything gets localized
+ } else {
+
+ ### localize variable access for the foreach
+ my $swap = $self->{'_vars'};
+ local $self->{'_vars'} = my $copy = {%$swap};
+
+ ### iterate use the iterator object
+ #foreach (my $i = $items->index; $i <= $#$vals; $items->index(++ $i)) {
+ my ($item, $error) = $items->get_first;
+ while (! $error) {
+
+ if (ref($item) eq 'HASH') {
+ @$copy{keys %$item} = values %$item;
+ }
+
+ ### execute the sub tree
+ eval { $self->execute_tree($sub_tree, $out_ref) };
+ if (my $err = $@) {
+ if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) {
+ if ($err->type eq 'next') {
+ ($item, $error) = $items->get_next;
+ next;
+ }
+ last if $err->type =~ /last|break/;
+ }
+ die $err;
+ }
+
+ ($item, $error) = $items->get_next;
+ }
+ die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
+ }
+
+ return;
+}
+
+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, $out_ref) = @_;
+ my $var = $self->play_expr($ident);
+ if (defined $var) {
+ $$out_ref .= $var;
+ } else {
+ $var = $self->undefined_get($ident, $node);
+ $$out_ref .= $var if defined $var;
+ }
+ return;
+}
+
+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};
+
+ return $DIRECTIVES->{'PROCESS'}->[1]->($self, $str_ref, $node, $out_ref);
+}
+
+sub parse_INSERT { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
+
+sub play_INSERT {
+ my ($self, $args, $node, $out_ref) = @_;
+ if ($self->{'NO_INCLUDES'}) {
+ $self->throw('file', "NO_INCLUDES was set during a $node->[0] directive");
+ }
+
+ my ($named, @files) = @$args;
+
+ foreach my $name (@files) {
+ my $filename = $self->play_expr($name);
+ $$out_ref .= $self->_insert($filename);
+ }
+
+ return;
+}
+
+sub parse_LOOP {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::parse_LOOP;
+}
+
+sub play_LOOP {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_LOOP;
+}
+
+sub parse_MACRO {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::parse_MACRO;
+}
+
+sub play_MACRO {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_MACRO;
+}
+
+sub parse_META {
+ my ($self, $str_ref) = @_;
+ my $args = $self->parse_args($str_ref, {named_at_front => 1});
+ my $hash;
+ return $hash if ($hash = $self->play_expr($args->[0])) && UNIVERSAL::isa($hash, 'HASH');
+ return undef;
+}
+
+
+sub play_META {
+ my ($self, $hash) = @_;
+ return if ! $hash;
+ my @keys = keys %$hash;
+
+ my $ref;
+ if ($self->{'_top_level'}) {
+ $ref = $self->{'_template'} ||= {};
+ } else {
+ $ref = $self->{'_component'} ||= {};
+ }
+
+ @{ $ref }{ @keys } = @{ $hash }{ @keys };
+ return;
+}
+
+sub play_PERL {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_PERL;
+}
+
+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) = @_;
+ if ($self->{'NO_INCLUDES'}) {
+ $self->throw('file', "NO_INCLUDES was set during a $node->[0] directive");
+ }
+
+ 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 {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_RAWPERL;
+}
+
+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
+ # do nothing - allow for setting to undef
+ } 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_TAGS {
+ my ($self, $str_ref, $node) = @_;
+
+ my ($start, $end);
+ if ($$str_ref =~ m{ \G (\w+) \s* $QR_COMMENTS }gcxs) {
+ my $ref = $TAGS->{lc $1} || $self->throw('parse', "Invalid TAGS name \"$1\"", undef, pos($$str_ref));
+ ($start, $end) = @$ref;
+
+ } else {
+ local $self->{'_operator_precedence'} = 1; # prevent operator matching
+ $start = $$str_ref =~ m{ \G (?= [\'\"\/]) }gcx
+ ? $self->parse_expr($str_ref)
+ : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s+ $QR_COMMENTS"})
+ || $self->throw('parse', "Invalid opening tag in TAGS", undef, pos($$str_ref));
+ $end = $$str_ref =~ m{ \G (?= [\'\"\/]) }gcx
+ ? $self->parse_expr($str_ref)
+ : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s* $QR_COMMENTS"})
+ || $self->throw('parse', "Invalid closing tag in TAGS", undef, pos($$str_ref));
+ for my $tag ($start, $end) {
+ $tag = $self->play_expr($tag);
+ $tag = quotemeta($tag) if ! ref $tag;
+ }
+ }
+ return [$start, $end];
+}
+
+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, @args) = @$args;
+ push @args, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some
+
+ @args = map { $self->play_expr($_) } @args;
+ $self->throw($name, \@args, $node); # dies
+ return; # but return just in case
+}
+
+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 {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::parse_USE;
+}
+
+sub play_USE {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_USE;
+}
+
+sub parse_VIEW {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::parse_VIEW;
+}
+
+sub play_VIEW {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_VIEW;
+}
+
+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;
+}
+
+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) = @_;
+ open(my $fh, '<', $file) || $self->throw('file', "$file couldn't be opened: $!");
+ read $fh, my $txt, -s $file;
+ 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;
+
+ ### 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
+ local $self->{'_template'};
+
+ delete $self->{'_debug_off'};
+ delete $self->{'_debug_format'};
+
+ ### handle pre process items that go before every document
+ my $pre = '';
+ if ($self->{'PRE_PROCESS'}) {
+ $self->_load_template_meta($content);
+ foreach my $name (@{ $self->split_paths($self->{'PRE_PROCESS'}) }) {
+ $self->_process($name, $copy, \$pre);
+ }
+ }
+
+ ### process the central file now - catching errors to allow for the ERROR config
+ eval {
+ ### handle the PROCESS config - which loads another template in place of the real one
+ if (exists $self->{'PROCESS'}) {
+ $self->_load_template_meta($content);
+ 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);
+ }
+ };
+
+ ### catch errors with ERROR config
+ if (my $err = $@) {
+ $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
+ die $err if $err->type =~ /stop|return/;
+ my $catch = $self->{'ERRORS'} || $self->{'ERROR'} || die $err;
+ $catch = {default => $catch} if ! ref $catch;
+ my $type = $err->type;
+ my $last_found;
+ my $file;
+ foreach my $name (keys %$catch) {
+ my $_name = (! defined $name || lc($name) eq 'default') ? '' : $name;
+ if ($type =~ / ^ \Q$_name\E \b /x
+ && (! defined($last_found) || length($last_found) < length($_name))) { # more specific wins
+ $last_found = $_name;
+ $file = $catch->{$name};
+ }
+ }
+
+ ### found error handler - try it out
+ if (defined $file) {
+ $output = '';
+ local $copy->{'error'} = local $copy->{'e'} = $err;
+ $self->_process($file, $copy, \$output);
+ }
+ }
+
+ ### handle wrapper directives
+ if (exists $self->{'WRAPPER'}) {
+ $self->_load_template_meta($content);
+ foreach my $name (reverse @{ $self->split_paths($self->{'WRAPPER'}) }) {
+ next if ! length $name;
+ local $copy->{'content'} = $output;
+ my $out = '';
+ $self->_process($name, $copy, \$out);
+ $output = $out;
+ }
+ }
+
+ $output = $pre . $output if length $pre;
+
+ ### handle post process items that go after every document
+ if ($self->{'POST_PROCESS'}) {
+ $self->_load_template_meta($content);
+ 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) {
+ if (open my $fh, '>', $file) {
+ if (my $bm = $args->{'binmode'}) {
+ if (+$bm == 1) { binmode $fh }
+ else { binmode $fh, $bm }
+ }
+ print $fh $output;
+ } 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 _load_template_meta {
+ my $self = shift;
+ return if $self->{'_template'}; # only do once as need
+
+ eval {
+ ### load the meta data for the top document
+ ### this is needed by some of the custom handlers such as PRE_PROCESS and POST_PROCESS
+ my $content = shift;
+ my $doc = $self->{'_template'} = $self->load_parsed_tree($content) || {};
+ my $meta = ($doc->{'_tree'} && ref($doc->{'_tree'}->[0]) && $doc->{'_tree'}->[0]->[0] eq 'META')
+ ? $doc->{'_tree'}->[0]->[3] : {};
+
+ $self->{'_template'} = $doc;
+ @{ $doc }{keys %$meta} = values %$meta;
+ };
+
+ return;
+}
+
+
+###----------------------------------------------------------------###
+
+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;
+ require CGI::Ex::Template::Extra;
+ return CGI::Ex::Template::Context->new({_template => $self});
+}
+
+sub iterator {
+ my $self = shift;
+ $PACKAGE_ITERATOR->new(@_);
+}
+
+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 {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::list_plugins;
+}
+
+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_syntax {
+ my ($self, $name, $sub) = @_;
+ $SYNTAX->{$name} = $sub;
+ return 1;
+}
+
+sub define_operator {
+ my ($self, $args) = @_;
+ push @$OPERATORS, [@{ $args }{qw(type precedence symbols play_sub)}];
+ _build_ops();
+ return 1;
+}
+
+sub define_directive {
+ my ($self, $name, $args) = @_;
+ $DIRECTIVES->{$name} = [@{ $args }{qw(parse_sub play_sub is_block is_postop continues no_interp)}];
+ return 1;
+}
+
+sub define_vmethod {
+ my ($self, $type, $name, $sub) = @_;
+ if ( $type =~ /scalar|item|text/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;
+ my $syntax = 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;
+ local $t->{'SYNTAX'} = $syntax || $t->{'SYNTAX'};
+ 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\": $!");
+ }
+ open (my $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;
+ 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));
+}
+
+###----------------------------------------------------------------###
+### support for few HTML::Template and HTML::Template::Expr calling syntax
+
+sub register_function {
+ my ($name, $sub) = @_;
+ $SCALAR_OPS->{$name} = $sub;
+}
+
+sub param {
+ require CGI::Ex::Template::HTE;
+ &CGI::Ex::Template::HTE::param;
+}
+
+sub output {
+ require CGI::Ex::Template::HTE;
+ &CGI::Ex::Template::HTE::output;
+}
+
+sub clear_param { shift->{'param'} = {} }
+
+sub query { shift->throw('query', "Not implemented in CGI::Ex::Template") }
+
+sub new_file { my $class = shift; my $in = shift; $class->new(source => $in, type => 'filename', @_) }
+sub new_scalar_ref { my $class = shift; my $in = shift; $class->new(source => $in, type => 'scalarref', @_) }
+sub new_array_ref { my $class = shift; my $in = shift; $class->new(source => $in, type => 'arrayref', @_) }
+sub new_filehandle { my $class = shift; my $in = shift; $class->new(source => $in, type => 'filehandle', @_) }
+
+###----------------------------------------------------------------###
+
+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];
+}
+
+###----------------------------------------------------------------###
+
+1;