File Coverage

blib/lib/Template/Extract/Compile.pm

Criterion	Covered	Total	%
statement	83	94	88.3
branch	19	26	73.0
condition			n/a
subroutine	17	17	100.0
pod	2	11	18.1
total	121	148	81.7

package Template::Extract::Compile;
$Template::Extract::Compile::VERSION = '0.50';
use strict;
use warnings;
use 5.006;

our ( $DEBUG,  );
our $EXACT = undef();

my ( $paren_id, $block_id );

sub new {
    my $class = shift;
    my $self  = {};
    return bless( $self, $class );
}

sub compile {
    my ( $self, $template, $parser ) = @_;

    $self->_init();

    if ( defined $template ) {
        $parser->{FACTORY} = ref($self);
        $template = $$template if UNIVERSAL::isa( $template, 'SCALAR' );
        $template =~ s/\n+$//;
        $template =~ s/\[%\s*(?:\.\.\.|_|__)\s*%\]/[% \/.*?\/ %]/g;
        $template =~ s/\[%\s*(\/.*?\/)\s*%\]/'[% "' . quotemeta($1) . '" %]'/eg;
        $template =~ s{
            \[%\s*([a-zA-z0-9][a-zA-z0-9\.]*)\s*\=\~\s*(/.*?/)\s*%\]
        }{
            '[% SET ' . $1 . ' = "' . quotemeta($2) . '" %]'
        }mxegi;

        return $parser->parse($template)->{BLOCK};
    }
    ## no critic
    return undef;
}

# initialize temporary variables
sub _init {
    $paren_id = 0;
    $block_id = 0;
}

# utility function to add regex eval brackets
sub _re { "(?{\n    @_\n})" }

# --- Factory API implementation begins here ---

sub template {
    my $regex = $_[1];

    $regex =~ s/\*\*//g;
    $regex =~ s/\+\+/+/g;
    if ($EXACT)
    {
        $regex = "^$regex\$";
    }

    # Deal with backtracking here -- substitute repeated occurences of
    # the variable into backtracking sequences like (\1)
    my %seen;
    $regex =~ s{(                       # entire sequence [1]
        \(\.\*\?\)                      #   matching regex
        \(\?\{                          #   post-matching regex...
            \s*                         #     whitespaces
            _ext\(                      #     capturing handler...
                \(                      #       inner cluster of...
                    \[ (.+?) \],\s*     #         var name [2]
                    \$.*?,\s*           #         dollar with ^N/counter
                    (\d+)               #         counter [3]
                \)                      #       ...end inner cluster
                (.*?)                   #       outer loop stack [4]
            \)                          #     ...end capturing handler
            \s*                         #     whitespaces
        \}\)                            #   ...end post-maching regex
    )}{
        if ($seen{$2, $4}) {                # if var reoccured in the same loop
            "(\\$seen{$2, $4})";            #   replace it with backtracker
        }
        else {
            $seen{$2, $4} = $3;
            if ($+[0] == length $regex) {   # otherwise, if it is the end
                '(.*)' . substr( $1, 5 );   #   make it greedy
            }
            else {
                $1;                         # otherwise, preserve the sequence
            }
        }
    }gex;

    return $regex;
}

sub foreach {
    my $regex = $_[4];

    # find out immediate children
    my %vars =
      reverse( $regex =~ /_ext\(\(\[(\[?)('\w+').*?\], [^,]+, \d+\)\*\*/g );
    my $vars = join( ',', map { $vars{$_} ? "\\$_" : $_ } sort keys %vars );

    # append this block's id into the _get calling chain
    ++$block_id;
    ++$paren_id;
    $regex =~ s/\*\*/, $block_id**/g;
    $regex =~ s/\+\+/*/g;

    return (

        # sets $cur_loop
        _re("_enter_loop($_[2], $block_id)") .

          # match loop content
          "(?:\\n*?$regex)++()" .

          # weed out partial matches
          _re("_ext(([[$_[2],[$vars]]], \\'leave_loop', $paren_id)**)") .

          # optional, implicit newline
          "\\n*?"
    );
}

sub get {
    return "(?:$1)" if $_[1] =~ m{^/(.*)/$};

    ++$paren_id;

    # ** is the placeholder for parent loop ids
    return "(.*?)" . _re("_ext(([$_[1]], \$$paren_id, $paren_id)\*\*)");
}

sub set {
    my $regex = undef;

    ++$paren_id;

    if ( $_[1][1] =~ m|^/(.*)/$| ) {
        $regex = $1;
    }

    my $val = $_[1][1];
    $val =~ s/^'(.*)'\z/$1/;
    $val = quotemeta($val);

    my $parents =
      join( ',', map { $_[1][0][ $_ * 2 ] } ( 0 .. $#{ $_[1][0] } / 2 ) );

    if ( defined($regex) ) {
        return $1 . _re("_ext(([$parents], \$$paren_id, $paren_id)\*\*)");
    }
    else {
        return '()' . _re("_ext(([$parents], \\\\'$val', $paren_id)\*\*)");
    }
}

sub textblock {
    return quotemeta( $_[1] );
}

sub block {
    my $rv = '';
    foreach my $chunk ( map "$_", @{ $_[1] || [] } ) {
        $chunk =~ s/^#line .*\n//;
        $rv .= $chunk;
    }
    return $rv;
}

sub quoted {
    my $rv = '';

    foreach my $token ( @{ $_[1] } ) {
        if ( $token =~ m/^'(.+)'$/ ) {    # nested hash traversal
            $rv .= '$';
            $rv .= "{$_}" foreach split( /','/, $1 );
        }
        else {
            $rv .= $token;
        }
    }

    return $rv;
}

sub ident {
    return join( ',', map { $_[1][ $_ * 2 ] } ( 0 .. $#{ $_[1] } / 2 ) );
}

sub text {
    return $_[1];
}

# debug routine to catch unsupported directives
sub AUTOLOAD {
    $DEBUG or return;

    require Data::Dumper;
    $Data::Dumper::Indent = $Data::Dumper::Indent = 1;

    our $AUTOLOAD;
    print "\n$AUTOLOAD -";

    for my $arg ( 1 .. $#_ ) {
        print "\n    [$arg]: ";
        print ref( $_[$arg] )
          ? Data::Dumper->Dump( [ $_[$arg] ], ['__'] )
          : $_[$arg];
    }

    return '';
}

1;

__END__