view release on metacpan or  search on metacpan

lib/AnyEvent/Run.pm  view on Meta::CPAN

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