#!/usr/bin/perl
use strict;
use warnings;
use IO::Async::Test;
use Test::More;
use Test::Fatal;
use IO::Async::Loop;
use IO::Async::OS;
use Data::Dumper;
plan skip_all => "POSIX fork() is not available" unless IO::Async::OS->HAVE_POSIX_FORK;
my $loop = IO::Async::Loop->new_builtin;
testing_loop( $loop );
# Same testing as run_child to proof that nothing broken
my ( $exitcode, $stdout, $stderr );
my $defaul_capture = [qw(exitcode stdout stderr)];
( $exitcode, $stdout, $stderr )
= $loop->run_process(
code => sub { 0 },
capture => $defaul_capture,
)->get;
ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after sub { 0 }' );
is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after sub { 0 }' );
is( $stdout, "", '$stdout after sub { 0 }' );
is( $stderr, "", '$stderr after sub { 0 }' );
( $exitcode, $stdout, $stderr )
= $loop->run_process(
code => sub { 3 },
capture => $defaul_capture,
)->get;
ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after sub { 3 }' );
is( ($exitcode >> 8), 3, 'WEXITSTATUS($exitcode) after sub { 3 }' );
is( $stdout, "", '$stdout after sub { 3 }' );
is( $stderr, "", '$stderr after sub { 3 }' );
( $exitcode, $stdout, $stderr )
= $loop->run_process(
command => [ $^X, "-e", '1' ],
capture => $defaul_capture,
)->get;
ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after perl -e 1' );
is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after perl -e 1' );
is( $stdout, "", '$stdout after perl -e 1' );
is( $stderr, "", '$stderr after perl -e 1' );
( $exitcode, $stdout, $stderr )
= $loop->run_process(
command => [ $^X, "-e", 'exit 5' ],
capture => $defaul_capture,
)->get;
ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after perl -e exit 5' );
is( ($exitcode >> 8), 5, 'WEXITSTATUS($exitcode) after perl -e exit 5' );
is( $stdout, "", '$stdout after perl -e exit 5' );
is( $stderr, "", '$stderr after perl -e exit 5' );
( $exitcode, $stdout, $stderr )
= $loop->run_process(
code => sub { print "hello\n"; 0 },
capture => $defaul_capture,
)->get;
ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after sub { print }' );
is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after sub { print }' );
is( $stdout, "hello\n", '$stdout after sub { print }' );
is( $stderr, "", '$stderr after sub { print }' );
( $exitcode, $stdout, $stderr )
= $loop->run_process(
command => [ $^X, "-e", 'print "goodbye\n"' ],
capture => $defaul_capture,
)->get;
ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after perl STDOUT' );
is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after perl STDOUT' );
is( $stdout, "goodbye\n", '$stdout after perl STDOUT' );
is( $stderr, "", '$stderr after perl STDOUT' );
( $exitcode, $stdout, $stderr )
= $loop->run_process(
command => [ $^X, "-e", 'print STDOUT "output\n"; print STDERR "error\n";' ],
capture => $defaul_capture,
)->get;
ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after perl STDOUT/STDERR' );
is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after perl STDOUT/STDERR' );
is( $stdout, "output\n", '$stdout after perl STDOUT/STDERR' );
is( $stderr, "error\n", '$stderr after perl STDOUT/STDERR' );
# perl -pe 1 behaves like cat; copies STDIN to STDOUT
( $exitcode, $stdout, $stderr )
= $loop->run_process(
command => [ $^X, "-pe", '1' ],
stdin => "some data\n",
capture => $defaul_capture,
)->get;
ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after perl STDIN->STDOUT' );
is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after perl STDIN->STDOUT' );
is( $stdout, "some data\n", '$stdout after perl STDIN->STDOUT' );
is( $stderr, "", '$stderr after perl STDIN->STDOUT' );
# Testing what the future will return by default
my ( $future, $proc_id, $pid );
$future = $loop->run_process(
command => [ $^X, "-e", 'print STDOUT "output"; print STDERR "error";' ],
);
( $exitcode, $stdout ) = $future->get;
ok( ($exitcode & 0x7f) == 0, 'Exit code is correct with default captures' );
is( ($exitcode >> 8), 0, 'Exit code is correct with default captures' );
is( $stdout, "output", 'STDOUT is correct with default captures' );
# Testing what the future will return with additional captures
( $future, $proc_id )
= $loop->run_process(
command => [ $^X, "-e", 'print STDOUT "output"; print STDERR "error";' ],
capture => [qw(pid exitcode stdout stderr)],
);
( $pid, $exitcode, $stdout, $stderr ) = $future->get;
is( $proc_id, $pid, 'PID is correct with default captures' );
ok( ($exitcode & 0x7f) == 0, 'Exit code is correct with custom captures' );
is( ($exitcode >> 8), 0, 'Exit code is correct with custom captures' );
is( $stdout, "output", 'STDOUT is correct with custom captures' );
is( $stderr, "error", 'STDERR is correct with custom captures' );
ok( exception { $loop->run_process(
command => [ $^X, "-e", 1 ],
some_key_you_fail => 1
) },
'unrecognised key fails'
);
# Testing what the future will return with additional captures in reverse order
( $future, $proc_id )
= $loop->run_process(
command => [ $^X, "-e", 'print STDOUT "output"; print STDERR "error";' ],
capture => [qw(stderr stdout exitcode pid)],
);
( $stderr, $stdout, $exitcode, $pid ) = $future->get;
is( $proc_id, $pid, 'PID is correct with reversed captures' );
ok( ($exitcode & 0x7f) == 0, 'Exit code is correct with reversed captures' );
is( ($exitcode >> 8), 0, 'Exit code is correct with reversed captures' );
is( $stdout, "output", 'STDOUT is correct with reversed captures' );
is( $stderr, "error", 'STDERR is correct with reversed captures' );
# Testing error handling
ok( exception { $loop->run_process(
command => [ $^X, "-e", 1 ],
some_key_you_fail => 1
) },
'unrecognised key fails'
);
ok( exception { $loop->run_process(
command => [ $^X, "-e", 1 ],
capture => 'pid'
) },
'Capture in invapid format'
);
ok( exception { $loop->run_process(
command => [ $^X, "-e", 1 ],
capture => ['invalid_capture']
) },
'Invalid capture type'
);
ok( exception { $loop->run_process(
command => [ $^X, "-e", 1 ],
on_finish => sub{ 0 }
) },
'Failing when finish callback is passed'
);
done_testing;
1283a1284,1349
>
> =head2 run_process
>
> $future = $loop->run_process( %params )
>
> This creates a new child process to run the given code block or command,
> capturing its STDOUT and STDERR streams. The method returns in scalar context
> future or in list context - future and pid of the child proccess. When the process
> exits, the future will be resolved. The Future will return C<exitcode> and
> captured C<stdout> by default.
>
> The method is a wrapper around run_child. It can accept the same parameters as
> run_child, except C<on_finish>.
>
> =over 8
>
> =item capture => ARRAY
> Optional, the list of value's names which should be returned by resolving future.
> Values will be returned in the same order as you put them in the array.
> It can contain next values: C<pid>, C<exitcode>, C<stdout>, C<stderr>
>
> =back
>
> This method is just a shortcut for run_child method.
>
>
> my ($future, $pid) = $loop->run_process(command => "command here");
>
> my ($exitcode, $stdout) = $future->get;
>
> Z<>
>
> my ($exitcode, $stdout) = $loop->run_process(command => "command here")->get();
>
> =cut
>
> my @process_captures = qw(pid exitcode stdout stderr);
>
> sub run_process
> {
> my $self = shift;
> my %params = @_;
>
> $params{on_finish} and croak "Unrecognised parameter on_finish";
>
> my $capture = delete $params{capture} // [qw(exitcode stdout)];
> ref $capture eq ref [] or croak "Expected 'capture' to be an array reference";
>
> for my $name ( @$capture ) {
> grep { $_ eq $name } @process_captures or croak "Unexpected capture $name";
> }
>
> my $future = $self->new_future;
> my $pid = $self->run_child(
> %params,
> on_finish => sub {
> my %results;
> @results{ @process_captures } = @_;
>
> $future->done( @results{ @$capture } );
> },
> );
>
> return wantarray ? ( $future, $pid ) : $future;
> }
>
