File Coverage

blib/lib/POE/Filter/RecordBlock.pm

Criterion	Covered	Total	%
statement	69	69	100.0
branch	19	20	95.0
condition	6	6	100.0
subroutine	14	14	100.0
pod	9	9	100.0
total	117	118	99.1

# 2001/01/25 [e-mail]

package POE::Filter::RecordBlock;

use strict;
use POE::Filter;

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

use Carp qw(croak);

sub BLOCKSIZE () { 0 };
sub GETBUFFER () { 1 };
sub PUTBUFFER () { 2 };
sub CHECKPUT  () { 3 };
sub FIRST_UNUSED () { 4 }

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 = @_;

  # Block size
  croak "BlockSize must be greater than 0" unless (
    defined($params{BlockSize}) && ($params{BlockSize} > 0)
  );
  my $block_size = $params{BlockSize};

  # check put
  my $check_put = $params{CheckPut};

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

  my $self = bless [
    $block_size,        # BLOCKSIZE
    [],                 # GETBUFFER
    [],                 # PUTBUFFER
    $check_put         # CHECKPUT
  ], $type;
}

sub clone {
  my $self = shift;
  my $clone = bless [
    $self->[0], # BLOCKSIZE
    [],         # GETBUFFER
    [],         # PUTBUFFER
    $self->[3]  # CHECKPUT
  ], ref $self;
  $clone;
}

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

#------------------------------------------------------------------------------
# 2001-07-27 RCC: Add get_one_start() and get_one() to correct filter
# changing and make input flow control possible.

sub get_one_start {
  my ($self, $data) = @_;
  push @{$self->[GETBUFFER]}, @$data;
}

sub get_one {
  my $self = shift;

  return [ ] unless @{$self->[GETBUFFER]} >= $self->[BLOCKSIZE];
  return [ [ splice @{$self->[GETBUFFER]}, 0, $self->[BLOCKSIZE] ] ];
}

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

sub put {
  my ($self, $data) = @_;
  my @result;

  if ($self->[CHECKPUT]) {
    foreach (@$data) {
      push @{$self->[PUTBUFFER]}, @$_;
    }
    while (@{$self->[PUTBUFFER]} >= $self->[BLOCKSIZE]) {
      push @result, splice @{$self->[PUTBUFFER]}, 0, $self->[BLOCKSIZE];
    }
  }
  else {
    push @result, splice(@{$self->[PUTBUFFER]}, 0);
    foreach (@$data) {
      push @result, @$_;
    }
  }
  \@result;
}

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

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

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

sub put_pending {
  my ($self) = @_;
  return undef unless $self->[CHECKPUT];
  return undef unless @{$self->[PUTBUFFER]};
  return [ @{$self->[PUTBUFFER]} ];
}

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

sub blocksize {
  my ($self, $size) = @_;
  if (defined($size) && ($size > 0)) {
    $self->[BLOCKSIZE] = $size;
  }
  $self->[BLOCKSIZE];
}

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

sub checkput {
  my ($self, $val) = @_;
  if (defined($val)) {
    $self->[CHECKPUT] = $val;
  }
  $self->[CHECKPUT];
}

1;

__END__