File Coverage

blib/lib/HTML/Template/JIT/Compiler.pm

Criterion	Covered	Total	%
statement	193	215	89.7
branch	65	86	75.5
condition	3	3	100.0
subroutine	24	24	100.0
pod	0	1	0.0
total	285	329	86.6

package HTML::Template::JIT::Compiler;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.01';

use HTML::Template;
use Carp qw(croak confess);
use File::Path qw(mkpath rmtree);

sub compile {
  my %args = @_;
  my $self = bless({});

  # parse the template as usual
  $self->{template} = HTML::Template->new(%args);

  # setup state
  $self->{jit_path}          = $args{jit_path};
  $self->{package}           = $args{package};
  $self->{package_dir}       = $args{package_dir};
  $self->{package_path}      = $args{package_path};
  $self->{jit_pool}          = [];
  $self->{jit_sym}           = 0;
  $self->{jit_debug}         = $args{jit_debug};
  $self->{text_size}         = 0;
  $self->{loop_context_vars} = $args{loop_context_vars};
  $self->{max_depth}         = 0;
  $self->{global_vars}       = $args{global_vars};
  $self->{print_to_stdout}   = $args{print_to_stdout};
  $self->{case_sensitive}    = $args{case_sensitive};

  # compile internal representation into a chunk of C code

  # get code for param function
  my @code = $self->_output();

  if ($self->{jit_debug}) {
    print STDERR "###################### CODE START ######################\n\n";
    open(INDENT, "| indent -kr > code.tmp");
    print INDENT join("\n", @code);
    close INDENT;
    open(CODE, 'code.tmp');
    print STDERR join('', );
    close(CODE);
    unlink('code.tmp');
    print STDERR "\n\n###################### CODE END ######################\n\n";
  }

  $self->_write_module(\@code);

  # try to load the module and return package handle if successful
  my $result;
  eval { $result = require $self->{package_path}; };
  return 1 if $result;

  # don't leave failed compiles lying around unless we're debuging
  rmtree($self->{package_dir}, 0, 0) unless $self->{jit_debug};
  die $@ if $@;
  return 0;
}

# writes out the module file
sub _write_module {
  my ($self, $code) = @_;

  # make directory
  mkpath($self->{package_dir}, 0, 0700);

  # open module file
  open(MODULE, ">$self->{package_path}") or die "Unable to open $self->{package_path} for output : $!";

  my $inline_debug = "";
  my $optimize = "-O3";
  if ($self->{jit_debug}) {
    $inline_debug = ", CLEAN_AFTER_BUILD => 0";
    $optimize = "-g";
  }

  # print out preamble
  print MODULE <
package $self->{package};
use base 'HTML::Template::JIT::Base';

use Inline C => Config => OPTIMIZE => "$optimize", DIRECTORY => "$self->{package_dir}" $inline_debug;
use Inline C => <<'CODE_END';

END

  # print out code
  print MODULE join("\n", @$code), "\nCODE_END\n";

  # output the param hash
  print MODULE "our \%param_hash = (\n", join(',', $self->_param_hash([])), ");\n";

  # empty param map
  print MODULE "our \%param_map;\n";

  # note case sensitivity
  print MODULE "our \$case_sensitive = $self->{case_sensitive};\n";

  print MODULE "\n1;\n";

  # all done
  close MODULE;
}

