File Coverage

blib/lib/Proc/Hevy/Reader.pm

Criterion	Covered	Total	%
statement	63	68	92.6
branch	26	36	72.2
condition	3	6	50.0
subroutine	12	12	100.0
pod	4	4	100.0
total	108	126	85.7

package Proc::Hevy::Reader;

use strict;
use warnings;

use Carp;
use Errno qw( EWOULDBLOCK );
use IO::Pipe;
use POSIX ();


sub new {
  my ( $class, $name, $buffer ) = @_;

  my $pipe;
  $pipe = IO::Pipe->new
    if defined $buffer and ref $buffer ne 'GLOB';

  bless { name => $name, buffer => $buffer, pipe => $pipe }, $class;
}

sub child {
  my ( $self, $std_h, $fileno ) = @_;

  my $handle;

  if( defined $self->{pipe} ) {
    $handle = $self->{pipe}->writer;
  }
  elsif( ref $self->{buffer} eq 'GLOB' ) {
    $handle = $self->{buffer};
  }
  else {
    open $handle, '>', '/dev/null'
      or confess "$self->{name}: open: /dev/null: $!\n";
  }

  $handle->autoflush;

  POSIX::dup2( $handle->fileno, $fileno )
    or confess "$self->{name}: dup2: $!\n"
      if $std_h != $handle;
}

sub parent {
  my ( $self, $select ) = @_;

  unless( defined $self->{pipe} ) {
    delete $self->{buffer}
      if defined $self->{buffer};

    return;
  }

  $self->{scratch} = undef;

  my $handle = $self->{pipe}->reader;
  $handle->blocking( 0 );

  $select->add( $handle );
  $self->{select} = $select;

  return ( $handle, $self );
}

sub read {
  my ( $self ) = @_;

  my $handle = $self->{pipe};
  my $rc     = $handle->sysread( my $data, 4096 );

  if( not defined $rc ) {
    if( $! != EWOULDBLOCK ) {
      $self->_flush( $self->{scratch} );
      confess "$self->{name}: sysread: $!\n";
    }
  }
  elsif( $rc == 0 ) {
    $self->_flush( $self->{scratch} );

    $self->{select}->remove( $handle );
    $handle->close
      or confess "$self->{name}: close: $!\n";
  }
  else {
    $self->_pack( $data );
  }
}

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

  if( ref $self->{buffer} eq 'SCALAR' ) {
    ${ $self->{buffer} } .= $data;
  }
  else {
    my $scratch = ( defined $self->{scratch} ? $self->{scratch} : '' ) . $data;

    if( defined $/ ) {
      while( index( $scratch, $/ ) != -1 ) {
        ( my $line, $scratch ) = split m#$/#, $scratch, 2;
        $self->_flush( $line );
      }
    }

    $self->{scratch} = length $scratch ? $scratch : undef;
  }
}

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

  return
    unless defined $data;

  my $buffer = $self->{buffer};

  if( ref $buffer eq 'ARRAY' ) {
    push @$buffer, $data;
  }
  elsif( ref $buffer eq 'CODE' ) {
    $buffer->( $data );
  }
  else {
    confess "$self->{name}: API error\n";
  }
}


1
__END__