File Coverage

blib/lib/Text/Template/Simple/Base/Parser.pm

Criterion	Covered	Total	%
statement	147	153	96.0
branch	67	92	72.8
condition	26	34	76.4
subroutine	24	25	96.0
pod			n/a
total	264	304	86.8

## no critic (ProhibitUnusedPrivateSubroutines)
package Text::Template::Simple::Base::Parser;
use strict;
use warnings;

our $VERSION = '0.90';

use Text::Template::Simple::Util      qw(:all);
use Text::Template::Simple::Constants qw(:all);
use constant MAPKEY_NUM => 5;

my %INTERNAL = __PACKAGE__->_set_internal_templates;

sub _needs_object {
   my $self = shift;
   $self->[NEEDS_OBJECT]++;
   return $self;
}

sub _internal {
   my $self = shift;
   my $id   = shift            || fatal('tts.base.parser._internal.id');
   my $rv   = $INTERNAL{ $id } || fatal('tts.base.parser._internal.id');
   LOG( INTERNAL => "TEMPLATE: $id" ) if DEBUG;
   return $rv;
}

sub _parse {
   my($self, $raw, $opt) = @_;

   # $opt->
   #      map_keys: code sections are hash keys
   #      as_is   : i.e.: do not parse -> static include

   #$self->[NEEDS_OBJECT] = 0; # reset

   my($ds, $de) = @{ $self->[DELIMITERS] };
   my $faker    = $self->[INSIDE_INCLUDE] ? $self->_output_buffer_var
                                          : $self->[FAKER]
                                          ;
   my $buf_hash = $self->[FAKER_HASH];
   my($mko, $mkc) = $self->_parse_mapkeys( $opt->{map_keys}, $faker, $buf_hash );

   LOG( RAW => $raw ) if DEBUG > DEBUG_LEVEL_INSANE;

   my $h = {
      raw     => sub { ";$faker .= q~$_[0]~;" },
      capture => sub { ";$faker .= sub {" . $_[0] . '}->();'; },
      code    => sub { $_[0] . q{;} },
   };

   # little hack to convert delims into escaped delims for static inclusion
   $raw =~ s{\Q$ds}{$ds!}xmsg if $opt->{as_is};

   my($code, $inside) = $self->_walk( $raw, $opt, $h, $mko, $mkc );

   $self->[FILENAME] ||= '<ANON>';

   fatal(
      'tts.base.parser._parse.unbalanced',
         abs($inside),
         ($inside > 0 ? 'opening' : 'closing'),
         $self->[FILENAME]
   ) if $inside;

   return $self->_wrapper( $code, $opt->{cache_id}, $faker, $opt->{map_keys}, $h );
}

sub _walk {
   my($self, $raw, $opt, $h, $mko, $mkc) = @_;
   my $uth    = $self->[USER_THANDLER];
   my $code   = EMPTY_STRING;
   my $inside = 0;
   my $toke   = $self->connector('Tokenizer')->new(
                  @{ $self->[DELIMITERS] },
                  $self->[PRE_CHOMP],
                  $self->[POST_CHOMP]
               );

   my $is_raw = sub { my($id) = @_; T_RAW     == $id || T_NOTADELIM == $id };
   my $is_inc = sub { my($id) = @_; T_DYNAMIC == $id || T_STATIC    == $id };

   # fetch and walk the tree
   PARSER: foreach my $token ( @{ $toke->tokenize( $raw, $opt->{map_keys} ) } ) {
      my($str, $id, $chomp, undef) = @{ $token };

      LOG( TOKEN => $toke->_visualize_tid($id) . " => $str" )
         if DEBUG >= DEBUG_LEVEL_VERBOSE;

      next PARSER if T_DISCARD == $id || T_COMMENT == $id;

      if ( T_DELIMSTART == $id ) { $inside++; next PARSER; }
      if ( T_DELIMEND   == $id ) { $inside--; next PARSER; }

      $code .= $is_raw->($id)   ? $h->{raw    }->( $self->_chomp( $str, $chomp ) )
             : T_COMMAND == $id ? $h->{raw    }->( $self->_parse_command( $str ) )
             : T_CODE    == $id ? $h->{code   }->( $str                          )
             : T_CAPTURE == $id ? $h->{capture}->( $str                          )
             : $is_inc->($id)   ? $h->{capture}->( $self->_walk_inc( $opt, $id, $str) )
             : T_MAPKEY  == $id ? $self->_walk_mapkey(  $mko, $mkc, $str         )
             :                    $self->_walk_unknown( $h, $uth, $id, $str      )
             ;
   }
   return $code, $inside;
}

