view release on metacpan or  search on metacpan

lib/Text/Template/Simple/Base/Parser.pm  view on Meta::CPAN

   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

lib/Text/Template/Simple/Base/Parser.pm  view on Meta::CPAN

}

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%>"