#!/usr/bin/perl

=pod

=head1 NAME

run.t - Test suite for IPC::Run::run, etc.

=cut

use strict;
use warnings;

BEGIN {
    $|  = 1;
    require File::Temp;    # load before $^W to avoid version-string warnings
    $^W = 1;
    if ( $ENV{PERL_CORE} ) {
        chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
        unshift @INC, 'lib', '../..';
        $^X = '../../../t/' . $^X;
    }
}

my @WARNING_MESSAGES;
$SIG{__WARN__} = sub {
    push @WARNING_MESSAGES, @_;
    diag("WARN: $_") foreach (@_);
};

sub get_warnings {
    my @warnings = @WARNING_MESSAGES;
    @WARNING_MESSAGES = ();
    return @warnings;
}

## Handy to have when our output is intermingled with debugging output sent
## to the debugging fd.
select STDERR;
select STDOUT;

use Test::More tests => 308;
use IPC::Run::Debug qw( _map_fds );
use IPC::Run qw( :filters :filter_imp start harness timeout );

require './t/lib/Test.pm';
IPC::Run::Test->import();

# Must do this late as plan uses localtime, and localtime on darwin opens a
# file descriptor. Quite probably other operating systems do file descriptor
# things during the test setup.
my $fd_map = _map_fds;

sub run {
    IPC::Run::run( ref $_[0] ? ( noinherit => 1 ) : (), @_ );
}

## Test at least some of the win32 PATHEXT logic
my $perl = $^X;
$perl =~ s/\.\w+\z// if IPC::Run::Win32_MODE();

sub _unlink {
    my ($f) = @_;
    my $tries;
    while () {
        return if unlink $f;
        if ( $^O =~ /Win32/ && ++$tries <= 10 ) {
            print STDOUT "# Waiting for Win32 to allow $f to be unlinked ($!)\n";
            select undef, undef, undef, 0.1;
            next;
        }
        die "$! unlinking $f at ", join( ", line ", (caller)[ 1, 2 ] ), "\n";
    }
}

my $text           = "Hello World\n";
my @perl           = ($perl);
my $emitter_script = qq{print '$text'; print STDERR uc( '$text' ) unless \@ARGV };
my @emitter        = ( @perl, '-e', $emitter_script );

my $in;
my $out;
my $err;

my $in_file  = 'run.t.in';
my $out_file = 'run.t.out';
my $err_file = 'run.t.err';

my $h;

sub slurp($) {
    my ($f) = @_;
    open( S, "<$f" ) or return "$! $f";
    my $r = join( '', <S> );
    close S or warn "$!: $f";
    select 0.1 if $^O =~ /Win32/;
    return $r;
}

sub spit($$) {
    my ( $f, $s ) = @_;
    open( S, ">$f" ) or die "$! $f";
    print S $s or die "$! $f";
    close S or die "$! $f";
}

##
## A grossly inefficient filter to test filter
## chains.  It's inefficient because we want to make sure that the
## filter chain flushing logic works.  The inefficiency is that it
## doesn't process as much input as it could each call, so lots of calls
## are required.
##
sub alt_casing_filter {
    my ( $in_ref, $out_ref ) = @_;
    return input_avail && do {
        $$out_ref .= lc( substr( $$in_ref, 0, 1, '' ) );
        1;
      }
      && (
        !input_avail || do {
            $$out_ref .= uc( substr( $$in_ref, 0, 1, '' ) );
            1;
        }
      );
}

sub case_inverting_filter {
    my ( $in_ref, $out_ref ) = @_;
    return input_avail && do {
        $$in_ref =~ tr/a-zA-Z/A-Za-z/;
        $$out_ref .= $$in_ref;
        $$in_ref = '';
        1;
    };
}

sub eok {
    my ( $got, $exp, $name ) = @_;
    # Normalize CRLF to LF on Win32 — binmode-specific behavior is tested in t/binmode.t
    $got =~ s/\r\n/\n/g if defined $got && IPC::Run::Win32_MODE();
    $got =~ s/([\000-\037])/sprintf "\\0x%02x", ord $1/ge if defined $exp;
    $exp =~ s/([\000-\037])/sprintf "\\0x%02x", ord $1/ge if defined $exp;

    my ( $pack, $file, $line ) = caller();
    $name ||= qq[eok at $file line $line];

    local $Test::Builder::Level = $Test::Builder::Level + 1;
    return is( $got, $exp, $name );
}

my $r;

is( _map_fds, $fd_map );
$fd_map = _map_fds;

