IPC::Open3 を使って、子プロセスの標準出力と標準エラー出力をポーリングする。(Windows では動かなかった…)

perl


Windowsでも動く続編を書いたので、そちらを参照ください。
IPC::Open3 を使って、子プロセスの標準出力と標準エラー出力をポーリングする。(Windows でも動くよ!) - ◆F99a.q8oVEの日記



とか言っていましたが、一時ファイルに吐かせる方法で書いてみました。

qx2_win が Windows 用、qx2 が Windows 以外(FD にたいして select が使えるプラットフォーム)用。 ただし、Windows 上で動かしてみていないので、実際に動くかどうかは不明。

#!/usr/bin/env perl
use strict;
use warnings;

sub qx2_win {
    my @cmd = @_;

    use IPC::Open3;
    use Symbol qw/gensym/;
    use POSIX ":sys_wait_h";
    use File::Temp qw/tempfile/;

    my $child_out = tempfile();
    my $child_err = tempfile();
    my $pid = open3(undef, '>&'. fileno($child_out), '>&' . fileno($child_err), @cmd);

    while (1) {
        if (waitpid($pid, WNOHANG) > 0) {
            last;
        }
    }

    my $code = WIFEXITED($?) ? WEXITSTATUS($?) : WTERMSIG($?);

    seek $child_out, 0, 0;
    seek $child_err, 0, 0;
    my $out = do { local $/; <$child_out>; };
    my $err = do { local $/; <$child_err>; };

    return ($out, $err, $code);
}

sub qx2 {
    my @cmd = @_;

    use IPC::Open3;
    use Symbol qw/gensym/;
    use IO::Select;
    use POSIX ":sys_wait_h";

    my ($child_out, $child_err) = (gensym, gensym);
    my $pid = open3(undef, $child_out, $child_err, @cmd);

    my $s = new IO::Select($child_out, $child_err);
    my $out = my $err = '';

    while (1) {
        while (my @ready = $s->can_read) {
            for my $fh (@ready) {
                if (sysread($fh, my $buf, 4096) > 0) {
                    if ($fh == $child_out) {
                        $out .= $buf;
                    } elsif ($fh == $child_err) {
                        $err .= $buf;
                    }
                } else {
                    $s->remove($fh);
                    close $fh;
                }
            }
        }

        if (waitpid($pid, WNOHANG) > 0) {
            last;
        }
    }

    my $code = WIFEXITED($?) ? WEXITSTATUS($?) : WTERMSIG($?);
    return ($out, $err, $code);
}

use Test::More;

my @tests = (
    { command => [ 'perl', '-e', q{print 'a'} ], out => 'a', err => '', code => 0 },
    { command => [ 'perl', '-e', q{exit 0} ], out => '', err => '', code => 0 },
    { command => [ 'perl', '-e', q{exit 1} ], out => '', err => '', code => 1 },
    { command => [ 'perl', '-e', q{exit 255} ], out => '', err => '', code => 255 },
    { command => [ 'perl', '-e', q{print 'a' x (1024 ** 2)} ], out => 'a' x (1024 ** 2), err => '', code => 0 },
    { command => [ 'perl', '-e', q{print STDERR 'a' x (1024 ** 2)} ], out => '', err => 'a' x (1024 ** 2), code => 0 },
    { command => [ 'perl', '-e', q{print 'a' x (1024 ** 2); print STDERR 'b' x (1024 ** 2)} ], out => 'a' x (1024 ** 2), err => 'b' x (1024 ** 2), code => 0 },
);


for my $test (@tests) {
    my ($out, $err, $code) = qx2(@{$test->{command}});
    is $out, $test->{out};
    is $err, $test->{err};
    is $code, $test->{code};
}

for my $test (@tests) {
    my ($out, $err, $code) = qx2_win(@{$test->{command}});
    is $out, $test->{out};
    is $err, $test->{err};
    is $code, $test->{code};
}

done_testing;