File Coverage

blib/lib/Template/Extract/Run.pm

Criterion	Covered	Total	%
statement	71	71	100.0
branch	27	34	79.4
condition	19	27	70.3
subroutine	12	12	100.0
pod	2	2	100.0
total	131	146	89.7

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

our ($DEBUG);
my ( %loop, $cur_loop, $data );

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

sub run {
    my ( $self, $regex, $document, $ext_data ) = @_;

    $self->_init($ext_data);
    ## no critic

    defined($document) or return undef;
    defined($regex)    or return undef;

    {
        use re 'eval';
        return $data if $document =~ /$regex/s;
    }

    return undef;
}

# initialize temporary variables
sub _init {
    %loop     = ();
    $cur_loop = undef;
    $data     = $_[1] || {};
}

sub _enter_loop {
    $cur_loop = $loop{ $_[1] } ||= {
        name  => $_[0],
        id    => $_[1],
        count => -1,
    };
    $cur_loop->{count}++;
    $cur_loop->{var} = {};
    $cur_loop->{pos} = {};
}

sub _leave_loop {
    my ( $obj, $key, $vars ) = @_;

    ref($obj) eq 'HASH' or return;
    my $old;
    if (exists $obj->{$key}) {
        $old = $obj->{$key};
    }
    ref($old) eq 'ARRAY' or return;

    print "Validate: [$old $key @$vars]\n" if $DEBUG;

    my @new;

  OUTER:
    foreach my $entry (@$old) {
        next unless %$entry;
        foreach my $var (@$vars) {

            # If it's a foreach, it needs to not match or match something.
            if ( ref($var) ) {
                next if !exists( $entry->{$$var} ) or @{ $entry->{$$var} };
            }
            else {
                next if exists( $entry->{$var} );
            }
            next OUTER;    # failed!
        }
        push @new, $entry;
    }

    delete $_[0]{$key} unless @$old = @new;
}

sub _adjust {
    my ( $obj, $val ) = ( shift, pop );

    foreach my $var (@_) {
        $obj = $obj->{$var} ||= {};
    }
    return ( $obj, $val );
}

sub _traverse {
    my ( $obj, $val ) = ( shift, shift );

    my $depth = -1;
    while ( my $id = pop(@_) ) {
        my $var = $loop{$id}{name};
        my $index = $loop{ $_[-1] || $val }{count};
        $obj = $obj->{$var}[$index] ||= {};
    }
    return $obj;
}

sub _ext {
    my ( $var, $val, $num ) = splice( @_, 0, 3 );
    my $obj = $data;

    if (@_) {
        print "Ext: [ $$val with $num on $-[$num]]\n" if ref($val) and $DEBUG;

        # fetch current loop structure
        my $cur = $loop{ $_[0] };

        # if pos() changed, increment the iteration counter
        $cur->{var}{$num}++
          if ( ( $cur->{pos}{$num} ||= -1 ) != $-[$num] )
          or ref $val and $$val eq 'leave_loop';

        # remember pos()
        $cur->{pos}{$num} = $-[$num];

        my $iteration = $cur->{var}{$num} - 1;
        $obj = _traverse( $data, @_ )->{ $cur->{name} }[$iteration] ||= {};
    }

    ( $obj, $var ) = _adjust( $obj, @$var );

    if ( !ref($val) ) {
        $obj->{$var} = $val;
    }
    elsif ( $$val eq 'leave_loop' ) {
        _leave_loop( $obj, @$var );
    }
    else {
        $obj->{$var} = $$$val;
    }
}

1;

__END__