##
## Internal testing
##
filter_tests(
    "alt_casing_filter",
    "Hello World",
    [ "hElLo wOrLd" =~ m/(..?)/g ],
    \&alt_casing_filter
  ),

  is( _map_fds, $fd_map );
$fd_map = _map_fds;

filter_tests(
    "case_inverting_filter",
    "Hello World",
    "hELLO wORLD",
    \&case_inverting_filter
  ),

  is( _map_fds, $fd_map );
$fd_map = _map_fds;

##
## Calling the local system shell
##
ok( run qq{"$perl" -e exit} );
is( $?, 0 );

is( _map_fds, $fd_map );
$fd_map = _map_fds;
SKIP: {
    if ( IPC::Run::Win32_MODE() ) {
        skip( "$^O's shell returns 0 even if last command doesn't", 3 );
    }

    ok( !run(qq{"$perl" -e 'exit(42)'}) );
    ok($?);
    is( $? >> 8, 42 );
}
is( _map_fds, $fd_map );
$fd_map = _map_fds;

##
## Simple commands, not executed via shell
##
ok( run $perl, qw{-e exit} );
is( $?, 0 );

is( _map_fds, $fd_map );
$fd_map = _map_fds;

ok( !run $perl, qw{-e exit(42)} );
ok($?);
is $? >> 8, 42;

is( _map_fds, $fd_map );
$fd_map = _map_fds;

##
## Arguments bearing most bytes, excluding NUL (unsupported) and BEL (noisy and
## not otherwise special).  Arguments bearing special sequences of bytes.
##
sub bytes_tests {
    my ( $printer, $bytes, $sequences ) = @_;

    local $ENV{PERL_UNICODE};
    delete $ENV{PERL_UNICODE};

    run( [ @$printer, @$bytes ], '>', \$out );
    eok( $out, join "\0", @$bytes );

    foreach my $payload ( join( '', @$bytes ), @$sequences ) {
        run( [ @$printer, $payload ], '>', \$out );
        eok( $out, $payload );
    }
}

my @bytes = map { $_ == 7 ? () : pack( 'C', $_ ); } 1 .. 0xFF;
my $sequence = qq{\\"\\az\\\\"\\\\\\};
bytes_tests(
    [ $perl, '-e', 'binmode STDOUT; print join "\0", @ARGV' ],
    \@bytes, [ $sequence, "$sequence\n" ]
);

##
## Executing Cygwin Perl (from any Perl)
##
SKIP: {
    # It's tempting to enable these automatically when c:/cygwin64/bin/perl
    # exists.  However, a hostile user could create that file on a system having
    # no Cygwin installation.
    skip( 'set TEST_CYGWIN_PERL=c:/cygwin64/bin/perl to test executing Cygwin from non-Cygwin', 3 )
      unless $ENV{TEST_CYGWIN_PERL};

    # Cygwin mishandles arguments containing non-ASCII bytes, even under
    # LANG=POSIX.  (It might handle them correctly if they're valid utf8 or if
    # one installs a non-utf8 locale.)  Cygwin also mishandles "\\\\x a" and
    # other lpCommandLine fragments with multiple backslashes.  (Cygwin programs
    # executing other Cygwin programs pass the argv outside lpCommandLine,
    # bypassing the problem.)  Don't test any of those.
    my @cygbytes = map { $_ == 7 ? () : pack( 'C', $_ ); } 1 .. 0x7F;
    bytes_tests(
        [
            $ENV{TEST_CYGWIN_PERL},
            '-e', 'binmode STDOUT; print join "\0", @ARGV'
        ],
        \@cygbytes,
        [$sequence]
    );
}

