File Coverage

blib/lib/HTML/Template/Expr.pm

Criterion	Covered	Total	%
statement	177	213	83.1
branch	61	90	67.7
condition	13	21	61.9
subroutine	19	20	95.0
pod	2	3	66.6
total	272	347	78.3

package HTML::Template::Expr;

use strict;
use vars qw($VERSION);

$VERSION = '0.07';

use HTML::Template 2.4;
use Carp qw(croak confess carp);
use Parse::RecDescent;

use base 'HTML::Template';

use vars qw($GRAMMAR);
$GRAMMAR = <<'END';
expression : paren /^$/  { $return = $item[1] }

paren         : '(' binary_op ')'     { $item[2] }
              | '(' subexpression ')' { $item[2] }
              | subexpression         { $item[1] }
              | '(' paren ')'         { $item[2] }

subexpression : function_call
              | var
              | literal
              |

binary_op     : paren (op paren { [ $item[2], $item[1] ] })(s)
              { $return = [ 'SUB_EXPR', $item[1], map { @$_ } @{$item[2]} ] }

op            : />=?|<=?|!=|==/      { [ 'BIN_OP',  $item[1] ] }
              | /le|ge|eq|ne|lt|gt/  { [ 'BIN_OP',  $item[1] ] }
              | /\|\||or|&&|and/     { [ 'BIN_OP',  $item[1] ] }
              | /[-+*\/%]/           { [ 'BIN_OP',  $item[1] ] }

function_call : function_name '(' args ')'
                { [ 'FUNCTION_CALL', $item[1], $item[3] ] }
              | function_name ...'(' paren
                { [ 'FUNCTION_CALL', $item[1], [ $item[3] ] ] }
              | function_name '(' ')'
                { [ 'FUNCTION_CALL', $item[1] ] }

function_name : /[A-Za-z_][A-Za-z0-9_]*/

args          :

var           : /[A-Za-z_][A-Za-z0-9_]*/ { [ 'VAR', $item[1] ] }

literal       : /-?\d*\.\d+/             { [ 'LITERAL', $item[1] ] }
              | /-?\d+/                  { [ 'LITERAL', $item[1] ] }
              |          { [ 'LITERAL', $item[1][2] ] }

END


# create global parser
use vars qw($PARSER);
$PARSER = Parse::RecDescent->new($GRAMMAR);

# initialize preset function table
use vars qw(%FUNC);
%FUNC =
  (
   'sprintf' => sub { sprintf(shift, @_); },
   'substr'  => sub {
     return substr($_[0], $_[1]) if @_ == 2;
     return substr($_[0], $_[1], $_[2]);
   },
   'lc'      => sub { lc($_[0]); },
   'lcfirst' => sub { lcfirst($_[0]); },
   'uc'      => sub { uc($_[0]); },
   'ucfirst' => sub { ucfirst($_[0]); },
   'length'  => sub { length($_[0]); },
   'defined' => sub { defined($_[0]); },
   'abs'     => sub { abs($_[0]); },
   'atan2'   => sub { atan2($_[0], $_[1]); },
   'cos'     => sub { cos($_[0]); },
   'exp'     => sub { exp($_[0]); },
   'hex'     => sub { hex($_[0]); },
   'int'     => sub { int($_[0]); },
   'log'     => sub { log($_[0]); },
   'oct'     => sub { oct($_[0]); },
   'rand'    => sub { rand($_[0]); },
   'sin'     => sub { sin($_[0]); },
   'sqrt'    => sub { sqrt($_[0]); },
   'srand'   => sub { srand($_[0]); },
  );

