--- /dev/null
+package CGI::Ex::Template::HTE;
+
+=head1 NAME
+
+CGI::Ex::Template::HTE - provide HTML::Template and HTML::Template::Expr support
+
+=head1 DESCRIPTION
+
+Provides for extra or extended features that may not be as commonly used.
+This module should not normally be used by itself.
+
+See the CGI::Ex::Template documentation for configuration and other parameters.
+
+=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';
+our %DOCUMENTS; # global cache used with new(cache => 1) and output
+
+sub parse_tree_hte {
+ my $self = shift;
+ my $str_ref = shift;
+ if (! $str_ref || ! defined $$str_ref) {
+ $self->throw('parse.no_string', "No string or undefined during parse");
+ }
+
+ my $START = qr{<(|!--\s*)(/?)([+=~-]?)[Tt][Mm][Pp][Ll]_(\w+)\b};
+ local $self->{'_end_tag'}; # changes over time
+
+ local @{ $self }{@CGI::Ex::Template::CONFIG_COMPILETIME} = @{ $self }{@CGI::Ex::Template::CONFIG_COMPILETIME};
+
+ my @tree; # the parsed tree
+ my $pointer = \@tree; # pointer to current tree to handle nested blocks
+ my @state; # maintain block levels
+ local $self->{'_state'} = \@state; # allow for items to introspect (usually BLOCKS)
+ local $self->{'_no_interp'} = 0; # no interpolation in perl
+ my @in_view; # let us know if we are in a view
+ my @blocks; # storage for defined blocks
+ my @meta; # place to store any found meta information (to go into META)
+ my $post_chomp = 0; # previous post_chomp setting
+ my $continue = 0; # flag for multiple directives in the same tag
+ my $post_op = 0; # found a post-operative DIRECTIVE
+ my $capture; # flag to start capture
+ my $func;
+ my $node;
+ my ($comment, $is_close);
+ local pos $$str_ref = 0;
+ my $allow_expr = ! defined($self->{'EXPR'}) || $self->{'EXPR'}; # default is on
+
+ while (1) {
+ ### allow for TMPL_SET foo = PROCESS foo
+ if ($capture) {
+ $func = $$str_ref =~ m{ \G \s* (\w+)\b }gcx
+ ? uc $1 : $self->throw('parse', "Error looking for block in capture DIRECTIVE", undef, pos($$str_ref));
+ if ($func ne 'VAR' && ! $CGI::Ex::Template::DIRECTIVES->{$func}) {
+ $self->throw('parse', "Found unknow DIRECTIVE ($func)", undef, pos($$str_ref) - length($func));
+ }
+
+ $node = [$func, pos($$str_ref) - length($func), undef];
+
+ push @{ $capture->[4] }, $node;
+ undef $capture;
+
+ ### handle all other TMPL tags
+ } else {
+ ### find the next opening tag
+ $$str_ref =~ m{ \G (.*?) $START }gcxs
+ || last;
+ (my $text, $comment, $is_close, my $pre_chomp, $func) = ($1, $2, $3, $4, uc $5);
+
+ ### found a text portion - chomp it, interpolate it and store it
+ if (length $text) {
+ my $_last = pos $$str_ref;
+ if ($post_chomp) {
+ if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x }
+ elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x }
+ elsif ($post_chomp == 3) { $_last += length($1) if $text =~ s{ ^ (\s+) }{}x }
+ }
+ if (length $text) {
+ push @$pointer, $text;
+ $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'};
+ }
+ }
+
+ ### make sure we know this directive
+ if ($func ne 'VAR' && ! $CGI::Ex::Template::DIRECTIVES->{$func}) {
+ $self->throw('parse', "Found unknow DIRECTIVE ($func)", undef, pos($$str_ref) - length($func));
+ }
+ $node = [$func, pos($$str_ref) - length($func) - length($pre_chomp) - 5, undef];
+
+ ### take care of chomping - yes HT now get CHOMP SUPPORT
+ $pre_chomp ||= $self->{'PRE_CHOMP'};
+ $pre_chomp =~ y/-=~+/1230/ if $pre_chomp;
+ if ($pre_chomp && $pointer->[-1] && ! ref $pointer->[-1]) {
+ if ($pre_chomp == 1) { $pointer->[-1] =~ s{ (?:\n|^) [^\S\n]* \z }{}x }
+ elsif ($pre_chomp == 2) { $pointer->[-1] =~ s{ (\s+) \z }{ }x }
+ elsif ($pre_chomp == 3) { $pointer->[-1] =~ s{ (\s+) \z }{}x }
+ splice(@$pointer, -1, 1, ()) if ! length $pointer->[-1]; # remove the node if it is zero length
+ }
+
+ push @$pointer, $node;
+ }
+
+ $$str_ref =~ m{ \G \s+ }gcx;
+
+ ### parse remaining tag details
+ if (! $is_close) {
+ ### handle HT style nodes
+ if ($func =~ /^(IF|ELSIF|UNLESS|LOOP|VAR|INCLUDE)$/) {
+ $func = $node->[0] = 'GET' if $func eq 'VAR';
+
+ ### handle EXPR attribute
+ if ($$str_ref =~ m{ \G [Ee][Xx][Pp][Rr] \s*=\s* ([\"\']?) \s* }gcx) {
+ if (! $allow_expr) {
+ $self->throw('parse', 'EXPR are not allowed without hte mode', undef, pos($$str_ref));
+ }
+ my $quote = $1;
+ $self->{'_end_tag'} = $comment ? qr{$quote\s*([+=~-]?)-->} : qr{$quote\s*([+=~-]?)>};
+ $node->[3] = $self->parse_expr($str_ref)
+ || $self->throw('parse', 'Error while looking for EXPR', undef, pos($$str_ref));
+
+ ### handle "normal" NAME attributes
+ } else {
+
+ ### store what we'll find at the end of the tag
+ $self->{'_end_tag'} = $comment ? qr{([+=~-]?)-->} : qr{([+=~-]?)>};
+
+ my ($name, $escape, $default);
+ while (1) {
+ if ($$str_ref =~ m{ \G (\w+) \s*=\s* }gcx) {
+ my $key = lc $1;
+ my $val = $$str_ref =~ m{ \G ([\"\']) (.*?) (?<!\\) \1 \s* }gcx ? $2
+ : $$str_ref =~ m{ \G ([\w./+_]+) \s* }gcx ? $1
+ : $self->throw('parse', "Error while looking for value of \"$key\" attribute", undef, pos($$str_ref));
+ if ($key eq 'name') {
+ $name ||= $val;
+ } else {
+ $self->throw('parse', uc($key)." not allowed in TMPL_$func tag") if $func ne 'GET';
+ if ($key eq 'escape') { $escape ||= lc $val }
+ elsif ($key eq 'default') { $default ||= $val }
+ else { $self->throw('parse', uc($key)." not allowed in TMPL_$func tag") }
+ }
+ } elsif ($$str_ref =~ m{ \G ([\w./+_]+) \s* }gcx) {
+ $name ||= $1;
+ } else {
+ last;
+ }
+ }
+
+ $self->throw('parse', 'Error while looking for NAME', undef, pos($$str_ref)) if ! $name;
+ $node->[3] = $func eq 'INCLUDE' ? $name : [($self->{'CASE_SENSITIVE'} ? $name : lc $name), 0]; # set the variable
+ $node->[3] = [[undef, '||', $node->[3], $default], 0] if $default;
+ $node->[2] = pos $$str_ref;
+
+ ### dress up node before finishing
+ $escape = lc $self->{'DEFAULT_ESCAPE'} if ! $escape && $self->{'DEFAULT_ESCAPE'};
+ if ($escape) {
+ $self->throw('parse', "ESCAPE not allowed in TMPL_$func tag") if $func ne 'GET';
+ if ($escape eq 'html' || $escape eq '1') {
+ push @{ $node->[3] }, '|', 'html', 0;
+ } elsif ($escape eq 'url') {
+ push @{ $node->[3] }, '|', 'url', 0;
+ } elsif ($escape eq 'js') {
+ push @{ $node->[3] }, '|', 'js', 0;
+ }
+ }
+ }
+
+ ### fixup DIRECTIVE storage
+ if ($func eq 'INCLUDE') {
+ $node->[3] = [[[undef, '{}'],0], $node->[3]];
+ } elsif ($func eq 'UNLESS') {
+ $node->[0] = 'IF';
+ $node->[3] = [[undef, '!', $node->[3]], 0];
+ }
+
+ ### handle TT Directive extensions
+ } else {
+ $self->throw('parse', "Found a TT tag $func with NO_TT enabled", undef, pos($$str_ref)) if $self->{'NO_TT'};
+ $self->{'_end_tag'} = $comment ? qr{\s*([+=~-]?)-->} : qr{\s*([+=~-]?)>};
+ $node->[3] = eval { $CGI::Ex::Template::DIRECTIVES->{$func}->[0]->($self, $str_ref, $node) };
+ if (my $err = $@) {
+ $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
+ die $err;
+ }
+ $node->[2] = pos $$str_ref;
+ }
+ }
+
+ ### handle ending tags - or continuation blocks
+ if ($is_close || $CGI::Ex::Template::DIRECTIVES->{$func}->[4]) {
+ if (! @state) {
+ $self->throw('parse', "Found an $func tag while not in a block", $node, pos($$str_ref));
+ }
+ my $parent_node = pop @state;
+
+ ### TODO - check for matching loop close name
+ $func = $node->[0] = 'END' if $is_close;
+
+ ### handle continuation blocks such as elsif, else, catch etc
+ if ($CGI::Ex::Template::DIRECTIVES->{$func}->[4]) {
+ pop @$pointer; # we will store the node in the parent instead
+ $parent_node->[5] = $node;
+ my $parent_type = $parent_node->[0];
+ if (! $CGI::Ex::Template::DIRECTIVES->{$func}->[4]->{$parent_type}) {
+ $self->throw('parse', "Found unmatched nested block", $node, pos($$str_ref));
+ }
+ }
+
+ ### restore the pointer up one level (because we hit the end of a block)
+ $pointer = (! @state) ? \@tree : $state[-1]->[4];
+
+ ### normal end block
+ if (! $CGI::Ex::Template::DIRECTIVES->{$func}->[4]) {
+ if ($parent_node->[0] eq 'BLOCK') { # move BLOCKS to front
+ if (defined($parent_node->[3]) && @in_view) {
+ push @{ $in_view[-1] }, $parent_node;
+ } else {
+ push @blocks, $parent_node;
+ }
+ if ($pointer->[-1] && ! $pointer->[-1]->[6]) { # capturing doesn't remove the var
+ splice(@$pointer, -1, 1, ());
+ }
+ } elsif ($parent_node->[0] eq 'VIEW') {
+ my $ref = { map {($_->[3] => $_->[4])} @{ pop @in_view }};
+ unshift @{ $parent_node->[3] }, $ref;
+ } elsif ($CGI::Ex::Template::DIRECTIVES->{$parent_node->[0]}->[5]) { # allow no_interp to turn on and off
+ $self->{'_no_interp'}--;
+ }
+
+
+ ### continuation block - such as an elsif
+ } else {
+ push @state, $node;
+ $pointer = $node->[4] ||= [];
+ }
+
+ ### handle block directives
+ } elsif ($CGI::Ex::Template::DIRECTIVES->{$func}->[2]) {
+ push @state, $node;
+ $pointer = $node->[4] ||= []; # allow future parsed nodes before END tag to end up in current node
+ push @in_view, [] if $func eq 'VIEW';
+ $self->{'_no_interp'}++ if $CGI::Ex::Template::DIRECTIVES->{$node->[0]}->[5] # allow no_interp to turn on and off
+
+ } elsif ($func eq 'META') {
+ unshift @meta, %{ $node->[3] }; # first defined win
+ $node->[3] = undef; # only let these be defined once - at the front of the tree
+ }
+
+
+ ### look for the closing tag
+ if ($$str_ref =~ m{ \G $self->{'_end_tag'} }gcxs) {
+ $post_chomp = $1 || $self->{'POST_CHOMP'};
+ $post_chomp =~ y/-=~+/1230/ if $post_chomp;
+ $continue = 0;
+ $post_op = 0;
+ next;
+
+ ### setup capturing
+ } elsif ($node->[6]) {
+ $capture = $node;
+ next;
+
+ ### no closing tag
+ } else {
+ $self->throw('parse', "Not sure how to handle tag", $node, pos($$str_ref));
+ }
+ }
+
+ ### cleanup the tree
+ unshift(@tree, @blocks) if @blocks;
+ unshift(@tree, ['META', 0, 0, {@meta}]) if @meta;
+ $self->throw('parse', "Missing </TMPL_ close tag", $state[-1], pos($$str_ref)) if @state > 0;
+
+ ### pull off the last text portion - if any
+ if (pos($$str_ref) != length($$str_ref)) {
+ my $text = substr $$str_ref, pos($$str_ref);
+ my $_last = pos($$str_ref);
+ if ($post_chomp) {
+ if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x }
+ elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x }
+ elsif ($post_chomp == 3) { $_last += length($1) if $text =~ s{ ^ (\s+) }{}x }
+ }
+ if (length $text) {
+ push @$pointer, $text;
+ $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'};
+ }
+ }
+
+ return \@tree;
+}
+
+###----------------------------------------------------------------###
+### a few HTML::Template and HTML::Template::Expr routines
+
+sub param {
+ my $self = shift;
+ my $args;
+ if (@_ == 1) {
+ my $key = shift;
+ if (ref($key) ne 'HASH') {
+ $key = lc $key if $self->{'CASE_SENSITIVE'};
+ return $self->{'_vars'}->{$key};
+ }
+ $args = [%$key];
+ } else {
+ $self->throw('param', "Odd number of parameters") if @_ % 2;
+ $args = \@_;
+ }
+ while (@$args) {
+ my $key = shift @$args;
+ $key = lc $key if $self->{'CASE_SENSITIVE'};
+ $self->{'_vars'}->{$key} = shift @$args;
+ }
+ return;
+}
+
+sub output {
+ my $self = shift;
+ my $args = ref($_[0]) eq 'HASH' ? shift : {@_};
+ my $type = $self->{'TYPE'} || '';
+
+ my $content;
+ if ($type eq 'filehandle' || $self->{'FILEHANDLE'}) {
+ my $in = $self->{'FILEHANDLE'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type filehandle');
+ local $/ = undef;
+ $content = <$in>;
+ $content = \$content;
+ } elsif ($type eq 'arrayref' || $self->{'ARRAYREF'}) {
+ my $in = $self->{'ARRAYREF'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type arrayref');
+ $content = join "", @$in;
+ $content = \$content;
+ } elsif ($type eq 'filename' || $self->{'FILENAME'}) {
+ $content = $self->{'FILENAME'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type filename');
+ } elsif ($type eq 'scalarref' || $self->{'SCALARREF'}) {
+ $content = $self->{'SCALARREF'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type scalarref');
+ } else {
+ $self->throw('output', "Unknown input type");
+ }
+
+
+ my $param = $self->{'_vars'} || {};
+ if (my $ref = $self->{'ASSOCIATE'}) {
+ foreach my $obj (ref($ref) eq 'ARRAY' ? $ref : @$ref) {
+ foreach my $key ($obj->param) {
+ $self->{'_vars'}->{$self->{'CASE_SENSITIVE'} ? lc($key) : $key} = $obj->param($key);
+ }
+ }
+ }
+
+
+ ### override some TT defaults
+ local $self->{'FILE_CACHE'} = $self->{'DOUBLE_FILE_CACHE'} ? 1 : $self->{'FILE_CACHE'};
+ my $cache_size = ($self->{'CACHE'}) ? undef : 0;
+ my $compile_dir = (! $self->{'FILE_CACHE'}) ? undef : $self->{'FILE_CACHE_DIR'} || $self->throw('output', 'Missing file_cache_dir');
+ my $stat_ttl = (! $self->{'BLIND_CACHE'}) ? undef : 60; # not sure how high to set the blind cache
+ $cache_size = undef if $self->{'DOUBLE_FILE_CACHE'};
+
+ local $self->{'SYNTAX'} = $self->{'SYNTAX'} || 'hte';
+ local $self->{'NO_TT'} = $self->{'NO_TT'} || ($self->{'SYNTAX'} eq 'hte' ? 0 : 1);
+ local $self->{'CACHE_SIZE'} = $cache_size;
+ local $self->{'STAT_TTL'} = $stat_ttl;
+ local $self->{'COMPILE_DIR'} = $compile_dir;
+ local $self->{'ABSOLUTE'} = 1;
+ local $self->{'RELATIVE'} = 1;
+ local $self->{'INCLUDE_PATH'} = $self->{'PATH'} || './';
+ local $self->{'V2EQUALS'} = $self->{'V2EQUALS'} || 0;
+ local $self->{'_documents'} = \%DOCUMENTS;
+ local $CGI::Ex::Template::QR_PRIVATE = undef;
+
+ if ($args->{'print_to'}) {
+ $self->process_simple($content, $param, $args->{'print_to'}) || die $self->error;
+ return undef;
+ } else {
+ my $out = '';
+ $self->process_simple($content, $param, \$out) || die $self->error;
+ return $out;
+ }
+}
+
+###----------------------------------------------------------------###
+
+1;
projects / chaz / p5-CGI-Ex / blobdiff