##
## Win32 batch files
##
SKIP: {
    if ( !IPC::Run::Win32_MODE() ) {
        skip( "batch files are specific to Win32", 11 );
    }

    use Cwd        ();
    use File::Spec ();
    use File::Temp ();
    require Win32::ShellQuote;

    my $parent_dir = File::Temp::tempdir( CLEANUP => 1 );
    my $simple = File::Spec->catfile( $parent_dir, 'simple.bat' );
    my $dir = File::Spec->catdir( $parent_dir, 'sub dir' );
    mkdir $dir;

    # List bytes that are valid in file names and potentially interesting to
    # test.  Exclude the colon, which selects a non-default "file stream".
    # Exclude ASCII alphanumeric bytes, which are uninteresting and would make
    # the name too long.
    my $file_name_bytes = join '', map {
        my $chr = pack( 'C', $_ );
        my $chr_file = File::Spec->catfile( $dir, "name_$chr.bat" );
        $chr !~ /[:a-zA-Z0-9]/ && open( my $fh, '>', $chr_file ) ? ($chr) : ();
    } 1 .. 0xFF;
    my $bat          = File::Spec->catfile( $dir, 'SCRIPT FILE.BAT' );
    my $cmd_basename = "SCRIPT ^&%SYSTEMROOT%!ipcrunpct!${file_name_bytes}.cmd  ";
    my $cmd          = File::Spec->catfile( $dir, $cmd_basename );
    my $bat_source   = sprintf(
        qq{\@echo off\n"%s" -e %s %%*},
        $perl,
        Win32::ShellQuote::quote_cmd('binmode STDOUT; print join "\0", @ARGV')
    );

    # Fill batch files and check their handling of trivial arguments.
    foreach my $f ( $simple, $bat, $cmd ) {
        spit( $f, $bat_source );
        run( [ $f, qw(xyz 1 23) ], '>', \$out );
        eok( $out, join( "\0", qw(xyz 1 23) ) );
    }

    # Zero arguments
    run( [$simple], '>', \$out );
    eok( $out, '' );

    # Forbidden character in batch file argument
    eval { run( [ $simple, "foo\nbar" ], '>', \$out ); };
    like( $@, qr/newline/ );

    # Missing COMSPEC
    {
        local $ENV{COMSPEC};
        run( [ $simple, 'arg' ], '>', \$out );
        eok( $out, 'arg' );
    }

    # Environment variable collision
    {
        local $ENV{'somevar^^^'} = 'FAIL';
        run( [ $simple, '%somevar%' ], '>', \$out );
        eok( $out, '%somevar%' );
    }

    ## As above, except that cmd.exe does not cope with \r or \n.
    bytes_tests(
        [$cmd],
        [ grep { $_ ne "\r" && $_ ne "\n" } @bytes ], [$sequence]
    );

    # Relative path doesn't begin with a volume specification, so it exercises
    # different cmd.exe behavior.  See https://stackoverflow.com/a/4095133.
    my $initial_cwd = Cwd::getcwd;
    chdir $parent_dir;
    my $rel = File::Spec->catfile( 'sub dir', $cmd_basename );
    run( [ $rel, 'arg' ], '>', \$out );
    eok( $out, 'arg' );
    chdir $initial_cwd;
}

##
## IPC::Run::Win32Process
##
SKIP: {
    if ( !IPC::Run::Win32_MODE() ) {
        skip( "cmd.exe is specific to Win32", 2 );
    }

    use File::Spec ();
    require Win32;
    require IPC::Run::Win32Process;

    run(
        IPC::Run::Win32Process->new( $ENV{COMSPEC}, q{cmd.exe /c echo ""} ),
        '>', \$out
    );
    eok( $out, qq{""\n} );

    my $find_exe = File::Spec->catfile(
        Win32::GetFolderPath( Win32::CSIDL_SYSTEM() ),
        'find.exe'
    );
    run(
        IPC::Run::Win32Process->new( $ENV{COMSPEC}, q{cmd.exe /c echo ""} ),
        '|', IPC::Run::Win32Process->new( $find_exe, q{find_exe """"""} ),
        '>', \$out
    );
    eok( $out, qq{""\n} );
}

##
## A function
##
SKIP: {
    if ( IPC::Run::Win32_MODE() ) {
        skip( "Can't spawn subroutines on $^O", 10 );
    }

    ok run sub { };
    is $?, 0;
    ok !run sub { exit 42 };
    ok $? ;
    is $? >> 8, 42;

    ## GH#122 / GH#97: die inside a coderef must propagate the exception
    ## back to the parent via the sync pipe, not escape into the parent's
    ## call stack.  The parent should see the exception in $@.
    my $lived = eval { run( sub { die "dying inside coderef\n" } ); 1 };
    ok !$lived, 'run with dying coderef throws in parent';
    like $@, qr/dying inside coderef/, 'parent sees child exception message';

    ## Verify exception propagation with start()/finish() too.
    $lived = eval {
        my $h = start( sub { die "start coderef dies\n" } );
        finish $h;
        1;
    };
    ok !$lived, 'start with dying coderef throws in parent';
    like $@, qr/start coderef dies/, 'parent sees child exception from start()';

    ## Normal coderef still works fine.
    ok run( sub { } ), 'normal coderef still succeeds';
}
is( _map_fds, $fd_map );
$fd_map = _map_fds;

##
## A function, and an init function
##
SKIP: {
    if ( IPC::Run::Win32_MODE() ) {
        skip( "Can't spawn subroutines on $^O", 2 );
    }

    my $e = 0;
    ok(
        !run(
            sub { exit($e) },
            init => sub { $e = 42 }
        )
    );
    ok($?);
}
is( _map_fds, $fd_map );
$fd_map = _map_fds;

