File Coverage

blib/lib/IO/Tty.pm

Criterion	Covered	Total	%
statement	41	62	66.1
branch	5	22	22.7
condition	0	3	0.0
subroutine	10	13	76.9
pod	0	5	0.0
total	56	105	53.3

# Documentation at the __END__
# -*-cperl-*-

package IO::Tty;

use strict;
use warnings;
use IO::Handle;
use IO::File;
use IO::Tty::Constant;
use Carp;

require POSIX;
require DynaLoader;

use vars qw(@ISA $VERSION $XS_VERSION $CONFIG $DEBUG);

$VERSION    = '1.17';
$XS_VERSION = "1.17";
@ISA        = qw(IO::Handle);

eval { local $^W = 0; undef local $SIG{__DIE__}; require IO::Stty };
push @ISA, "IO::Stty" if ( not $@ );    # if IO::Stty is installed

BOOT_XS: {
    # If I inherit DynaLoader then I inherit AutoLoader and I DON'T WANT TO
    require DynaLoader;

    # DynaLoader calls dl_load_flags as a static method.
    *dl_load_flags = DynaLoader->can('dl_load_flags');

    do {
        defined(&bootstrap)
          ? \&bootstrap
          : \&DynaLoader::bootstrap;
      }
      ->(__PACKAGE__);
}

sub import {
    IO::Tty::Constant->export_to_level( 1, @_ );
}

sub open {
    my ( $tty, $dev, $mode ) = @_;

    IO::File::open( $tty, $dev, $mode )
      or return undef;

    $tty->autoflush;

    1;
}

sub clone_winsize_from {
    my ( $self, $fh ) = @_;
    croak "Given filehandle is not a tty in clone_winsize_from, called"
      if not POSIX::isatty($fh);
    return 1 if not POSIX::isatty($self);    # ignored for master ptys
    my $winsize = " " x 1024;                # preallocate memory for older perl versions
    $winsize = '';                           # But leave the SV as empty
    ioctl( $fh, &IO::Tty::Constant::TIOCGWINSZ, $winsize )
      and ioctl( $self, &IO::Tty::Constant::TIOCSWINSZ, $winsize )
      and return 1;
    warn "clone_winsize_from: error: $!" if $^W;
    return undef;
}

# ioctl() doesn't tell us how long the structure is, so we'll have to trim it
# after TIOCGWINSZ
my $SIZEOF_WINSIZE = length IO::Tty::pack_winsize( 0, 0, 0, 0 );

sub get_winsize {
    my $self = shift;
    my $winsize = " " x 1024;    # preallocate memory
    ioctl( $self, IO::Tty::Constant::TIOCGWINSZ(), $winsize )
      or croak "Cannot TIOCGWINSZ - $!";
    substr( $winsize, $SIZEOF_WINSIZE ) = "";
    return IO::Tty::unpack_winsize($winsize);
}

sub set_winsize {
    my $self    = shift;
    my $winsize = IO::Tty::pack_winsize(@_);
    ioctl( $self, IO::Tty::Constant::TIOCSWINSZ(), $winsize )
      or croak "Cannot TIOCSWINSZ - $!";
}

sub set_raw($) {
    require POSIX;
    my $self = shift;
    return 1 if not POSIX::isatty($self);
    my $ttyno   = fileno($self);
    my $termios = new POSIX::Termios;
    unless ($termios) {
        warn "set_raw: new POSIX::Termios failed: $!";
        return undef;
    }
    unless ( $termios->getattr($ttyno) ) {
        warn "set_raw: getattr($ttyno) failed: $!";
        return undef;
    }
    $termios->setiflag(0);
    $termios->setoflag(0);
    $termios->setlflag(0);
    $termios->setcc( &POSIX::VMIN,  1 );
    $termios->setcc( &POSIX::VTIME, 0 );
    unless ( $termios->setattr( $ttyno, &POSIX::TCSANOW ) ) {
        warn "set_raw: setattr($ttyno) failed: $!";
        return undef;
    }
    return 1;
}

1;

__END__