File Coverage

blib/lib/IO/Tty.pm

Criterion	Covered	Total	%
statement	40	60	66.6
branch	5	22	22.7
condition	0	3	0.0
subroutine	10	13	76.9
pod	0	5	0.0
total	55	103	53.4

# 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.15';
$XS_VERSION = "1.15";
@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 = " "x1024; # preallocate memory
  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;
  ioctl($self, IO::Tty::Constant::TIOCGWINSZ(), my $winsize = q<>)
    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__