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
--- /dev/null
+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<run()> (I<not> C<harness()>, C<start()>,
+or C<finish()>) 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<optimize()> 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<binary()> modifier.
+
+To detect cases that you might want to optimize by closing inputs, try
+setting the C<IPCRUNDEBUG> environment variable to the special C<notopt>
+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<run()>), 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<Text::ParseWords>), 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<LIMITATIONS>.
+
+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<Win32API::GetOSFHandle(FH)> or
+C<Win32API::FdGetOsFHandle($fd)> 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<OsFHandleOpen()> or C<OsFHandleOpenFd()> and possibly
+C<<open FOO ">&BAR">> or C<<open FOO ">&$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 <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
--- /dev/null
+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/(?<!\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 $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 <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
--- /dev/null
+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<IPC::Run::Win32Helper|IPC::Run::Win32Helper> 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 <<STUBS_END or die $@;
+ sub _debug {}
+ sub _debug_init {}
+ sub _debugging() { 0 }
+ sub _debugging_data() { 0 }
+ sub _debugging_details() { 0 }
+ sub _debugging_gory_details() { 0 }
+ 1;
+STUBS_END
+ }
+}
+
+## For some reason these get created with binmode on. AAargh, gotta #### REMOVE
+## do it by hand below. #### REMOVE
+if ( $debug ) { #### REMOVE
+close STDERR; #### REMOVE
+OsFHandleOpen( \*STDERR, $debug_fh, "w" ) #### REMOVE
+ or print "$! opening STDERR as Win32 handle $debug_fh in pumper $$"; #### REMOVE
+} #### REMOVE
+close STDIN; #### REMOVE
+OsFHandleOpen( \*STDIN, $stdin_fh, "r" ) #### REMOVE
+or die "$! opening STDIN as Win32 handle $stdin_fh in pumper $$"; #### REMOVE
+close STDOUT; #### REMOVE
+OsFHandleOpen( \*STDOUT, $stdout_fh, "w" ) #### REMOVE
+or die "$! opening STDOUT as Win32 handle $stdout_fh in pumper $$"; #### REMOVE
+
+binmode STDIN;
+binmode STDOUT;
+$| = 1;
+select STDERR; $| = 1; select STDOUT;
+
+$child_label ||= "pump";
+_debug_init(
+$parent_pid,
+$parent_start_time,
+$debug,
+fileno STDERR,
+$child_label,
+);
+
+_debug "Entered" if _debugging_details;
+
+# No need to close all fds; win32 doesn't seem to pass any on to us.
+$| = 1;
+my $buf;
+my $total_count = 0;
+while (1) {
+my $count = sysread STDIN, $buf, 10_000;
+last unless $count;
+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 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 <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 ir the Artistic License.
+
+=cut