552 lines
16 KiB
Perl
552 lines
16 KiB
Perl
package IPC::Run::Win32IO;
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
IPC::Run::Win32IO - helper routines for IPC::Run on Win32 platforms.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use IPC::Run::Win32IO; # Exports all by default
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
IPC::Run needs to use sockets to redirect subprocess I/O so that the select()
|
|
loop will work on Win32. This seems to only work on WinNT and Win2K at this
|
|
time, not sure if it will ever work on Win95 or Win98. If you have experience
|
|
in this area, please contact me at barries@slaysys.com, thanks!.
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
A specialized IO class used on Win32.
|
|
|
|
=cut
|
|
|
|
use strict;
|
|
use Carp;
|
|
use IO::Handle;
|
|
use Socket;
|
|
require POSIX;
|
|
|
|
use vars qw{$VERSION};
|
|
|
|
BEGIN {
|
|
$VERSION = '20200505.0';
|
|
}
|
|
|
|
use Socket qw( IPPROTO_TCP TCP_NODELAY );
|
|
use Symbol;
|
|
use Text::ParseWords;
|
|
use Win32::Process;
|
|
use IPC::Run::Debug qw( :default _debugging_level );
|
|
use IPC::Run::Win32Helper qw( _inherit _dont_inherit );
|
|
use Fcntl qw( O_TEXT O_RDONLY );
|
|
|
|
use base qw( IPC::Run::IO );
|
|
my @cleanup_fields;
|
|
|
|
BEGIN {
|
|
## These fields will be set to undef in _cleanup to close
|
|
## the handles.
|
|
@cleanup_fields = (
|
|
'SEND_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()
|
|
'RECV_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()
|
|
'TEMP_FILE_NAME', ## The name of the temp file, needed for
|
|
## error reporting / debugging only.
|
|
|
|
'PARENT_HANDLE', ## The handle of the socket for the parent
|
|
'PUMP_SOCKET_HANDLE', ## The socket handle for the pump
|
|
'PUMP_PIPE_HANDLE', ## The anon pipe handle for the pump
|
|
'CHILD_HANDLE', ## The anon pipe handle for the child
|
|
|
|
'TEMP_FILE_HANDLE', ## The Win32 filehandle for the temp file
|
|
);
|
|
}
|
|
|
|
## REMOVE OSFHandleOpen
|
|
use Win32API::File qw(
|
|
GetOsFHandle
|
|
OsFHandleOpenFd
|
|
OsFHandleOpen
|
|
FdGetOsFHandle
|
|
SetHandleInformation
|
|
SetFilePointer
|
|
HANDLE_FLAG_INHERIT
|
|
INVALID_HANDLE_VALUE
|
|
|
|
createFile
|
|
WriteFile
|
|
ReadFile
|
|
CloseHandle
|
|
|
|
FILE_ATTRIBUTE_TEMPORARY
|
|
FILE_FLAG_DELETE_ON_CLOSE
|
|
FILE_FLAG_WRITE_THROUGH
|
|
|
|
FILE_BEGIN
|
|
);
|
|
|
|
# FILE_ATTRIBUTE_HIDDEN
|
|
# FILE_ATTRIBUTE_SYSTEM
|
|
|
|
BEGIN {
|
|
## Force AUTOLOADED constants to be, well, constant by getting them
|
|
## to AUTOLOAD before compilation continues. Sigh.
|
|
() = (
|
|
SOL_SOCKET,
|
|
SO_REUSEADDR,
|
|
IPPROTO_TCP,
|
|
TCP_NODELAY,
|
|
HANDLE_FLAG_INHERIT,
|
|
INVALID_HANDLE_VALUE,
|
|
);
|
|
}
|
|
|
|
use constant temp_file_flags => ( FILE_ATTRIBUTE_TEMPORARY() | FILE_FLAG_DELETE_ON_CLOSE() | FILE_FLAG_WRITE_THROUGH() );
|
|
|
|
# FILE_ATTRIBUTE_HIDDEN() |
|
|
# FILE_ATTRIBUTE_SYSTEM() |
|
|
my $tmp_file_counter;
|
|
my $tmp_dir;
|
|
|
|
sub _cleanup {
|
|
my IPC::Run::Win32IO $self = shift;
|
|
my ($harness) = @_;
|
|
|
|
$self->_recv_through_temp_file($harness)
|
|
if $self->{RECV_THROUGH_TEMP_FILE};
|
|
|
|
CloseHandle( $self->{TEMP_FILE_HANDLE} )
|
|
if defined $self->{TEMP_FILE_HANDLE};
|
|
|
|
close( $self->{CHILD_HANDLE} )
|
|
if defined $self->{CHILD_HANDLE};
|
|
|
|
$self->{$_} = undef for @cleanup_fields;
|
|
}
|
|
|
|
sub _create_temp_file {
|
|
my IPC::Run::Win32IO $self = shift;
|
|
|
|
## Create a hidden temp file that Win32 will delete when we close
|
|
## it.
|
|
unless ( defined $tmp_dir ) {
|
|
$tmp_dir = File::Spec->catdir( File::Spec->tmpdir, "IPC-Run.tmp" );
|
|
|
|
## Trust in the user's umask.
|
|
## This could possibly be a security hole, perhaps
|
|
## we should offer an option. Hmmmm, really, people coding
|
|
## security conscious apps should audit this code and
|
|
## tell me how to make it better. Nice cop-out :).
|
|
unless ( -d $tmp_dir ) {
|
|
mkdir $tmp_dir or croak "$!: $tmp_dir";
|
|
}
|
|
}
|
|
|
|
$self->{TEMP_FILE_NAME} = File::Spec->catfile(
|
|
## File name is designed for easy sorting and not conflicting
|
|
## with other processes. This should allow us to use "t"runcate
|
|
## access in CreateFile in case something left some droppings
|
|
## around (which should never happen because we specify
|
|
## FLAG_DELETE_ON_CLOSE.
|
|
## heh, belt and suspenders are better than bug reports; God forbid
|
|
## that NT should ever crash before a temp file gets deleted!
|
|
$tmp_dir, sprintf "Win32io-%06d-%08d", $$, $tmp_file_counter++
|
|
);
|
|
|
|
$self->{TEMP_FILE_HANDLE} = createFile(
|
|
$self->{TEMP_FILE_NAME},
|
|
"trw", ## new, truncate, read, write
|
|
{
|
|
Flags => temp_file_flags,
|
|
},
|
|
) or croak "Can't create temporary file, $self->{TEMP_FILE_NAME}: $^E";
|
|
|
|
$self->{TFD} = OsFHandleOpenFd $self->{TEMP_FILE_HANDLE}, 0;
|
|
$self->{FD} = undef;
|
|
|
|
_debug
|
|
"Win32 Optimizer: temp file (",
|
|
$self->{KFD},
|
|
$self->{TYPE},
|
|
$self->{TFD},
|
|
", fh ",
|
|
$self->{TEMP_FILE_HANDLE},
|
|
"): ",
|
|
$self->{TEMP_FILE_NAME}
|
|
if _debugging_details;
|
|
}
|
|
|
|
sub _reset_temp_file_pointer {
|
|
my $self = shift;
|
|
SetFilePointer( $self->{TEMP_FILE_HANDLE}, 0, 0, FILE_BEGIN )
|
|
or confess "$^E seeking on (fd $self->{TFD}) $self->{TEMP_FILE_NAME} for kid's fd $self->{KFD}";
|
|
}
|
|
|
|
sub _send_through_temp_file {
|
|
my IPC::Run::Win32IO $self = shift;
|
|
|
|
_debug "Win32 optimizer: optimizing " . " $self->{KFD} $self->{TYPE} temp file instead of ",
|
|
ref $self->{SOURCE} || $self->{SOURCE}
|
|
if _debugging_details;
|
|
|
|
$self->_create_temp_file;
|
|
|
|
if ( defined ${ $self->{SOURCE} } ) {
|
|
my $bytes_written = 0;
|
|
my $data_ref;
|
|
if ( $self->binmode ) {
|
|
$data_ref = $self->{SOURCE};
|
|
}
|
|
else {
|
|
my $data = ${ $self->{SOURCE} }; # Ugh, a copy.
|
|
$data =~ s/(?<!\r)\n/\r\n/g;
|
|
$data_ref = \$data;
|
|
}
|
|
|
|
WriteFile(
|
|
$self->{TEMP_FILE_HANDLE},
|
|
$$data_ref,
|
|
0, ## Write entire buffer
|
|
$bytes_written,
|
|
[], ## Not overlapped.
|
|
) or croak "$^E writing $self->{TEMP_FILE_NAME} for kid to read on fd $self->{KFD}";
|
|
_debug "Win32 optimizer: wrote $bytes_written to temp file $self->{TEMP_FILE_NAME}"
|
|
if _debugging_data;
|
|
|
|
$self->_reset_temp_file_pointer;
|
|
|
|
}
|
|
|
|
_debug "Win32 optimizer: kid to read $self->{KFD} from temp file on $self->{TFD}"
|
|
if _debugging_details;
|
|
}
|
|
|
|
sub _init_recv_through_temp_file {
|
|
my IPC::Run::Win32IO $self = shift;
|
|
|
|
$self->_create_temp_file;
|
|
}
|
|
|
|
## TODO: Use the Win32 API in the select loop to see if the file has grown
|
|
## and read it incrementally if it has.
|
|
sub _recv_through_temp_file {
|
|
my IPC::Run::Win32IO $self = shift;
|
|
|
|
## This next line kicks in if the run() never got to initting things
|
|
## and needs to clean up.
|
|
return undef unless defined $self->{TEMP_FILE_HANDLE};
|
|
|
|
push @{ $self->{FILTERS} }, sub {
|
|
my ( undef, $out_ref ) = @_;
|
|
|
|
return undef unless defined $self->{TEMP_FILE_HANDLE};
|
|
|
|
my $r;
|
|
my $s;
|
|
ReadFile(
|
|
$self->{TEMP_FILE_HANDLE},
|
|
$s,
|
|
999_999, ## Hmmm, should read the size.
|
|
$r,
|
|
[]
|
|
) or croak "$^E reading from $self->{TEMP_FILE_NAME}";
|
|
|
|
_debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data;
|
|
|
|
return undef unless $r;
|
|
|
|
$s =~ s/\r\n/\n/g unless $self->binmode;
|
|
|
|
my $pos = pos $$out_ref;
|
|
$$out_ref .= $s;
|
|
pos($out_ref) = $pos;
|
|
return 1;
|
|
};
|
|
|
|
my ($harness) = @_;
|
|
|
|
$self->_reset_temp_file_pointer;
|
|
|
|
1 while $self->_do_filters($harness);
|
|
|
|
pop @{ $self->{FILTERS} };
|
|
|
|
IPC::Run::_close( $self->{TFD} );
|
|
}
|
|
|
|
=head1 SUBROUTINES
|
|
|
|
=over
|
|
|
|
=item poll
|
|
|
|
Windows version of IPC::Run::IP::poll.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub poll {
|
|
my IPC::Run::Win32IO $self = shift;
|
|
|
|
return if $self->{SEND_THROUGH_TEMP_FILE} || $self->{RECV_THROUGH_TEMP_FILE};
|
|
|
|
return $self->SUPER::poll(@_);
|
|
}
|
|
|
|
## When threaded Perls get good enough, we should use threads here.
|
|
## The problem with threaded perls is that they dup() all sorts of
|
|
## filehandles and fds and don't allow sufficient control over
|
|
## closing off the ones we don't want.
|
|
|
|
sub _spawn_pumper {
|
|
my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_;
|
|
my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout );
|
|
|
|
_debug "pumper stdin = ", $stdin_fd if _debugging_details;
|
|
_debug "pumper stdout = ", $stdout_fd if _debugging_details;
|
|
_inherit $stdin_fd, $stdout_fd, $debug_fd;
|
|
my @I_options = map qq{"-I$_"}, @INC;
|
|
|
|
my $cmd_line = join(
|
|
" ",
|
|
qq{"$^X"},
|
|
@I_options,
|
|
qw(-MIPC::Run::Win32Pump -e 1 ),
|
|
## I'm using this clunky way of passing filehandles to the child process
|
|
## in order to avoid some kind of premature closure of filehandles
|
|
## problem I was having with VCP's test suite when passing them
|
|
## via CreateProcess. All of the ## REMOVE code is stuff I'd like
|
|
## to be rid of and the ## ADD code is what I'd like to use.
|
|
FdGetOsFHandle($stdin_fd), ## REMOVE
|
|
FdGetOsFHandle($stdout_fd), ## REMOVE
|
|
FdGetOsFHandle($debug_fd), ## REMOVE
|
|
$binmode ? 1 : 0,
|
|
$$, $^T, _debugging_level, qq{"$child_label"},
|
|
@opts
|
|
);
|
|
|
|
# open SAVEIN, "<&STDIN" or croak "$! saving STDIN"; #### ADD
|
|
# open SAVEOUT, ">&STDOUT" or croak "$! saving STDOUT"; #### ADD
|
|
# open SAVEERR, ">&STDERR" or croak "$! saving STDERR"; #### ADD
|
|
# _dont_inherit \*SAVEIN; #### ADD
|
|
# _dont_inherit \*SAVEOUT; #### ADD
|
|
# _dont_inherit \*SAVEERR; #### ADD
|
|
# open STDIN, "<&$stdin_fd" or croak "$! dup2()ing $stdin_fd (pumper's STDIN)"; #### ADD
|
|
# open STDOUT, ">&$stdout_fd" or croak "$! dup2()ing $stdout_fd (pumper's STDOUT)"; #### ADD
|
|
# open STDERR, ">&$debug_fd" or croak "$! dup2()ing $debug_fd (pumper's STDERR/debug_fd)"; #### ADD
|
|
|
|
_debug "pump cmd line: ", $cmd_line if _debugging_details;
|
|
|
|
my $process;
|
|
Win32::Process::Create(
|
|
$process,
|
|
$^X,
|
|
$cmd_line,
|
|
1, ## Inherit handles
|
|
NORMAL_PRIORITY_CLASS,
|
|
".",
|
|
) or croak "$!: Win32::Process::Create()";
|
|
|
|
# open STDIN, "<&SAVEIN" or croak "$! restoring STDIN"; #### ADD
|
|
# open STDOUT, ">&SAVEOUT" or croak "$! restoring STDOUT"; #### ADD
|
|
# open STDERR, ">&SAVEERR" or croak "$! restoring STDERR"; #### ADD
|
|
# close SAVEIN or croak "$! closing SAVEIN"; #### ADD
|
|
# close SAVEOUT or croak "$! closing SAVEOUT"; #### ADD
|
|
# close SAVEERR or croak "$! closing SAVEERR"; #### ADD
|
|
|
|
close $stdin or croak "$! closing pumper's stdin in parent";
|
|
close $stdout or croak "$! closing pumper's stdout in parent";
|
|
|
|
# Don't close $debug_fd, we need it, as do other pumpers.
|
|
|
|
# Pause a moment to allow the child to get up and running and emit
|
|
# debug messages. This does not always work.
|
|
# select undef, undef, undef, 1 if _debugging_details;
|
|
|
|
_debug "_spawn_pumper pid = ", $process->GetProcessID
|
|
if _debugging_data;
|
|
}
|
|
|
|
my $loopback = inet_aton "127.0.0.1";
|
|
my $tcp_proto = getprotobyname('tcp');
|
|
croak "$!: getprotobyname('tcp')" unless defined $tcp_proto;
|
|
|
|
sub _socket {
|
|
my ($server) = @_;
|
|
$server ||= gensym;
|
|
my $client = gensym;
|
|
|
|
my $listener = gensym;
|
|
socket $listener, PF_INET, SOCK_STREAM, $tcp_proto
|
|
or croak "$!: socket()";
|
|
setsockopt $listener, SOL_SOCKET, SO_REUSEADDR, pack( "l", 0 )
|
|
or croak "$!: setsockopt()";
|
|
|
|
unless ( bind $listener, sockaddr_in( 0, $loopback ) ) {
|
|
croak "Error binding: $!";
|
|
}
|
|
|
|
my ($port) = sockaddr_in( getsockname($listener) );
|
|
|
|
_debug "win32 port = $port" if _debugging_details;
|
|
|
|
listen $listener, my $queue_size = 1
|
|
or croak "$!: listen()";
|
|
|
|
{
|
|
socket $client, PF_INET, SOCK_STREAM, $tcp_proto
|
|
or croak "$!: socket()";
|
|
|
|
my $paddr = sockaddr_in( $port, $loopback );
|
|
|
|
connect $client, $paddr
|
|
or croak "$!: connect()";
|
|
|
|
croak "$!: accept" unless defined $paddr;
|
|
|
|
## The windows "default" is SO_DONTLINGER, which should make
|
|
## sure all socket data goes through. I have my doubts based
|
|
## on experimentation, but nothing prompts me to set SO_LINGER
|
|
## at this time...
|
|
setsockopt $client, IPPROTO_TCP, TCP_NODELAY, pack( "l", 0 )
|
|
or croak "$!: setsockopt()";
|
|
}
|
|
|
|
{
|
|
_debug "accept()ing on port $port" if _debugging_details;
|
|
my $paddr = accept( $server, $listener );
|
|
croak "$!: accept()" unless defined $paddr;
|
|
}
|
|
|
|
_debug "win32 _socket = ( ", fileno $server, ", ", fileno $client, " ) on port $port"
|
|
if _debugging_details;
|
|
return ( $server, $client );
|
|
}
|
|
|
|
sub _open_socket_pipe {
|
|
my IPC::Run::Win32IO $self = shift;
|
|
my ( $debug_fd, $parent_handle ) = @_;
|
|
|
|
my $is_send_to_child = $self->dir eq "<";
|
|
|
|
$self->{CHILD_HANDLE} = gensym;
|
|
$self->{PUMP_PIPE_HANDLE} = gensym;
|
|
|
|
(
|
|
$self->{PARENT_HANDLE},
|
|
$self->{PUMP_SOCKET_HANDLE}
|
|
) = _socket $parent_handle;
|
|
|
|
## These binmodes seem to have no effect on Win2K, but just to be safe
|
|
## I do them.
|
|
binmode $self->{PARENT_HANDLE} or die $!;
|
|
binmode $self->{PUMP_SOCKET_HANDLE} or die $!;
|
|
|
|
_debug "PUMP_SOCKET_HANDLE = ", fileno $self->{PUMP_SOCKET_HANDLE}
|
|
if _debugging_details;
|
|
##my $buf;
|
|
##$buf = "write on child end of " . fileno( $self->{WRITE_HANDLE} ) . "\n\n\n\n\n";
|
|
##POSIX::write(fileno $self->{WRITE_HANDLE}, $buf, length $buf) or warn "$! in syswrite";
|
|
##$buf = "write on parent end of " . fileno( $self->{CHILD_HANDLE} ) . "\r\n";
|
|
##POSIX::write(fileno $self->{CHILD_HANDLE},$buf, length $buf) or warn "$! in syswrite";
|
|
## $self->{CHILD_HANDLE}->autoflush( 1 );
|
|
## $self->{WRITE_HANDLE}->autoflush( 1 );
|
|
|
|
## Now fork off a data pump and arrange to return the correct fds.
|
|
if ($is_send_to_child) {
|
|
pipe $self->{CHILD_HANDLE}, $self->{PUMP_PIPE_HANDLE}
|
|
or croak "$! opening child pipe";
|
|
_debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
|
|
if _debugging_details;
|
|
_debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
|
|
if _debugging_details;
|
|
}
|
|
else {
|
|
pipe $self->{PUMP_PIPE_HANDLE}, $self->{CHILD_HANDLE}
|
|
or croak "$! opening child pipe";
|
|
_debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
|
|
if _debugging_details;
|
|
_debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
|
|
if _debugging_details;
|
|
}
|
|
|
|
## These binmodes seem to have no effect on Win2K, but just to be safe
|
|
## I do them.
|
|
binmode $self->{CHILD_HANDLE};
|
|
binmode $self->{PUMP_PIPE_HANDLE};
|
|
|
|
## No child should ever see this.
|
|
_dont_inherit $self->{PARENT_HANDLE};
|
|
|
|
## We clear the inherit flag so these file descriptors are not inherited.
|
|
## It'll be dup()ed on to STDIN/STDOUT/STDERR before CreateProcess is
|
|
## called and *that* fd will be inheritable.
|
|
_dont_inherit $self->{PUMP_SOCKET_HANDLE};
|
|
_dont_inherit $self->{PUMP_PIPE_HANDLE};
|
|
_dont_inherit $self->{CHILD_HANDLE};
|
|
|
|
## Need to return $self so the HANDLEs don't get freed.
|
|
## Return $self, $parent_fd, $child_fd
|
|
my ( $parent_fd, $child_fd ) = (
|
|
fileno $self->{PARENT_HANDLE},
|
|
fileno $self->{CHILD_HANDLE}
|
|
);
|
|
|
|
## Both PUMP_..._HANDLEs will be closed, no need to worry about
|
|
## inheritance.
|
|
_debug "binmode on" if _debugging_data && $self->binmode;
|
|
_spawn_pumper(
|
|
$is_send_to_child
|
|
? ( $self->{PUMP_SOCKET_HANDLE}, $self->{PUMP_PIPE_HANDLE} )
|
|
: ( $self->{PUMP_PIPE_HANDLE}, $self->{PUMP_SOCKET_HANDLE} ),
|
|
$debug_fd,
|
|
$self->binmode,
|
|
$child_fd . $self->dir . "pump" . $self->dir . $parent_fd,
|
|
);
|
|
|
|
{
|
|
my $foo;
|
|
confess "PARENT_HANDLE no longer open"
|
|
unless POSIX::read( $parent_fd, $foo, 0 );
|
|
}
|
|
|
|
_debug "win32_fake_pipe = ( $parent_fd, $child_fd )"
|
|
if _debugging_details;
|
|
|
|
$self->{FD} = $parent_fd;
|
|
$self->{TFD} = $child_fd;
|
|
}
|
|
|
|
sub _do_open {
|
|
my IPC::Run::Win32IO $self = shift;
|
|
|
|
if ( $self->{SEND_THROUGH_TEMP_FILE} ) {
|
|
return $self->_send_through_temp_file(@_);
|
|
}
|
|
elsif ( $self->{RECV_THROUGH_TEMP_FILE} ) {
|
|
return $self->_init_recv_through_temp_file(@_);
|
|
}
|
|
else {
|
|
return $self->_open_socket_pipe(@_);
|
|
}
|
|
}
|
|
|
|
1;
|
|
|
|
=pod
|
|
|
|
=head1 AUTHOR
|
|
|
|
Barries Slaymaker <barries@slaysys.com>. Funded by Perforce Software, Inc.
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright 2001, Barrie Slaymaker, All Rights Reserved.
|
|
|
|
You may use this under the terms of either the GPL 2.0 or the Artistic License.
|
|
|
|
=cut
|