##
## init after timeout (https://github.com/cpan-authors/IPC-Run/issues/134)
## A timer must not reset $cur_kid, so init can appear after timeout().
##
SKIP: {
    if ( IPC::Run::Win32_MODE() ) {
        skip( "Can't spawn subroutines on $^O", 2 );
    }

    my $e = 0;
    ok(
        !run(
            sub { exit($e) },
            timeout(10),
            init => sub { $e = 42 }
        )
    );
    ok($?);
}
is( _map_fds, $fd_map );
$fd_map = _map_fds;

##
## scalar ref I & O redirection using op tokens
##
$out    = 'REPLACE ME';
$fd_map = _map_fds;
$r      = run [ @emitter, "nostderr" ], '>', \$out;
ok($r);

ok( !$? );
is( _map_fds, $fd_map );
eok( $out, $text );

$out    = 'REPLACE ME';
$fd_map = _map_fds;
$r      = run [ @emitter, "nostderr" ], '<', \undef, '>', \$out;
ok($r);

ok( !$? );
is( _map_fds, $fd_map );
eok( $out, $text );

$in     = $emitter_script;
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
$r      = run \@perl, '<', \$in, '>', \$out, '2>', \$err,;
ok($r);

ok( !$? );
is( _map_fds, $fd_map );

eok( $in,  $emitter_script );
eok( $out, $text );
eok( $err, uc($text) );
##
## scalar ref I & O redirection, succinct mode.
##

$in     = $emitter_script;
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
$r      = run \@perl, \$in, \$out, \$err;
ok($r);

ok( !$? );
is( _map_fds, $fd_map );

eok( $in,  $emitter_script );
eok( $out, $text );
eok( $err, uc($text) );

##
## Long output, to test for blocking read.
##
## Assume pipe buffer length <= 10000, need to double that to assure enough
## chars to fill a buffer so.  This test adapted from a test submitted by
## Borislav Deianov <borislav@ensim.com>.

$in     = "-" x 20000 . "end\n";
$out    = 'REPLACE ME';
$fd_map = _map_fds;
$r      = run [ $perl, qw{-e print"-"x20000;<STDIN>;} ], \$in, \$out;
ok($r);

ok( !$? );
is( _map_fds, $fd_map );

is( length $out, 20000 );
unlike( $out, qr/[^-]/ );

##
## Long output run through twice
##
## Adapted from a stress test by Aaron Elkiss <aelkiss@wam.umd.edu>
##

$h   = start [ $perl, qw( -pe BEGIN{$|=1}1 ) ], \$in, \$out;
$in  = "\n";
$out = "";
pump $h until length $out;
$out =~ s/\r\n/\n/g if IPC::Run::Win32_MODE();
is $out, "\n";

my $long_string = "x" x 20000 . "DOC2\n";
$in  = $long_string;
$out = "";
my $ok_1 = eval {
    pump $h until $out =~ /DOC2/;
    1;
};
my $x    = $@;
my $ok_2 = eval {
    finish $h;
    1;
};

$x = $@ if $ok_1 && !$ok_2;

if ( $ok_1 && $ok_2 ) {
    $out =~ s/\r\n/\n/g if IPC::Run::Win32_MODE();
    is $long_string, $out;
}
else {
    $x =~ s/(x+)/sprintf "...%d \"x\" chars...", length $1/e;
    is $x, "";
}

##
## child function, scalar ref I & O redirection, succinct mode.
##
SKIP: {
    if ( IPC::Run::Win32_MODE() ) {
        skip( "Can't spawn subroutines on $^O", 6 );
    }

    $in     = $text;
    $out    = 'REPLACE ME';
    $err    = 'REPLACE ME';
    $fd_map = _map_fds;
    $r      = run(
        sub {
            while (<>) { print; print STDERR uc($_) }
        },
        \$in,
        \$out,
        \$err
    );
    ok($r);
    ok !$?;
    is( _map_fds, $fd_map );
    eok( $in,  $text );
    eok( $out, $text );
    eok( $err, uc($text) );
}

##
## here document as input
##
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
$r      = run \@perl, \<<TOHERE, \$out, \$err;
$emitter_script
TOHERE
ok($r);

ok( !$? );
is( _map_fds, $fd_map );

eok( $out, $text );
eok( $err, uc($text) );

##
## undef as input
##
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
$r      = run \@perl, \undef, \$out, \$err;
ok($r);

ok( !$? );
is( _map_fds, $fd_map );

eok( $out, '' );
eok( $err, '' );

