File Coverage

blib/lib/Proc/Hevy/Writer.pm

Criterion	Covered	Total	%
statement	64	67	95.5
branch	25	36	69.4
condition	3	6	50.0
subroutine	12	12	100.0
pod	4	4	100.0
total	108	125	86.4

package Proc::Hevy::Writer;

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}->reader;
  }
  elsif( ref $self->{buffer} eq 'GLOB' ) {
    $handle = $self->{buffer};
  }
  else {
    open $handle, '<', '/dev/null'
      or confess "$self->{name}: open: /dev/null: $!\n";
  }

  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} = '';

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

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

  return ( $handle, $self );
}

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

  my $handle = $self->{pipe};

  if( length( $self->{scratch} ) == 0 ) {
    my $scratch = $self->_unpack;

    unless( defined $scratch ) {
      $self->{select}->remove( $handle );
      $handle->close
        or confess "$self->{name}: close: $!\n";
      return;
    }

    $self->{scratch} = $scratch;
  }

  $self->_flush;
}

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

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

  return delete $self->{buffer}
    if $ref eq '';

  my $data;

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

  $data .= defined $\ ? $\ : "\n"
    if defined $data;

  return $data;
}

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

  return
    unless length $self->{scratch};

  my $handle = $self->{pipe};
  my $rc     = $handle->syswrite( $self->{scratch} );

  if( not defined $rc ) {
    confess "$self->{name}: syswrite: $!\n"
      if $! != EWOULDBLOCK;
  }
  else {
    substr( $self->{scratch}, 0, $rc ) = '';
  }
}


1
__END__