Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/Template/HTE.pm

   1 package CGI::Ex::Template::HTE;
   2
   3 =head1 NAME
   4
   5 CGI::Ex::Template::HTE - provide HTML::Template and HTML::Template::Expr support
   6
   7 =head1 DESCRIPTION
   8
   9 Provides for extra or extended features that may not be as commonly used.
  10 This module should not normally be used by itself.
  11
  12 See the CGI::Ex::Template documentation for configuration and other parameters.
  13
  14 =head1 AUTHOR
  15
  16 Paul Seamons <paul at seamons dot com>
  17
  18 =head1 LICENSE
  19
  20 This module may be distributed under the same terms as Perl itself.
  21
  22 =cut
  23
  24 use strict;
  25 use warnings;
  26
  27 our $VERSION = '2.13';
  28 our %DOCUMENTS; # global cache used with new(cache => 1) and output
  29
  30 sub parse_tree_hte {
  31     my $self    = shift;
  32     my $str_ref = shift;
  33     if (! $str_ref || ! defined $$str_ref) {
  34         $self->throw('parse.no_string', "No string or undefined during parse");
  35     }
  36
  37     my $START = qr{<(|!--\s*)(/?)([+=~-]?)[Tt][Mm][Pp][Ll]_(\w+)\b};
  38     local $self->{'_end_tag'}; # changes over time
  39
  40     local @{ $self }{@CGI::Ex::Template::CONFIG_COMPILETIME} = @{ $self }{@CGI::Ex::Template::CONFIG_COMPILETIME};
  41
  42     my @tree;             # the parsed tree
  43     my $pointer = \@tree; # pointer to current tree to handle nested blocks
  44     my @state;            # maintain block levels
  45     local $self->{'_state'} = \@state; # allow for items to introspect (usually BLOCKS)
  46     local $self->{'_no_interp'} = 0;   # no interpolation in perl
  47     my @in_view;          # let us know if we are in a view
  48     my @blocks;           # storage for defined blocks
  49     my @meta;             # place to store any found meta information (to go into META)
  50     my $post_chomp = 0;   # previous post_chomp setting
  51     my $continue   = 0;   # flag for multiple directives in the same tag
  52     my $post_op    = 0;   # found a post-operative DIRECTIVE
  53     my $capture;          # flag to start capture
  54     my $func;
  55     my $node;
  56     my ($comment, $is_close);
  57     local pos $$str_ref = 0;
  58     my $allow_expr = ! defined($self->{'EXPR'}) || $self->{'EXPR'}; # default is on
  59
  60     while (1) {
  61         ### allow for TMPL_SET foo = PROCESS foo
  62         if ($capture) {
  63             $func = $$str_ref =~ m{ \G \s* (\w+)\b }gcx
  64                 ? uc $1 : $self->throw('parse', "Error looking for block in capture DIRECTIVE", undef, pos($$str_ref));
  65             if ($func ne 'VAR' && ! $CGI::Ex::Template::DIRECTIVES->{$func}) {
  66                 $self->throw('parse', "Found unknow DIRECTIVE ($func)", undef, pos($$str_ref) - length($func));
  67             }
  68
  69             $node = [$func, pos($$str_ref) - length($func), undef];
  70
  71             push @{ $capture->[4] }, $node;
  72             undef $capture;
  73
  74         ### handle all other TMPL tags
  75         } else {
  76             ### find the next opening tag
  77             $$str_ref =~ m{ \G (.*?) $START }gcxs
  78                 || last;
  79             (my $text, $comment, $is_close, my $pre_chomp, $func) = ($1, $2, $3, $4, uc $5);
  80
  81             ### found a text portion - chomp it, interpolate it and store it
  82             if (length $text) {
  83                 my $_last = pos $$str_ref;
  84                 if ($post_chomp) {
  85                     if    ($post_chomp == 1) { $_last += length($1)     if $text =~ s{ ^ ([^\S\n]* \n) }{}x  }
  86                     elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+)         }{ }x }
  87                     elsif ($post_chomp == 3) { $_last += length($1)     if $text =~ s{ ^ (\s+)         }{}x  }
  88                 }
  89                 if (length $text) {
  90                     push @$pointer, $text;
  91                     $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'};
  92                 }
  93             }
  94
  95             ### make sure we know this directive
  96             if ($func ne 'VAR' && ! $CGI::Ex::Template::DIRECTIVES->{$func}) {
  97                 $self->throw('parse', "Found unknow DIRECTIVE ($func)", undef, pos($$str_ref) - length($func));
  98             }
  99             $node = [$func, pos($$str_ref) - length($func) - length($pre_chomp) - 5, undef];
 100
 101             ### take care of chomping - yes HT now get CHOMP SUPPORT
 102             $pre_chomp ||= $self->{'PRE_CHOMP'};
 103             $pre_chomp  =~ y/-=~+/1230/ if $pre_chomp;
 104             if ($pre_chomp && $pointer->[-1] && ! ref $pointer->[-1]) {
 105                 if    ($pre_chomp == 1) { $pointer->[-1] =~ s{ (?:\n|^) [^\S\n]* \z }{}x  }
 106                 elsif ($pre_chomp == 2) { $pointer->[-1] =~ s{             (\s+) \z }{ }x }
 107                 elsif ($pre_chomp == 3) { $pointer->[-1] =~ s{             (\s+) \z }{}x  }
 108                 splice(@$pointer, -1, 1, ()) if ! length $pointer->[-1]; # remove the node if it is zero length
 109             }
 110
 111             push @$pointer, $node;
 112         }
 113
 114         $$str_ref =~ m{ \G \s+ }gcx;
 115
 116         ### parse remaining tag details
 117         if (! $is_close) {
 118             ### handle HT style nodes
 119             if ($func =~ /^(IF|ELSIF|UNLESS|LOOP|VAR|INCLUDE)$/) {
 120                 $func = $node->[0] = 'GET' if $func eq 'VAR';
 121
 122                 ### handle EXPR attribute
 123                 if ($$str_ref =~ m{ \G [Ee][Xx][Pp][Rr] \s*=\s* ([\"\']?) \s* }gcx) {
 124                     if (! $allow_expr) {
 125                         $self->throw('parse', 'EXPR are not allowed without hte mode', undef, pos($$str_ref));
 126                     }
 127                     my $quote = $1;
 128                     $self->{'_end_tag'} = $comment ? qr{$quote\s*([+=~-]?)-->} : qr{$quote\s*([+=~-]?)>};
 129                     $node->[3] = $self->parse_expr($str_ref)
 130                         || $self->throw('parse', 'Error while looking for EXPR', undef, pos($$str_ref));
 131
 132                 ### handle "normal" NAME attributes
 133                 } else {
 134
 135                     ### store what we'll find at the end of the tag
 136                     $self->{'_end_tag'} = $comment ? qr{([+=~-]?)-->} : qr{([+=~-]?)>};
 137
 138                     my ($name, $escape, $default);
 139                     while (1) {
 140                         if ($$str_ref =~ m{ \G (\w+) \s*=\s* }gcx) {
 141                             my $key = lc $1;
 142                             my $val = $$str_ref =~ m{ \G ([\"\']) (.*?) (?<!\\) \1 \s* }gcx ? $2
 143                                     : $$str_ref =~ m{ \G ([\w./+_]+) \s* }gcx               ? $1
 144                                     : $self->throw('parse', "Error while looking for value of \"$key\" attribute", undef, pos($$str_ref));
 145                             if ($key eq 'name') {
 146                                 $name ||= $val;
 147                             } else {
 148                                 $self->throw('parse', uc($key)." not allowed in TMPL_$func tag") if $func ne 'GET';
 149                                 if    ($key eq 'escape')  { $escape  ||= lc $val }
 150                                 elsif ($key eq 'default') { $default ||= $val    }
 151                                 else  { $self->throw('parse', uc($key)." not allowed in TMPL_$func tag") }
 152                             }
 153                         } elsif ($$str_ref =~ m{ \G ([\w./+_]+) \s* }gcx) {
 154                             $name ||= $1;
 155                         } else {
 156                             last;
 157                         }
 158                     }
 159
 160                     $self->throw('parse', 'Error while looking for NAME', undef, pos($$str_ref)) if ! $name;
 161                     $node->[3] = $func eq 'INCLUDE' ? $name : [($self->{'CASE_SENSITIVE'} ? $name : lc $name), 0]; # set the variable
 162                     $node->[3] = [[undef, '||', $node->[3], $default], 0] if $default;
 163                     $node->[2] = pos $$str_ref;
 164
 165                     ### dress up node before finishing
 166                     $escape = lc $self->{'DEFAULT_ESCAPE'} if ! $escape && $self->{'DEFAULT_ESCAPE'};
 167                     if ($escape) {
 168                         $self->throw('parse', "ESCAPE not allowed in TMPL_$func tag") if $func ne 'GET';
 169                         if ($escape eq 'html' || $escape eq '1') {
 170                             push @{ $node->[3] }, '|', 'html', 0;
 171                         } elsif ($escape eq 'url') {
 172                             push @{ $node->[3] }, '|', 'url', 0;
 173                         } elsif ($escape eq 'js') {
 174                             push @{ $node->[3] }, '|', 'js', 0;
 175                         }
 176                     }
 177                 }
 178
 179                 ### fixup DIRECTIVE storage
 180                 if ($func eq 'INCLUDE') {
 181                     $node->[3] = [[[undef, '{}'],0], $node->[3]];
 182                 } elsif ($func eq 'UNLESS') {
 183                     $node->[0] = 'IF';
 184                     $node->[3] = [[undef, '!', $node->[3]], 0];
 185                 }
 186
 187             ### handle TT Directive extensions
 188             } else {
 189                 $self->throw('parse', "Found a TT tag $func with NO_TT enabled", undef, pos($$str_ref)) if $self->{'NO_TT'};
 190                 $self->{'_end_tag'} = $comment ? qr{\s*([+=~-]?)-->} : qr{\s*([+=~-]?)>};
 191                 $node->[3] = eval { $CGI::Ex::Template::DIRECTIVES->{$func}->[0]->($self, $str_ref, $node) };
 192                 if (my $err = $@) {
 193                     $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
 194                     die $err;
 195                 }
 196                 $node->[2] = pos $$str_ref;
 197             }
 198         }
 199
 200         ### handle ending tags - or continuation blocks
 201         if ($is_close || $CGI::Ex::Template::DIRECTIVES->{$func}->[4]) {
 202             if (! @state) {
 203                 $self->throw('parse', "Found an $func tag while not in a block", $node, pos($$str_ref));
 204             }
 205             my $parent_node = pop @state;
 206
 207             ### TODO - check for matching loop close name
 208             $func = $node->[0] = 'END' if $is_close;
 209
 210             ### handle continuation blocks such as elsif, else, catch etc
 211             if ($CGI::Ex::Template::DIRECTIVES->{$func}->[4]) {
 212                 pop @$pointer; # we will store the node in the parent instead
 213                 $parent_node->[5] = $node;
 214                 my $parent_type = $parent_node->[0];
 215                 if (! $CGI::Ex::Template::DIRECTIVES->{$func}->[4]->{$parent_type}) {
 216                     $self->throw('parse', "Found unmatched nested block", $node, pos($$str_ref));
 217                 }
 218             }
 219
 220             ### restore the pointer up one level (because we hit the end of a block)
 221             $pointer = (! @state) ? \@tree : $state[-1]->[4];
 222
 223             ### normal end block
 224             if (! $CGI::Ex::Template::DIRECTIVES->{$func}->[4]) {
 225                 if ($parent_node->[0] eq 'BLOCK') { # move BLOCKS to front
 226                     if (defined($parent_node->[3]) && @in_view) {
 227                         push @{ $in_view[-1] }, $parent_node;
 228                     } else {
 229                         push @blocks, $parent_node;
 230                     }
 231                     if ($pointer->[-1] && ! $pointer->[-1]->[6]) { # capturing doesn't remove the var
 232                         splice(@$pointer, -1, 1, ());
 233                     }
 234                 } elsif ($parent_node->[0] eq 'VIEW') {
 235                     my $ref = { map {($_->[3] => $_->[4])} @{ pop @in_view }};
 236                     unshift @{ $parent_node->[3] }, $ref;
 237                 } elsif ($CGI::Ex::Template::DIRECTIVES->{$parent_node->[0]}->[5]) { # allow no_interp to turn on and off
 238                     $self->{'_no_interp'}--;
 239                 }
 240
 241
 242             ### continuation block - such as an elsif
 243             } else {
 244                 push @state, $node;
 245                 $pointer = $node->[4] ||= [];
 246             }
 247
 248         ### handle block directives
 249         } elsif ($CGI::Ex::Template::DIRECTIVES->{$func}->[2]) {
 250             push @state, $node;
 251             $pointer = $node->[4] ||= []; # allow future parsed nodes before END tag to end up in current node
 252             push @in_view, [] if $func eq 'VIEW';
 253             $self->{'_no_interp'}++ if $CGI::Ex::Template::DIRECTIVES->{$node->[0]}->[5] # allow no_interp to turn on and off
 254
 255         } elsif ($func eq 'META') {
 256             unshift @meta, %{ $node->[3] }; # first defined win
 257             $node->[3] = undef;             # only let these be defined once - at the front of the tree
 258         }
 259
 260
 261         ### look for the closing tag
 262         if ($$str_ref =~ m{ \G $self->{'_end_tag'} }gcxs) {
 263             $post_chomp = $1 || $self->{'POST_CHOMP'};
 264             $post_chomp =~ y/-=~+/1230/ if $post_chomp;
 265             $continue = 0;
 266             $post_op  = 0;
 267             next;
 268
 269         ### setup capturing
 270         } elsif ($node->[6]) {
 271             $capture = $node;
 272             next;
 273
 274         ### no closing tag
 275         } else {
 276             $self->throw('parse', "Not sure how to handle tag", $node, pos($$str_ref));
 277         }
 278     }
 279
 280     ### cleanup the tree
 281     unshift(@tree, @blocks) if @blocks;
 282     unshift(@tree, ['META', 0, 0, {@meta}]) if @meta;
 283     $self->throw('parse', "Missing </TMPL_ close tag", $state[-1], pos($$str_ref)) if @state > 0;
 284
 285     ### pull off the last text portion - if any
 286     if (pos($$str_ref) != length($$str_ref)) {
 287         my $text  = substr $$str_ref, pos($$str_ref);
 288         my $_last = pos($$str_ref);
 289         if ($post_chomp) {
 290             if    ($post_chomp == 1) { $_last += length($1)     if $text =~ s{ ^ ([^\S\n]* \n) }{}x  }
 291             elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+)         }{ }x }
 292             elsif ($post_chomp == 3) { $_last += length($1)     if $text =~ s{ ^ (\s+)         }{}x  }
 293         }
 294         if (length $text) {
 295             push @$pointer, $text;
 296             $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'};
 297         }
 298     }
 299
 300     return \@tree;
 301 }
 302
 303 ###----------------------------------------------------------------###
 304 ### a few HTML::Template and HTML::Template::Expr routines
 305
 306 sub param {
 307     my $self = shift;
 308     my $args;
 309     if (@_ == 1) {
 310         my $key = shift;
 311         if (ref($key) ne 'HASH') {
 312             $key = lc $key if $self->{'CASE_SENSITIVE'};
 313             return $self->{'_vars'}->{$key};
 314         }
 315         $args = [%$key];
 316     } else {
 317         $self->throw('param', "Odd number of parameters") if @_ % 2;
 318         $args = \@_;
 319     }
 320     while (@$args) {
 321         my $key = shift @$args;
 322         $key = lc $key if $self->{'CASE_SENSITIVE'};
 323         $self->{'_vars'}->{$key} = shift @$args;
 324     }
 325     return;
 326 }
 327
 328 sub output {
 329     my $self = shift;
 330     my $args = ref($_[0]) eq 'HASH' ? shift : {@_};
 331     my $type = $self->{'TYPE'} || '';
 332
 333     my $content;
 334     if ($type eq 'filehandle' || $self->{'FILEHANDLE'}) {
 335         my $in = $self->{'FILEHANDLE'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type filehandle');
 336         local $/ = undef;
 337         $content = <$in>;
 338         $content = \$content;
 339     } elsif ($type eq 'arrayref' || $self->{'ARRAYREF'}) {
 340         my $in = $self->{'ARRAYREF'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type arrayref');
 341         $content = join "", @$in;
 342         $content = \$content;
 343     } elsif ($type eq 'filename' || $self->{'FILENAME'}) {
 344         $content = $self->{'FILENAME'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type filename');
 345     } elsif ($type eq 'scalarref' || $self->{'SCALARREF'}) {
 346         $content = $self->{'SCALARREF'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type scalarref');
 347     } else {
 348         $self->throw('output', "Unknown input type");
 349     }
 350
 351
 352     my $param = $self->{'_vars'} || {};
 353     if (my $ref = $self->{'ASSOCIATE'}) {
 354         foreach my $obj (ref($ref) eq 'ARRAY' ? $ref : @$ref) {
 355             foreach my $key ($obj->param) {
 356                 $self->{'_vars'}->{$self->{'CASE_SENSITIVE'} ? lc($key) : $key} = $obj->param($key);
 357             }
 358         }
 359     }
 360
 361
 362     ### override some TT defaults
 363     local $self->{'FILE_CACHE'} = $self->{'DOUBLE_FILE_CACHE'} ? 1 : $self->{'FILE_CACHE'};
 364     my $cache_size  = ($self->{'CACHE'})         ? undef : 0;
 365     my $compile_dir = (! $self->{'FILE_CACHE'})  ? undef : $self->{'FILE_CACHE_DIR'} || $self->throw('output', 'Missing file_cache_dir');
 366     my $stat_ttl    = (! $self->{'BLIND_CACHE'}) ? undef : 60; # not sure how high to set the blind cache
 367     $cache_size = undef if $self->{'DOUBLE_FILE_CACHE'};
 368
 369     local $self->{'SYNTAX'}       = $self->{'SYNTAX'} || 'hte';
 370     local $self->{'NO_TT'}        = $self->{'NO_TT'} || ($self->{'SYNTAX'} eq 'hte' ? 0 : 1);
 371     local $self->{'CACHE_SIZE'}   = $cache_size;
 372     local $self->{'STAT_TTL'}     = $stat_ttl;
 373     local $self->{'COMPILE_DIR'}  = $compile_dir;
 374     local $self->{'ABSOLUTE'}     = 1;
 375     local $self->{'RELATIVE'}     = 1;
 376     local $self->{'INCLUDE_PATH'} = $self->{'PATH'} || './';
 377     local $self->{'V2EQUALS'}     = $self->{'V2EQUALS'} || 0;
 378     local $self->{'_documents'}   = \%DOCUMENTS;
 379     local $CGI::Ex::Template::QR_PRIVATE = undef;
 380
 381     if ($args->{'print_to'}) {
 382         $self->process_simple($content, $param, $args->{'print_to'}) || die $self->error;
 383         return undef;
 384     } else {
 385         my $out = '';
 386         $self->process_simple($content, $param, \$out) || die $self->error;
 387         return $out;
 388     }
 389 }
 390
 391 ###----------------------------------------------------------------###
 392
 393 1;