File Coverage

blib/lib/IO/Interactive.pm

Criterion	Covered	Total	%
statement	36	71	50.7
branch	5	22	22.7
condition	1	12	8.3
subroutine	11	12	91.6
pod	3	3	100.0
total	56	120	46.6

use 5.008;
package IO::Interactive;

use strict;
use warnings;

$IO::Interactive::VERSION = '1.025';

sub is_interactive {
    my ($out_handle) = (@_, select);    # Default to default output handle

    # Not interactive if output is not to terminal...
    return 0 if not -t $out_handle;

    # If *ARGV is opened, we're interactive if...
    if ( tied(*ARGV) or defined(fileno(ARGV)) ) { # this is what 'Scalar::Util::openhandle *ARGV' boils down to

        # ...it's currently opened to the magic '-' file
        return -t *STDIN if defined $ARGV && $ARGV eq '-';

        # ...it's at end-of-file and the next file is the magic '-' file
        return @ARGV>0 && $ARGV[0] eq '-' && -t *STDIN if eof *ARGV;

        # ...it's directly attached to the terminal
        return -t *ARGV;
    }

    # If *ARGV isn't opened, it will be interactive if *STDIN is attached
    # to a terminal.
    else {
        return -t *STDIN;
    }
}

local (*DEV_NULL, *DEV_NULL2);
my $dev_null;
BEGIN {
    pipe *DEV_NULL, *DEV_NULL2
        or die "Internal error: can't create null filehandle";
    $dev_null = \*DEV_NULL;
}

sub interactive {
    my ($out_handle) = (@_, \*STDOUT);      # Default to STDOUT
    return &is_interactive ? $out_handle : $dev_null;
}

sub _input_pending_on {
    my ($fh) = @_;
    my $read_bits = "";
    my $bit = fileno($fh);
    return if $bit < 0;
    vec($read_bits, fileno($fh), 1) = 1;
    select $read_bits, undef, undef, 0.1;
    return $read_bits;
}

sub busy (&) {
    my ($block_ref) = @_;

    # Non-interactive busy-ness is easy...just do it
    if (!is_interactive()) {
        $block_ref->();
        open my $fh, '<', \ "";
        return $fh;
    }

    # Otherwise fork off an interceptor process...
    my ($read, $write);
    pipe $read, $write;
    my $child = fork;

    # Within that interceptor process...
    if (!$child) {
        # Prepare to send back any intercepted input...
        use IO::Handle;
        close $read;
        $write->autoflush(1);

        # Intercept that input...
        while (1) {
            if (_input_pending_on(\*ARGV)) {
                # Read it...
                my $res = ;

                # Send it back to the parent...
                print {$write} $res;

                # Admonish them for not waiting...
                print {*STDERR} "That input was ignored. ",
                                "Please don't press any keys yet.\n";
            }
        }
        exit;
    }

    # Meanwhile, back in the parent...
    close $write;

    # Temporarily close the input...
    local *ARGV;
    open *ARGV, '<', \ "";

    # Do the job...
    $block_ref->();

    # Take down the interceptor...
    kill 9, $child;
    wait;

    # Return whatever the interceptor caught...
    return $read;
}

sub import {
    my ($package) = shift;
    my $caller = caller;

    # Export each sub if it's requested...
    for my $request ( @_ ) {
        no strict 'refs';
        my $impl = *{$package.'::'.$request}{CODE};
        if(!$impl || $request =~ m/\A _/xms) {
            require Carp;
            Carp::croak("Unknown subroutine ($request()) requested");
        }
        *{$caller.'::'.$request} = $impl;
    }
}

1; # Magic true value required at end of module
__END__