sub new {
  my $pkg = shift;
  my $self;

  # check hashworthyness
  croak("HTML::Template::Expr->new() called with odd number of option parameters - should be of the form option => value")
    if (@_ % 2);
  my %options = @_;

  # check for unsupported options file_cache and shared_cache
  croak("HTML::Template::Expr->new() : sorry, this module won't work with file_cache or shared_cache modes.  This will hopefully be fixed in an upcoming version.")
    if ($options{file_cache} or $options{shared_cache});

  # push on our filter, one way or another.  Why did I allow so many
  # different ways to say the same thing?  Was I smoking crack?
  my @expr;
  if (exists $options{filter}) {
    # CODE => ARRAY
    $options{filter} = [ { 'sub'    => $options{filter},
                           'format' => 'scalar'         } ]
      if ref($options{filter}) eq 'CODE';

    # HASH => ARRAY
    $options{filter} = [ $options{filter} ]
      if ref($options{filter}) eq 'HASH';

    # push onto ARRAY
    if (ref($options{filter}) eq 'ARRAY') {
      push(@{$options{filter}}, { 'sub'    => sub { _expr_filter(\@expr, @_); },
                                  'format' => 'scalar' });
    } else {
      # unrecognized
      croak("HTML::Template::Expr->new() : bad format for filter argument.  Please check the HTML::Template docs for the allowed forms.");
    }
  } else {
    # new filter
    $options{filter} = [ { 'sub'    => sub { _expr_filter(\@expr, @_) },
                           'format' => 'scalar'
                         } ];
  }

  # force global_vars on
  $options{global_vars} = 1;

  # create an HTML::Template object, catch the results to keep error
  # message line-numbers helpful.
  eval {
    $self = $pkg->SUPER::new(%options,
			     expr => \@expr,
			     expr_func => $options{functions} || {});
  };
  croak("HTML::Template::Expr->new() : Error creating HTML::Template object : $@") if $@;

  return $self;
}

sub _expr_filter {
  my $expr = shift;
  my $text = shift;

  # find expressions and create parse trees
  my ($ref, $tree, $before_expr, $expr_text, $after_expr, $vars, $which, $out);
  $$text =~ s/
               <(?:!--\s*)?
               [Tt][Mm][Pp][Ll]_
               ([Ii][Ff]|[Uu][Nn][Ll][Ee][Ss][Ss]|[Vv][Aa][Rr]) # $1 => which tag
               (\s+[^<]+)?                                      # $2 => before expr
               \s+[Ee][Xx][Pp][Rr]=
               "([^"]*)"                                        # $3 => the actual expr
               (\s+[^>-]+)?                                     # $4 => after expr
               \s*(?:--)?>
             /
               $which       = $1;
               $before_expr = $2 || '';
               $expr_text   = $3;
               $after_expr  = $4 || '';

               # add enclosing parens to keep grammar simple
               $expr_text = "($expr_text)";

               # parse the expression
               eval {
                 $tree = $PARSER->expression($expr_text);
               };
               croak("HTML::Template::Expr : Unable to parse expression: $expr_text")
                  if $@ or not $tree;

               # stub out variables needed by the expression
               $out = "";
               foreach my $var (_expr_vars($tree)) {
                 next unless defined $var;
                 $out .= "";
               }

               # save parse tree for later
               push(@$expr, $tree);

               # add the expression placeholder and replace
               $out . "<\/tmpl_if>";
             /xeg;
  # stupid emacs - /

  return;
}

# find all variables in a parse tree
sub _expr_vars {
    my $tree = shift;
    my %vars;

    # hunt for VAR nodes in the tree
    my @stack = @$tree;
    while (@stack) {
        my $node = shift @stack;
        if (ref $node and ref $node eq 'ARRAY') {
            if ($node->[0] eq 'VAR') {
                $vars{$node->[1]} = 1;
            } else {
                push @stack, @$node;
            }
        }
    }
    return keys %vars;
}

# allow loops to stay as HTML::Template objects, we don't need to
# override output for them
sub _new_from_loop {
    my ($pkg, @args) = @_;
    return HTML::Template->_new_from_loop(@args);
}

sub output {
  my $self = shift;
  my $parse_stack = $self->{parse_stack};
  my $options = $self->{options};
  my ($expr, $expr_func);

  # pull expr and expr_func out of the parse_stack for cache mode.
  if ($options->{cache}) {
    $expr      = pop @$parse_stack;
    $expr_func = pop @$parse_stack;
  } else {
    $expr      = $options->{expr};
    $expr_func = $options->{expr_func};
  }

  # setup expression evaluators
  my %param;
  for (my $x = 0; $x < @$expr; $x++) {
    my $node = $expr->[$x];
    $param{"__expr_" . $x . "__"} = sub { _expr_evaluate($node, @_) };
  }
  $self->param(\%param);

  # setup %FUNC
  local %FUNC = (%FUNC, %$expr_func);

  my $result = $self->SUPER::output(@_);

  # restore cached values to their hideout in the parse_stack
  if ($options->{cache}) {
    push @$parse_stack, $expr_func;
    push @$parse_stack, $expr;
  }

  return $result;
}

