IPC::Open3 を使って、子プロセスの標準出力と標準エラー出力をポーリングする。(Windows でも動くよ!)

先日の
IPC::Open3 を使って、子プロセスの標準出力と標準エラー出力をポーリングする。(Windows では動かなかった…) - ◆F99a.q8oVEの日記
は Windows では動きませんでした。

Windows のルートでは

# $dad_wtr は open3 の第2引数
#   open3(undef, '>&'. fileno($child_out), '>&' . fileno($child_err), @cmd)
#   を実行したとすると '>&'. fileno($child_out)
$dad_wtr =~ s/^[<>]&//
$kid_rdr = \*{$dad_wtr};

されたものが fdopen に渡されています。
ここで、上の例のように fd を渡してもうまくいきませんでした。

そこで、

open3(undef, '>&'. $child_out, '>&' . $child_err, @cmd);

こうして見てもうまくいかないので…

色々試して↓ならうまくいきました。"*" できるもの、つまりグロブを指定しないといけないということかな?

open3(undef, '>&CHILD_OUT', '>&CHILD_ERR', @cmd);

ということで、完成版。

qx2 は Windows 以外、qx2_win は Windows 用。Windows では WIFEXITED が定義されていないと思うので、適宜あれしてください。

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

sub qx2_win {
    my @cmd = @_;

    use IPC::Open3;
    use File::Temp qw/tmpnam/;

    my $out_file = tmpnam();
    my $err_file = tmpnam();
    local (*CHILD_OUT, *CHILD_ERR);
    open CHILD_OUT, '+>', $out_file or die $!;
    open CHILD_ERR, '+>', $err_file or die $!;
    my $pid = open3(undef, '>&CHILD_OUT', '>&CHILD_ERR', @cmd);
    waitpid $pid, 0;

    # my $code = WIFEXITED($?) ? WEXITSTATUS($?) : WTERMSIG($?);
    my $code = ($? | 0xFF) ? ($? >> 8) & 0xFF : $?;

    seek CHILD_OUT, 0, 0;
    seek CHILD_ERR, 0, 0;
    my $out = do { local $/; <CHILD_OUT>; };
    my $err = do { local $/; <CHILD_ERR>; };
    close CHILD_OUT;
    close CHILD_ERR;
    unlink $out_file, $err_file;

    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 STDERR 'b' x (1024 ** 2); sleep 3; print 'a' x (1024 ** 2)} ], out => 'a' x (1024 ** 2), err => 'b' x (1024 ** 2), code => 0 },
);


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

done_testing;