If the code being tested calls for input from STDIN more times than there are elements in the array tied to STDIN (or if those elements are undef), and if the user prompt is located (as is likely) within a while (<>) loop, then the program goes into an infinite loop because all elements of the tied array have been shifted off.

A simple change in Preempt::Stdin::READLINE() solves this problem: Croak if there are no elements left in the list provided to the subroutine; then capture and examine the error in the testing script.

Here's the revised Preempt::Stdin:

package Preempt::Stdin;
use strict;
use Carp;

sub TIEHANDLE {
    my $class = shift;
    my @lines = @_;
    bless \@lines, $class;
}

sub READLINE {
    my $self = shift;
    if (@$self) { shift @$self; } 
    else { croak "List of prompt responses has been exhausted: $!"; }
}

1;
[download]

And here's the revised testing script, starting with the two passing tests from yesterday and followed by a new test in which the error is captured and examined.

package main;
use strict;
use warnings;
use Test::More tests => 3;

my (@lines, $room);

# 1st pass: valid data reached at $lines[4]
@lines = (
    'a string with numbers and letters 4678',
    '5678', '46789', ' 4678', '4678',
);
tie *STDIN, 'Preempt::Stdin', @lines;
ok($room = enter_number(), 'enter_number executed');
is(4678, $room, 'predicted value achieved');
untie *STDIN;

# 2nd pass: never reached valid data
@lines = (
    'a string with numbers and letters 4678',
    '5678', '46789',
);
{
    tie *STDIN, 'Preempt::Stdin', @lines;
    my $room;
    eval { $room = enter_number(); };
    like($@, qr/^List of prompt responses has been exhausted/, 
       "Prompt responses exhausted")
       || print STDERR "$@\n";
    untie *STDIN;
}

sub enter_number { # no change from yesterday
    local $_;
    while () {
        print "Enter new room number:  ";
        chomp ($_ = <STDIN>);
        if ($_ =~ /^4\d\d\d$/) {
            return $_;
        } else {
            print "\nMust be a 4-digit number beginning with '4'; try 
+again.\n";
            next;
        }
    }
}
[download]

Two additional points.

First, as mentioned yesterday, if you wanted to capture all those prompt messages going to STDOUT, you could do so with IO::Capture::Stdout.

Second, if the subroutine being tested were more complex than the one above, there is a good chance that, in the case of insufficient arguments, warnings would be generated due to uninitialized variables. Since those warnings would be expected, you would probably want to suppress them during testing. You could so by defining a subroutine

sub _capture { my $str = $_[0]; }

and then calling

    local $SIG{__WARN__} = \&_capture;
    tie *STDIN, 'Preempt::Stdin', @lines;
    ...  # as before
[download]

at the top of the block.

To give credit where credit is due: The idea of capturing the error from a deliberately failing test and examining it with Test::More::like() was picked up from monk dha during our joint work on the Phalanx project. And the idea of capturing warnings within a block was picked up from (IIRC) Benjamin Goldberg on c.l.p.misc a couple of years back.

Jim Keenan