diff --git a/MANIFEST b/MANIFEST index 2af32fe..f578a50 100644 --- a/MANIFEST +++ b/MANIFEST @@ -14,9 +14,6 @@ lib/IPC/Run.pm lib/IPC/Run/Debug.pm lib/IPC/Run/IO.pm lib/IPC/Run/Timer.pm -lib/IPC/Run/Win32Helper.pm -lib/IPC/Run/Win32IO.pm -lib/IPC/Run/Win32Pump.pm LICENSE Makefile.PL MANIFEST This list of files @@ -49,6 +46,5 @@ t/signal.t t/timeout.t t/timer.t t/utf8.t -t/win32_compile.t t/windows_search_path.t TODO diff --git a/abuse/blocking_debug_with_sub_coprocess b/abuse/blocking_debug_with_sub_coprocess index 54c3c52..2b50fa0 100644 --- a/abuse/blocking_debug_with_sub_coprocess +++ b/abuse/blocking_debug_with_sub_coprocess @@ -1,4 +1,4 @@ -#!/opt/i386-linux/perl/bin/perl -w +/usr/bin/perl -w ## Submitted by Blair Zajac diff --git a/abuse/timers b/abuse/timers index d945f3f..8b8a4db 100644 --- a/abuse/timers +++ b/abuse/timers @@ -1,4 +1,4 @@ -#!/usr/local/lib/perl -w +/usr/bin/perl -w use strict; use IPC::Run qw( :all ); diff --git a/eg/run_daemon b/eg/run_daemon index ce1a95c..3298972 100644 --- a/eg/run_daemon +++ b/eg/run_daemon @@ -1,4 +1,4 @@ -#!/usr/local/bin/perl -w +/usr/bin/perl -w ## An example of how to daemonize. See the IPC::Run LIMITATIONS section for ## some reasons why this can be a bit dangerous. diff --git a/lib/IPC/Run/Win32Helper.pm b/lib/IPC/Run/Win32Helper.pm deleted file mode 100644 index 1d7773a..0000000 --- a/lib/IPC/Run/Win32Helper.pm +++ /dev/null @@ -1,486 +0,0 @@ -package IPC::Run::Win32Helper; - -=pod - -=head1 NAME - -IPC::Run::Win32Helper - helper routines for IPC::Run on Win32 platforms. - -=head1 SYNOPSIS - - use IPC::Run::Win32Helper; # 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!. - -=cut - -use strict; -use Carp; -use IO::Handle; -use vars qw{ $VERSION @ISA @EXPORT }; - -BEGIN { - $VERSION = '0.99'; - @ISA = qw( Exporter ); - @EXPORT = qw( - win32_spawn - win32_parse_cmd_line - _dont_inherit - _inherit - ); -} - -require POSIX; - -use Text::ParseWords; -use Win32::Process; -use IPC::Run::Debug; -use Win32API::File qw( - FdGetOsFHandle - SetHandleInformation - HANDLE_FLAG_INHERIT - INVALID_HANDLE_VALUE -); - -## Takes an fd or a GLOB ref, never never never a Win32 handle. -sub _dont_inherit { - for (@_) { - next unless defined $_; - my $fd = $_; - $fd = fileno $fd if ref $fd; - _debug "disabling inheritance of ", $fd if _debugging_details; - my $osfh = FdGetOsFHandle $fd; - croak $^E if !defined $osfh || $osfh == INVALID_HANDLE_VALUE; - - SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 0 ); - } -} - -sub _inherit { #### REMOVE - for (@_) { #### REMOVE - next unless defined $_; #### REMOVE - my $fd = $_; #### REMOVE - $fd = fileno $fd if ref $fd; #### REMOVE - _debug "enabling inheritance of ", $fd if _debugging_details; #### REMOVE - my $osfh = FdGetOsFHandle $fd; #### REMOVE - croak $^E if !defined $osfh || $osfh == INVALID_HANDLE_VALUE; #### REMOVE - #### REMOVE - SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 1 ); #### REMOVE - } #### REMOVE -} #### REMOVE -#### REMOVE -#sub _inherit { -# for ( @_ ) { -# next unless defined $_; -# my $osfh = GetOsFHandle $_; -# croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE; -# SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT ); -# } -#} - -=pod - -=head1 FUNCTIONS - -=over - -=item optimize() - -Most common incantations of C (I C, C, -or C) now use temporary files to redirect input and output -instead of pumper processes. - -Temporary files are used when sending to child processes if input is -taken from a scalar with no filter subroutines. This is the only time -we can assume that the parent is not interacting with the child's -redirected input as it runs. - -Temporary files are used when receiving from children when output is -to a scalar or subroutine with or without filters, but only if -the child in question closes its inputs or takes input from -unfiltered SCALARs or named files. Normally, a child inherits its STDIN -from its parent; to close it, use "0<&-" or the C<< noinherit => 1 >> option. -If data is sent to the child from CODE refs, filehandles or from -scalars through filters than the child's outputs will not be optimized -because C assumes the parent is interacting with the child. -It is ok if the output is filtered or handled by a subroutine, however. - -This assumes that all named files are real files (as opposed to named -pipes) and won't change; and that a process is not communicating with -the child indirectly (through means not visible to IPC::Run). -These can be an invalid assumptions, but are the 99% case. -Write me if you need an option to enable or disable optimizations; I -suspect it will work like the C modifier. - -To detect cases that you might want to optimize by closing inputs, try -setting the C environment variable to the special C -value: - - C:> set IPCRUNDEBUG=notopt - C:> my_app_that_uses_IPC_Run.pl - -=item optimizer() rationalizations - -Only for that limited case can we be sure that it's ok to batch all the -input in to a temporary file. If STDIN is from a SCALAR or from a named -file or filehandle (again, only in C), then outputs to CODE refs -are also assumed to be safe enough to batch through a temp file, -otherwise only outputs to SCALAR refs are batched. This can cause a bit -of grief if the parent process benefits from or relies on a bit of -"early returns" coming in before the child program exits. As long as -the output is redirected to a SCALAR ref, this will not be visible. -When output is redirected to a subroutine or (deprecated) filters, the -subroutine will not get any data until after the child process exits, -and it is likely to get bigger chunks of data at once. - -The reason for the optimization is that, without it, "pumper" processes -are used to overcome the inconsistencies of the Win32 API. We need to -use anonymous pipes to connect to the child processes' stdin, stdout, -and stderr, yet select() does not work on these. select() only works on -sockets on Win32. So for each redirected child handle, there is -normally a "pumper" process that connects to the parent using a -socket--so the parent can select() on that fd--and to the child on an -anonymous pipe--so the child can read/write a pipe. - -Using a socket to connect directly to the child (as at least one MSDN -article suggests) seems to cause the trailing output from most children -to be lost. I think this is because child processes rarely close their -stdout and stderr explicitly, and the winsock dll does not seem to flush -output when a process that uses it exits without explicitly closing -them. - -Because of these pumpers and the inherent slowness of Win32 -CreateProcess(), child processes with redirects are quite slow to -launch; so this routine looks for the very common case of -reading/writing to/from scalar references in a run() routine and -converts such reads and writes in to temporary file reads and writes. - -Such files are marked as FILE_ATTRIBUTE_TEMPORARY to increase speed and -as FILE_FLAG_DELETE_ON_CLOSE so it will be cleaned up when the child -process exits (for input files). The user's default permissions are -used for both the temporary files and the directory that contains them, -hope your Win32 permissions are secure enough for you. Files are -created with the Win32API::File defaults of -FILE_SHARE_READ|FILE_SHARE_WRITE. - -Setting the debug level to "details" or "gory" will give detailed -information about the optimization process; setting it to "basic" or -higher will tell whether or not a given call is optimized. Setting -it to "notopt" will highlight those calls that aren't optimized. - -=cut - -sub optimize { - my ($h) = @_; - - my @kids = @{ $h->{KIDS} }; - - my $saw_pipe; - - my ( $ok_to_optimize_outputs, $veto_output_optimization ); - - for my $kid (@kids) { - ( $ok_to_optimize_outputs, $veto_output_optimization ) = () - unless $saw_pipe; - - _debug "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over ok of non-SCALAR output optimization" - if _debugging_details && $ok_to_optimize_outputs; - _debug "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over veto of non-SCALAR output optimization" - if _debugging_details && $veto_output_optimization; - - if ( $h->{noinherit} && !$ok_to_optimize_outputs ) { - _debug "Win32 optimizer: (kid $kid->{NUM}) STDIN not inherited from parent oking non-SCALAR output optimization" - if _debugging_details && $ok_to_optimize_outputs; - $ok_to_optimize_outputs = 1; - } - - for ( @{ $kid->{OPS} } ) { - if ( substr( $_->{TYPE}, 0, 1 ) eq "<" ) { - if ( $_->{TYPE} eq "<" ) { - if ( @{ $_->{FILTERS} } > 1 ) { - ## Can't assume that the filters are idempotent. - } - elsif (ref $_->{SOURCE} eq "SCALAR" - || ref $_->{SOURCE} eq "GLOB" - || UNIVERSAL::isa( $_, "IO::Handle" ) ) { - if ( $_->{KFD} == 0 ) { - _debug - "Win32 optimizer: (kid $kid->{NUM}) 0$_->{TYPE}", - ref $_->{SOURCE}, - ", ok to optimize outputs" - if _debugging_details; - $ok_to_optimize_outputs = 1; - } - $_->{SEND_THROUGH_TEMP_FILE} = 1; - next; - } - elsif ( !ref $_->{SOURCE} && defined $_->{SOURCE} ) { - if ( $_->{KFD} == 0 ) { - _debug - "Win32 optimizer: (kid $kid->{NUM}) 0<$_->{SOURCE}, ok to optimize outputs", - if _debugging_details; - $ok_to_optimize_outputs = 1; - } - next; - } - } - _debug - "Win32 optimizer: (kid $kid->{NUM}) ", - $_->{KFD}, - $_->{TYPE}, - defined $_->{SOURCE} - ? ref $_->{SOURCE} - ? ref $_->{SOURCE} - : $_->{SOURCE} - : defined $_->{FILENAME} ? $_->{FILENAME} - : "", - @{ $_->{FILTERS} } > 1 ? " with filters" : (), - ", VETOING output opt." - if _debugging_details || _debugging_not_optimized; - $veto_output_optimization = 1; - } - elsif ( $_->{TYPE} eq "close" && $_->{KFD} == 0 ) { - $ok_to_optimize_outputs = 1; - _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&-, ok to optimize outputs" - if _debugging_details; - } - elsif ( $_->{TYPE} eq "dup" && $_->{KFD2} == 0 ) { - $veto_output_optimization = 1; - _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&$_->{KFD2}, VETOING output opt." - if _debugging_details || _debugging_not_optimized; - } - elsif ( $_->{TYPE} eq "|" ) { - $saw_pipe = 1; - } - } - - if ( !$ok_to_optimize_outputs && !$veto_output_optimization ) { - _debug "Win32 optimizer: (kid $kid->{NUM}) child STDIN not redirected, VETOING non-SCALAR output opt." - if _debugging_details || _debugging_not_optimized; - $veto_output_optimization = 1; - } - - if ( $ok_to_optimize_outputs && $veto_output_optimization ) { - $ok_to_optimize_outputs = 0; - _debug "Win32 optimizer: (kid $kid->{NUM}) non-SCALAR output optimizations VETOed" - if _debugging_details || _debugging_not_optimized; - } - - ## SOURCE/DEST ARRAY means it's a filter. - ## TODO: think about checking to see if the final input/output of - ## a filter chain (an ARRAY SOURCE or DEST) is a scalar...but - ## we may be deprecating filters. - - for ( @{ $kid->{OPS} } ) { - if ( $_->{TYPE} eq ">" ) { - if ( - ref $_->{DEST} eq "SCALAR" - || ( - ( - @{ $_->{FILTERS} } > 1 - || ref $_->{DEST} eq "CODE" - || ref $_->{DEST} eq "ARRAY" ## Filters? - ) - && ( $ok_to_optimize_outputs && !$veto_output_optimization ) - ) - ) { - $_->{RECV_THROUGH_TEMP_FILE} = 1; - next; - } - _debug - "Win32 optimizer: NOT optimizing (kid $kid->{NUM}) ", - $_->{KFD}, - $_->{TYPE}, - defined $_->{DEST} - ? ref $_->{DEST} - ? ref $_->{DEST} - : $_->{SOURCE} - : defined $_->{FILENAME} ? $_->{FILENAME} - : "", - @{ $_->{FILTERS} } ? " with filters" : (), - if _debugging_details; - } - } - } - -} - -=pod - -=item win32_parse_cmd_line - - @words = win32_parse_cmd_line( q{foo bar 'baz baz' "bat bat"} ); - -returns 4 words. This parses like the bourne shell (see -the bit about shellwords() in L), assuming we're -trying to be a little cross-platform here. The only difference is -that "\" is *not* treated as an escape except when it precedes -punctuation, since it's used all over the place in DOS path specs. - -TODO: globbing? probably not (it's unDOSish). - -TODO: shebang emulation? Probably, but perhaps that should be part -of Run.pm so all spawned processes get the benefit. - -LIMITATIONS: shellwords dies silently on malformed input like - - a\" - -=cut - -sub win32_parse_cmd_line { - my $line = shift; - $line =~ s{(\\[\w\s])}{\\$1}g; - return shellwords $line; -} - -=pod - -=item win32_spawn - -Spawns a child process, possibly with STDIN, STDOUT, and STDERR (file descriptors 0, 1, and 2, respectively) redirected. - -B. - -Cannot redirect higher file descriptors due to lack of support for this in the -Win32 environment. - -This can be worked around by marking a handle as inheritable in the -parent (or leaving it marked; this is the default in perl), obtaining it's -Win32 handle with C or -C and passing it to the child using the command -line, the environment, or any other IPC mechanism (it's a plain old integer). -The child can then use C or C and possibly -C<&BAR">> or C<&$fd>> as need be. Ach, the pain! - -Remember to check the Win32 handle against INVALID_HANDLE_VALUE. - -=cut - -sub _save { - my ( $saved, $saved_as, $fd ) = @_; - - ## We can only save aside the original fds once. - return if exists $saved->{$fd}; - - my $saved_fd = IPC::Run::_dup($fd); - _dont_inherit $saved_fd; - - $saved->{$fd} = $saved_fd; - $saved_as->{$saved_fd} = $fd; - - _dont_inherit $saved->{$fd}; -} - -sub _dup2_gently { - my ( $saved, $saved_as, $fd1, $fd2 ) = @_; - _save $saved, $saved_as, $fd2; - - if ( exists $saved_as->{$fd2} ) { - ## The target fd is colliding with a saved-as fd, gotta bump - ## the saved-as fd to another fd. - my $orig_fd = delete $saved_as->{$fd2}; - my $saved_fd = IPC::Run::_dup($fd2); - _dont_inherit $saved_fd; - - $saved->{$orig_fd} = $saved_fd; - $saved_as->{$saved_fd} = $orig_fd; - } - _debug "moving $fd1 to kid's $fd2" if _debugging_details; - IPC::Run::_dup2_rudely( $fd1, $fd2 ); -} - -sub win32_spawn { - my ( $cmd, $ops ) = @_; - - ## NOTE: The debug pipe write handle is passed to pump processes as STDOUT. - ## and is not to the "real" child process, since they would not know - ## what to do with it...unlike Unix, we have no code executing in the - ## child before the "real" child is exec()ed. - - my %saved; ## Map of parent's orig fd -> saved fd - my %saved_as; ## Map of parent's saved fd -> orig fd, used to - ## detect collisions between a KFD and the fd a - ## parent's fd happened to be saved to. - - for my $op (@$ops) { - _dont_inherit $op->{FD} if defined $op->{FD}; - - if ( defined $op->{KFD} && $op->{KFD} > 2 ) { - ## TODO: Detect this in harness() - ## TODO: enable temporary redirections if ever necessary, not - ## sure why they would be... - ## 4>&1 1>/dev/null 1>&4 4>&- - croak "Can't redirect fd #", $op->{KFD}, " on Win32"; - } - - ## This is very similar logic to IPC::Run::_do_kid_and_exit(). - if ( defined $op->{TFD} ) { - unless ( $op->{TFD} == $op->{KFD} ) { - _dup2_gently \%saved, \%saved_as, $op->{TFD}, $op->{KFD}; - _dont_inherit $op->{TFD}; - } - } - elsif ( $op->{TYPE} eq "dup" ) { - _dup2_gently \%saved, \%saved_as, $op->{KFD1}, $op->{KFD2} - unless $op->{KFD1} == $op->{KFD2}; - } - elsif ( $op->{TYPE} eq "close" ) { - _save \%saved, \%saved_as, $op->{KFD}; - IPC::Run::_close( $op->{KFD} ); - } - elsif ( $op->{TYPE} eq "init" ) { - ## TODO: detect this in harness() - croak "init subs not allowed on Win32"; - } - } - - my $process; - my $cmd_line = join " ", map { - ( my $s = $_ ) =~ s/"/"""/g; - $s = qq{"$s"} if /[\"\s]|^$/; - $s; - } @$cmd; - - _debug "cmd line: ", $cmd_line - if _debugging; - - Win32::Process::Create( - $process, - $cmd->[0], - $cmd_line, - 1, ## Inherit handles - 0, ## Inherit parent priortiy class. Was NORMAL_PRIORITY_CLASS - ".", - ) or croak "$!: Win32::Process::Create()"; - - for my $orig_fd ( keys %saved ) { - IPC::Run::_dup2_rudely( $saved{$orig_fd}, $orig_fd ); - IPC::Run::_close( $saved{$orig_fd} ); - } - - return ( $process->GetProcessID(), $process ); -} - -1; - -=pod - -=back - -=head1 AUTHOR - -Barries Slaymaker . 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 diff --git a/lib/IPC/Run/Win32IO.pm b/lib/IPC/Run/Win32IO.pm deleted file mode 100644 index 5149567..0000000 --- a/lib/IPC/Run/Win32IO.pm +++ /dev/null @@ -1,551 +0,0 @@ -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 = '0.99'; -} - -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/(?{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 . 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 diff --git a/lib/IPC/Run/Win32Pump.pm b/lib/IPC/Run/Win32Pump.pm deleted file mode 100644 index 9b3d787..0000000 --- a/lib/IPC/Run/Win32Pump.pm +++ /dev/null @@ -1,173 +0,0 @@ -package IPC::Run::Win32Pump; - -=pod - -=head1 NAME - -IPC::Run::Win32Pump - helper processes to shovel data to/from parent, child - -=head1 SYNOPSIS - -Internal use only; see IPC::Run::Win32IO and best of luck to you. - -=head1 DESCRIPTION - -See L for details. This -module is used in subprocesses that are spawned to shovel data to/from -parent processes from/to their child processes. Where possible, pumps -are optimized away. - -NOTE: This is not a real module: it's a script in module form, designed -to be run like - - $^X -MIPC::Run::Win32Pumper -e 1 ... - -It parses a bunch of command line parameters from IPC::Run::Win32IO. - -=cut - -use strict; -use vars qw{$VERSION}; - -BEGIN { - $VERSION = '0.99'; -} - -use Win32API::File qw( - OsFHandleOpen -); - -my ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ); - -BEGIN { - ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ) = @ARGV; - ## Rather than letting IPC::Run::Debug export all-0 constants - ## when not debugging, we do it manually in order to not even - ## load IPC::Run::Debug. - if ($debug) { - eval "use IPC::Run::Debug qw( :default _debug_init ); 1;" - or die $@; - } - else { - eval < 100; - $msg =~ s/\n/\\n/g; - $msg =~ s/\r/\\r/g; - $msg =~ s/\t/\\t/g; - $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg; - _debug sprintf( "%5d chars revc: ", $count ), $msg; - } - $total_count += $count; - $buf =~ s/\r//g unless $binmode; - if (_debugging_gory_details) { - my $msg = "'$buf'"; - substr( $msg, 100, -1 ) = '...' if length $msg > 100; - $msg =~ s/\n/\\n/g; - $msg =~ s/\r/\\r/g; - $msg =~ s/\t/\\t/g; - $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg; - _debug sprintf( "%5d chars sent: ", $count ), $msg; - } - print $buf; -} - -_debug "Exiting, transferred $total_count chars" if _debugging_details; - -## Perform a graceful socket shutdown. Windows defaults to SO_DONTLINGER, -## which should cause a "graceful shutdown in the background" on sockets. -## but that's only true if the process closes the socket manually, it -## seems; if the process exits and lets the OS clean up, the OS is not -## so kind. STDOUT is not always a socket, of course, but it won't hurt -## to close a pipe and may even help. With a closed source OS, who -## can tell? -## -## In any case, this close() is one of the main reasons we have helper -## processes; if the OS closed socket fds gracefully when an app exits, -## we'd just redirect the client directly to what is now the pump end -## of the socket. As it is, however, we need to let the client play with -## pipes, which don't have the abort-on-app-exit behavior, and then -## adapt to the sockets in the helper processes to allow the parent to -## select. -## -## Possible alternatives / improvements: -## -## 1) use helper threads instead of processes. I don't trust perl's threads -## as of 5.005 or 5.6 enough (which may be myopic of me). -## -## 2) figure out if/how to get at WaitForMultipleObjects() with pipe -## handles. May be able to take the Win32 handle and pass it to -## Win32::Event::wait_any, dunno. -## -## 3) Use Inline::C or a hand-tooled XS module to do helper threads. -## This would be faster than #1, but would require a ppm distro. -## -close STDOUT; -close STDERR; - -1; - -=pod - -=head1 AUTHOR - -Barries Slaymaker . 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 ir the Artistic License. - -=cut diff --git a/t/win32_compile.t b/t/win32_compile.t deleted file mode 100644 index 1a2a166..0000000 --- a/t/win32_compile.t +++ /dev/null @@ -1,94 +0,0 @@ -#!/usr/bin/perl - -=pod - -=head1 NAME - -win32_compile.t - See if IPC::Run::Win32Helper compiles, even on Unix - -=cut - -use strict; - -BEGIN { - $| = 1; - $^W = 1; - if ( $ENV{PERL_CORE} ) { - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - $^X = '../../../t/' . $^X; - } -} - -use Test::More; - -BEGIN { - unless ( eval "require 5.006" ) { - ## NOTE: I'm working around this here because I don't want this - ## test to fail on non-Win32 systems with older Perls. Makefile.PL - ## does the require 5.6.0 to protect folks on Windows. - plan( skip_all => "perl5.00503's Socket.pm does not export IPPROTO_TCP" ); - } - - if ( $^O eq 'android' ) { - plan( skip_all => "android does not support getprotobyname()" ); - } - - $INC{$_} = 1 for qw( Win32/Process.pm Win32API/File.pm ); - - package Win32API::File; - - use vars qw( @ISA @EXPORT ); - - @ISA = qw( Exporter ); - @EXPORT = qw( - GetOsFHandle - OsFHandleOpen - OsFHandleOpenFd - 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 - ); - - eval "sub $_ { 1 }" for @EXPORT; - - use Exporter; - - package Win32::Process; - - use vars qw( @ISA @EXPORT ); - - @ISA = qw( Exporter ); - @EXPORT = qw( - NORMAL_PRIORITY_CLASS - ); - - eval "sub $_ {}" for @EXPORT; - - use Exporter; -} - -sub Socket::IPPROTO_TCP() { undef } - -package main; - -use IPC::Run::Win32Helper; -use IPC::Run::Win32IO; - -plan( tests => 1 ); - -ok(1);