##
## filehandle input redirection
##
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
spit( $in_file, $emitter_script );
open( F, "<$in_file" ) or die "$! $in_file";
$r = run \@perl, \*F, \$out, \$err;
close F;
unlink $in_file or warn "$! $in_file";
ok($r);

ok( !$? );
is( _map_fds, $fd_map );

eok( $out, $text );
eok( $err, uc($text) );

##
## input redirection via caller writing directly to a pipe
##
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
$h      = start \@perl, '<pipe', \*IN, '>', \$out, '2>', \$err;
## Assume this won't block...
print IN $emitter_script;
close IN or warn $!;
$r = $h->finish;
ok($r);

ok( !$? );
is( _map_fds, $fd_map );

eok( $out, $text );
eok( $err, uc($text) );

##
## input redirection via caller writing directly to a blocking pipe
##
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
$h      = start \@perl, '<blocking_pipe', \*IN, '>', \$out, '2>', \$err;
print IN $emitter_script;
close IN or warn $!;
$r = $h->finish;
ok($r);

ok( !$? );
is( _map_fds, $fd_map );

eok( $out, $text );
eok( $err, uc($text) );

##
## blocking pipe should allow large writes without EAGAIN
##
SKIP: {
    skip "Win32 pipes are always blocking", 2 if IPC::Run::Win32_MODE();

    ## Write enough data to overflow a typical pipe buffer (64KB).
    ## With a non-blocking pipe this would fail with EAGAIN; with
    ## <blocking_pipe it must succeed.
    my $big_data = "x" x 65536;
    my $got_out   = '';
    $h = start [ $^X, '-e', 'local $/; $_ = <STDIN>; print length($_)' ],
      '<blocking_pipe', \*IN2, '>', \$got_out;
    my $ok = print IN2 $big_data;
    close IN2 or warn $!;
    $h->finish;
    ok( $ok, '<blocking_pipe large write succeeded without EAGAIN' );
    is( $got_out, length($big_data), '<blocking_pipe child received all data' );
}

##
## filehandle input redirection, passed via *F{IO}
##
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
spit( $in_file, $emitter_script );
open( F, "<$in_file" ) or die "$! $in_file";
$r = run \@perl, *F{IO}, \$out, \$err;
close F;
_unlink $in_file;
ok($r);

ok( !$? );
is( _map_fds, $fd_map );

eok( $out, $text );
eok( $err, uc($text) );

##
## filehandle output redirection
##
$fd_map = _map_fds;
open( OUT, ">$out_file" ) or die "$! $out_file";
open( ERR, ">$err_file" ) or die "$! $err_file";
print OUT "out: ";
print ERR uc("err: ");
$r = run \@emitter, \undef, \*OUT, \*ERR;
print OUT " more out data";
print ERR uc(" more err data");
close OUT;
close ERR;
$out = slurp($out_file);
$err = slurp($err_file);
_unlink $out_file;
_unlink $err_file;
ok($r);

ok( !$? );
is( _map_fds, $fd_map );

eok( $out, "out: $text more out data" );
eok( $err, uc("err: $text more err data") );

##
## filehandle output redirection via a pipe that is returned to the caller
##
$fd_map = _map_fds;
$r      = run \@emitter, \undef, '>pipe', \*OUT, '2>pipe', \*ERR;
$out    = '';
$err    = '';
read OUT, $out, 10000 or warn $!;
read ERR, $err, 10000 or warn $!;
close OUT or warn $!;
close ERR or warn $!;
ok($r);

ok( !$? );
is( _map_fds, $fd_map );

eok( $out, $text );
eok( $err, uc($text) );

##
## sub I & O redirection
##
$in     = $emitter_script;
$out    = undef;
$err    = undef;
$fd_map = _map_fds;
$r      = run(
    \@perl,
    '<', sub { my $f = $in; $in = undef; return $f },
    '>',  sub { $out .= shift },
    '2>', sub { $err .= shift },
);
ok($r);
ok( !$? );
is( _map_fds, $fd_map );

eok( $out, $text );
eok( $err, uc($text) );

##
## input redirection from a file
##
$out    = undef;
$err    = undef;
$fd_map = _map_fds;
spit( $in_file, $emitter_script );
$r = run(
    \@perl,
    "<$in_file",
    '>',  sub { $out .= shift },
    '2>', sub { $err .= shift },
);
_unlink $in_file;
ok($r);
ok( !$? );
is( _map_fds, $fd_map );
eok( $out, $text );
eok( $err, uc($text) );

