File Coverage

blib/lib/AnyEvent/Run.pm

Criterion	Covered	Total	%
statement	71	90	78.8
branch	19	36	52.7
condition	8	10	80.0
subroutine	10	11	90.9
pod	1	1	100.0
total	109	148	73.6

package AnyEvent::Run;

use strict;
use base 'AnyEvent::Handle';

use AnyEvent ();
use AnyEvent::Util ();
use Carp;
use POSIX ();

our $VERSION = 0.01;

our $FD_MAX = eval { POSIX::sysconf(&POSIX::_SC_OPEN_MAX) - 1 } || 1023;

BEGIN {
    if ( AnyEvent::WIN32 ) {
        eval { require Win32 };
        die "Win32 failed to load:\n$@" if $@;

        eval { require Win32::Console };
        die "Win32::Console failed to load:\n$@" if $@;
        Win32::Console->import();

        eval { require Win32API::File };
        die "Win32API::File failed to load:\n$@" if $@;
        Win32API::File->import('FdGetOsFHandle');

        eval { require Win32::Job };
        die "Win32::Job failed to load:\n$@" if $@;
    }
};

sub new {
    my ( $class, %args ) = @_;

    my $cls = $args{class};
    my $cmd = $args{cmd};

    unless ( $cls || $cmd ) {
        croak "mandatory argument cmd or class is missing";
    }

    if ( $cls ) {
        my $method = $args{method} || 'main';
        # double quotes around -e needed on Windows for some reason
        $cmd = "$^X -M$cls -I" . join( ' -I', @INC ) . " -e \"${cls}::${method}()\"";
    }

    $args{args} ||= [];

    my ($parent, $child) = AnyEvent::Util::portable_socketpair
        or croak "unable to create AnyEvent::Run socketpair: $!";

    $args{fh} = $child;

    my $self = $class->SUPER::new(%args);

    my $pid = fork;

    if ( $pid == 0 ) {
        # child

        close $child;

        # Stdio should not be tied.
        if (tied *STDOUT) {
            carp "Cannot redirect into tied STDOUT.  Untying it";
            untie *STDOUT;
        }
        if (tied *STDERR) {
            carp "Cannot redirect into tied STDERR.  Untying it";
            untie *STDERR;
        }

        # Set priority if requested
        if ( $args{priority} && $args{priority} =~ /^-?\d+$/ ) {
            $self->_set_priority();
        }

        # Redirect STDIN from the read end of the stdin pipe.
        close STDIN if AnyEvent::WIN32;
        open STDIN, "<&" . fileno($parent)
            or croak "can't redirect STDIN in child pid $$: $!";

        # Redirect STDOUT
        close STDOUT if AnyEvent::WIN32;
        open STDOUT, ">&" . fileno($parent)
            or croak "can't redirect stdout in child pid $$: $!";

        # Redirect STDERR
        close STDERR if AnyEvent::WIN32;
        open STDERR, ">&" . fileno($parent)
            or die "can't redirect stderr in child: $!";

        # Make STDOUT and STDERR auto-flush.
        select STDERR; $| = 1;
        select STDOUT; $| = 1;

        if ( AnyEvent::WIN32 )  {
            # The Win32 pseudo fork sets up the std handles in the child
            # based on the true win32 handles For the exec these get
            # remembered, so manipulation of STDIN/OUT/ERR is not enough.
            # Only necessary for the exec, as Perl CODE subroutine goes
            # through 0/1/2 which are correct.  But of course that coderef
            # might invoke exec, so better do it regardless.
            # HACK: Using Win32::Console as nothing else exposes SetStdHandle
            Win32::Console::_SetStdHandle(
                STD_INPUT_HANDLE(),
                FdGetOsFHandle(fileno($parent))
            );
            Win32::Console::_SetStdHandle(
                STD_OUTPUT_HANDLE(),
                FdGetOsFHandle(fileno($parent))
            );
            Win32::Console::_SetStdHandle(
                STD_ERROR_HANDLE(),
                FdGetOsFHandle(fileno($parent))
            );
        }

        if ( ref $cmd eq 'CODE' ) {
            unless ( AnyEvent::WIN32 ) {
                my @fd_keep = (
                    fileno(STDIN),
                    fileno(STDOUT),
                    fileno(STDERR),
                    fileno($parent),
                );

                for my $fd ( 0..$FD_MAX ) {
                    next if grep { $_ == $fd } @fd_keep;
                    POSIX::close($fd);
                }
            }

            $cmd->( @{$args{args}} );

            close $parent;

            if ( AnyEvent::WIN32 ) {
                sleep 10; # give parent a chance to kill us
                exit 1;
            }
            else {
                POSIX::_exit(0);
            }
        }

        if ( AnyEvent::WIN32 ) {
            my $exitcode = 0;

            # XXX: should close open fd's, but it doesn't seem to work right on win32

            my ($appname, $cmdline);

            if ( ref $cmd eq 'ARRAY' ) {
                $appname = $cmd->[0];
                $cmdline = join(' ', map { /\s/ && ! /"/ ? qq{"$_"} : $_ } (@{$cmd}, @{$args{args}}) );
            }
            else {
                $appname = undef;
                $cmdline = join(' ', $cmd, map { /\s/ && ! /"/ ? qq{"$_"} : $_ } @{$args{args}} );
            }

            my $w32job;

            unless ( $w32job = Win32::Job->new() ) {
                die Win32::FormatMessage( Win32::GetLastError() );
            }

            my $w32pid;

            unless ( $w32pid = $w32job->spawn( $appname, $cmdline ) ) {
                die Win32::FormatMessage( Win32::GetLastError() );
            }
            else {
                my $ok = $w32job->watch( sub { 0 }, 60 );
                my $hashref = $w32job->status();
                $exitcode = $hashref->{$w32pid}->{exitcode};
            }

            close $parent;

            sleep 10; # give parent a chance to kill us
            exit($exitcode);
        }

        if ( ref $cmd eq 'ARRAY' ) {
            exec( @{$cmd}, @{$args{args}} )
                or die "can't exec (" . @{$cmd} . ") in child pid $$: $!";
        }
        else {
            exec( join(" ", $cmd, @{$args{args}} ) )
                or die "can't exec ($cmd) in child pid $$: $!";
        }

        # end of child
    }

    # parent
    close $parent;

    $self->{child_pid} = $pid;

    return $self;
}

sub _set_priority {
    my $self = shift;

    my $pri = $self->{priority};

    if ( AnyEvent::WIN32 ) {
        eval { require Win32::API };
        die "Win32::API failed to load:\n$@" if $@;

        eval { require Win32::Process };
        die "Win32::Process failed to load:\n$@" if $@;

        # ABOVE_NORMAL_PRIORITY_CLASS and BELOW_NORMAL_PRIORITY_CLASS aren't
        # provided by Win32::Process so their values have been hardcoded.
        $pri = $pri <= -16 ? Win32::Process::HIGH_PRIORITY_CLASS()
             : $pri <= -6  ? 0x00008000 # ABOVE_NORMAL
             : $pri <= 4   ? Win32::Process::NORMAL_PRIORITY_CLASS()
             : $pri <= 14  ? 0x00004000 # BELOW_NORMAL
             :               Win32::Process::IDLE_PRIORITY_CLASS();

        my $getCurrentProcess = Win32::API->new('kernel32', 'GetCurrentProcess', ['V'], 'N');
        my $setPriorityClass  = Win32::API->new('kernel32', 'SetPriorityClass',  ['N', 'N'], 'N');

        my $processHandle = eval { $getCurrentProcess->Call(0) };

        if ( !$processHandle || $@ ) {
            carp "Can't get process handle ($^E) [$@]";
            return;
        }

        eval { $setPriorityClass->Call($processHandle, $pri) };

        if ( $@ ) {
            carp "Couldn't set priority to $pri ($^E) [$@]";
        }
    }
    else {
        eval {
            unless ( setpriority( 0, $$, $pri ) ) {
                die "unable to set child priority to $pri\n";
            }
        };
        carp $@ if $@;
    }
}

sub DESTROY {
    my $self = shift;

    # XXX: doesn't play nice with linger option, so clear wbuf
    $self->{wbuf} = '';

    $self->SUPER::DESTROY(@_);

    if ( $self->{child_pid} ) {
        kill 9 => $self->{child_pid};
        waitpid $self->{child_pid}, 0;
    }
}

1;
__END__