sub _walk_mapkey {
   my($self, $mko, $mkc, $str) = @_;
   return sprintf $mko, $mkc ? ( ($str) x MAPKEY_NUM ) : $str;
}

sub _walk_inc {
   my($self, $opt, $id, $str) = @_;
   return $self->_needs_object->include($id, $str, $opt);
}

sub _walk_unknown {
   my($self, $h, $uth, $id, $str) = @_;
   if ( DEBUG ) {
      LOG(
         $uth  ? ( USER_THANDLER => "$id" )
               : ( UNKNOWN_TOKEN => "Adding unknown token as RAW: $id($str)" )
      );
   }

   return $uth ? $uth->( $self, $id ,$str, $h ) : $h->{raw}->( $str );
}

sub _parse_command {
   my $self = shift;
   my $str  = shift;
   my($head, $raw_block) = split m{;}xms, $str, 2;
   my @buf  = split RE_PIPE_SPLIT, q{|} . trim($head);
   shift @buf;
   my %com  = map { trim $_ } @buf;

   if ( DEBUG >= DEBUG_LEVEL_INSANE ) {
      require Data::Dumper;
      LOG(
         PARSE_COMMAND => Data::Dumper::Dumper(
                           {
                              string  => $str,
                              header  => $head,
                              raw     => $raw_block,
                              command => \%com,
                           }
                        )
      );
   }

   if ( $com{FILTER} ) {
      # embed into the template & NEEDS_OBJECT++ ???
      my $old = $self->[FILENAME];
      $self->[FILENAME] = '<ANON BLOCK>';
      $self->_call_filters( \$raw_block, split RE_FILTER_SPLIT, $com{FILTER} );
      $self->[FILENAME] = $old;
   }

   return $raw_block;
}

sub _chomp {
   # remove the unnecessary white space
   my($self, $str, $chomp) = @_;

   # NEXT: discard: left;  right -> left
   # PREV: discard: right; left  -> right
   my($next, $prev) = @{ $chomp };
   $next ||= CHOMP_NONE;
   $prev ||= CHOMP_NONE;

   my $left_collapse  = ( $next & COLLAPSE_ALL ) || ( $next & COLLAPSE_RIGHT);
   my $left_chomp     = ( $next & CHOMP_ALL    ) || ( $next & CHOMP_RIGHT   );

   my $right_collapse = ( $prev & COLLAPSE_ALL ) || ( $prev & COLLAPSE_LEFT );
   my $right_chomp    = ( $prev & CHOMP_ALL    ) || ( $prev & CHOMP_LEFT    );

   $str = $left_collapse  ? ltrim($str, q{ })
        : $left_chomp     ? ltrim($str)
        :                   $str
        ;

   $str = $right_collapse ? rtrim($str, q{ })
        : $right_chomp    ? rtrim($str)
        :                   $str
        ;

   return $str;
}