##
## reading input from a non standard fd
##
SKIP: {
    if ( IPC::Run::Win32_MODE() ) {
        skip( "$^O does not allow redirection of file descriptors > 2", 11 );
    }

    $out    = undef;
    $err    = undef;
    $fd_map = _map_fds;
    $r      = run(
        ## FreeBSD doesn't guarantee that fd 3 or 4 are available, so
        ## don't assume, go for 5.
        [ @perl, '-le', 'open( STDIN, "<&5" ) or die $!; print <STDIN>' ],
        "5<", \"Hello World",
        '>',  \$out,
        '2>', \$err,
    );
    ok($r);
    ok( !$? );
    is( _map_fds, $fd_map );
    eok( $out, $text );
    eok( $err, '' );

    ##
    ## duping input descriptors and an input descriptor > 0
    ##
    $in     = $emitter_script;
    $out    = 'REPLACE ME';
    $err    = 'REPLACE ME';
    $fd_map = _map_fds;
    $r      = run(
        \@perl,
        '>',  \$out,
        '2>', \$err,
        '3<', \$in,
        '0<&3',
    );
    ok($r);
    ok( !$? );
    is( _map_fds, $fd_map );
    eok( $in,  $emitter_script );
    eok( $out, $text );
    eok( $err, uc($text) );
}

##
## closing input descriptors
##
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
spit( $in_file, $emitter_script );
$r = run(
    [ @perl, '-e', '$l = readline *STDIN or die $!; print $l' ],
    '>',  \$out,
    '2>', \$err,
    '<',  $in_file,
    '0<&-',
);
_unlink $in_file;
ok( !$r );
ok($?);
is( _map_fds, $fd_map );
eok( $out, '' );

#ok( $err =~ /file descriptor/i ? "Bad file descriptor error" : $err, "Bad file descriptor error" );
# XXX This should be use Errno; if $!{EBADF}. --rs
is( length $err ? "Bad file descriptor error" : $err, "Bad file descriptor error" );

##
## input redirection from a non-existent file
##
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
my $bad_file = "$in_file.nonexistent";
_unlink $bad_file if -e $bad_file;
eval { $r = run \@perl, ">$out_file", "<$bad_file"; };
like $@, qr/\Q$bad_file\E/;
is( _map_fds, $fd_map );

##
## output redirection to a file w/ creation or truncation
##
$fd_map = _map_fds;
_unlink $out_file if -x $out_file;
_unlink $err_file if -x $err_file;
$r = run(
    \@emitter,
    ">$out_file",
    "2>$err_file",
);
$out = slurp($out_file);
$err = slurp($err_file);
ok($r);
ok( !$? );
is( _map_fds, $fd_map );

eok( $out, $text );
eok( $err, uc($text) );

##
## output file redirection, w/ truncation
##
$fd_map = _map_fds;
spit( $out_file, 'out: ' );
spit( $err_file, 'ERR: ' );
$r = run(
    \@emitter,
    ">$out_file",
    "2>$err_file",
);
$out = slurp($out_file);
_unlink $out_file;
$err = slurp($err_file);
_unlink $err_file;
ok($r);
ok( !$? );
is( _map_fds, $fd_map );

eok( $out, $text );
eok( $err, uc($text) );

##
## output file redirection w/ append
##
spit( $out_file, 'out: ' );
spit( $err_file, 'ERR: ' );
$fd_map = _map_fds;
$r      = run(
    \@emitter,
    ">>$out_file",
    "2>>$err_file",
);
$out = slurp($out_file);
_unlink $out_file;
$err = slurp($err_file);
_unlink $err_file;
ok($r);
ok( !$? );
is( _map_fds, $fd_map );

eok( $out, "out: $text" );
eok( $err, uc("err: $text") );
##
## dup()ing output descriptors
##
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
$r      = run \@emitter, '>', \$out, '2>', \$err, '2>&1';
ok($r);
ok( !$? );
is( _map_fds, $fd_map );
$out =~ s/\r\n/\n/g if IPC::Run::Win32_MODE();
like $out, qr/(?:$text){2}/i;
eok( $err, '' );

##
## stderr & stdout redirection to the same file via >&word
##
$fd_map = _map_fds;
_unlink $out_file if -x $out_file;
$r = run \@emitter, ">&$out_file";
$out = slurp($out_file);
ok($r);
ok( !$? );
is( _map_fds, $fd_map );

like $out, qr/(?:$text){2}/i;

##
## Non-zero exit value, command with args, no redirects.
##
$fd_map = _map_fds;
$r = run [ @perl, '-e', 'exit(42)' ];
ok( !$r );
is( $?,       42 << 8 );
is( _map_fds, $fd_map );

##
## Zero exit value, command with args, no redirects.
##
$fd_map = _map_fds;
$r = run [ @perl, qw{ -e exit } ];
ok($r);
ok( !$? );
is( _map_fds, $fd_map );

