File Coverage

blib/lib/IPC/Exe.pm

Criterion	Covered	Total	%
statement	241	362	66.5
branch	148	306	48.3
condition	55	141	39.0
subroutine	27	29	93.1
pod	2	2	100.0
total	473	840	56.3

package IPC::Exe;

use 5.008_008;

use warnings;
use strict;

BEGIN {
    require Exporter;
    *import = \&Exporter::import;

    our $VERSION   = "2.002001";
    our @EXPORT_OK = qw(exe bg);
}

use Carp qw(carp croak);
use Data::Dumper qw(Dumper);
use File::Spec ();
use Scalar::Util qw(tainted);
use Symbol qw(gensym);
use Time::HiRes qw(usleep);

++$Carp::Internal{$_} for __PACKAGE__;

use constant NON_UNIX => ($^O =~ /^(?:MSWin32|os2)$/);
use constant OPEN_RDWR_RX => qr/^\s*(\d*)\s*(\+?[<>].*)/;

# default environment variables to check for taint
our @TAINT_ENV = qw(PATH PATHEXT IFS CDPATH ENV BASH_ENV PERL5SHELL);

our $is_forked = 0;

# if set, fallback to forked child/parent process to ensure execution
our $bg_fallback = 0;

my $DEVNULL = File::Spec->devnull();

sub _reftype { Scalar::Util::reftype($_[0]) || "" }
sub _is_fh { eval { defined(fileno($_[0])) } }

sub _stringify_args {
    local $Data::Dumper::Indent = 0;
    local $Data::Dumper::Useqq  = 1;
    local $Data::Dumper::Terse  = 1;
    return join(", " => map { Dumper($_) } @_);
}

# exit thread/process
sub _quit {
    my $status = shift || 0;
    $^E = 0;
    $! = $status == -1 ? 255 : $status;
    $? = $! << 8;
    threads->exit($status) if threads->can("exit");
    exit($status);
}

