File Coverage

blib/lib/Array/Stream/Transactional/Matcher.pm

Criterion	Covered	Total	%
statement	69	71	97.1
branch	17	24	70.8
condition	2	5	40.0
subroutine	12	13	92.3
pod	4	4	100.0
total	104	117	88.8

# $Id: Matcher.pm,v 1.11 2004/06/11 21:50:53 claes Exp $

package Array::Stream::Transactional::Matcher;

use Array::Stream::Transactional::Matcher::Rule;
use Array::Stream::Transactional::Matcher::Logical;
use Array::Stream::Transactional::Matcher::Value;
use Array::Stream::Transactional::Matcher::Flow;

use 5.006001;
use Carp qw(croak confess);
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(mkrule) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw();

our $VERSION = '1.00';

sub mkrule {
  my $type = shift;
  $type =~ s/-/::/g;
  unless($type =~ /^Array::Stream::Transactional::Matcher::/) {
    $type = "Array::Stream::Transactional::Matcher::${type}";
  }
  return $type->new(@_);
}

sub new {
  my $class = shift;
  my %args = @_;
  croak "Missing mandatory argument 'rules'" unless(exists $args{rules} && ref $args{rules} eq 'ARRAY');
  my $self = bless {}, $class;

  my $default = undef;
  if(exists $args{call}) {
    croak "Argument 'call' must be a CODE reference" unless(ref $args{call} eq 'CODE');
    $default = $args{call};
  } else {
    $default = sub {};
  }

  my @rules;
  foreach(@{$args{rules}}) {
    if(ref $_ eq 'ARRAY') {
      my ($rule, $callback) = @{$_};
      croak "Rule match object must be an Array::Stream::Transactional::Matcher::Rule subclass" unless(UNIVERSAL::isa($rule, 'Array::Stream::Transactional::Matcher::Rule'));
      croak "Rule callback must be a CODE reference" unless(ref $callback eq 'CODE');
      push @rules, [ $rule, $callback ];
    } elsif (UNIVERSAL::isa($_, 'Array::Stream::Transactional::Matcher::Rule')) {
      push @rules, [ $_, $default ];
    } else {
      croak "Rule entry must be an Array::Stream::Transactional::Matcher::Rule or an ARRAY reference";
    }
  }

  $self->{rules} = \@rules;
  return $self;
}

sub rules {
  my $self = shift;
  return $self->{rules} || [];
}

sub match {
  my ($self, $stream) = @_;
  croak "Can't match a non Array::Stream::Transactional stream" unless(UNIVERSAL::isa($stream, 'Array::Stream::Transactional'));

  my @matches;

  my $match = 0;
 MATCH: while($stream->has_more) {
    my $start = $stream->pos;
    for my $rule (@{$self->rules}) {
      $match = $rule->[0]->match($stream);
      if($match) {
	my $end = $start == $stream->pos ? $start : $stream->pos - 1;
	push @matches, { rule => $rule, start => $start, end => $end };
	$rule->[1]->($rule->[0], $start, $end);
	next MATCH;
      }
    }
  } continue {
    $stream->next unless($match == -1);
    $match = 0;
  }

  return @matches;
}

1;

__END__