From c490a34900286a8a9892d21eb63c58c8430ce136 Mon Sep 17 00:00:00 2001 From: Martin Quinson Date: Wed, 30 Sep 2015 16:10:36 +0200 Subject: [PATCH] Add the Win32 bits of IPC::Run --- tools/cmake/DefinePackages.cmake | 3 + tools/cmake/scripts/IPC/Run/Win32Helper.pm | 489 ++++++++++++++++++ tools/cmake/scripts/IPC/Run/Win32IO.pm | 573 +++++++++++++++++++++ tools/cmake/scripts/IPC/Run/Win32Pump.pm | 170 ++++++ 4 files changed, 1235 insertions(+) create mode 100644 tools/cmake/scripts/IPC/Run/Win32Helper.pm create mode 100644 tools/cmake/scripts/IPC/Run/Win32IO.pm create mode 100644 tools/cmake/scripts/IPC/Run/Win32Pump.pm diff --git a/tools/cmake/DefinePackages.cmake b/tools/cmake/DefinePackages.cmake index 80f3163765..2101bd06ee 100644 --- a/tools/cmake/DefinePackages.cmake +++ b/tools/cmake/DefinePackages.cmake @@ -1208,6 +1208,9 @@ set(CMAKE_SOURCE_FILES tools/cmake/scripts/IPC/Run/Debug.pm tools/cmake/scripts/IPC/Run/IO.pm tools/cmake/scripts/IPC/Run/Timer.pm + tools/cmake/scripts/IPC/Run/Win32Helper.pm + tools/cmake/scripts/IPC/Run/Win32IO.pm + tools/cmake/scripts/IPC/Run/Win32Pump.pm tools/cmake/scripts/Diff.pm tools/cmake/scripts/Makefile.default tools/cmake/scripts/SimGrid.packproj diff --git a/tools/cmake/scripts/IPC/Run/Win32Helper.pm b/tools/cmake/scripts/IPC/Run/Win32Helper.pm new file mode 100644 index 0000000000..ddbdadb152 --- /dev/null +++ b/tools/cmake/scripts/IPC/Run/Win32Helper.pm @@ -0,0 +1,489 @@ +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.90'; + @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 + 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/tools/cmake/scripts/IPC/Run/Win32IO.pm b/tools/cmake/scripts/IPC/Run/Win32IO.pm new file mode 100644 index 0000000000..69afd8e97c --- /dev/null +++ b/tools/cmake/scripts/IPC/Run/Win32IO.pm @@ -0,0 +1,573 @@ +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.90'; +} + +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}; + + $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 $next_port = 2048; +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()"; + + my $port; + my @errors; +PORT_FINDER_LOOP: + { + $port = $next_port; + $next_port = 2048 if ++$next_port > 65_535; + unless ( bind $listener, sockaddr_in( $port, $loopback ) ) { + push @errors, "$! on port $port"; + croak join "\n", @errors if @errors > 10; + goto PORT_FINDER_LOOP; + } + } + + _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/tools/cmake/scripts/IPC/Run/Win32Pump.pm b/tools/cmake/scripts/IPC/Run/Win32Pump.pm new file mode 100644 index 0000000000..ea7be051c8 --- /dev/null +++ b/tools/cmake/scripts/IPC/Run/Win32Pump.pm @@ -0,0 +1,170 @@ +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.90'; +} + +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 -- 2.20.1