File Coverage

lib/Su/Template.pm

Criterion	Covered	Total	%
statement	231	235	98.3
branch	50	62	80.6
condition	21	27	77.7
subroutine	14	15	93.3
pod	3	4	75.0
total	319	343	93.0

package Su::Template;

use strict;
use warnings;
use Exporter;

use File::Path;
use Data::Dumper;
use Test::More;
use Carp;
use Fatal qw(open close);

use Su::Log;

our @ISA = qw(Exporter);

# render requires explicit use declaration.
our @EXPORT    = qw(expand);
our @EXPORT_OK = qw(render);

our $DEBUG = 0;

# not used.
my $MODULE_PATH = __FILE__;

# not used.
our $TEMPLATE_BASE_DIR = "./";

# not used.
our $TEMPLATE_DIR = "Templates";

=pod

=head1 NAME

Su::Template - A module to make the string using the specified template and passed parameters.

=head1 SYNOPSIS

 my $tmpl = Su::Template->new;
 my $str = $tmpl->expand( <<'HERE', $arg);
 % my $arg = shift;
 arg is <%=$arg%>
 HERE

=head1 DESCRIPTION

Su::Template is a module to make the string using the specified template and passed parameters.

=head1 AUTHOR

lottz

=head1 FUNCTIONS

=over

=cut

=item new()

A constructor.

=cut

sub new {
  my $self = shift;

  my %h = @_ if @_;
  my $log = Su::Log->new;
  $h{logger} = $log;
  return bless \%h, $self;
} ## end sub new

sub import {
  my $self = shift;

  # Save import list and remove from hash.
  my %tmp_h = @_ if @_;
  my $imports_aref = $tmp_h{import};
  delete $tmp_h{import};
  my $base = $tmp_h{base};
  my $dir  = $tmp_h{dir};
  Su::Log->trace( "base:" . Dumper($base) );
  Su::Log->trace( "dir:" . Dumper($dir) );

  #  print "base:" . Dumper($base) . "\n";
  #  print "dir:" . Dumper($dir) . "\n";

  $TEMPLATE_BASE_DIR = $base if $base;
  $TEMPLATE_DIR      = $dir  if $dir;

  if ( $base || $dir ) {
    $self->export_to_level( 1, $self, @{$imports_aref} );
  } else {

# If 'base' or 'dir' is not passed, then all of the parameters are required method names.
    $self->export_to_level( 1, $self, @_ );
  }

} ## end sub import

=item expand()

Expand the template using the passed context and return the result string.
Note that the keyword for here document must quoted by single quote. Double quote should cause unexpected error.

Template syntax:

 <%= $val %> render the variable. Html special character will escaped.
 <%== $val %> render the variable. Html special character will not escaped.
 End tag ~%> discards line separator.
 Expression surrounded by <% %> or the line start with '%' will parsed as Perl statements.

If you want debug output, set the following flag on,  then expand method return the debug string.

 $Su::Template::DEBUG=1;

The functional style usage of this method is the following.

 $ret = Su::Template::expand(<<'__HERE__');
 <% foreach my $v ("aa","bb","cc"){~%>
 <%= $v%>
 <%}~%>
 xxx
 yyy
 zzz
 __HERE__

The OO style usage of this method is the following.

 my $tmpl = Su::Template->new;
 my $str = $tmpl->expand( <<'HERE', $title, $link );
 % my $title = shift;
 % my $link = shift;
 <%=$title%>
 HERE

