home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Win32Helper.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-26  |  16.2 KB  |  482 lines
  1. package IPC::Run::Win32Helper ;
  2.  
  3. =head1 NAME
  4.  
  5. IPC::Run::Win32Helper - helper routines for IPC::Run on Win32 platforms.
  6.  
  7. =head1 SYNOPSIS
  8.  
  9. use IPC::Run::Win32Helper ;   # Exports all by default
  10.  
  11. =head1 DESCRIPTION
  12.  
  13. IPC::Run needs to use sockets to redirect subprocess I/O so that the select() loop
  14. will work on Win32. This seems to only work on WinNT and Win2K at this time, not
  15. sure if it will ever work on Win95 or Win98. If you have experience in this area, please
  16. contact me at barries@slaysys.com, thanks!.
  17.  
  18. =cut
  19.  
  20. @ISA = qw( Exporter ) ;
  21.  
  22. @EXPORT = qw(
  23.    win32_spawn
  24.    win32_parse_cmd_line
  25.    _dont_inherit
  26.    _inherit
  27. ) ;
  28.  
  29. use strict ;
  30. use Carp ;
  31. use IO::Handle ;
  32. #use IPC::Open3 ();
  33. require POSIX ;
  34.  
  35. use Text::ParseWords ;
  36. use Win32::Process ;
  37. use IPC::Run::Debug;
  38. ## REMOVE OSFHandleOpen
  39. use Win32API::File qw(
  40.    FdGetOsFHandle
  41.    SetHandleInformation
  42.    HANDLE_FLAG_INHERIT
  43.    INVALID_HANDLE_VALUE
  44. ) ;
  45.  
  46. ## Takes an fd or a GLOB ref, never never never a Win32 handle.
  47. sub _dont_inherit {
  48.    for ( @_ ) {
  49.       next unless defined $_ ;
  50.       my $fd = $_ ;
  51.       $fd = fileno $fd if ref $fd ;
  52.       _debug "disabling inheritance of ", $fd if _debugging_details ;
  53.       my $osfh = FdGetOsFHandle $fd ;
  54.       croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE ;
  55.  
  56.       SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 0 ) ;
  57.    }
  58. }
  59.  
  60. sub _inherit {       #### REMOVE
  61.    for ( @_ ) {       #### REMOVE
  62.       next unless defined $_ ;       #### REMOVE
  63.       my $fd = $_ ;       #### REMOVE
  64.       $fd = fileno $fd if ref $fd ;       #### REMOVE
  65.       _debug "enabling inheritance of ", $fd if _debugging_details ;       #### REMOVE
  66.       my $osfh = FdGetOsFHandle $fd ;       #### REMOVE
  67.       croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE ;       #### REMOVE
  68.        #### REMOVE
  69.       SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 1 ) ;       #### REMOVE
  70.    }       #### REMOVE
  71. }       #### REMOVE
  72.        #### REMOVE
  73. #sub _inherit {
  74. #   for ( @_ ) {
  75. #      next unless defined $_ ;
  76. #      my $osfh = GetOsFHandle $_ ;
  77. #      croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE ;
  78. #      SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT ) ;
  79. #   }
  80. #}
  81.  
  82. =head1 FUNCTIONS
  83.  
  84. =over
  85.  
  86. =cut
  87.  
  88. =item optimize()
  89.  
  90. Most common incantations of C<run()> (I<not> C<harness()>, C<start()>,
  91. or C<finish()>) now use temporary files to redirect input and output
  92. instead of pumper processes.
  93.  
  94. Temporary files are used when sending to child processes if input is
  95. taken from a scalar with no filter subroutines.  This is the only time
  96. we can assume that the parent is not interacting with the child's
  97. redirected input as it runs.
  98.  
  99. Temporary files are used when receiving from children when output is
  100. to a scalar or subroutine with or without filters, but only if
  101. the child in question closes its inputs or takes input from 
  102. unfiltered SCALARs or named files.  Normally, a child inherits its STDIN
  103. from its parent; to close it, use "0<&-" or the C<noinherit => 1> option.
  104. If data is sent to the child from CODE refs, filehandles or from
  105. scalars through filters than the child's outputs will not be optimized
  106. because C<optimize()> assumes the parent is interacting with the child.
  107. It is ok if the output is filtered or handled by a subroutine, however.
  108.  
  109. This assumes that all named files are real files (as opposed to named
  110. pipes) and won't change; and that a process is not communicating with
  111. the child indirectly (through means not visible to IPC::Run).
  112. These can be an invalid assumptions, but are the 99% case.
  113. Write me if you need an option to enable or disable optimizations; I
  114. suspect it will work like the C<binary()> modifier.
  115.  
  116. To detect cases that you might want to optimize by closing inputs, try
  117. setting the C<IPCRUNDEBUG> environment variable to the special C<notopt>
  118. value:
  119.  
  120.    C:> set IPCRUNDEBUG=notopt
  121.    C:> my_app_that_uses_IPC_Run.pl
  122.  
  123. =item optimizer() rationalizations
  124.  
  125. Only for that limited case can we be sure that it's ok to batch all the
  126. input in to a temporary file.  If STDIN is from a SCALAR or from a named
  127. file or filehandle (again, only in C<run()>), then outputs to CODE refs
  128. are also assumed to be safe enough to batch through a temp file,
  129. otherwise only outputs to SCALAR refs are batched.  This can cause a bit
  130. of grief if the parent process benefits from or relies on a bit of
  131. "early returns" coming in before the child program exits.  As long as
  132. the output is redirected to a SCALAR ref, this will not be visible.
  133. When output is redirected to a subroutine or (deprecated) filters, the
  134. subroutine will not get any data until after the child process exits,
  135. and it is likely to get bigger chunks of data at once.
  136.  
  137. The reason for the optimization is that, without it, "pumper" processes
  138. are used to overcome the inconsistancies of the Win32 API.  We need to
  139. use anonymous pipes to connect to the child processes' stdin, stdout,
  140. and stderr, yet select() does not work on these.  select() only works on
  141. sockets on Win32.  So for each redirected child handle, there is
  142. normally a "pumper" process that connects to the parent using a
  143. socket--so the parent can select() on that fd--and to the child on an
  144. anonymous pipe--so the child can read/write a pipe.
  145.  
  146. Using a socket to connect directly to the child (as at least one MSDN
  147. article suggests) seems to cause the trailing output from most children
  148. to be lost.  I think this is because child processes rarely close their
  149. stdout and stderr explicitly, and the winsock dll does not seem to flush
  150. output when a process that uses it exits without explicitly closing
  151. them.
  152.  
  153. Because of these pumpers and the inherent slowness of Win32
  154. CreateProcess(), child processes with redirects are quite slow to
  155. launch; so this routine looks for the very common case of
  156. reading/writing to/from scalar references in a run() routine and
  157. converts such reads and writes in to temporary file reads and writes.
  158.  
  159. Such files are marked as FILE_ATTRIBUTE_TEMPORARY to increase speed and
  160. as FILE_FLAG_DELETE_ON_CLOSE so it will be cleaned up when the child
  161. process exits (for input files).  The user's default permissions are
  162. used for both the temporary files and the directory that contains them,
  163. hope your Win32 permissions are secure enough for you.  Files are
  164. created with the Win32API::File defaults of
  165. FILE_SHARE_READ|FILE_SHARE_WRITE.
  166.  
  167. Setting the debug level to "details" or "gory" will give detailed
  168. information about the optimization process; setting it to "basic" or
  169. higher will tell whether or not a given call is optimized.  Setting
  170. it to "notopt" will highligh those calls that aren't optimized.
  171.  
  172. =cut
  173.  
  174. sub optimize {
  175.    my ( $h ) = @_;
  176.  
  177.    my @kids = @{$h->{KIDS}};
  178.  
  179.    my $saw_pipe;
  180.  
  181.    my ( $ok_to_optimize_outputs, $veto_output_optimization );
  182.  
  183.    for my $kid ( @kids ) {
  184.       ( $ok_to_optimize_outputs, $veto_output_optimization ) = ()
  185.          unless $saw_pipe;
  186.  
  187.       _debug
  188.          "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over ok of non-SCALAR output optimization"
  189.          if _debugging_details && $ok_to_optimize_outputs;
  190.       _debug
  191.          "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over veto of non-SCALAR output optimization"
  192.          if _debugging_details && $veto_output_optimization;
  193.  
  194.       if ( $h->{noinherit} && ! $ok_to_optimize_outputs ) {
  195.      _debug
  196.         "Win32 optimizer: (kid $kid->{NUM}) STDIN not inherited from parent oking non-SCALAR output optimization"
  197.         if _debugging_details && $ok_to_optimize_outputs;
  198.      $ok_to_optimize_outputs = 1;
  199.       }
  200.  
  201.       for ( @{$kid->{OPS}} ) {
  202.          if ( substr( $_->{TYPE}, 0, 1 ) eq "<" ) {
  203.             if ( $_->{TYPE} eq "<" ) {
  204.            if ( @{$_->{FILTERS}} > 1 ) {
  205.           ## Can't assume that the filters are idempotent.
  206.            }
  207.                elsif ( ref $_->{SOURCE} eq "SCALAR"
  208.               || ref $_->{SOURCE} eq "GLOB"
  209.           || UNIVERSAL::isa( $_, "IO::Handle" )
  210.            ) {
  211.                   if ( $_->{KFD} == 0 ) {
  212.                      _debug
  213.                         "Win32 optimizer: (kid $kid->{NUM}) 0$_->{TYPE}",
  214.                         ref $_->{SOURCE},
  215.                         ", ok to optimize outputs"
  216.                         if _debugging_details;
  217.                      $ok_to_optimize_outputs = 1;
  218.                   }
  219.                   $_->{SEND_THROUGH_TEMP_FILE} = 1;
  220.                   next;
  221.                }
  222.                elsif ( ! ref $_->{SOURCE} && defined $_->{SOURCE} ) {
  223.                   if ( $_->{KFD} == 0 ) {
  224.                      _debug
  225.                         "Win32 optimizer: (kid $kid->{NUM}) 0<$_->{SOURCE}, ok to optimize outputs",
  226.                         if _debugging_details;
  227.                      $ok_to_optimize_outputs = 1;
  228.                   }
  229.                   next;
  230.                }
  231.             }
  232.             _debug
  233.                "Win32 optimizer: (kid $kid->{NUM}) ",
  234.                $_->{KFD},
  235.                $_->{TYPE},
  236.                defined $_->{SOURCE}
  237.                   ? ref $_->{SOURCE}      ? ref $_->{SOURCE}
  238.                                           : $_->{SOURCE}
  239.                   : defined $_->{FILENAME}
  240.                                           ? $_->{FILENAME}
  241.                                           : "",
  242.            @{$_->{FILTERS}} > 1 ? " with filters" : (),
  243.                ", VETOING output opt."
  244.                if _debugging_details || _debugging_not_optimized;
  245.             $veto_output_optimization = 1;
  246.          }
  247.          elsif ( $_->{TYPE} eq "close" && $_->{KFD} == 0 ) {
  248.             $ok_to_optimize_outputs = 1;
  249.             _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&-, ok to optimize outputs"
  250.                if _debugging_details;
  251.          }
  252.          elsif ( $_->{TYPE} eq "dup" && $_->{KFD2} == 0 ) {
  253.             $veto_output_optimization = 1;
  254.             _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&$_->{KFD2}, VETOING output opt."
  255.                if _debugging_details || _debugging_not_optimized;
  256.          }
  257.          elsif ( $_->{TYPE} eq "|" ) {
  258.             $saw_pipe = 1;
  259.          }
  260.       }
  261.  
  262.       if ( ! $ok_to_optimize_outputs && ! $veto_output_optimization ) {
  263.          _debug
  264.             "Win32 optimizer: (kid $kid->{NUM}) child STDIN not redirected, VETOING non-SCALAR output opt."
  265.             if _debugging_details || _debugging_not_optimized;
  266.          $veto_output_optimization = 1;
  267.       }
  268.  
  269.       if ( $ok_to_optimize_outputs && $veto_output_optimization ) {
  270.          $ok_to_optimize_outputs = 0;
  271.          _debug "Win32 optimizer: (kid $kid->{NUM}) non-SCALAR output optimizations VETOed"
  272.             if _debugging_details || _debugging_not_optimized;
  273.       }
  274.  
  275.       ## SOURCE/DEST ARRAY means it's a filter.
  276.       ## TODO: think about checking to see if the final input/output of
  277.       ## a filter chain (an ARRAY SOURCE or DEST) is a scalar...but
  278.       ## we may be deprecating filters.
  279.  
  280.       for ( @{$kid->{OPS}} ) {
  281.          if ( $_->{TYPE} eq ">" ) {
  282.             if ( ref $_->{DEST} eq "SCALAR"
  283.                || (
  284.                   ( @{$_->{FILTERS}} > 1
  285.              || ref $_->{DEST} eq "CODE"
  286.              || ref $_->{DEST} eq "ARRAY"  ## Filters?
  287.               )
  288.                   && ( $ok_to_optimize_outputs && ! $veto_output_optimization ) 
  289.                )
  290.             ) {
  291.            $_->{RECV_THROUGH_TEMP_FILE} = 1;
  292.            next;
  293.             }
  294.         _debug
  295.            "Win32 optimizer: NOT optimizing (kid $kid->{NUM}) ",
  296.            $_->{KFD},
  297.            $_->{TYPE},
  298.            defined $_->{DEST}
  299.           ? ref $_->{DEST}      ? ref $_->{DEST}
  300.                       : $_->{SOURCE}
  301.           : defined $_->{FILENAME}
  302.                       ? $_->{FILENAME}
  303.                       : "",
  304.           @{$_->{FILTERS}} ? " with filters" : (),
  305.            if _debugging_details;
  306.          }
  307.       }
  308.    }
  309.  
  310. }
  311.  
  312. =item win32_parse_cmd_line
  313.  
  314.    @words = win32_parse_cmd_line( q{foo bar 'baz baz' "bat bat"} ) ;
  315.  
  316. returns 4 words. This parses like the bourne shell (see
  317. the bit about shellwords() in L<Text::ParseWords>), assuming we're
  318. trying to be a little cross-platform here.  The only difference is
  319. that "\" is *not* treated as an escape except when it precedes 
  320. punctuation, since it's used all over the place in DOS path specs.
  321.  
  322. TODO: globbing? probably not (it's unDOSish).
  323.  
  324. TODO: shebang emulation? Probably, but perhaps that should be part
  325. of Run.pm so all spawned processes get the benefit.
  326.  
  327. LIMITATIONS: shellwords dies silently on malformed input like 
  328.  
  329.    a\"
  330.  
  331. =cut
  332.  
  333. sub win32_parse_cmd_line {
  334.    my $line = shift ;
  335.    $line =~ s{(\\[\w\s])}{\\$1}g ;
  336.    return shellwords $line ;
  337. }
  338.  
  339.  
  340. =item win32_spawn
  341.  
  342. Spawns a child process, possibly with STDIN, STDOUT, and STDERR (file descriptors 0, 1, and 2, respectively) redirected.
  343.  
  344. B<LIMITATIONS>.
  345.  
  346. Cannot redirect higher file descriptors due to lack of support for this in the
  347. Win32 environment.
  348.  
  349. This can be worked around by marking a handle as inheritable in the
  350. parent (or leaving it marked; this is the default in perl), obtaining it's
  351. Win32 handle with C<Win32API::GetOSFHandle(FH)> or
  352. C<Win32API::FdGetOsFHandle($fd)> and passing it to the child using the command
  353. line, the environment, or any other IPC mechanism (it's a plain old integer).
  354. The child can then use C<OsFHandleOpen()> or C<OsFHandleOpenFd()> and possibly
  355. C<<open FOO ">&BAR">> or C<<open FOO ">&$fd>> as need be.  Ach, the pain!
  356.  
  357. Remember to check the Win32 handle against INVALID_HANDLE_VALUE.
  358.  
  359. =cut
  360.  
  361. sub _save {
  362.    my ( $saved, $saved_as, $fd ) = @_ ;
  363.  
  364.    ## We can only save aside the original fds once.
  365.    return if exists $saved->{$fd} ;
  366.  
  367.    my $saved_fd = IPC::Run::_dup( $fd ) ;
  368.    _dont_inherit $saved_fd ;
  369.  
  370.    $saved->{$fd} = $saved_fd ;
  371.    $saved_as->{$saved_fd} = $fd ;
  372.  
  373.    _dont_inherit $saved->{$fd} ;
  374. }
  375.  
  376. sub _dup2_gently {
  377.    my ( $saved, $saved_as, $fd1, $fd2 ) = @_ ;
  378.    _save $saved, $saved_as, $fd2 ;
  379.  
  380.    if ( exists $saved_as->{$fd2} ) {
  381.       ## The target fd is colliding with a saved-as fd, gotta bump
  382.       ## the saved-as fd to another fd.
  383.       my $orig_fd = delete $saved_as->{$fd2} ;
  384.       my $saved_fd = IPC::Run::_dup( $fd2 ) ;
  385.       _dont_inherit $saved_fd ;
  386.  
  387.       $saved->{$orig_fd} = $saved_fd ;
  388.       $saved_as->{$saved_fd} = $orig_fd ;
  389.    }
  390.    _debug "moving $fd1 to kid's $fd2" if _debugging_details ;
  391.    IPC::Run::_dup2_rudely( $fd1, $fd2 ) ;
  392. }
  393.  
  394. sub win32_spawn {
  395.    my ( $cmd, $ops) = @_ ;
  396.  
  397.    ## NOTE: The debug pipe write handle is passed to pump processes as STDOUT.
  398.    ## and is not to the "real" child process, since they would not know
  399.    ## what to do with it...unlike Unix, we have no code executing in the
  400.    ## child before the "real" child is exec()ed.
  401.    
  402.    my %saved ;      ## Map of parent's orig fd -> saved fd
  403.    my %saved_as ;   ## Map of parent's saved fd -> orig fd, used to
  404.                     ## detect collisions between a KFD and the fd a
  405.             ## parent's fd happened to be saved to.
  406.    
  407.    for my $op ( @$ops ) {
  408.       _dont_inherit $op->{FD}  if defined $op->{FD} ;
  409.  
  410.       if ( defined $op->{KFD} && $op->{KFD} > 2 ) {
  411.      ## TODO: Detect this in harness()
  412.      ## TODO: enable temporary redirections if ever necessary, not
  413.      ## sure why they would be...
  414.      ## 4>&1 1>/dev/null 1>&4 4>&-
  415.          croak "Can't redirect fd #", $op->{KFD}, " on Win32" ;
  416.       }
  417.  
  418.       ## This is very similar logic to IPC::Run::_do_kid_and_exit().
  419.       if ( defined $op->{TFD} ) {
  420.      unless ( $op->{TFD} == $op->{KFD} ) {
  421.         _dup2_gently \%saved, \%saved_as, $op->{TFD}, $op->{KFD} ;
  422.         _dont_inherit $op->{TFD} ;
  423.      }
  424.       }
  425.       elsif ( $op->{TYPE} eq "dup" ) {
  426.          _dup2_gently \%saved, \%saved_as, $op->{KFD1}, $op->{KFD2}
  427.             unless $op->{KFD1} == $op->{KFD2} ;
  428.       }
  429.       elsif ( $op->{TYPE} eq "close" ) {
  430.      _save \%saved, \%saved_as, $op->{KFD} ;
  431.      IPC::Run::_close( $op->{KFD} ) ;
  432.       }
  433.       elsif ( $op->{TYPE} eq "init" ) {
  434.      ## TODO: detect this in harness()
  435.          croak "init subs not allowed on Win32" ;
  436.       }
  437.    }
  438.  
  439.    my $process ;
  440.    my $cmd_line = join " ", map {
  441.       ( my $s = $_ ) =~ s/"/"""/g;
  442.       $s = qq{"$s"} if /["\s]/;
  443.       $s ;
  444.    } @$cmd ;
  445.  
  446.    _debug "cmd line: ", $cmd_line
  447.       if _debugging;
  448.  
  449.    Win32::Process::Create( 
  450.       $process,
  451.       $cmd->[0],
  452.       $cmd_line,
  453.       1,  ## Inherit handles
  454.       NORMAL_PRIORITY_CLASS,
  455.       ".",
  456.    ) or croak "$!: Win32::Process::Create()" ;
  457.  
  458.    for my $orig_fd ( keys %saved ) {
  459.       IPC::Run::_dup2_rudely( $saved{$orig_fd}, $orig_fd ) ;
  460.       IPC::Run::_close( $saved{$orig_fd} ) ;
  461.    }
  462.  
  463.    return ( $process->GetProcessID(), $process ) ;
  464. }
  465.  
  466.  
  467. =back
  468.  
  469. =head1 AUTHOR
  470.  
  471. Barries Slaymaker <barries@slaysys.com>.  Funded by Perforce Software, Inc.
  472.  
  473. =head1 COPYRIGHT
  474.  
  475. Copyright 2001, Barrie Slaymaker, All Rights Reserved.
  476.  
  477. You may use this under the terms of either the GPL 2.0 ir the Artistic License.
  478.  
  479. =cut
  480.  
  481. 1 ;
  482.