[My apologies for taking so long to reply.]
On Sat, Oct 10, 2009 at 04:57:21PM -0500, Jonathan Rockway wrote:
> Maybe. You are writing an application that makes use of "unusual" IO
> patterns (i.e., something more complex than readline on stdin and print
> on stdout; something like curses, Term::Readkey, whatever...), and you
> want to be able to test in an environment that replicates sitting at a
> terminal.
Yeah, something like that. (For me, it was a character device connected
via a serial link, but I assume that terminal display would be the
typical case.)
Term::Readkey is a good example, as it currently lacks any automated
tests. Writing tests for such modules is quite a pain; this would
attempt to make it a little bit less painful.
> That makes sense, although I think you could repurpose
> POE::Wheel::Run or AnyEvent::Subprocess for this.
Thanks for the idea, but I don't think that event dispatching would work
in such a case. The problem is that you have to surrender control to
the subroutine you are testing, so you can't rely on a run() loop.
> Does your test and the code you're testing run in the same process?
Yes, but the test relies on a subprocess to handle the communication
asynchronously. (I suppose I could've used signals or threads instead,
but they both feel "icky" in Perl.)
> Do you worry about deadlocking in that case?
Yes. :)
> I don't see how a regular pipe/socket would not be applicable, unless
> you actually want input cooking or something else that the TTY
> provides. (And yes, you often want this.)
The module I was writing did expect to be able to call tcsetattr().
> Just a tip for future posters; a long email about your code *might* be
> enough information, but you can say a lot more in fewer characters if
> you just link to your github repository :)
I was kinda waiting for confirmation on the usefulness of this module
before setting up a public repo. In the meantime, I'll attach the
current code, in hope that it will clear any confusion.
(Yes, the blocking read() ought to be replaced by a proper select().)
--
Maybe it's time to break that.
-- Larry Wall in <199710311718.jaa19...@wall.org>
package IO::FakeTty;
use 5.008;
use strict;
use warnings;
use Carp;
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
use IO::Pty;
use IO::Pipe;
use base 'IO::Handle';
=head1 NAME
IO::FakeTty - Pseudo-terminal with a controllable talker/listener slave
=head1 SYNOPSIS
use IO::FakeTty;
# This can be treated like any filehandle
$fake_tty = new IO::FakeTty;
# Our slave will read from the tty for 2 seconds, then respond
$fake_tty->fake("<response>\n", 2);
# Now we do whatver we normally do with our tty
print $fake_tty "<command>\n";
$response = <$fake_tty>;
# The slave sent back what we asked for
print 'ok' if ($response eq "<response>\n");
# And we can verify what we actually sent
print 'ok' if ($fake_tty->saw eq "<command>\n");
=head1 DESCRIPTION
C<IO::FakeTty> creates a pseudo-terminal (also known as "pseudo tty" or "pty")
and attaches a talker/listener slave to the other end. The slave can then be
instructed to write to the pty, or read from it and return its contents.
Since the slave runs in a separate process, this can be done in parallel with
the execution of the main program.
This module is primarily intended for testing Perl code which interacts with a
terminal. Given a black-box function or method, you can determine what it
sends to its tty, and how it reacts when fed a given input.
(This is somewhat the opposite of C<Test::Expect>, which tests applications
from the outside, while C<IO::FakeTty> allows testing Perl code from the
inside.)
=head1 CONSTRUCTOR
=over
=item new()
Creates and returns a new C<IO::FakeTty> object. This object inherits
from C<IO::Handle>, and can therefore be treated like a regular filehandle.
=cut
sub new {
my ($class) = @_;
# Our pseudo-terminal and pair of one-way pipes
my $pty = new IO::Pty;
my $pipe_down = new IO::Pipe;
my $pipe_up = new IO::Pipe;
if (my $pid = fork) {
# Parent
$pipe_up->reader();
$pipe_down->writer();
$pipe_down->autoflush();
# Only the slave is guaranteed to be a tty
my $tty = $pty->slave();
close $pty;
# We're done with IO::Tty, so we can snatch this object
bless $tty, $class;
${*$tty}{io_faketty_pid} = $pid;
${*$tty}{io_faketty_pipe_r} = $pipe_up;
${*$tty}{io_faketty_pipe_w} = $pipe_down;
return $tty;
}
elsif (defined $pid) {
# Child
$pipe_down->reader();
$pipe_up->writer();
$pipe_up->autoflush();
# Retain the master device, which may or may not be a tty
$pty->close_slave();
# This will be a no-op if $pty is not a tty
$pty->set_raw();
# Set the file descriptor to be non-blocking
my $fd_flags = fcntl($pty, F_GETFL, 0)
or die "Can't get flags for the slave filehandle: $!\n";
fcntl($pty, F_SETFL, $fd_flags | O_NONBLOCK)
or die "Can't set flags for the slave filehandle: $!\n";
IO::FakeTty::Child::loop($pty, $pipe_down, $pipe_up);
exit 0;
}
}
=back
=head1 METHODS
=over
=item fake( [SEND_STRING], [TIMEOUT], [N_READ] )
Instructs the slave device to read N_READ characters from its tty within
TIMEOUT seconds, and send back SEND_STRING afterwards. The data that was read
will be available via C<saw()>.
If N_READ is zero or C<undef>, the slave will return upon the first successful
read. If N_READ is a negative number, it will be considered to be infinite.
TIMEOUT can be a fractional value; if set to zero or C<undef>, the slave will
read whatever data is available and return immediately. If TIMEOUT is a
negative number, it will be considered to be infinite. (Great care should
then be taken if N_READ is also infinite, as C<saw()> will never return as
long as the tty is open.)
If SEND_STRING is empty or undefined, nothing will be sent and the slave will
return immediately after reading.
(The reversed order of the arguments is meant to make it easier to omit
N_READ.)
=cut
sub fake {
my ($self, $send_str, $timeout, $n_read ) = @_;
$n_read ||= 0;
$timeout ||= 0;
$send_str = '' unless defined $send_str;
${*$self}{io_faketty_fake}++;
# Just being a bit paranoid
local $\;
my $len = length $send_str;
${*$self}{io_faketty_pipe_w}->print("$n_read $timeout $len\n");
${*$self}{io_faketty_pipe_w}->print($send_str);
}
=item saw()
Returns the data the slave read from its tty as instructed by the
corresponding C<fake()> call, or C<undef> if there was no such call. (See
L</Spooling> below for more information.)
=cut
sub saw {
my ($self) = @_;
return undef unless ${*$self}{io_faketty_fake};
${*$self}{io_faketty_fake}--;
local $/ = "\n";
my $len = readline ${*$self}{io_faketty_pipe_r};
my $saw;
read ${*$self}{io_faketty_pipe_r}, $saw, $len;
return $saw;
}
=item remaining()
Asks the slave to consume and return whatever input is present on the terminal
device. This is merely the equivalent to calling C<fake()> and C<saw()> in
one swoop.
=cut
sub remaining {
my ($self) = @_;
$self->fake();
return $self->saw();
}
=item close()
Closes the terminal and waits for the slave device to shut down. Returns true
if the slave exited successfully.
B<NOTE>: This method will I<not> be called when invoking Perl's own C<close>
function. In that case, the child process will remain in a sleeping or zombie
state until this object is destroyed.
=cut
sub close {
my ($self) = @_;
return $self->_reap_child;
}
sub new_from_fd {
croak "Cannot call IO::FakeTty->new_from_fd()";
}
sub fdopen {
croak "Cannot call fdopen() on a IO::FakeTty object";
}
# Reap our child process
sub _reap_child {
my ($self) = @_;
# Close all handles -- our child is sure to wake up
$self->SUPER::close;
CORE::close ${*$self}{io_faketty_pipe_r};
CORE::close ${*$self}{io_faketty_pipe_w};
# Reap the child and return its exit status
if (waitpid(${*$self}{io_faketty_pid}, 0) > 0) {
return ($? >> 8) == 0;
} else {
return undef;
}
}
sub DESTROY { shift->_reap_child }
=back
=cut
package IO::FakeTty::Child;
use Math::BigInt;
use List::Util 'min';
use Time::HiRes 'time';
sub loop {
my ($tty, $pipe_r, $pipe_w) = @_;
local ($/, $\) = ("\n", undef);
while (<$pipe_r>) {
my ($n_char, $timeout, $len) = split / /, $_, 3;
my $send;
read $pipe_r, $send, $len;
my $saw = _read($tty, $n_char, $timeout);
# POSIX doesn't define write('') for non-regular files
$tty->syswrite($send) if length $send;
$pipe_w->print(length $saw, "\n");
$pipe_w->print($saw);
}
}
sub _read {
my ($tty, $n_char, $timeout) = @_;
my $str = '';
# fd_set to be used with select()
my $readfds = '';
vec($readfds, fileno($tty), 1) = 1;
# Provide large enough values for our special cases
$n_char = Math::BigInt->binf if $n_char < 0;
$timeout = undef if $timeout < 0;
my $last_time = time;
# Note that we allow $n_char == 0 to enter the loop
while ((($timeout || 0) >= 0) && ($n_char >= 0) &&
select($readfds, undef, undef, $timeout))
{
# Handle the "read all you can, but only once" case by faking it
if ($n_char == 0) {
$n_char = 1e+15 - 1;
$timeout = 0;
}
$n_char -= sysread($tty, $str, min($n_char, 2**15 - 1), length $str);
# Bypass the exception we made to allow $n_char == 0 into the loop
last if $n_char == 0;
if (defined $timeout) {
$timeout -= (time - $last_time);
$last_time = time;
}
}
return $str;
}
1;
__END__
=head1 DETAILS
=head2 Spooling
C<fake()> can be called several times to simulate a back-and-forth exchange
between a function/method and a terminal:
$fake_tty->fake("My name is Sir Launcelot of Camelot.\n", 0.1);
$fake_tty->fake("To seek the Holy Grail.\n", 0.1);
$fake_tty->fake("Blue.\n", 0.1);
# This is what our function would do
print $fake_tty "What is your name?\n";
$name = <$fake_tty>;
print $fake_tty "What is your quest?\n";
$quest = <$fake_tty>;
print $fake_tty "What is your favorite color?\n";
$color = <$fake_tty>;
# Now the function has run, and gotten its answers. We can peek at the
# questions it asked by calling saw() once for each preceding fake().
print 'ok' if $fake_tty->saw eq "What is your name?\n";
print 'ok' if $fake_tty->saw eq "What is your quest?\n";
print 'ok' if $fake_tty->saw eq "What is your favorite color?\n";
=head1 BUGS
The slave will not resume its sysread if it was interrupted by a signal. (But
then again, who does? <g>)
=head1 NOTES
This module calls C<fork()> within its constructor, so it might be best to
create any C<IO::FakeTty> objects as soon as possible, since some modules do
not react well to forking.
Communication between the parent and child processes is done through a pair of
pipes. When calling C<fake()> several times (as illustrated in L</Spooling>),
it is possible to fill up the pipe buffer and block until the slave times out.
Similarly, the slave may also block until its data is fetched via C<saw()>.
Either case may result in a deadlock, depending on the sequence of events.
(The capacity of a pipe is system-dependant, and may be as low as 512 bytes.)
When calling C<fake()> with TIMEOUT set to zero, there is no difference
between setting N_READ to a zero or a negative value.
=head1 SEE ALSO
L<IO::Handle>, L<IO::Pty>, L<Test::Expect>
=head1 AUTHOR
Frédéric Brière, E<lt>fbri...@fbriere.nete<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2009 by Frédéric Brière
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.0 or,
at your option, any later version of Perl 5 you may have available.
=cut
