File Coverage

blib/lib/HTML/Template/Bundle.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package HTML::Template::Bundle;
use strict;
use warnings FATAL => 'all';
use Carp qw(croak);
use HTML::Template::Expr '0.07_01';
use base 'HTML::Template::Expr';
use Exporter qw(import);
use HTML::Template::Filters;
our $VERSION = '0.01';
our @EXPORT = qw(tmpl_render);
our $DEBUG = int(defined $ENV{DEBUG} ? $ENV{DEBUG} : 0) unless $DEBUG;

sub new {
  my $proto = shift;
  my $class = ref($proto) || $proto;

  my $options = {};
  $options = HTML::Template::_load_supplied_options([@_], $options);
  $options->{extended_syntax} = 1;

  # Should we associate the environmental variables? If the value is set
  # to a string, that is the prefix otherwise use the syntax ENV.xxx (we
  # have already enabled structure_vars).
  my $env = delete $options->{env_variables};

  # create the instance
  my $self = $class->SUPER::new(%$options);
  die "Failed to create ".__PACKAGE__ unless $self;

  # Pump in the environmental variables
  if ($env) {
    my %pmap = map { $_ => 1 } $self->param();
    $env = "ENV" if ($env =~ /^\d+$/);
    my $sep = $options->{structure_vars} ? "." : "_";
    foreach my $k (keys %ENV) {
      my $key = $env.$sep.$k;
      $key = lc($key) unless $options->{case_sensitive};
      exists $pmap{$key} && $self->param($key => $ENV{$k});
    }
  }

  return bless $self, $class;
}

sub new_bundle {
  my $proto = shift;
  my $class = ref($proto) || $proto;

  my $options = {
    die_on_bad_params => 0,
    die_on_unset_params => 1,
    structure_vars => 1,
    loop_context_vars => 1,
    intrinsic_vars => 1,
    recursive_templates => -1,
    strict => 0,
    filter => HTML::Template::Filters->get_filters(
      HT_FILTER_ALLOW_TRAILING_SLASH,
      HT_FILTER_SSI_INCLUDE_VIRTUAL,
      HT_FILTER_PERCENT_VARIABLES,
      HT_FILTER_TMPL_CONSTANT,
      HT_FILTER_TMPL_COMMENT,
      HT_FILTER_TMPL_FIXME,
      HT_FILTER_TMPL_JOIN,
      $DEBUG ? HT_FILTER_STRIP_TMPL_NEWLINE_WHITESPACE : HT_FILTER_STRIP_REDUNDANT,
    ),
  };
  $options = HTML::Template::_load_supplied_options([@_], $options);

  my $self = $class->new(%$options);
  $self->param(DEBUG => $DEBUG);

  return $self;
}

#--------------------------------------------------------------------------
# Override the default handling of parsing of unknown
# TMPL_xxx tags. Tags we know about:
#
# TMPL_SET
#
sub handle_tmpl_construct {
  my ($self,$slash,$which,$part,$post,$pmap,$top_pmap) = @_;
  my $options = $self->{options};
  print STDERR "Handling custom TMPL_xxx construct:$/- TMPL_xxx: $slash$which$/- TMPL part: $part$/- post: $post$/ $/" if $options->{debug};

  if ($which eq 'SET') {

    # Translation of string and any template variables
    if ($part =~ /^\s*

                   # name = value
                   ([^=]+)         # $1 => name
                   \s*=\s*
                   (
                     (?:"[^"]*")
                     |
                     (?:'[^']*')
                     |
                     (?:[^\s]*)
                   )               # $2 => value

                   $/sxo) {
      my $name = $1;
      my $value = defined $2 ? $2 : '';
      if (defined $name and length $name) {
        $self->{set_stack} = [] unless $self->{set_stack};
        push @{$self->{set_stack}}, [$name,$value];
        return undef,$post;
      }
      print STDERR "Failed handling  - unknown key $/";
      return undef,$post;
    }

    print STDERR "Failed handling <".$slash."TMPL_$which \"$part\"> - incorrect syntax $/";
    return undef,$post;
  }

  return $self->SUPER::handle_tmpl_construct($slash,$which,$part,$post,$pmap,$top_pmap);
}

## overload default handling of ouput generation for custom TMPL_xxx tags
sub handle_parse_stack_construct {
  my ($self,$index,$type,$tmpl_obj,$force_untaint) = @_;
  my $options = $self->{options};
  return $self->SUPER::handle_parse_stack_construct($index,$type,$tmpl_obj,$force_untaint);
}

## Overload _init() so that we pump out the TMPL_SET param()'s
sub _init {
  my $self = shift;
  $self->SUPER::_init(@_);
  if ($self->{set_stack}) {
    foreach my $set (@{$self->{set_stack}}) {
      $self->param($set->[0] => $set->[1]);
    }
  }
}

## Simple support for batch/CGI processing
sub tmpl_render {
  my $tmplfile = shift;
  my $htmlfile = defined wantarray ? undef : shift;
  croak("Incorrect num of params to tmpl_render") unless (@_ % 2 == 0);
  my $path = [];
  if ($tmplfile =~ /(.*)\/(.*)$/) {
    push @$path, $1;
  }
  my $ht = __PACKAGE__->new_bundle(
    filename => $tmplfile,
    path => $path,
    search_path_on_include => 1,
  );
  for($. = 0; $. < scalar(@_); $. += 2) {
    my $key = $_[$.];
    my $val = $_[$.+1];
    $ht->param($key => $val);
    my $r = HTML::Template::reftype($val);
    if ($r eq 'ARRAY') {
      $val = scalar(@$val);
    } elsif ($r =~ 'HASH') {
      $val = scalar(keys %$val);
    } elsif (defined $val) {
      $val = length $val;
    } else {
      $val = 0;
    }
    $ht->param($key.".length" => $val);
  }
  my $content = $ht->output();
  if ($htmlfile) {
    open(FH,">","$htmlfile.tmp") or die $!;
    print FH $content;
    close(FH);
    rename("$htmlfile.tmp","$htmlfile") or die $!;
  }
  return $content;
}

1;
__END__