Source/t/lib/IPC/Run/Win32Pump.pm

   1 package IPC::Run::Win32Pump;
   2
   3 =head1 NAME
   4
   5 IPC::Run::Win32Pump - helper processes to shovel data to/from parent, child
   6
   7 =head1 SYNOPSIS
   8
   9 Internal use only; see IPC::Run::Win32IO and best of luck to you.
  10
  11 =head1 DESCRIPTION
  12
  13 See L<IPC::Run::Win32Helper|IPC::Run::Win32Helper> for details.  This
  14 module is used in subprocesses that are spawned to shovel data to/from
  15 parent processes from/to their child processes.  Where possible, pumps
  16 are optimized away.
  17
  18 NOTE: This is not a real module: it's a script in module form, designed
  19 to be run like
  20
  21    $^X -MIPC::Run::Win32Pumper -e 1 ...
  22
  23 It parses a bunch of command line parameters from IPC::Run::Win32IO.
  24
  25 =cut
  26
  27 use strict ;
  28
  29 use Win32API::File qw(
  30    OsFHandleOpen
  31 ) ;
  32
  33
  34 my ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label );
  35 BEGIN {
  36    ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ) = @ARGV ;
  37    ## Rather than letting IPC::Run::Debug export all-0 constants
  38    ## when not debugging, we do it manually in order to not even
  39    ## load IPC::Run::Debug.
  40    if ( $debug ) {
  41       eval "use IPC::Run::Debug qw( :default _debug_init ); 1;"
  42          or die $@;
  43    }
  44    else {
  45       eval <<STUBS_END or die $@;
  46          sub _debug {}
  47          sub _debug_init {}
  48          sub _debugging() { 0 }
  49          sub _debugging_data() { 0 }
  50          sub _debugging_details() { 0 }
  51          sub _debugging_gory_details() { 0 }
  52          1;
  53 STUBS_END
  54    }
  55 }
  56
  57 ## For some reason these get created with binmode on.  AAargh, gotta       #### REMOVE
  58 ## do it by hand below.       #### REMOVE
  59 if ( $debug ) {       #### REMOVE
  60 close STDERR;       #### REMOVE
  61 OsFHandleOpen( \*STDERR, $debug_fh, "w" )       #### REMOVE
  62  or print "$! opening STDERR as Win32 handle $debug_fh in pumper $$" ;       #### REMOVE
  63 }       #### REMOVE
  64 close STDIN;       #### REMOVE
  65 OsFHandleOpen( \*STDIN, $stdin_fh, "r" )       #### REMOVE
  66 or die "$! opening STDIN as Win32 handle $stdin_fh in pumper $$" ;       #### REMOVE
  67 close STDOUT;       #### REMOVE
  68 OsFHandleOpen( \*STDOUT, $stdout_fh, "w" )       #### REMOVE
  69 or die "$! opening STDOUT as Win32 handle $stdout_fh in pumper $$" ;       #### REMOVE
  70
  71 binmode STDIN;
  72 binmode STDOUT;
  73 $| = 1 ;
  74 select STDERR ; $| = 1 ; select STDOUT ;
  75
  76 $child_label ||= "pump" ;
  77 _debug_init(
  78 $parent_pid,
  79 $parent_start_time,
  80 $debug,
  81 fileno STDERR,
  82 $child_label,
  83 ) ;
  84
  85 _debug "Entered" if _debugging_details ;
  86
  87 # No need to close all fds; win32 doesn't seem to pass any on to us.
  88 $| = 1 ;
  89 my $buf ;
  90 my $total_count = 0 ;
  91 while (1) {
  92 my $count = sysread STDIN, $buf, 10_000 ;
  93 last unless $count ;
  94 if ( _debugging_gory_details ) {
  95  my $msg = "'$buf'" ;
  96  substr( $msg, 100, -1 ) = '...' if length $msg > 100 ;
  97  $msg =~ s/\n/\\n/g ;
  98  $msg =~ s/\r/\\r/g ;
  99  $msg =~ s/\t/\\t/g ;
 100  $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg ;
 101  _debug sprintf( "%5d chars revc: ", $count ), $msg ;
 102 }
 103 $total_count += $count ;
 104 $buf =~ s/\r//g unless $binmode;
 105 if ( _debugging_gory_details ) {
 106  my $msg = "'$buf'" ;
 107  substr( $msg, 100, -1 ) = '...' if length $msg > 100 ;
 108  $msg =~ s/\n/\\n/g ;
 109  $msg =~ s/\r/\\r/g ;
 110  $msg =~ s/\t/\\t/g ;
 111  $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg ;
 112  _debug sprintf( "%5d chars sent: ", $count ), $msg ;
 113 }
 114 print $buf ;
 115 }
 116
 117 _debug "Exiting, transferred $total_count chars" if _debugging_details ;
 118
 119 ## Perform a graceful socket shutdown.  Windows defaults to SO_DONTLINGER,
 120 ## which should cause a "graceful shutdown in the background" on sockets.
 121 ## but that's only true if the process closes the socket manually, it
 122 ## seems; if the process exits and lets the OS clean up, the OS is not
 123 ## so kind.  STDOUT is not always a socket, of course, but it won't hurt
 124 ## to close a pipe and may even help.  With a closed source OS, who
 125 ## can tell?
 126 ##
 127 ## In any case, this close() is one of the main reasons we have helper
 128 ## processes; if the OS closed socket fds gracefully when an app exits,
 129 ## we'd just redirect the client directly to what is now the pump end
 130 ## of the socket.  As it is, however, we need to let the client play with
 131 ## pipes, which don't have the abort-on-app-exit behavior, and then
 132 ## adapt to the sockets in the helper processes to allow the parent to
 133 ## select.
 134 ##
 135 ## Possible alternatives / improvements:
 136 ##
 137 ## 1) use helper threads instead of processes.  I don't trust perl's threads
 138 ## as of 5.005 or 5.6 enough (which may be myopic of me).
 139 ##
 140 ## 2) figure out if/how to get at WaitForMultipleObjects() with pipe
 141 ## handles.  May be able to take the Win32 handle and pass it to
 142 ## Win32::Event::wait_any, dunno.
 143 ##
 144 ## 3) Use Inline::C or a hand-tooled XS module to do helper threads.
 145 ## This would be faster than #1, but would require a ppm distro.
 146 ##
 147 close STDOUT ;
 148 close STDERR ;
 149
 150 =head1 AUTHOR
 151
 152 Barries Slaymaker <barries@slaysys.com>.  Funded by Perforce Software, Inc.
 153
 154 =head1 COPYRIGHT
 155
 156 Copyright 2001, Barrie Slaymaker, All Rights Reserved.
 157
 158 You may use this under the terms of either the GPL 2.0 ir the Artistic License.
 159
 160 =cut
 161
 162 1 ;