##
## dup()ing output descriptors that collide.
##
## This test assumes that our caller doesn't leave a lot of fds opened,
## and assumes that $out_file will be opened on fd 3, 4 or 5.
##
SKIP: {
    if ( IPC::Run::Win32_MODE() ) {
        skip( "$^O does not allow redirection of file descriptors > 2", 5 );
    }

    $out = 'REPLACE ME';
    $err = 'REPLACE ME';
    _unlink $out_file if -x $out_file;
    $fd_map = _map_fds;
    $r      = run(
        \@emitter,
        "<", \"",
        "3>&1", "4>&1", "5>&1",
        ">$out_file",
        '2>', \$err,
    );
    $out = slurp($out_file);
    _unlink $out_file;
    ok($r);
    ok( !$? );
    is( _map_fds, $fd_map );
    eok( $out, $text );
    eok( $err, uc($text) );
}

##
## Pipelining
##
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
$r      = run(
    [ @perl, '-lane', 'print STDERR qq{1:$_}; print uc($F[0]), q{ },$F[1]' ],
    \q{Hello World},
    '|', [ @perl, '-lane', 'print STDERR qq{2:$_}; print $F[0], q{ },lc($F[1])' ],
    \$out,
    \$err,
);
ok($r);
ok( !$? );
is( _map_fds, $fd_map );
eok( $out, "HELLO world\n" );
eok( $err, "1:Hello World\n2:HELLO World\n" );

##
## Parallel (unpiplined) processes
##
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
$r      = run(
    [ @perl, '-lane', 'print STDERR qq{1:$_}; print uc($F[0]),q{ },$F[1]' ],
    \q{Hello World},
    '&', [ @perl, '-lane', 'print STDERR "2:$_"; print $F[0],q{ },lc( $F[1] )' ],
    \q{Hello World},
    \$out,
    \$err,
);
ok($r);
ok( !$? );
is( _map_fds, $fd_map );
$out =~ s/\r\n/\n/g if IPC::Run::Win32_MODE();
like $out, qr/^(?:HELLO World\n|Hello world\n){2}$/s;
like $err, qr/^(?:[12]:Hello World.*){2}$/s;

##
## A few error cases...
##
eval { $r = run \@perl, '<', [], [] };
like( $@, qr/not allowed/ );
eval { $r = run \@perl, '>', [], [] };
like( $@, qr/not allowed/ );
foreach my $foo (qw( | & < > >& 1>&2 >file <file 2<&1 <&- 3<&- )) {
    eval { $r = run $foo, [] };
    like( $@, qr/command/ );
}
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
get_warnings();    # clear any prior warnings
eval {
    $r = run(
        \@emitter, '>', \$out, '2>', \$err,
        _simulate_fork_failure => 1
    );
};
ok($@);
ok( !$? );
is( _map_fds, $fd_map );

eok( $out, '' );
eok( $err, '' );
is( scalar get_warnings(), 0, 'no warnings when fork fails (rt.cpan.org #57186)' );

$fd_map = _map_fds;
eval { $r = run \@perl, '<file', _simulate_open_failure => 1; };
ok($@);
ok( !$? );
is( _map_fds, $fd_map );

$fd_map = _map_fds;
eval { $r = run \@perl, '>file', _simulate_open_failure => 1; };
ok($@);
ok( !$? );
is( _map_fds, $fd_map );

##
## harness, pump, run
##
$in     = 'SHOULD BE UNCHANGED';
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$?      = 99;
$fd_map = _map_fds;
$h      = start(
    [ @perl, '-pe', 'BEGIN { $| = 1 } print STDERR uc($_)' ],
    \$in, \$out, \$err,

    # hangs w/o fix for https://github.com/toddr/IPC-Run/issues/77
    _sleep_after_win32_spawn => 1,
);
isa_ok( $h, 'IPC::Run' );
is( $?, 99 );

eok( $in,  'SHOULD BE UNCHANGED' );
eok( $out, '' );
eok( $err, '' );
ok( $h->pumpable );

$in = '';
$?  = 0;
pump_nb $h for ( 1 .. 100 );
pass("after pump_nb");
eok( $in,  '' );
eok( $out, '' );
eok( $err, '' );
ok( $h->pumpable );

$in = $text;
$?  = 0;
pump $h until $out =~ /Hello World/;
pass("after pump");
ok( !$? );
eok( $in,  '' );
eok( $out, $text );
ok( $h->pumpable );

ok( $h->finish );
ok( !$? );
is( _map_fds, $fd_map );
eok( $out, $text );
eok( $err, uc($text) );
ok( !$h->pumpable );

