+++ /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
