view release on metacpan or  search on metacpan

t/run.t  view on Meta::CPAN

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;