sub _expr_evaluate {
  my ($tree, $template) = @_;
  my ($op, $lhs, $rhs, $node, $type, @stack);

  my @nodes = $tree;
  while (@nodes) {
      my $node = shift @nodes;
      my $type = $node->[0];

      if ($type eq 'LITERAL') {
          push @stack, $node->[1];
          next;
      }

      if ($type eq 'VAR') {
          push @stack, $template->param($node->[1]);
          next;
      }

      if ($type eq 'SUB_EXPR') {
          unshift @nodes, @{$node}[1..$#{$node}];
          next;
      }

      if ($type eq 'BIN_OP') {
          $op  = $node->[1];
          $rhs = pop(@stack);
          $lhs = pop(@stack);

          # do the op
          if ($op eq '==') {push @stack, $lhs == $rhs; next; }
          if ($op eq 'eq') {push @stack, $lhs eq $rhs; next; }
          if ($op eq '>')  {push @stack, $lhs >  $rhs; next; }
          if ($op eq '<')  {push @stack, $lhs <  $rhs; next; }

          if ($op eq '!=') {push @stack, $lhs != $rhs; next; }
          if ($op eq 'ne') {push @stack, $lhs ne $rhs; next; }
          if ($op eq '>=') {push @stack, $lhs >= $rhs; next; }
          if ($op eq '<=') {push @stack, $lhs <= $rhs; next; }

          if ($op eq '+')  {push @stack, $lhs + $rhs;  next; }
          if ($op eq '-')  {push @stack, $lhs - $rhs;  next; }
          if ($op eq '/')  {push @stack, $lhs / $rhs;  next; }
          if ($op eq '*')  {push @stack, $lhs * $rhs;  next; }
          if ($op eq '%')  {push @stack, $lhs % $rhs;  next; }

          if ($op eq 'le') {push @stack, $lhs le $rhs; next; }
          if ($op eq 'ge') {push @stack, $lhs ge $rhs; next; }
          if ($op eq 'lt') {push @stack, $lhs lt $rhs; next; }
          if ($op eq 'gt') {push @stack, $lhs gt $rhs; next; }

          # short circuit or
          if ($op eq 'or' or $op eq '||') {
              if ($lhs) {
                  push @stack, 1;
                  next;
              }
              if ($rhs) {
                  push @stack, 1;
                  next;
              }
              push @stack, 0;
              next;
          }

          # short circuit and
          if ($op eq '&&' or $op eq 'and') {
              unless ($lhs) {
                  push @stack, 0;
                  next;
              }
              unless ($rhs) {
                  push @stack, 0;
                  next;
              }
              push @stack, 1;
              next;
          }

          confess("HTML::Template::Expr : unknown op: $op");
      }

      if ($type eq 'FUNCTION_CALL') {
          my $name = $node->[1];
          my $args = $node->[2];
          croak("HTML::Template::Expr : found unknown subroutine call ".
                ": $name.\n")
            unless exists($FUNC{$name});
          if (defined $args) {
              push @stack,
                scalar
                  $FUNC{$name}->(map { _expr_evaluate($_, $template) } @$args);
          } else {
              push @stack, scalar $FUNC{$name}->();
          }
          next;
      }

      confess("HTML::Template::Expr : unrecognized node in tree: $node");
  }

  unless (@stack == 1) {
      confess("HTML::Template::Expr : stack overflow!  ".
              "Please report this bug to the maintainer.");
  }

  return $stack[0];
}

sub register_function {
  my($class, $name, $sub) = @_;

  croak("HTML::Template::Expr : args 3 of register_function must be subroutine reference\n")
    unless ref($sub) eq 'CODE';

  $FUNC{$name} = $sub;
}


# Make caching work right by hiding our vars in the parse_stack
# between cache store and load.  This is such a hack.
sub _commit_to_cache {
  my $self = shift;
  my $parse_stack = $self->{parse_stack};

  push @$parse_stack, $self->{options}{expr_func};
  push @$parse_stack, $self->{options}{expr};

  my $result = HTML::Template::_commit_to_cache($self, @_);
}

1;
__END__