File Coverage

blib/lib/Test2/Harness/Proc.pm

Criterion	Covered	Total	%
statement	77	87	88.5
branch	22	34	64.7
condition	5	6	83.3
subroutine	16	17	94.1
pod	5	10	50.0
total	125	154	81.1

package Test2::Harness::Proc;
use strict;
use warnings;

our $VERSION = '0.000013';

use IO::Handle;
use Carp qw/croak/;
use POSIX qw/:sys_wait_h/;

use Test2::Util::HashBase qw/file pid in_fh out_fh err_fh exit lines idx/;

sub init {
    my $self = shift;

    for my $thing (PID(), IN_FH(), OUT_FH(), FILE()) {
        next if $self->{$thing};
        croak "'$thing' is a required attribute";
    }

    for my $fh (@{$self}{OUT_FH(), ERR_FH()}) {
        next unless $fh;
        $fh->blocking(0);
    }

    $self->{+LINES} = {
        stderr => [],
        stdout => [],
        muxed  => [],
    };
}

sub encoding {
    my $self = shift;
    my ($enc) = @_;

    # https://rt.perl.org/Public/Bug/Display.html?id=31923
    # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in
    # order to avoid the thread segfault.
    if ($enc =~ m/^utf-?8$/i) {
        binmode($_, ":utf8") for grep {$_} @{$self}{qw/out_fh err_fh in_fh/};
    }
    else {
        binmode($_, ":encoding($enc)") for grep {$_} @{$self}{qw/out_fh err_fh in_fh/};
    }
}

sub is_done {
    my $self = shift;

    $self->wait(WNOHANG);

    return 1 if defined $self->{+EXIT};
    return 0;
}

sub wait {
    my $self = shift;
    my ($flags) = @_;

    return if defined $self->{+EXIT};

    my $pid = $self->{+PID} or die "No PID";
    my $ret = waitpid($pid, $flags || 0);
    my $exit = $?;

    return if $ret == 0;
    die "Process $pid was already reaped!" if $ret == -1;

    $exit >>= 8;
    $self->{+EXIT} = $exit;

    return;
}

sub force_kill {
    my $self = shift;

    my $pid = $self->{+PID} or die "No PID";
    kill('INT', $pid) or die "Could not signal process";
    $self->{+EXIT} = -1;
    for (1 .. 5) {
        $self->wait(WNOHANG) and last;
        sleep 1 unless $_ >= 5;
    }
}

sub write {
    my $self = shift;
    my $fh = $self->{+IN_FH};
    print $fh @_;
}

sub seen_out_lines {
    my $self = shift;
    return @{$self->{+LINES}->{stdout}};
}

sub seen_err_lines {
    my $self = shift;
    return @{$self->{+LINES}->{stderr}};
}

sub get_out_line {
    my $self = shift;
    return $self->_get_line_for(OUT_FH(), 'stdout', @_);
}

sub get_err_line {
    my $self = shift;
    return $self->_get_line_for(ERR_FH(), 'stderr', @_);
}

sub _get_line_for {
    my $self = shift;
    my ($io_name, $stash_name, %params) = @_;

    my $stash = $self->{+LINES}->{$stash_name} ||= [];
    my $idx = \($self->{+IDX}->{$stash_name});
    $$idx ||= 0;

    if (@$stash > $$idx) {
        my $line = $stash->[$$idx];
        $$idx++ unless $params{peek};
        return $line;
    }

    my $h = $self->{$io_name} or return;

    seek($h,0,1);
    my $line = <$h>;
    return unless defined $line;

    push @$stash => $line;

    $$idx++ unless $params{peek};

    return $line;
}

1;

__END__