package Template::Extract::Run; 
$Template::Extract::Run::VERSION = '0.37';

use 5.006;
use strict;
use warnings;

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

=head1 NAME

Template::Extract::Run - Apply compiled regular expressions on documents

=head1 SYNOPSIS

    use Template::Extract::Run;
    use Data::Dumper;

    open FH, '<', 'stored_regex' or die $!;
    my $regex = join('', <FH>);
    close FH;

    my $document = << '.';
    <html><head><title>Great links</title></head><body>
    <ul><li><A HREF="http://slashdot.org">News for nerds.</A>: A+ - nice.
    this text is ignored.</li>
    <li><A HREF="http://microsoft.com">Where do you want...</A>: Z! - yeah.
    this text is ignored, too.</li></ul>
    .

    print Data::Dumper::Dumper(
	Template::Extract::Run->new->run($regex, $document)
    );

=head1 DESCRIPTION

This module applies a regular expression generated by
B<Template::Extract::Compile> to a document.

=head1 METHODS

=head2 new()

Constructor.  Currently takes no parameters.

=head2 run($regex, $document, \%values)

Applying C<$regex> on C<$document> and returning the resulting C<\%values>.
This process does not make use of the Template Toolkit or any other modules.

=cut

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

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

    $self->_init($ext_data);
    
    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 = $obj->{$key} if exists $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;

=head1 SEE ALSO

L<Template::Extract>, L<Template::Extract::Compile>

=head1 AUTHORS

Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>

=head1 COPYRIGHT

Copyright 2004 by Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>.

This program is free software; you can redistribute it and/or 
modify it under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>

=cut