sub _wrapper {
   # this'll be tricky to re-implement around a template
   my($self, $code, $cache_id, $faker, $map_keys, $h) = @_;
   my $buf_hash   = $self->[FAKER_HASH];
   my $wrapper    = EMPTY_STRING;
   my $inside_inc = $self->[INSIDE_INCLUDE] != RESET_FIELD ? 1 : 0;

   # build the anonymous sub
   if ( ! $inside_inc ) {
      # don't duplicate these if we're including something
      $wrapper .= 'package ' . DUMMY_CLASS . q{;};
      $wrapper .= 'use strict;' if $self->[STRICT];
   }
   $wrapper .= 'sub { ';
   $wrapper .= sprintf q~local $0 = '%s';~, escape( q{'} => $self->[FILENAME] );
   if ( $self->[NEEDS_OBJECT] ) {
      --$self->[NEEDS_OBJECT];
      $wrapper .= 'my ' . $self->[FAKER_SELF] . ' = shift;';
   }
   $wrapper .= $self->[HEADER].q{;}            if $self->[HEADER];
   $wrapper .= "my $faker = '';";
   $wrapper .= $self->_add_stack( $cache_id )  if $self->[STACK];
   $wrapper .= "my $buf_hash = {\@_};"         if $map_keys;
   $wrapper .= $self->_add_sigwarn if $self->[CAPTURE_WARNINGS];
   $wrapper .= "\n#line 1 " .  $self->[FILENAME] . "\n";
   $wrapper .= $code . q{;};
   $wrapper .= $self->_dump_sigwarn($h) if $self->[CAPTURE_WARNINGS];
   $wrapper .= "return $faker;";
   $wrapper .= '}';
   # make this a capture sub if we're including
   $wrapper .= '->()' if $inside_inc;

   LOG( COMPILED =>  $self->_mini_compiler(
                        $self->_internal('fragment'),
                        { FRAGMENT => $self->_tidy($wrapper) }
                     )
   ) if DEBUG >= DEBUG_LEVEL_VERBOSE;
   #LOG( OUTPUT => $wrapper );
   # reset
   $self->[DEEP_RECURSION] = 0; # reset
   return $wrapper;
}

sub _parse_mapkeys {
   my($self, $map_keys, $faker, $buf_hash) = @_;
   return( undef, undef ) if ! $map_keys;

   my $mkc = $map_keys eq 'check';
   my $mki = $map_keys eq 'init';
   my $t   = $mki ? 'map_keys_init'
           : $mkc ? 'map_keys_check'
           :        'map_keys_default'
           ;
   my $mko = $self->_mini_compiler(
               $self->_internal( $t ) => {
                  BUF  => $faker,
                  HASH => $buf_hash,
                  KEY  => '%s',
               } => {
                  flatten => 1,
               }
            );
   return $mko, $mkc;
}

sub _add_sigwarn {
   my $self = shift;
   $self->[FAKER_WARN] = $self->_output_buffer_var('array');
   my $rv = $self->_mini_compiler(
               $self->_internal('add_sigwarn'),
               { BUF     => $self->[FAKER_WARN] },
               { flatten => 1                   }
            );
   return $rv;
}

sub _dump_sigwarn {
   my $self = shift;
   my $h    = shift;
   my $rv = $h->{capture}->(
               $self->_mini_compiler(
                  $self->_internal('dump_sigwarn'),
                  { BUF     => $self->[FAKER_WARN] },
                  { flatten => 1                   }
               )
            );
   return $rv;
}

sub _add_stack {
   my $self    = shift;
   my $cs_name = shift || '<ANON TEMPLATE>';
   my $stack   = $self->[STACK] || EMPTY_STRING;

   return if lc($stack) eq 'off';

   my $check   = ($stack eq '1' || $stack eq 'yes' || $stack eq 'on')
               ? 'string'
               : $stack
               ;

   my($type, $channel) = split m{:}xms, $check;
   $channel = ! $channel             ? 'warn'
            :   $channel eq 'buffer' ? $self->[FAKER] . ' .= '
            :                          'warn'
            ;

   foreach my $e ( $cs_name, $type, $channel ) {
      $e =~ s{'}{\\'}xmsg;
   }

   return "$channel stack( { type => '$type', name => '$cs_name' } );";
}

sub _set_internal_templates {
   return
   # we need string eval in this template to catch syntax errors
   sub_include => <<'TEMPLATE_CONSTANT',
      <%OBJECT%>->_compile(
         do {
            local $@;
            my $file = eval '<%INCLUDE%>';
            my $rv;
            if ( my $e = $@ ) {
               chomp $e;
               $file ||= '<%INCLUDE%>';
               my $m = "The parameter ($file) is not a file. "
                     . "Error from sub-include ($file): $e";
               $rv = [ ERROR => '<%ERROR_TITLE%> ' . $m ]
            }
            else {
               $rv = $file;
            }
            $rv;
         },
         <%PARAMS%>,
         {
            _sub_inc => '<%TYPE%>',
            _filter  => '<%FILTER%>',
            _share   => [<%SHARE%>],
         }
      )
TEMPLATE_CONSTANT

   no_monolith => <<'TEMPLATE_CONSTANT',
      <%OBJECT%>->compile(
         q~<%FILE%>~,
         undef,
         {
            chkmt    => 1,
            _sub_inc => q~<%TYPE%>~,
         }
      );
TEMPLATE_CONSTANT

   # see _parse()
   map_keys_check => <<'TEMPLATE_CONSTANT',
      <%BUF%> .= exists <%HASH%>->{"<%KEY%>"}
               ? (
                  defined <%HASH%>->{"<%KEY%>"}
                  ? <%HASH%>->{"<%KEY%>"}
                  : "[ERROR] Key not defined: <%KEY%>"
                  )
               : "[ERROR] Invalid key: <%KEY%>"
               ;
TEMPLATE_CONSTANT

   map_keys_init => <<'TEMPLATE_CONSTANT',
      <%BUF%> .= <%HASH%>->{"<%KEY%>"} || '';
TEMPLATE_CONSTANT

   map_keys_default => <<'TEMPLATE_CONSTANT',
      <%BUF%> .= <%HASH%>->{"<%KEY%>"};
TEMPLATE_CONSTANT

   add_sigwarn => <<'TEMPLATE_CONSTANT',
      my <%BUF%>;
      local $SIG{__WARN__} = sub {
         push @{ <%BUF%> }, $_[0];
      };
TEMPLATE_CONSTANT

   dump_sigwarn => <<'TEMPLATE_CONSTANT',
      join("\n",
            map {
               s{ \A \s+    }{}xms;
               s{    \s+ \z }{}xms;
               "[warning] $_\n"
            } @{ <%BUF%> }
         );
TEMPLATE_CONSTANT

   compile_error => <<'TEMPLATE_CONSTANT',
Error compiling code fragment (cache id: <%CID%>):

<%ERROR%>
-------------------------------
PARSED CODE (VERBATIM):
-------------------------------

<%PARSED%>

-------------------------------
PARSED CODE    (tidied):
-------------------------------

<%TIDIED%>
TEMPLATE_CONSTANT

   fragment => <<'TEMPLATE_CONSTANT',

# BEGIN TIDIED FRAGMENT

<%FRAGMENT%>

# END TIDIED FRAGMENT
TEMPLATE_CONSTANT

   disk_cache_comment => <<'TEMPLATE_CONSTANT',
# !!!   W A R N I N G      W A R N I N G      W A R N I N G   !!!
# This file was automatically generated by <%NAME%> on <%DATE%>.
# This file is a compiled template cache.
# Any changes you make here will be lost.
#
TEMPLATE_CONSTANT
}

1;

__END__

=head1 NAME

Text::Template::Simple::Base::Parser - Base class for Text::Template::Simple

=head1 SYNOPSIS

Private module.

=head1 DESCRIPTION

This document describes version C<0.90> of C<Text::Template::Simple::Base::Parser>
released on C<5 July 2016>.

Private module.

=begin CHOMPING

The tokenizer uses a cursor to mark the chomping around a RAW token. Only RAW
tokens can be chomped. Basically, a RAW token can be imagined like this:

    _________
   |N|     |P|
   |E| STR |R|
   |X|     |E|
   |T|     |V|
    ---------

It'll have two labels on sides and the content in the center. When a chomp
directive is placed to the left delimiter, this affects the previous RAW token
and when it is placed to the right delimiter, it'll affect the next RAW token.
If the previous or next is not raw, nothing will happen. You need to swap sides
when handling the chomping. i.e.: left chomping affects the right side of the
RAW, and right chomping affects the left side of the RAW. _chomp() method in
the parser swaps sides to handle chomping. See Text::Template::Simple::Tokenizer
to have an idea on how pre-parsing happens.

=end CHOMPING

=head1 AUTHOR

Burak Gursoy <[e-mail]>.

=head1 COPYRIGHT

Copyright 2004 - 2016 Burak Gursoy. All rights reserved.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.24.0 or,
at your option, any later version of Perl 5 you may have available.
=cut