Logo AND Algorithmique Numérique Distribuée

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