File Coverage

blib/lib/POE/Filter/Grep.pm

Criterion	Covered	Total	%
statement	53	53	100.0
branch	28	30	93.3
condition	12	17	70.5
subroutine	11	11	100.0
pod	6	6	100.0
total	110	117	94.0

# 2001/01/25 [e-mail]

package POE::Filter::Grep;

use strict;
use POE::Filter;

use vars qw($VERSION @ISA);
$VERSION = '1.367'; # NOTE - Should be #.### (three decimal places)
@ISA = qw(POE::Filter);

use Carp qw(croak carp);

sub BUFFER   () { 0 }
sub CODEGET  () { 1 }
sub CODEPUT  () { 2 }

sub FIRST_UNUSED     () { 3 }  # First unused $self offset.

use base 'Exporter';
our @EXPORT_OK = qw( FIRST_UNUSED );


#------------------------------------------------------------------------------

sub new {
  my $type = shift;
  croak "$type must be given an even number of parameters" if @_ & 1;
  my %params = @_;

  croak "$type requires a Code or both Get and Put parameters" unless (
    defined($params{Code}) or
    (defined($params{Get}) and defined($params{Put}))
  );
  croak "Code element is not a subref"
    unless (defined $params{Code} ? ref $params{Code} eq 'CODE' : 1);
  croak "Get or Put element is not a subref"
    unless ((defined $params{Get} ? (ref $params{Get} eq 'CODE') : 1)
      and   (defined $params{Put} ? (ref $params{Put} eq 'CODE') : 1));

  my $get = $params{Code} || $params{Get};
  my $put = $params{Code} || $params{Put};

  delete @params{qw(Code Get Put)};
  carp("$type ignores unknown parameters: ", join(', ', sort keys %params))
    if scalar keys %params;

  my $self = bless [
    [ ],    # BUFFER
    $get,   # CODEGET
    $put,   # CODEPUT
  ], $type;
}

#------------------------------------------------------------------------------
# get() is inherited from POE::Filter.

#------------------------------------------------------------------------------
# 2001-07-27 RCC: The get_one variant of get() allows Wheel::Xyz to
# retrieve one filtered record at a time.  This is necessary for
# filter changing and proper input flow control.

sub get_one_start {
  my ($self, $stream) = @_;
  push( @{$self->[BUFFER]}, @$stream ) if defined $stream;
}

sub get_one {
  my $self = shift;

  # Must be a loop so that the buffer will be altered as items are
  # tested.
  while (@{$self->[BUFFER]}) {
    my $next_record = shift @{$self->[BUFFER]};
    return [ $next_record ] if (
      grep { $self->[CODEGET]->($_) } $next_record
    );
  }

  return [ ];
}

#------------------------------------------------------------------------------

sub put {
  my ($self, $data) = @_;
  [ grep { $self->[CODEPUT]->($_) } @$data ];
}

#------------------------------------------------------------------------------
# 2001-07-27 RCC: This filter now tracks state, so get_pending has
# become useful.

sub get_pending {
  my $self = shift;
  return undef unless @{$self->[BUFFER]};
  [ @{$self->[BUFFER]} ];
}

#------------------------------------------------------------------------------

sub modify {
  my ($self, %params) = @_;

  for (keys %params) {
    (carp("Modify $_ element must be given a coderef") and next) unless (ref $params{$_} eq 'CODE');
    if (lc eq 'code') {
        $self->[CODEGET] = $params{$_};
        $self->[CODEPUT] = $params{$_};
    }
    elsif (lc eq 'put') {
        $self->[CODEPUT] = $params{$_};
    }
    elsif (lc eq 'get') {
        $self->[CODEGET] = $params{$_};
    }
  }
}

1;

__END__