##
## start, run, run, run.  See Tom run.  A do-run-run, a-do-run-run.
##
$in     = 'SHOULD BE UNCHANGED';
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
$h      = start(
    [ @perl, '-pe', 'binmode STDOUT; binmode STDERR; BEGIN { $| = 1 } print STDERR uc($_)' ],
    \$in, \$out, \$err,
);
ok( $h->isa('IPC::Run') );

eok( $in,  'SHOULD BE UNCHANGED' );
eok( $out, '' );
eok( $err, '' );
ok( $h->pumpable );

$in = $text;
ok( $h->finish );
ok( !$? );
is( _map_fds, $fd_map );
eok( $in,  '' );
eok( $out, $text );
eok( $err, uc($text) );
ok( !$h->pumpable );

$in  = $text;
$out = 'REPLACE ME';
$err = 'REPLACE ME';
ok( $h->run );
ok( !$? );
is( _map_fds, $fd_map );
eok( $in,  $text );
eok( $out, $text );
eok( $err, uc($text) );
ok( !$h->pumpable );

$in  = $text;
$out = 'REPLACE ME';
$err = 'REPLACE ME';
ok( $h->run );
ok( !$? );
is( _map_fds, $fd_map );
eok( $in,  $text );
eok( $out, $text );
eok( $err, uc($text) );
ok( !$h->pumpable );

##
## Output filters
##
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
$r      = run(
    \@emitter,
    '>',
    \&alt_casing_filter,
    \&case_inverting_filter,
    \$out,
    '2>', \$err,
);
ok($r);
ok( !$? );
is( _map_fds, $fd_map );

eok( $out, "HeLlO WoRlD\n" );
eok( $err, uc($text) );

##
## Input filters
##
$out    = 'REPLACE ME';
$err    = 'REPLACE ME';
$fd_map = _map_fds;
$in     = $text;
$r      = run(
    [ @perl, '-pe', 'binmode STDOUT; binmode STDERR; print STDERR uc $_' ],
    '0<',
    \&case_inverting_filter,
    \&alt_casing_filter,
    \$in,
    '1>', \$out,
    '2>', \$err,
);
ok($r);
ok( !$? );
is( _map_fds, $fd_map );

eok( $in,  $text );
eok( $out, "HeLlO WoRlD\n" );
eok( $err, uc($text) );

##
## env option: set environment variables in child without affecting parent
##
SKIP: {
    if ( IPC::Run::Win32_MODE() ) {
        skip( "env option not supported on $^O", 4 );
    }

    # env sets a variable in the child process
    $out = '';
    run(
        [ @perl, '-e', 'print defined $ENV{IPC_RUN_TEST_VAR} ? $ENV{IPC_RUN_TEST_VAR} : q{}' ],
        env => { IPC_RUN_TEST_VAR => 'hello_env' },
        '>', \$out,
    );
    is( $out, 'hello_env', 'env option sets variable in child process' );

    # env does not modify the parent's %ENV
    delete local $ENV{IPC_RUN_TEST_VAR};
    $out = '';
    run(
        [ @perl, '-e', 'print defined $ENV{IPC_RUN_TEST_VAR} ? $ENV{IPC_RUN_TEST_VAR} : q{}' ],
        env => { IPC_RUN_TEST_VAR => 'child_only' },
        '>', \$out,
    );
    ok( !exists $ENV{IPC_RUN_TEST_VAR}, 'env option does not affect parent %ENV' );

    # init can override a variable set by env
    $out = '';
    run(
        [ @perl, '-e', 'print defined $ENV{IPC_RUN_TEST_VAR} ? $ENV{IPC_RUN_TEST_VAR} : q{}' ],
        env  => { IPC_RUN_TEST_VAR => 'from_env' },
        init => sub { $ENV{IPC_RUN_TEST_VAR} = 'from_init' },
        '>', \$out,
    );
    is( $out, 'from_init', 'init sub can override env option' );

    # invalid env value croaks
    eval {
        harness( [ @perl, '-e', '1' ], env => 'not_a_hashref' );
    };
    like( $@, qr/requires a hash reference/, 'env option croaks on non-hashref' );
}

{    # no warnings for an empty path but it does die.
        # Some other OSes might not support find. Windows and UNIX do...
    my @simple_command = ('bogusprogram');

    local $ENV{PATH};
    delete $ENV{PATH};

    eval { $h = start \@simple_command, \$in, \$out; };
    ok( $@, "Error running bogus program when path is empty" );

    my ($message) = get_warnings();
    is( $message, undef, "No warnings found during program call with empty path" );
    finish $h;    # Close out the program call
}

