File Coverage

blib/lib/IO/Pty.pm

Criterion	Covered	Total	%
statement	67	113	59.2
branch	13	52	25.0
condition	1	2	50.0
subroutine	10	11	90.9
pod	5	5	100.0
total	96	183	52.4

# Documentation at the __END__

package IO::Pty;

use strict;
use warnings;
use Carp;
use IO::Tty qw(TIOCSCTTY TCSETCTTY TIOCNOTTY);
use IO::File;
require POSIX;

our @ISA     = qw(IO::Handle);
our $VERSION = '1.31';    # keep same as in Tty.pm
eval { local $^W = 0; local $SIG{__DIE__}; require IO::Stty };
push @ISA, "IO::Stty" if ( not $@ );    # if IO::Stty is installed

sub new {
    my ($class) = $_[0] || "IO::Pty";
    $class = ref($class) if ref($class);
    @_ <= 1 or croak 'usage: new $class';

    my ( $ptyfd, $ttyfd, $ttyname ) = pty_allocate();

    croak "Cannot open a pty" if not defined $ptyfd;

    my $pty = $class->SUPER::new_from_fd( $ptyfd, "r+" );
    if (not $pty) {
        POSIX::close($ptyfd);
        POSIX::close($ttyfd);
        croak "Cannot create a new $class from fd $ptyfd: $!";
    }
    $pty->autoflush(1);
    bless $pty => $class;

    my $slave = IO::Tty->new_from_fd( $ttyfd, "r+" );
    if (not $slave) {
        POSIX::close($ttyfd);
        croak "Cannot create a new IO::Tty from fd $ttyfd: $!";
    }
    $slave->autoflush(1);

    ${*$pty}{'io_pty_slave'}     = $slave;
    ${*$pty}{'io_pty_ttyname'}   = $ttyname;
    ${*$slave}{'io_tty_ttyname'} = $ttyname;

    return $pty;
}

sub ttyname {
    @_ == 1 or croak 'usage: $pty->ttyname();';
    my $pty = shift;
    ${*$pty}{'io_pty_ttyname'};
}

sub close_slave {
    @_ == 1 or croak 'usage: $pty->close_slave();';

    my $master = shift;

    if ( exists ${*$master}{'io_pty_slave'} ) {
        close ${*$master}{'io_pty_slave'};
        delete ${*$master}{'io_pty_slave'};
    }
}

sub slave {
    @_ == 1 or croak 'usage: $pty->slave();';

    my $master = shift;

    if ( exists ${*$master}{'io_pty_slave'} ) {
        return ${*$master}{'io_pty_slave'};
    }

    my $tty = ${*$master}{'io_pty_ttyname'};

    my $slave_fd = IO::Tty::_open_tty($tty);
    croak "Cannot open slave $tty: $!" if $slave_fd < 0;

    my $slave = IO::Tty->new_from_fd( $slave_fd, "r+" );
    if (not $slave) {
        POSIX::close($slave_fd);
        croak "Cannot create IO::Tty from fd $slave_fd: $!";
    }
    $slave->autoflush(1);

    ${*$slave}{'io_tty_ttyname'}    = $tty;
    ${*$master}{'io_pty_slave'}     = $slave;

    return $slave;
}

sub make_slave_controlling_terminal {
    @_ == 1 or croak 'usage: $pty->make_slave_controlling_terminal();';

    my $self = shift;
    local (*DEVTTY);

    # lose controlling terminal explicitly
    if ( defined TIOCNOTTY ) {
        if ( open( \*DEVTTY, "/dev/tty" ) ) {
            ioctl( \*DEVTTY, TIOCNOTTY, 0 );
            close \*DEVTTY;
        }
    }

    # Create a new 'session', lose controlling terminal.
    if ( POSIX::setsid() == -1 ) {
        warn "setsid() failed, strange behavior may result: $!\r\n";
    }

    if ( open( \*DEVTTY, "/dev/tty" ) ) {
        warn "Could not disconnect from controlling terminal?!\n";
        close \*DEVTTY;
    }

    # now open slave, this should set it as controlling tty on some systems
    # Use _open_tty() to ensure STREAMS modules (ptem, ldterm, ttcompat)
    # are pushed on Solaris/HP-UX.  Pass noctty=0 so the open can
    # automatically acquire a controlling terminal (the whole point of
    # this method).
    my $ttyname  = ${*$self}{'io_pty_ttyname'};
    my $slave_fd = IO::Tty::_open_tty($ttyname, 0);
    croak "Cannot open slave $ttyname: $!" if $slave_fd < 0;
    my $slv = IO::Tty->new_from_fd( $slave_fd, "r+" );
    croak "Cannot create IO::Tty from fd $slave_fd: $!" if not $slv;
    $slv->autoflush(1);

    if ( not exists ${*$self}{'io_pty_slave'} ) {
        ${*$self}{'io_pty_slave'} = $slv;
    }
    else {
        $slv->close;
    }

    # Acquire a controlling terminal if this doesn't happen automatically
    if ( not open( \*DEVTTY, "/dev/tty" ) ) {
        if ( defined TIOCSCTTY ) {
            if ( not defined ioctl( ${*$self}{'io_pty_slave'}, TIOCSCTTY, 0 ) ) {
                warn "warning: TIOCSCTTY failed, slave might not be set as controlling terminal: $!";
            }
        }
        elsif ( defined TCSETCTTY ) {
            if ( not defined ioctl( ${*$self}{'io_pty_slave'}, TCSETCTTY, 0 ) ) {
                warn "warning: TCSETCTTY failed, slave might not be set as controlling terminal: $!";
            }
        }
        else {
            warn "warning: You have neither TIOCSCTTY nor TCSETCTTY on your system\n";
            return 0;
        }
    }

    if ( not open( \*DEVTTY, "/dev/tty" ) ) {
        warn "Error: could not connect pty as controlling terminal!\n";
        return undef;
    }
    else {
        close \*DEVTTY;
    }

    return 1;
}

sub DESTROY {
    my $self = shift;
    # Only delete the internal reference; do not force-close the slave.
    # Perl's refcounting will close the fd when no references remain.
    # Force-closing here breaks consumers (e.g. IPC::Run) that hold
    # their own reference to the slave obtained via $pty->slave().
    delete ${*$self}{'io_pty_slave'};
}

*clone_winsize_from = \&IO::Tty::clone_winsize_from;
*get_winsize        = \&IO::Tty::get_winsize;
*set_winsize        = \&IO::Tty::set_winsize;
*set_raw            = \&IO::Tty::set_raw;

1;

__END__