# escape LIST to be passed to exec() in a portable way
sub _escape_cmd_list {
    return NON_UNIX
      ? map {
            (my $x = $_)
              =~ s/(\\"|")/$1 eq '"' ? '\\"' : '\\\\\\"'/ge;

            $x =~ /[\[\](){}<>'"`~!@^&+=|;,\s]/
              ? qq("$x")
              : $x;
        } @_
      : @_;
}

sub _check_taint {
    my (@bad_args, @bad_env);

    my $i = -1;
    for my $v (@_)
    {
        ++$i;
        push(@bad_args, [ $v, $i ]) if tainted($v);
    }
    for my $v (@TAINT_ENV)
    {
        push(@bad_env, $v) if tainted($ENV{$v});
    }

    # die if environment / arguments are tainted
    if (@bad_args || @bad_env)
    {
        croak("IPC::Exe::exe() called with tainted vars:\n  ",
            join("\n  " => map { "\$ENV{$_}" } @bad_env), "\n  ",
            join("\n  " => map { "<$_->[0]> at index $_->[1]" } @bad_args), "\n",
        );
    }

    return;
}

sub _fh_slot {
    my ($slots, $n) = @_;
    $n += 0;

    my $FH_name = qw(STDIN STDOUT STDERR)[$n] || "FH[$n]";
    my $FH = ($n <= 2)
      ? (\*STDIN, \*STDOUT, \*STDERR)[$n]
      : ($slots->[$n] ||= gensym());

    return ($FH, $FH_name);
}

sub exe {
    _check_taint(@_) if $] >= 5.008 && ${^TAINT};

    return () if @_ == 0;

    # exe(sub { .. }) returns (sub { .. }) itself
    return $_[0] if @_ == 1 && _reftype($_[0]) eq "CODE";

    my $args = \@_;
    return sub { _exe(@_ ? [ @_ ] : undef, @{ $args }) };
}
sub _exe {
    # record error variables
    my @status = ($?, -+-$!, -+-$^E, $@);

    # ref to arguments passed to closure
    my $_args = shift;

    # merge options hash reference, if available
    my %opt = (
        pid        => undef,
        stdin      => 0,
        stdout     => 0,
        stderr     => 0,
        autoflush  => 1,
        binmode_io => undef,
    );
    my $opt_ref = $_[0];
    if (_reftype($opt_ref) eq "HASH")
    {
        @opt{keys %{ $opt_ref }} = values %{ $opt_ref };
        shift;
    }

    # propagate $opt{binmode_io} to set binmode down chain of executions
    local $IPC::Exe::_binmode_io = defined($opt{binmode_io})
      ? $opt{binmode_io}
      : $IPC::Exe::_binmode_io;

    # propagate $opt{stdin} down chain of executions
    local $IPC::Exe::_stdin = $IPC::Exe::_stdin || !(!$opt{stdin});

    # setup input filehandle to write to STDIN
    my ($FOR_STDIN, $TO_STDIN);
    if ($opt{stdin})
    {
        pipe($FOR_STDIN, $TO_STDIN)
          or carp("IPC::Exe::exe() cannot create pipe to STDIN", "\n  ", $!)
          and return ();

        # make filehandle hot
        select((select($TO_STDIN), $| = 1)[0]) if $opt{autoflush};
    }

    # setup output filehandle to read from STDERR
    my ($FROM_STDERR, $BY_STDERR);
    if ($opt{stderr})
    {
        pipe($FROM_STDERR, $BY_STDERR)
          or carp("IPC::Exe::exe() cannot create pipe from STDERR", "\n  ", $!)
          and return ();

        # make filehandle hot
        select((select($BY_STDERR), $| = 1)[0]) if $opt{autoflush};
    }

    # obtain CODE references, if available, for READER & PREEXEC subroutines
    my ($Preexec, $Reader);
    $Preexec = shift if _reftype($_[0])  eq "CODE";
    $Reader  =   pop if _reftype($_[-1]) eq "CODE";

    # obtain redirects
    my @redirs;
    unshift(@redirs, pop) while ref($_[-1]);
    if (@redirs)
    {
        my $old_preexec;
        $old_preexec = $Preexec if $Preexec;

        $Preexec = sub {
            my @FHops;
            @FHops = $old_preexec->(@_) if $old_preexec;
            return (@FHops, @redirs);
        };
    }

    # what is left is the command LIST
    my @cmd_list = @_;

    # ban undefined values in LIST
    if (grep { !defined($_) } @cmd_list)
    {
        carp("IPC::Exe::exe() cannot execute undef argument(s) below:", "\n  ",
          _stringify_args(@cmd_list), "\n");
        return ();
    }

    # as a precaution, do not continue if no PREEXEC or LIST found
    return () unless defined($Preexec) || @cmd_list;

    # duplicate stdin to be restored later
    my $ORIGSTDIN;
    NON_UNIX
      ? open($ORIGSTDIN, "<&=STDIN")
      : open($ORIGSTDIN, "<&STDIN")
      or carp("IPC::Exe::exe() cannot dup STDIN", "\n  ", $!)
      and return ();

    # safe pipe open to forked child connected to opened filehandle
    my $gotchild = _pipe_from_fork(my $EXE_READ, my $EXE_GO);
    my $defined_child = defined($gotchild);

    # check if fork was successful
    unless ($defined_child)
    {
        carp("IPC::Exe::exe() cannot fork child", "\n  ", $!);
        return ();
    }

    # parent reads stdout of child process
    if ($gotchild)
    {
        # unneeded stuff
        undef $_ for $Preexec, $_args, @redirs;
        close($FOR_STDIN) if $FOR_STDIN;
        close($BY_STDERR) if $BY_STDERR;

        # set binmode if required
        if (defined($IPC::Exe::_binmode_io)
           && index($IPC::Exe::_binmode_io, ":") == 0)
        {
            my $layer = $IPC::Exe::_binmode_io;

            if ($opt{stdin})
            {
                binmode($TO_STDIN, $layer) or croak(<<"EOT", "  ", $!);
IPC::Exe::exe() cannot set binmode STDIN_WRITEHANDLE for layer "$layer"
EOT
            }

            binmode($EXE_READ, $layer) or croak(<<"EOT", "  ", $!);
IPC::Exe::exe() cannot set binmode STDOUT_READHANDLE for layer "$layer"
EOT
        }

        my (@ret, @status_reader);

        if ($Reader)
        {
            # non-Unix: reset to default $IPC::Exe::_preexec_wait time
            local $IPC::Exe::_preexec_wait;

            # temporarily replace stdin
            $IPC::Exe::_stdin
              ? open(*STDIN, "<&=", $EXE_READ)
              : open(*STDIN, "<&",  $EXE_READ)
                  or croak("IPC::Exe::exe() cannot replace STDIN", "\n  ", $!);

            # create local package-scope $IPC::Exe::PIPE
            local our $PIPE = $EXE_READ;

            ($?, $!, $^E, my $err) = @status;

            my $failed = ! eval {
                $@ = $err;
                @ret = $Reader->($gotchild, @cmd_list);
                $err = $@;
                1;
            };

            @status_reader = ($?, -+-$!, -+-$^E, $failed ? $@ : $err);

            # restore stdin
            NON_UNIX
              ? open(*STDIN, "<&=", $ORIGSTDIN)
              : open(*STDIN, "<&",  $ORIGSTDIN)
              or croak("IPC::Exe::exe() cannot restore STDIN", "\n  ", $!);

            die $status_reader[3] if $failed;
        }
        elsif (!$opt{stdout})
        {
            # default &READER just prints stdin
            while (my $read = <$EXE_READ>)
            {
                print $read;
            }
        }

        # do not wait for interactive children
        my $reap = 0;
        unless ($IPC::Exe::_stdin || $opt{stdout} || $opt{stderr})
        {
            $reap = waitpid($gotchild, 0);
            $status[0] = $?;
        }

        #print STDERR "reap> $gotchild : $reap | $status[0]\n";

        # record status and close pipe for default &READER
        if (!$Reader && !$opt{stdout})
        {
            $ret[0] = $status[0];
            close($EXE_READ);
        }

        my $ret_pid = $gotchild;

        # reading from failed exec
        if ($status[0] == -1 || $status[0] == 255 << 8) # 255 (assumed as failed exec)
        {
            # must correctly reap before we decide to return undef PID
            # if using default &READER, additionally check if we reaped -1
            #   and return -1 since it looks like a failed exec

            $ret_pid = undef
              if (!$Reader && !$opt{stdout} # using default &READER
                && ($reap == $gotchild || $reap == -1 || $reap == 0)
                && ($ret[0] = -1)) # return -1
              || $reap == $gotchild;
        }

        # writing to failed exec
        if ($status[0] == -1 && $Reader && $reap == $gotchild && @ret)
        {
            # child PID is undef if exec failed
            $ret[0] = undef;
        }

        # assign scalar references if provided
        ${ $opt{pid} }    = $ret_pid     if _reftype($opt{pid})    eq "SCALAR";
        ${ $opt{stdin} }  = $TO_STDIN    if _reftype($opt{stdin})  eq "SCALAR";
        ${ $opt{stdout} } = $EXE_READ    if _reftype($opt{stdout}) eq "SCALAR";
        ${ $opt{stderr} } = $FROM_STDERR if _reftype($opt{stderr}) eq "SCALAR";

        # collect child PIDs & filehandle(s)
        unshift(@ret,
                            _reftype($opt{pid})    ne "SCALAR" ? $ret_pid     : (),
            $opt{stdin}  && _reftype($opt{stdin})  ne "SCALAR" ? $TO_STDIN    : (),
            $opt{stdout} && _reftype($opt{stdout}) ne "SCALAR" ? $EXE_READ    : (),
            $opt{stderr} && _reftype($opt{stderr}) ne "SCALAR" ? $FROM_STDERR : (),
        );

        # restore exit status
        ($?, $!, $^E, $@) = @status_reader ? @status_reader : @status;

        undef $Reader;

        return @ret[0 .. $#ret]; # return LIST instead of ARRAY
    }
    else # child performs exec()
    {
        # set package-scope $IPC::Exe::is_forked
        $is_forked = 1;

        # disassociate any ties with parent
        untie(*STDIN);
        untie(*STDOUT);
        untie(*STDERR);

        # unneeded stuff
        undef $Reader;
        close($TO_STDIN)    if $TO_STDIN;
        close($FROM_STDERR) if $FROM_STDERR;

        # change STDIN if input filehandle was required
        if ($FOR_STDIN)
        {
            open(*STDIN, "<&=", $FOR_STDIN)
              or croak("IPC::Exe::exe() cannot change STDIN", "\n  ", $!);
        }

        # collect STDERR if error filehandle was required
        if ($BY_STDERR)
        {
            open(*STDERR, ">&=", $BY_STDERR)
              or croak("IPC::Exe::exe() cannot collect STDERR", "\n  ", $!);
        }

        # set binmode if required
        if (defined($IPC::Exe::_binmode_io)
           && index($IPC::Exe::_binmode_io, ":") == 0)
        {
            my $layer = $IPC::Exe::_binmode_io;

            binmode(*STDIN, $layer) and binmode(*STDOUT, $layer)
              or croak(<<"EOT", "  ", $!);
IPC::Exe::exe() cannot set binmode STDIN and STDOUT for layer "$layer"
EOT
        }

        # call PREEXEC subroutine if defined
        my @FHops;
        if ($Preexec)
        {
            local ($?, $!, $^E, $@) = @status;
            @FHops = $Preexec->($_args ? @{ $_args } : ());
            undef $_ for $Preexec, $_args, @redirs;
        }

        # manually flush STDERR and STDOUT
        select((select(*STDERR), $| = ($|++, print "")[0])[0]) if _is_fh(*STDERR);
        select((select(*STDOUT), $| = ($|++, print "")[0])[0]) if _is_fh(*STDOUT);

        # only exec() LIST if defined
        unless (@cmd_list)
        {
            # non-Unix: signal parent "process" to restore filehandles
            if (NON_UNIX && _is_fh($EXE_GO))
            {
                print $EXE_GO "exe_no_exec\n";
                close($EXE_GO);
            }

            _quit(0);
        }

        # perform redirections
        my @FHs;
        for (@FHops)
        {
            if (ref($_))
            {
                my $is_sysopen = 0;

                if (_reftype($_) =~ /REF|SCALAR/)
                {
                    $_ = ${ $_ };
                    ++$is_sysopen;
                }

                # open / sysopen
                if (_reftype($_) eq "ARRAY")
                {
                    my @args = @{ $_ };
                    my $FH_name;

                    if (!$is_sysopen && defined($args[0]))
                    {
                        my ($src, $op) = ($args[0] =~ OPEN_RDWR_RX);

                        if (defined($op))
                        {
                            $src = (index($op, "<") == -1) ? 1 : 0
                              if $src eq "";

                            (my $FH, $FH_name) = _fh_slot(\@FHs, $src);
                            shift @args;
                            unshift @args, ($FH, $op);
                        }
                    }

                    my $error_msg =
                      "IPC::Exe::exe() failed "
                      . ($is_sysopen ? "sysopen" : "open") . "( "
                      . ($FH_name ? "$FH_name, " : "")
                      . _stringify_args(
                          $FH_name ? () : $args[0],
                          @args[1 .. $#args],
                      ) . " )";

                    croak($error_msg, "\n  ", $! = 22)
                      if $is_sysopen
                        ? (@args < 3 || @args > 4)
                        : (@args == 0);

                    $is_sysopen
                      ? (@args == 4
                          ? sysopen($args[0], $args[1], $args[2], $args[3])
                          : sysopen($args[0], $args[1], $args[2])
                        )
                      : open(
                            $args[0],
                            @args >= 2 ? $args[1] : (),
                            @args >= 3 ? $args[2] : (),
                            @args[3 .. $#args],
                        )
                          or croak($error_msg, "\n  ", $!);

                    next;
                }
            }

            next unless defined($_);

            # set binmode
            if (/^\s*([012])\s*(:.*)$/)
            {
                my $FH_name = qw(STDIN STDOUT STDERR)[$1];
                my $layer = $2;
                $layer = ":raw" if $layer eq ":";

                binmode((*STDIN, *STDOUT, *STDERR)[$1], $layer)
                  or croak(<<"EOT", "  ", $!);
IPC::Exe::exe() cannot set binmode $FH_name for layer "$layer"
EOT
                next;
            }

            # silence filehandles
            if (/^\s*(\d*)\s*>\s*(?:null|#)\s*$/)
            {
                my $src = ($1 eq "") ? 1 : $1;
                my ($FH, $FH_name) = _fh_slot(\@FHs, $src);

                open($FH, ">", $DEVNULL)
                  or croak(<<"EOT", "  ", $!);
IPC::Exe::exe() cannot silence $FH_name (does $DEVNULL exist?)
EOT
                next;
            }

            # swap filehandles
            if (/^\s*(\d+)\s*><\s*(\d+)\s*$/)
            {
                my ($FH1, $FH_name1) = _fh_slot(\@FHs, $1);
                my ($FH2, $FH_name2) = _fh_slot(\@FHs, $2);

                my $SWAP;
                local $! = 9;
                _is_fh($FH1) && _is_fh($FH2)
                  && open($SWAP, ">&", $FH1)
                  && open($FH1, ">&", $FH2)
                  && open($FH2, ">&=", $SWAP)
                  or croak(<<"EOT", "  ", $!);
IPC::Exe::exe() cannot swap $FH_name1 and $FH_name2
EOT
                next;
            }

            # redirect/close filehandles
            my ($src, $op, $tgt) =
              /^\s*(\d*)\s*(\+?(?:<|>>?)&=?)\s*(\d+|-)\s*$/;

            if (defined($op))
            {
                $src = (index($op, "<") == -1) ? 1 : 0
                  if $src eq "";

                my ($FH1, $FH_name1) = _fh_slot(\@FHs, $src);

                if ($tgt eq "-")
                {
                    close($FH1) or croak(<<"EOT", "  ", $!);
IPC::Exe::exe() failed to close $FH_name1
EOT
                    next;
                }

                my ($FH2, $FH_name2) = _fh_slot(\@FHs, $tgt);

                local $! = 9;
                _is_fh($FH2) && open($FH1, $op, $FH2)
                  or croak(<<"EOT", "  ", $!);
IPC::Exe::exe() failed redirect $FH_name1 $op $FH_name2
EOT
                next;
            }

            if ($_ =~ OPEN_RDWR_RX)
            {
                $_ = [ $_ ];
                redo;
            }
        }

        # non-Unix: escape command so that it feels Unix-like
        my @cmd = _escape_cmd_list(@cmd_list);

        # non-Unix: signal parent "process" to restore filehandles
        my $restore_fh = (NON_UNIX && _is_fh($EXE_GO));

        no warnings qw(exec);
        # XXX: be quiet about "Attempt to free unreferenced scalar" for Win32
        no warnings qw(internal);

        # assume exit status 255 indicates failed exec
        ($restore_fh ? print $EXE_GO "exe_with_exec\n" : 1)
          and exec { $cmd[0] } @cmd
          or carp("IPC::Exe::exe() failed to exec the command below", " - ", $!, "\n  ",
               _stringify_args(@cmd), "\n")
          and _quit(-1);
    }
}

sub bg {
    return () if @_ == 0;

    my $args = \@_;
    return sub { _bg(@_ ? [ @_ ] : undef, @{ $args }) };
}
sub _bg {
    # record error variables
    my @status = ($?, -+-$!, -+-$^E, $@);
    local ($?, $!, $^E, $@);

    # ref to arguments passed to closure
    my $_args = shift;

    # merge options hash reference, if available
    my %opt = (
        wait => 2,
    );
    my $opt_ref = $_[0];
    if (_reftype($opt_ref) eq "HASH")
    {
        @opt{keys %{ $opt_ref }} = values %{ $opt_ref };
        shift;
    }

    # CODE reference for BACKGROUND subroutine
    my $Background;
    $Background = shift if _reftype($_[0]) eq "CODE";

    # do not continue if no BACKGROUND found
    return () unless defined($Background);

    # non-Unix: set longer $IPC::Exe::_preexec_wait time
    local $IPC::Exe::_preexec_wait = 2;
    if (defined($opt{wait}) && $opt{wait} >= 0)
    {
        $IPC::Exe::_preexec_wait = $opt{wait};
    }

    # dup(2) stdout
    my $ORIGSTDOUT;
    open($ORIGSTDOUT, ">&STDOUT")
      or carp("IPC::Exe::bg() cannot dup STDOUT", "\n  ", $!)
      and return ();

    # double fork -- immediately wait() for child,
    #       and init daemon will wait() for grandchild, once child exits

    # safe pipe open to forked child connected to opened filehandle
    my $gotchild = _pipe_from_fork(my $BG_READ, my $BG_GO1);
    my $defined_child = defined($gotchild);

    # check if fork was successful
    unless ($defined_child)
    {
        if ($bg_fallback)
        {
            carp("IPC::Exe::bg() cannot fork child, will try fork again", "\n  ", $!);
        }
        else
        {
            carp("IPC::Exe::bg() cannot fork child", "\n  ", $!) and return ();
        }
    }

    # parent reads stdout of child process
    if ($gotchild)
    {
        # background: parent reads output from child,
        #                and waits for child to exit
        my $grandpid = readline($BG_READ);
        waitpid($gotchild, 0);
        my $status = $?;
        close($BG_READ);
        return $status ? $gotchild : -+-$grandpid;
    }
    else
    {
        # background: perform second fork
        my $gotgrand = NON_UNIX
          ? _pipe_from_fork(my $DUMMY, my $BG_GO2)
          : fork();
        my $defined_grand = defined($gotgrand);

        # check if second fork was successful
        if ($defined_child)
        {
            $defined_grand or carp(<<"EOT", "  ", $!);
IPC::Exe::bg() cannot fork grandchild, using child instead
 -> parent must wait
EOT
        }
        else
        {
            if ($defined_grand)
            {
                $gotgrand and carp(<<"EOT", "  ", $!);
IPC::Exe::bg() managed to fork child, using child now
 -> parent must wait
EOT
            }
            else
            {
                carp(<<"EOT", "  ", $!);
IPC::Exe::bg() cannot fork child again, using parent instead
 -> parent does all the work
EOT
            }
        }

        # send grand/child's PID to parent process somehow
        my $childpid;
        if ($defined_grand && $gotgrand)
        {
            if ($defined_child)
            {
                # child writes grandchild's PID to parent process
                print { *STDOUT } "$gotgrand\n";
            }
            else
            {
                # parent returns child's PID later
                $childpid = $gotgrand;
            }
        }

        # child exits once grandchild is forked
        # grandchild calls BACKGROUND subroutine
        unless ($gotgrand)
        {
            # set package-scope $IPC::Exe::is_forked
            $is_forked = 1;

            # disassociate any ties with parent
            untie(*STDIN);
            untie(*STDOUT);
            untie(*STDERR);

            # restore stdout
            open(*STDOUT, ">&=", $ORIGSTDOUT)
              or croak("IPC::Exe::bg() cannot restore STDOUT", "\n  ", $!);

            # non-Unix: signal parent/child "process" to restore filehandles
            if (NON_UNIX)
            {
                if (_is_fh($BG_GO2))
                {
                    print $BG_GO2 "bg2\n";
                    close($BG_GO2);
                }

                if (_is_fh($BG_GO1))
                {
                    print $BG_GO1 "bg1\n";
                    close($BG_GO1);
                }
            }

            # BACKGROUND subroutine does not need to return
            ($?, $!, $^E, $@) = @status;
            $Background->($_args ? @{ $_args } : ());
            undef $_ for $Background, $_args;
        }
        elsif (!$defined_child)
        {
            # parent must wait to reap child
            waitpid($gotgrand, 0);
        }

        #  $gotchild  $gotgrand    exit
        #  ---------  ---------    ----
        #   childpid   grandpid    both child & grandchild
        #   childpid    undef      child
        #    undef     childpid    child
        #    undef      undef      none (parent executes BACKGROUND subroutine)
        _quit(0)  if  $defined_child &&  $defined_grand;
        _quit(10) if  $defined_child && !$defined_grand;
        _quit(10) if !$defined_child &&  $defined_grand && !$gotgrand;

        # falls back here if forks were unsuccessful
        return $childpid;
    }
}

# child writes while parent reads
# simulate open(FILEHANDLE, "-|");
# http://perldoc.perl.org/perlfork.html#CAVEATS-AND-LIMITATIONS
sub _pipe_from_fork ($$) {
    my $pid;

    # cannot fork on these platforms
    return undef if $^O =~ /^(?:VMS|dos|MacOS|riscos|amigaos|vmesa)$/;

    if (NON_UNIX)
    {
        # dup(2) stdin/stdout/stderr to be restored later
        my ($ORIGSTDIN, $ORIGSTDOUT, $ORIGSTDERR);

        open($ORIGSTDIN,  "<&STDIN")
          or carp("IPC::Exe cannot dup STDIN",  "\n  ", $!)
          and return undef;

        open($ORIGSTDOUT, ">&STDOUT")
          or carp("IPC::Exe cannot dup STDOUT", "\n  ", $!)
          and return undef;

        open($ORIGSTDERR, ">&STDERR")
          or carp("IPC::Exe cannot dup STDERR", "\n  ", $!)
          and return undef;

        # create pipe for READHANDLE and WRITEHANDLE
        pipe($_[0], my $WRITE) or return undef;

        # create pipe for READYHANDLE and GOHANDLE
        pipe(my $READY, $_[1]) or return undef;
        select((select($_[1]), $| = 1)[0]);

        # fork is emulated with threads on Win32
        if (defined($pid = fork()))
        {
            if ($pid)
            {
                close($WRITE);
                close($_[1]);

                # block until signalled to GO!
                #print STDERR "go> " . readline($READY);
                readline($READY);
                close($READY);

                # restore filehandles after slight delay to allow exec to happen
                my $wait = 0; # default
                $wait = $IPC::Exe::_preexec_wait
                    if defined($IPC::Exe::_preexec_wait);

                usleep($wait * 1e6);
                #print STDERR "wait> $wait\n";

                open(*STDIN,  "<&=", $ORIGSTDIN)
                  or croak("IPC::Exe cannot restore STDIN",  "\n  ", $!);

                open(*STDOUT, ">&=", $ORIGSTDOUT)
                  or croak("IPC::Exe cannot restore STDOUT", "\n  ", $!);

                open(*STDERR, ">&=", $ORIGSTDERR)
                  or croak("IPC::Exe cannot restore STDERR", "\n  ", $!);
            }
            else
            {
                close($_[0]);
                close($READY);

                # file descriptors are not "process"-persistent on Win32
                open(*STDOUT, ">&=", $WRITE)
                  or croak("IPC::Exe cannot establish IPC after fork", "\n  ", $!);
            }
        }
    }
    else
    {
        # need this form to allow close($_[0]) to set $? properly
        $pid = open($_[0], "-|");
    }

    return $pid;
}

'IPC::Exe';


__END__