The html special character in variable expression will be escaped like the following.

 $ret = $t->expand( <<'__HERE__', "aacc'dd\"ee&ff" );
 % my $arg = shift;
 <%= $arg ~%>
 __HERE__

 is( $ret, "aa<bb>cc'dd"ee&ff" );

Note that the html special character described in the raw part of the template will not be escaped.

=cut

my $escape_hash_str =
"my %escape_h = (  '<'  => '<',  '>'  => '>',  '\"'  => '"',  \"'\", => ''',  '&'  => '&',);";

sub expand {
  no warnings qw(redefine);

  # TODO: If the pushed data to the list @f_t_a is a empty strng, then
  #       we should remove this process to simplify and optimize the
  #       method `make_template`.  But whether add "\n" or not is rather
  #       complex, so optimization is a put-offed task.
  my $self = shift if ( ref $_[0] eq __PACKAGE__ );
  my $DEBUG = $self->{debug} ? $self->{debug} : $DEBUG;

  my $org                = shift;
  my @args               = @_;
  my @ret                = "";
  my $b_perl_mode        = 0;
  my $b_no_last_newline  = 0;
  my $b_need_escape_hash = 0;
  my $b_need_tmp_val     = 0;

# add dumy \n prepare for after pop. And set flag not to add \n the end of the line.
  if ( substr( $org, ( length $org ) - 1 ) ne "\n" ) {
    $org .= "\n";
    $b_no_last_newline = 1;
  }

  my @lines = split "\n", $org, -1;
  pop @lines;
  my $line_num      = scalar @lines;
  my $current_line  = 0;
  my $candidate_str = '';
  Su::Log->trace( "org:" . Dumper($org) );
  for my $l (@lines) {
    Su::Log->trace( "loop:" . $l );
    ++$current_line;
    my $b_match            = 0;
    my $b_need_line_return = 1;
    if ( $b_perl_mode && $l =~ /(.*)%>(\s*)$/ ) {
      $b_perl_mode        = 0;
      $b_match            = 1;
      $b_need_line_return = 0;
      push @ret, $1;
      Su::Log->trace("perl mode out");
    } elsif ($b_perl_mode) {
      Su::Log->trace("is perl mode");
      $b_match            = 1;
      $b_need_line_return = 0;
      push @ret, $l;
    } elsif ( substr( $l, 0, 1 ) eq '%' ) {
      push @ret, substr( $l, 1 );
      $b_match            = 1;
      $b_need_line_return = 0;
    } elsif ( $l =~ /^\s*<%(.*)/ && index( $l, "%>" ) == -1 ) {
      $b_perl_mode        = 1;
      $b_need_line_return = 0;
      $b_match            = 1;
      push @ret, $1;
      Su::Log->trace("perl mode in");
    } else {
      my $prev_pos = 0;
      while ( $l =~ /<%((={0,2})(.*?)([~])?)%>/g ) {
        $b_match = 1;

   #      push @ret, ('push(@f_t_a, \'' . $`. '\');') if $`; # add previous part
        my $tmp = $-[0];

        $candidate_str = substr( $l, $prev_pos, $tmp - $prev_pos );

        #note: Ensure matched varibe like $1 not effect outer scope.
        {
          $candidate_str =~ s/'/\\'/g if defined $candidate_str;
        }
        $candidate_str && push @ret,
          ( 'push(@f_t_a, \'' . $candidate_str . '\');' )
          ;    # save from previous end pos to current start pos.
        if ( defined $2 && ( $2 eq '=' or $2 eq '==' ) )
        {      # print variable itself
          my $exp = $3;

          $b_need_tmp_val = 1;
          if ( $2 eq '=' ) {
            $b_need_escape_hash = 1;
          }

          {
            $exp =~ s/^ *(.*?) *$/$1/;    # trim front and end of white space.
          }

#        push @ret, ('push(@f_t_a, (' . $exp . '));'); # NOTE: other variables may be double quote not single quote like this like.

          # Escape and push.
          if ( $2 eq '=' ) {
            push @ret, '$tmp_val = ' . '(' . $exp . ');';

# If the special charactor is already escaped using '&', then prevent unexpected double escaped.
            push @ret, 'if($tmp_val){
                            $tmp_val=~s/&(?!(lt|gt|amp|quot|apos);)/&/go;
                            $tmp_val=~s/(<|>|\'|")/$escape_h{$1}/go;';

            # $tmp_val=~s/(<|>|\'|"|&)/$escape_h{$1}/go;';
            push @ret, ( 'push(@f_t_a, $tmp_val' . ');}' );
            push @ret, ('elsif(defined $tmp_val){push(@f_t_a, $tmp_val);}');
          } else {

            # Push only. Not escape.
            push @ret, '$tmp_val = ' . '(' . $exp . ');';
            push @ret, 'if($tmp_val){';
            push @ret, ( 'push(@f_t_a, $tmp_val' . ');}' );
            push @ret, ('elsif(defined $tmp_val){push(@f_t_a, $tmp_val);}');

          } ## end else [ if ( $2 eq '=' ) ]

        } else {
          push @ret, $3;
        }
        $prev_pos = pos($l);

        $b_need_line_return = 0 if ( defined $4 && $4 eq '~' );
      }    #while match

# If match, register tail part. If not this condition, <% %>not include line will  retisterred twice!
      if ($b_match) {
        $candidate_str = substr( $l, $prev_pos, ( length $l ) - $prev_pos );

        #note: Ensure matched varibe like $1 not effect outer scope.
        {
          $candidate_str =~ s/'/\\'/g if defined $candidate_str;
        }
        $candidate_str && push @ret,
          ( 'push(@f_t_a, \'' . $candidate_str . '\');' )
          ;    # save to the tail of the line.
      } ## end if ($b_match)
    }    # else end

    my $no_need_newline = ( $line_num == $current_line ) && $b_no_last_newline;

# Add new line to the make_template function itself. If the current line is comment, then we need new line to add \n to the @f_t_a array.
    push @ret, "\n";

    if ($b_match) {
      Su::Log->trace("line b_match");

#      push @ret, ('push(@f_t_a, \'' . (($b_need_line_return && !$b_no_newline) ? "\n" : '') . '\');');# print eol.
      push @ret,
        (   'push(@f_t_a, \''
          . ( ( $b_need_line_return && !$no_need_newline ) ? "\n" : '' )
          . '\');' );    # print eol.
    } else {
      Su::Log->trace("line not b_match");
      $l =~ s/'/\\'/g;

#      push @ret, ('push(@f_t_a, \'' . $l. (($b_need_line_return && !$b_no_newline) ? "\n" : '') . '\');');#print whole line.
      if ( !$b_need_line_return || $no_need_newline ) {
        $l && push @ret, ( 'push(@f_t_a, \'' . $l . '\');' );
      } else {

        #print whole line.
        push @ret, ( 'push(@f_t_a, \'' . $l . "\n" . '\');' );
      }
    } ## end else [ if ($b_match) ]

    #    push @ret, "\n";
  }    #while line

  unshift( @ret, 'my $tmp_val="";' . "\n" )
    if $b_need_tmp_val;
  unshift( @ret, $escape_hash_str . "\n" )
    if $b_need_escape_hash;

  unshift( @ret, 'sub make_template{' . "\n" . 'my @f_t_a=();' . "\n" );
  push( @ret, 'return join(\'\',@f_t_a);' . "\n" . '}' );
  my $prepare_data = join( '', @ret );
  eval($prepare_data);
  $@ and die "[ERROR]Invalid Template format:" . $@ . "\n" . $prepare_data;

  if ($DEBUG) {
    return $prepare_data;    # return pre-eval data.
  } else {
    return make_template(@args);    # call evaled method.
  }
}    # eos expand()

=item render()

An alias to the method L.

=cut

sub render {
  return expand(@_);
}

=pod

=back

=cut

1;