# construct the output function
sub _output {
  my $self = shift;
  my $template = $self->{template};

  # construct body of output
  my @code = $self->_output_template($template, 0);

  # write global pool
  unshift @code, '', $self->_write_pool();

  # setup result size based on gathered stats with a little extra for variables
  my $size = int ($self->{text_size} + ($self->{text_size} * .10));

  # head code for output function, deferred to allow for $size and
  # max_depth setup
  unshift @code, <
SV * output(SV *self) {
  SV *result = NEWSV(0, $size);
  HV *param_map[($self->{max_depth} + 1)];
  SV ** temp_svp;
  SV * temp_sv;
  int i;
  STRLEN len;
  unsigned char c;
  char buf[4];

  SvPOK_on(result);
  param_map[0] = get_hv("$self->{package}::param_map", 0);

END

  # finish output function
  push @code, "return result;", "}";

  return @code;
}

# output the body of a single scope (top-level or loop)
sub _output_template {
  my ($self, $template, $offset) = @_;
  $self->{max_depth} = $offset
    if $offset > $self->{max_depth};

  my (@code, @top, %vars, @pool, %blocks, $type, $name, $var,
      $do_escape, $has_default);

  # setup some convenience aliases ala HTML::Template::output()
  use vars qw($line  @parse_stack  %param_map);
  local      (*line, *parse_stack, *param_map);
  *parse_stack = $template->{parse_stack};
  *param_map   = $template->{param_map};

  my %reverse_param_map = map { $param_map{$_} => $_ } keys %param_map;
  my $parse_stack_length = $#parse_stack;

  for (my $x = 0; $x <= $parse_stack_length; $x++) {
    *line = \$parse_stack[$x];
    $type = ref($line);

    # need any block closings on this line?
    push(@code, "}" x $blocks{$x}) if $blocks{$x};

    if ($type eq 'SCALAR') {
      # append string and add size to text_size counter
      if ($self->{print_to_stdout}) {
        push @code, _print_string($$line);
      } else {
        push @code, _concat_string($$line);
        $self->{text_size} += length $$line;
      }

    } elsif ($type eq 'HTML::Template::VAR') {
      # get name for this variable from reverse map
      $name = $reverse_param_map{$line};

      # check var cache - can't use it for escaped variables
      if (exists $vars{$name}) {
        $var = $vars{$name};
      }

      # load a new one if needed
      else {
        $var = $self->_get_var("SV *", "&PL_sv_undef", \@pool);
        push @top, _load_var($name, $var, $offset, $self->{global_vars});
        $vars{$name} = $var;
      }

      # escape var if needed
      if ($do_escape) {
        push @code, _escape_var($var, $do_escape);
      }

      # append the var
      push @code, ($self->{print_to_stdout} ? _print_var($var,  $do_escape, $has_default) :
                                              _concat_var($var, $do_escape, $has_default));

      # reset flags
      undef $do_escape;
      undef $has_default;

    } elsif ($type eq 'HTML::Template::DEFAULT') {
      $has_default = $$line;

    } elsif ($type eq 'HTML::Template::LOOP') {
      # get loop template
      my $loop_template = $line->[HTML::Template::LOOP::TEMPLATE_HASH]{$x};

      # allocate an hv for the loop param_map
      my $loop_offset = $offset + 1;

      # remember text_size before loop
      my $old_text_size = $self->{text_size};

      # output the loop start
      push @code, $self->_start_loop($reverse_param_map{$line}, $offset,
				     $loop_offset);

      # output the loop code
      push @code, $self->_output_template($loop_template, $loop_offset);

      # send the loop
      push @code, $self->_end_loop();

      # guesstimate average loop run of 10 and pre-allocate space for
      # text accordingly.  This is a bit silly but something has to be
      # done to account for loops increasing result size...
      $self->{text_size} += (($self->{text_size} - $old_text_size) * 9);

    } elsif ($type eq 'HTML::Template::COND') {
      # if, unless and else

      # store block end loc
      $blocks{$line->[HTML::Template::COND::JUMP_ADDRESS]}++;

      # get name for this var
      $name = $reverse_param_map{$line->[HTML::Template::COND::VARIABLE]};

      # load a new var unless we have this one
      if (exists $vars{$name}) {
        $var = $vars{$name};
      } else {
        $var = $self->_get_var("SV *", "&PL_sv_undef", \@pool);
        push @top, _load_var($name, $var, $offset, $self->{global_vars});
        $vars{$name} = $var;
      }

      # output conditional
      push(@code, $self->_cond($line->[HTML::Template::COND::JUMP_IF_TRUE],
			       $line->[HTML::Template::COND::VARIABLE_TYPE] == HTML::Template::COND::VARIABLE_TYPE_VAR,
                               $var,
                               $line->[HTML::Template::COND::UNCONDITIONAL_JUMP],
			      ));
    } elsif ($type eq 'HTML::Template::ESCAPE') {
      $do_escape = 'HTML';
    } elsif ($type eq 'HTML::Template::URLESCAPE') {
      $do_escape = 'URL';
    } elsif ($type eq 'HTML::Template::JSESCAPE') {
      $do_escape = 'JS';
    } elsif ($type eq 'HTML::Template::NOOP') {
      # noop
    } else {
      confess("Unsupported object type in parse stack : $type");
    }
  }

  # output pool of variables used in body
  unshift @code, '{', $self->_write_pool(\@pool), @top;
  push @code, '}';

  return @code;
}

# output a conditional expression
sub _cond {
  my ($self, $is_unless, $is_var, $var, $is_uncond) = @_;
  my @code;

  if ($is_uncond) {
    push(@code, "else {");
  } else {
    if ($is_var) {
      if ($is_unless) {
        # unless var
        push(@code, "if (!SvTRUE($var)) {");
      } else {
        # if var
        push(@code, "if (SvTRUE($var)) {");
      }
    } else {
      if ($is_unless) {
        # unless loop
        push(@code, "if ($var == &PL_sv_undef || av_len((AV *) SvRV($var)) == -1) {");
      } else {
        # if loop
        push(@code, "if ($var != &PL_sv_undef && av_len((AV *) SvRV($var)) != -1) {");
      }
    }
  }

  return @code;
}

# start a loop
sub _start_loop {
  my ($self, $name, $offset, $loop_offset) = @_;
  my $name_string = _quote_string($name);
  my $name_len    = length($name_string);
  my @pool;
  my $av          = $self->_get_var("AV *", 0, \@pool);
  my $av_len      = $self->_get_var("I32", 0, \@pool);
  my $counter     = $self->_get_var("I32", 0, \@pool);
  my @code;

  my $odd;
  if ($self->{loop_context_vars}) {
    $odd = $self->_get_var("I32", 0, \@pool);
    push(@code, "$odd = 0;");
  }

  push @code, <
temp_svp = hv_fetch(param_map[$offset], "$name_string", $name_len, 0);
if (temp_svp && (*temp_svp != &PL_sv_undef)) {
   $av = (AV *) SvRV(*temp_svp);
   $av_len = av_len($av);

   for($counter = 0; $counter <= $av_len; $counter++) {
      param_map[$loop_offset] = (HV *) SvRV(*(av_fetch($av, $counter, 0)));
END

  if ($self->{loop_context_vars}) {
    push @code, <
      if ($counter == 0) {
	hv_store(param_map[$loop_offset], "__first__", 9, &PL_sv_yes, 0);
	hv_store(param_map[$loop_offset], "__inner__", 9, &PL_sv_no, 0);
	if ($av_len == 0)
        hv_store(param_map[$loop_offset], "__last__",  8,  &PL_sv_yes, 0);
      } else if ($counter == $av_len) {
        hv_store(param_map[$loop_offset], "__first__", 9, &PL_sv_no, 0);
        hv_store(param_map[$loop_offset], "__inner__", 9, &PL_sv_no, 0);
        hv_store(param_map[$loop_offset], "__last__",  8,  &PL_sv_yes, 0);
      } else {
        hv_store(param_map[$loop_offset], "__first__", 9, &PL_sv_no, 0);
        hv_store(param_map[$loop_offset], "__inner__", 9, &PL_sv_yes, 0);
        hv_store(param_map[$loop_offset], "__last__",  8,  &PL_sv_no, 0);
      }

      hv_store(param_map[$loop_offset], "__odd__", 7, (($odd = !$odd) ? &PL_sv_yes : &PL_sv_no), 0);
      hv_store(param_map[$loop_offset], "__counter__", 11, newSViv($counter + 1), 0);
END

  }

  unshift @code, "{", $self->_write_pool(\@pool);

  return @code;
}

# end a loop
sub _end_loop {
  return '}}}';
}

# construct %param_hash
sub _param_hash {
  my ($self, $path) = @_;
  my $template = $self->{template};

  my @params;
  if (@$path) {
    @params = $template->query(LOOP => $path);
  } else {
    @params = $template->param();
  }

  my @out;
  foreach my $name (@params) {
    my $type = $template->query(name => [ @$path, $name ]);
    if ($type eq 'VAR') {
      push @out, "'$name'", 1;
    } else {
      push @out, "'$name'", "\n{" . join(', ', $self->_param_hash([ @$path, $name ])) . "\n}\n";
    }
  }

  return @out;
}


# get a fresh var of the requested C type from the pool
sub _get_var {
  my ($self, $type, $default, $pool) = @_;
  $pool = $self->{jit_pool} unless defined $pool;
  my $sym = "sym_" . $self->{jit_sym}++;
  push @$pool, $type, ($default ? "$sym = $default" : $sym);
  return $sym;
}

# write out the code to initialize the pool
sub _write_pool {
  my ($self, $pool) = @_;
  $pool = $self->{jit_pool} unless defined $pool;
  my @code;

  for (my $index = 0; $index < @$pool; $index += 2) {
      push(@code, $pool->[$index] . ' ' . $pool->[$index + 1] . ";");
  }
  @$pool = ();
  return @code;
}

# concatenate a string onto result
sub _concat_string {
  return "" unless $_[0];
  my $len = length($_[0]);
  my $string = _quote_string($_[0]);

  return "sv_catpvn(result, \"$string\", $len);"
}

# concatenate a string onto result
sub _print_string {
  return "" unless $_[0];
  my $string = _quote_string($_[0]);
  return "PerlIO_stdoutf(\"$string\");";
}

# loads a variable into a lexical pool variable
sub _load_var {
  my ($name, $var, $offset, $global) = @_;
  my $string = _quote_string($name);
  my $len    = length($name);

  return <
for (i = $offset; i >= 0; i--) {
   if (hv_exists(param_map[i], "$string", $len)) {
      $var = *(hv_fetch(param_map[i], "$string", $len, 0));
      if ($var != &PL_sv_undef) break;
   }
}
END

  return <
if (hv_exists(param_map[$offset], "$string", $len))
   $var = *(hv_fetch(param_map[$offset], "$string", $len, 0));
END
}

# loads a variable and escapes it
sub _escape_var {
  my ($var, $escape) = @_;

  # apply escaping to a mortal copy in temp_sv
  my @code = (<
if ($var != &PL_sv_undef) {
  SvPV_force($var, len);
  temp_sv = sv_mortalcopy($var);
  len = 0;
  while (len < SvCUR(temp_sv)) {
    c = *(SvPVX(temp_sv) + len);
END

  # perform the appropriate escapes
  if ($escape eq 'HTML') {
      push @code, <
    switch (c) {
      case '&':
        sv_insert(temp_sv, len, 1, "&",  5);
        len += 4;
        break;
      case '"':
        sv_insert(temp_sv, len, 1, """, 6);
        len += 5;
        break;
      case '>':
        sv_insert(temp_sv, len, 1, ">",   4);
        len += 3;
        break;
      case '<':
        sv_insert(temp_sv, len, 1, "<",   4);
        len += 3;
        break;
      case '\\'':
        sv_insert(temp_sv, len, 1, "'",  5);
        len += 4;
        break;
    }
END
  } elsif ($escape eq 'URL') {
      push @code, <
    if (!(isALNUM(c) || (c == '-') || (c == '.'))) {
       sprintf(buf, "%%%02X", c);
       sv_insert(temp_sv, len, 1, buf, 3);
       len += 2;
    }
END
  } elsif ($escape eq 'JS') {
      push @code, <<'END';
    switch (c) {
      case '\\':
      case '\'':
      case '"':
        sprintf(buf, "\\%c", c);
        sv_insert(temp_sv, len, 1, buf, 2);
        len += 1;
        break;
      case '\n':
        sprintf(buf, "\\n");
        sv_insert(temp_sv, len, 1, buf, 2);
        len += 1;
        break;
      case '\r':
        sprintf(buf, "\\r");
        sv_insert(temp_sv, len, 1, buf, 2);
        len += 1;
    }
END

  } else {
    die "Unknown escape type '$escape'.";
  }

  push @code, <
    len++;
  }
}
END

  return @code;
}

# concatenate a var onto result
sub _concat_var {
  return "if ($_[0] != &PL_sv_undef) sv_catsv(result, " .
    ($_[1] ? "temp_sv" : $_[0]) . ");" .
        (defined $_[2] ? " else " . _concat_string($_[2]) : "");
}

# print a var to stdout
sub _print_var {
  return "if ($_[0] != &PL_sv_undef) PerlIO_stdoutf(SvPV_nolen(" .
    ($_[1] ? "temp_sv" : $_[0]) . "));" .
      (defined $_[2] ? " else " . _print_string($_[2]) : "");
}

# turn a string into something that C will accept inside
# double-quotes.  or should I go the array of bytes route?  I think
# that might be the only way to get UTF-8 working.  It's such hell to
# debug though...
sub _quote_string {
  my $string = shift;
  $string    =~ s/\\/\\\\/g;
  $string    =~ s/"/\\"/g;
  $string    =~ s/\r/\\r/g;
  $string    =~ s/\n/\\n/g;
  $string    =~ s/\t/\\t/g;
  return $string;
}

1;

__END__