File Coverage

blib/lib/IO/Pty/Easy.pm

Criterion	Covered	Total	%
statement	159	184	86.4
branch	41	66	62.1
condition	2	6	33.3
subroutine	19	20	95.0
pod	10	10	100.0
total	231	286	80.7

package IO::Pty::Easy;
our $AUTHORITY = 'cpan:DOY';
$IO::Pty::Easy::VERSION = '0.10';
use warnings;
use strict;
# ABSTRACT: Easy interface to IO::Pty

use Carp;
use POSIX ();
use Scalar::Util qw(weaken);

use base 'IO::Pty';



sub new {
    my $class = shift;
    my %args = @_;

    my $handle_pty_size = 1;
    $handle_pty_size = delete $args{handle_pty_size}
        if exists $args{handle_pty_size};
    $handle_pty_size = 0 unless POSIX::isatty(*STDIN);
    my $def_max_read_chars = 8192;
    $def_max_read_chars = delete $args{def_max_read_chars}
        if exists $args{def_max_read_chars};
    my $raw = 1;
    $raw = delete $args{raw}
        if exists $args{raw};

    my $self = $class->SUPER::new(%args);
    bless $self, $class;
    $self->handle_pty_size($handle_pty_size);
    $self->def_max_read_chars($def_max_read_chars);
    ${*{$self}}{io_pty_easy_raw} = $raw;
    ${*{$self}}{io_pty_easy_final_output} = '';
    ${*{$self}}{io_pty_easy_did_handle_pty_size} = 0;

    return $self;
}


sub spawn {
    my $self = shift;
    my $slave = $self->slave;

    croak "Attempt to spawn a subprocess when one is already running"
        if $self->is_active;

    # set up a pipe to use for keeping track of the child process during exec
    my ($readp, $writep);
    unless (pipe($readp, $writep)) {
        croak "Failed to create a pipe";
    }
    $writep->autoflush(1);

    # fork a child process
    # if the exec fails, signal the parent by sending the errno across the pipe
    # if the exec succeeds, perl will close the pipe, and the sysread will
    # return due to EOF
    ${*{$self}}{io_pty_easy_pid} = fork;
    unless ($self->pid) {
        close $readp;
        $self->make_slave_controlling_terminal;
        close $self;
        $slave->clone_winsize_from(\*STDIN) if $self->handle_pty_size;
        $slave->set_raw if ${*{$self}}{io_pty_easy_raw};
        # reopen the standard file descriptors in the child to point to the
        # pty rather than wherever they have been pointing during the script's
        # execution
        open(STDIN,  '<&', $slave->fileno)
            or carp "Couldn't reopen STDIN for reading";
        open(STDOUT, '>&', $slave->fileno)
            or carp "Couldn't reopen STDOUT for writing";
        open(STDERR, '>&', $slave->fileno)
            or carp "Couldn't reopen STDERR for writing";
        close $slave;
        { exec(@_) };
        print $writep $! + 0;
        carp "Cannot exec(@_): $!";
        exit 1;
    }

    close $writep;
    $self->close_slave;
    # this sysread will block until either we get an EOF from the other end of
    # the pipe being closed due to the exec, or until the child process sends
    # us the errno of the exec call after it fails
    my $errno;
    my $read_bytes = sysread($readp, $errno, 256);
    unless (defined $read_bytes) {
        # XXX: should alarm here and follow up with SIGKILL if the process
        # refuses to die
        kill TERM => $self->pid;
        close $readp;
        $self->_wait_for_inactive;
        croak "Cannot sync with child: $!";
    }
    close $readp;
    if ($read_bytes > 0) {
        $errno = $errno + 0;
        $self->_wait_for_inactive;
        croak "Cannot exec(@_): $errno";
    }

    if ($self->handle_pty_size) {
        my $weakself = weaken($self);
        $SIG{WINCH} = sub {
            return unless $weakself;
            $weakself->slave->clone_winsize_from(\*STDIN);
            kill WINCH => $weakself->pid if $weakself->is_active;
        };
        ${*{$self}}{io_pty_easy_did_handle_pty_size} = 1;
    }
}


sub read {
    my $self = shift;
    my ($timeout, $max_chars) = @_;
    $max_chars ||= $self->def_max_read_chars;

    my $rin = '';
    vec($rin, fileno($self), 1) = 1;
    my $nfound = select($rin, undef, undef, $timeout);
    my $buf;
    if ($nfound > 0) {
        my $nchars = sysread($self, $buf, $max_chars);
        $buf = '' if defined($nchars) && $nchars == 0;
    }
    if (length(${*{$self}}{io_pty_easy_final_output}) > 0) {
        no warnings 'uninitialized';
        $buf = ${*{$self}}{io_pty_easy_final_output} . $buf;
        ${*{$self}}{io_pty_easy_final_output} = '';
    }
    return $buf;
}


sub write {
    my $self = shift;
    my ($text, $timeout) = @_;

    my $win = '';
    vec($win, fileno($self), 1) = 1;
    my $nfound = select(undef, $win, undef, $timeout);
    my $nchars;
    if ($nfound > 0) {
        $nchars = syswrite($self, $text);
    }
    return $nchars;
}


sub is_active {
    my $self = shift;

    return 0 unless defined $self->pid;

    if (defined(my $fd = fileno($self))) {
        # XXX FreeBSD 7.0 will not allow a session leader to exit until the
        # kernel tty output buffer is empty.  Make it so.
        my $rin = '';
        vec($rin, $fd, 1) = 1;
        my $nfound = select($rin, undef, undef, 0);
        if ($nfound > 0) {
            sysread($self, ${*{$self}}{io_pty_easy_final_output},
                    $self->def_max_read_chars,
                    length ${*{$self}}{io_pty_easy_final_output});
        }
    }

    my $active = kill 0 => $self->pid;
    if ($active) {
        my $pid = waitpid($self->pid, POSIX::WNOHANG());
        $active = 0 if $pid == $self->pid;
    }
    if (!$active) {
        $SIG{WINCH} = 'DEFAULT'
            if ${*{$self}}{io_pty_easy_did_handle_pty_size};
        ${*{$self}}{io_pty_easy_did_handle_pty_size} = 0;
        delete ${*{$self}}{io_pty_easy_pid};
    }
    return $active;
}


sub kill {
    my $self = shift;
    my ($sig, $non_blocking) = @_;
    $sig = "TERM" unless defined $sig;

    my $kills;
    $kills = kill $sig => $self->pid if $self->is_active;
    $self->_wait_for_inactive unless $non_blocking;

    return $kills;
}


sub close {
    my $self = shift;

    close $self;
    $self->kill;
}


sub handle_pty_size {
    my $self = shift;
    ${*{$self}}{io_pty_easy_handle_pty_size} = $_[0] if @_;
    ${*{$self}}{io_pty_easy_handle_pty_size};
}


sub def_max_read_chars {
    my $self = shift;
    ${*{$self}}{io_pty_easy_def_max_read_chars} = $_[0] if @_;
    ${*{$self}}{io_pty_easy_def_max_read_chars};
}


sub pid {
    my $self = shift;
    ${*{$self}}{io_pty_easy_pid};
}

sub _wait_for_inactive {
    my $self = shift;

    select(undef, undef, undef, 0.01) while $self->is_active;
}

sub DESTROY {
    my $self = shift;
    local $@;
    local $?;
    $self->close;
}


1;

__END__