File Coverage

blib/lib/IO/Tty/Util.pm

Criterion	Covered	Total	%
statement	34	52	65.3
branch	9	26	34.6
condition			n/a
subroutine	8	9	88.8
pod	3	4	75.0
total	54	91	59.3

package IO::Tty::Util ;

use strict ;
use IO::Handle ;
use IO::Select ;
use Carp ;

our $VERSION = '0.03' ;

require Exporter ;
our @ISA = qw(Exporter) ;
our @EXPORT_OK = qw( openpty login_tty forkpty passthru ) ;

require XSLoader ;
XSLoader::load('IO::Tty::Util', $VERSION) ;


sub import {
	my $class = shift ;

	foreach my $a (@_){
		if ($a eq "passthru"){
			shift ;
			my ($pid, $master) = forkpty(@_) ;
			croak("forkpty error: $!") unless $master ;
			passthru($master) ;
			exit() ;
		}
	}

	$class->export_to_level(1, $class, @_) ;
}


sub openpty {
	my ($rows, $cols) = @_ ;

	my ($master, $slave) = _openpty($rows, $cols) ;
	return () unless defined($master) ;

	return (IO::Handle->new_from_fd($master, "r+"), IO::Handle->new_from_fd($slave, "r+")) ;
}


sub login_tty {
	my $h = shift ;

	my $rc = _login_tty(fileno($h)) ;
	return ($rc == -1 ? 0 : 1) ;
}


sub forkpty {
	my ($rows, $cols, @cmd) = @_ ;

	my ($master, $slave) = openpty($rows, $cols) ;
    return () unless defined($master) ;

	my $pid = fork() ;
	return () unless defined($pid) ;

	if ($pid){
		close($slave) ;
		return ($pid, $master) ;
	}
	else {
		close($master) ;
		return () unless login_tty($slave) ;
		return (0) unless scalar(@cmd) ;
		exec(@cmd) or die("Can't exec '@cmd': $!") ;
	}
}


sub passthru {
	my $master = shift ;

	STDOUT->autoflush(1) ;
	$master->autoflush(1) ;
	my $select = new IO::Select($master, \*STDIN) ;
	while (1){
		my @ready = $select->can_read() ;
		foreach my $h (@ready){
	        my $buf = '' ;
	        my $rc = sysread($h, $buf, 4096) ;
			return if !$rc ; # pty seems to return error instead of EOF...

			my $out = ($h eq \*STDIN ? $master : \*STDOUT) ;
			# open(DEBUG, ">>/tmp/output") && print DEBUG "[$buf]\n" ;
			print $out $buf or croak("print error: $!") ;
        }
    }
}




1 ;
__END__