# $File: //member/autrijus/Template-Extract/lib/Template/Extract/Run.pm $ $Author: autrijus $ # $Revision: #1 $ $Change: 10075 $ $DateTime: 2004/02/16 16:50:48 $ package Template::Extract::Run; $Template::Extract::Run::VERSION = '0.36'; 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('', ); close FH; my $document = << '.'; Great links . print Data::Dumper::Dumper( Template::Extract::Run->new->run($regex, $document) ); =head1 DESCRIPTION This module applies a regular expression generated by B 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, L =head1 AUTHORS Autrijus Tang Eautrijus@autrijus.orgE =head1 COPYRIGHT Copyright 2004 by Autrijus Tang Eautrijus@autrijus.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut