1 package IPC::Run::Win32IO;
7 IPC::Run::Win32IO - helper routines for IPC::Run on Win32 platforms.
11 use IPC::Run::Win32IO; # Exports all by default
15 IPC::Run needs to use sockets to redirect subprocess I/O so that the select()
16 loop will work on Win32. This seems to only work on WinNT and Win2K at this
17 time, not sure if it will ever work on Win95 or Win98. If you have experience
18 in this area, please contact me at barries@slaysys.com, thanks!.
22 A specialized IO class used on Win32.
32 use vars qw{$VERSION};
37 use Socket qw( IPPROTO_TCP TCP_NODELAY );
41 use IPC::Run::Debug qw( :default _debugging_level );
42 use IPC::Run::Win32Helper qw( _inherit _dont_inherit );
43 use Fcntl qw( O_TEXT O_RDONLY );
45 use base qw( IPC::Run::IO );
48 ## These fields will be set to undef in _cleanup to close
51 'SEND_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()
52 'RECV_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()
53 'TEMP_FILE_NAME', ## The name of the temp file, needed for
54 ## error reporting / debugging only.
56 'PARENT_HANDLE', ## The handle of the socket for the parent
57 'PUMP_SOCKET_HANDLE', ## The socket handle for the pump
58 'PUMP_PIPE_HANDLE', ## The anon pipe handle for the pump
59 'CHILD_HANDLE', ## The anon pipe handle for the child
61 'TEMP_FILE_HANDLE', ## The Win32 filehandle for the temp file
65 ## REMOVE OSFHandleOpen
66 use Win32API::File qw(
81 FILE_ATTRIBUTE_TEMPORARY
82 FILE_FLAG_DELETE_ON_CLOSE
83 FILE_FLAG_WRITE_THROUGH
88 # FILE_ATTRIBUTE_HIDDEN
89 # FILE_ATTRIBUTE_SYSTEM
93 ## Force AUTOLOADED constants to be, well, constant by getting them
94 ## to AUTOLOAD before compilation continues. Sigh.
101 INVALID_HANDLE_VALUE,
105 use constant temp_file_flags => (
106 FILE_ATTRIBUTE_TEMPORARY() |
107 FILE_FLAG_DELETE_ON_CLOSE() |
108 FILE_FLAG_WRITE_THROUGH()
111 # FILE_ATTRIBUTE_HIDDEN() |
112 # FILE_ATTRIBUTE_SYSTEM() |
113 my $tmp_file_counter;
117 my IPC::Run::Win32IO $self = shift;
118 my ( $harness ) = @_;
120 $self->_recv_through_temp_file( $harness )
121 if $self->{RECV_THROUGH_TEMP_FILE};
123 CloseHandle( $self->{TEMP_FILE_HANDLE} )
124 if defined $self->{TEMP_FILE_HANDLE};
126 $self->{$_} = undef for @cleanup_fields;
130 sub _create_temp_file {
131 my IPC::Run::Win32IO $self = shift;
133 ## Create a hidden temp file that Win32 will delete when we close
135 unless ( defined $tmp_dir ) {
136 $tmp_dir = File::Spec->catdir(
137 File::Spec->tmpdir, "IPC-Run.tmp"
140 ## Trust in the user's umask.
141 ## This could possibly be a security hole, perhaps
142 ## we should offer an option. Hmmmm, really, people coding
143 ## security conscious apps should audit this code and
144 ## tell me how to make it better. Nice cop-out :).
145 unless ( -d $tmp_dir ) {
146 mkdir $tmp_dir or croak "$!: $tmp_dir";
150 $self->{TEMP_FILE_NAME} = File::Spec->catfile(
151 ## File name is designed for easy sorting and not conflicting
152 ## with other processes. This should allow us to use "t"runcate
153 ## access in CreateFile in case something left some droppings
154 ## around (which should never happen because we specify
155 ## FLAG_DELETE_ON_CLOSE.
156 ## heh, belt and suspenders are better than bug reports; God forbid
157 ## that NT should ever crash before a temp file gets deleted!
158 $tmp_dir, sprintf "Win32io-%06d-%08d", $$, $tmp_file_counter++
161 $self->{TEMP_FILE_HANDLE} = createFile(
162 $self->{TEMP_FILE_NAME},
163 "trw", ## new, truncate, read, write
165 Flags => temp_file_flags,
167 ) or croak "Can't create temporary file, $self->{TEMP_FILE_NAME}: $^E";
169 $self->{TFD} = OsFHandleOpenFd $self->{TEMP_FILE_HANDLE}, 0;
173 "Win32 Optimizer: temp file (",
178 $self->{TEMP_FILE_HANDLE},
180 $self->{TEMP_FILE_NAME}
181 if _debugging_details;
185 sub _reset_temp_file_pointer {
187 SetFilePointer( $self->{TEMP_FILE_HANDLE}, 0, 0, FILE_BEGIN )
188 or confess "$^E seeking on (fd $self->{TFD}) $self->{TEMP_FILE_NAME} for kid's fd $self->{KFD}";
192 sub _send_through_temp_file {
193 my IPC::Run::Win32IO $self = shift;
196 "Win32 optimizer: optimizing "
197 . " $self->{KFD} $self->{TYPE} temp file instead of ",
198 ref $self->{SOURCE} || $self->{SOURCE}
199 if _debugging_details;
201 $self->_create_temp_file;
203 if ( defined ${$self->{SOURCE}} ) {
204 my $bytes_written = 0;
206 if ( $self->binmode ) {
207 $data_ref = $self->{SOURCE};
210 my $data = ${$self->{SOURCE}}; # Ugh, a copy.
211 $data =~ s/(?<!\r)\n/\r\n/g;
216 $self->{TEMP_FILE_HANDLE},
218 0, ## Write entire buffer
220 [], ## Not overlapped.
222 "$^E writing $self->{TEMP_FILE_NAME} for kid to read on fd $self->{KFD}";
224 "Win32 optimizer: wrote $bytes_written to temp file $self->{TEMP_FILE_NAME}"
227 $self->_reset_temp_file_pointer;
232 _debug "Win32 optimizer: kid to read $self->{KFD} from temp file on $self->{TFD}"
233 if _debugging_details;
237 sub _init_recv_through_temp_file {
238 my IPC::Run::Win32IO $self = shift;
240 $self->_create_temp_file;
244 ## TODO: Use the Win32 API in the select loop to see if the file has grown
245 ## and read it incrementally if it has.
246 sub _recv_through_temp_file {
247 my IPC::Run::Win32IO $self = shift;
249 ## This next line kicks in if the run() never got to initting things
250 ## and needs to clean up.
251 return undef unless defined $self->{TEMP_FILE_HANDLE};
253 push @{$self->{FILTERS}}, sub {
254 my ( undef, $out_ref ) = @_;
256 return undef unless defined $self->{TEMP_FILE_HANDLE};
261 $self->{TEMP_FILE_HANDLE},
263 999_999, ## Hmmm, should read the size.
266 ) or croak "$^E reading from $self->{TEMP_FILE_NAME}";
268 _debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data;
270 return undef unless $r;
272 $s =~ s/\r\n/\n/g unless $self->binmode;
274 my $pos = pos $$out_ref;
276 pos( $out_ref ) = $pos;
280 my ( $harness ) = @_;
282 $self->_reset_temp_file_pointer;
284 1 while $self->_do_filters( $harness );
286 pop @{$self->{FILTERS}};
288 IPC::Run::_close( $self->{TFD} );
297 Windows version of IPC::Run::IP::poll.
304 my IPC::Run::Win32IO $self = shift;
306 return if $self->{SEND_THROUGH_TEMP_FILE} || $self->{RECV_THROUGH_TEMP_FILE};
308 return $self->SUPER::poll( @_ );
312 ## When threaded Perls get good enough, we should use threads here.
313 ## The problem with threaded perls is that they dup() all sorts of
314 ## filehandles and fds and don't allow sufficient control over
315 ## closing off the ones we don't want.
318 my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_;
319 my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout );
321 _debug "pumper stdin = ", $stdin_fd if _debugging_details;
322 _debug "pumper stdout = ", $stdout_fd if _debugging_details;
323 _inherit $stdin_fd, $stdout_fd, $debug_fd;
324 my @I_options = map qq{"-I$_"}, @INC;
326 my $cmd_line = join( " ",
329 qw(-MIPC::Run::Win32Pump -e 1 ),
330 ## I'm using this clunky way of passing filehandles to the child process
331 ## in order to avoid some kind of premature closure of filehandles
332 ## problem I was having with VCP's test suite when passing them
333 ## via CreateProcess. All of the ## REMOVE code is stuff I'd like
334 ## to be rid of and the ## ADD code is what I'd like to use.
335 FdGetOsFHandle( $stdin_fd ), ## REMOVE
336 FdGetOsFHandle( $stdout_fd ), ## REMOVE
337 FdGetOsFHandle( $debug_fd ), ## REMOVE
339 $$, $^T, _debugging_level, qq{"$child_label"},
343 # open SAVEIN, "<&STDIN" or croak "$! saving STDIN"; #### ADD
344 # open SAVEOUT, ">&STDOUT" or croak "$! saving STDOUT"; #### ADD
345 # open SAVEERR, ">&STDERR" or croak "$! saving STDERR"; #### ADD
346 # _dont_inherit \*SAVEIN; #### ADD
347 # _dont_inherit \*SAVEOUT; #### ADD
348 # _dont_inherit \*SAVEERR; #### ADD
349 # open STDIN, "<&$stdin_fd" or croak "$! dup2()ing $stdin_fd (pumper's STDIN)"; #### ADD
350 # open STDOUT, ">&$stdout_fd" or croak "$! dup2()ing $stdout_fd (pumper's STDOUT)"; #### ADD
351 # open STDERR, ">&$debug_fd" or croak "$! dup2()ing $debug_fd (pumper's STDERR/debug_fd)"; #### ADD
353 _debug "pump cmd line: ", $cmd_line if _debugging_details;
356 Win32::Process::Create(
360 1, ## Inherit handles
361 NORMAL_PRIORITY_CLASS,
363 ) or croak "$!: Win32::Process::Create()";
365 # open STDIN, "<&SAVEIN" or croak "$! restoring STDIN"; #### ADD
366 # open STDOUT, ">&SAVEOUT" or croak "$! restoring STDOUT"; #### ADD
367 # open STDERR, ">&SAVEERR" or croak "$! restoring STDERR"; #### ADD
368 # close SAVEIN or croak "$! closing SAVEIN"; #### ADD
369 # close SAVEOUT or croak "$! closing SAVEOUT"; #### ADD
370 # close SAVEERR or croak "$! closing SAVEERR"; #### ADD
372 close $stdin or croak "$! closing pumper's stdin in parent";
373 close $stdout or croak "$! closing pumper's stdout in parent";
374 # Don't close $debug_fd, we need it, as do other pumpers.
376 # Pause a moment to allow the child to get up and running and emit
377 # debug messages. This does not always work.
378 # select undef, undef, undef, 1 if _debugging_details;
380 _debug "_spawn_pumper pid = ", $process->GetProcessID
385 my $next_port = 2048;
386 my $loopback = inet_aton "127.0.0.1";
387 my $tcp_proto = getprotobyname('tcp');
388 croak "$!: getprotobyname('tcp')" unless defined $tcp_proto;
395 my $listener = gensym;
396 socket $listener, PF_INET, SOCK_STREAM, $tcp_proto
397 or croak "$!: socket()";
398 setsockopt $listener, SOL_SOCKET, SO_REUSEADDR, pack("l", 0)
399 or croak "$!: setsockopt()";
406 $next_port = 2048 if ++$next_port > 65_535;
407 unless ( bind $listener, sockaddr_in( $port, $loopback ) ) {
408 push @errors, "$! on port $port";
409 croak join "\n", @errors if @errors > 10;
410 goto PORT_FINDER_LOOP;
414 _debug "win32 port = $port" if _debugging_details;
416 listen $listener, my $queue_size = 1
417 or croak "$!: listen()";
420 socket $client, PF_INET, SOCK_STREAM, $tcp_proto
421 or croak "$!: socket()";
423 my $paddr = sockaddr_in($port, $loopback );
425 connect $client, $paddr
426 or croak "$!: connect()";
428 croak "$!: accept" unless defined $paddr;
430 ## The windows "default" is SO_DONTLINGER, which should make
431 ## sure all socket data goes through. I have my doubts based
432 ## on experimentation, but nothing prompts me to set SO_LINGER
434 setsockopt $client, IPPROTO_TCP, TCP_NODELAY, pack("l", 0)
435 or croak "$!: setsockopt()";
439 _debug "accept()ing on port $port" if _debugging_details;
440 my $paddr = accept( $server, $listener );
441 croak "$!: accept()" unless defined $paddr;
445 "win32 _socket = ( ", fileno $server, ", ", fileno $client, " ) on port $port"
446 if _debugging_details;
447 return ( $server, $client );
451 sub _open_socket_pipe {
452 my IPC::Run::Win32IO $self = shift;
453 my ( $debug_fd, $parent_handle ) = @_;
455 my $is_send_to_child = $self->dir eq "<";
457 $self->{CHILD_HANDLE} = gensym;
458 $self->{PUMP_PIPE_HANDLE} = gensym;
461 $self->{PARENT_HANDLE},
462 $self->{PUMP_SOCKET_HANDLE}
463 ) = _socket $parent_handle;
465 ## These binmodes seem to have no effect on Win2K, but just to be safe
467 binmode $self->{PARENT_HANDLE} or die $!;
468 binmode $self->{PUMP_SOCKET_HANDLE} or die $!;
470 _debug "PUMP_SOCKET_HANDLE = ", fileno $self->{PUMP_SOCKET_HANDLE}
471 if _debugging_details;
473 ##$buf = "write on child end of " . fileno( $self->{WRITE_HANDLE} ) . "\n\n\n\n\n";
474 ##POSIX::write(fileno $self->{WRITE_HANDLE}, $buf, length $buf) or warn "$! in syswrite";
475 ##$buf = "write on parent end of " . fileno( $self->{CHILD_HANDLE} ) . "\r\n";
476 ##POSIX::write(fileno $self->{CHILD_HANDLE},$buf, length $buf) or warn "$! in syswrite";
477 ## $self->{CHILD_HANDLE}->autoflush( 1 );
478 ## $self->{WRITE_HANDLE}->autoflush( 1 );
480 ## Now fork off a data pump and arrange to return the correct fds.
481 if ( $is_send_to_child ) {
482 pipe $self->{CHILD_HANDLE}, $self->{PUMP_PIPE_HANDLE}
483 or croak "$! opening child pipe";
484 _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
485 if _debugging_details;
486 _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
487 if _debugging_details;
490 pipe $self->{PUMP_PIPE_HANDLE}, $self->{CHILD_HANDLE}
491 or croak "$! opening child pipe";
492 _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
493 if _debugging_details;
494 _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
495 if _debugging_details;
498 ## These binmodes seem to have no effect on Win2K, but just to be safe
500 binmode $self->{CHILD_HANDLE};
501 binmode $self->{PUMP_PIPE_HANDLE};
503 ## No child should ever see this.
504 _dont_inherit $self->{PARENT_HANDLE};
506 ## We clear the inherit flag so these file descriptors are not inherited.
507 ## It'll be dup()ed on to STDIN/STDOUT/STDERR before CreateProcess is
508 ## called and *that* fd will be inheritable.
509 _dont_inherit $self->{PUMP_SOCKET_HANDLE};
510 _dont_inherit $self->{PUMP_PIPE_HANDLE};
511 _dont_inherit $self->{CHILD_HANDLE};
513 ## Need to return $self so the HANDLEs don't get freed.
514 ## Return $self, $parent_fd, $child_fd
515 my ( $parent_fd, $child_fd ) = (
516 fileno $self->{PARENT_HANDLE},
517 fileno $self->{CHILD_HANDLE}
520 ## Both PUMP_..._HANDLEs will be closed, no need to worry about
522 _debug "binmode on" if _debugging_data && $self->binmode;
525 ? ( $self->{PUMP_SOCKET_HANDLE}, $self->{PUMP_PIPE_HANDLE} )
526 : ( $self->{PUMP_PIPE_HANDLE}, $self->{PUMP_SOCKET_HANDLE} ),
529 $child_fd . $self->dir . "pump" . $self->dir . $parent_fd,
534 confess "PARENT_HANDLE no longer open"
535 unless POSIX::read( $parent_fd, $foo, 0 );
538 _debug "win32_fake_pipe = ( $parent_fd, $child_fd )"
539 if _debugging_details;
541 $self->{FD} = $parent_fd;
542 $self->{TFD} = $child_fd;
546 my IPC::Run::Win32IO $self = shift;
548 if ( $self->{SEND_THROUGH_TEMP_FILE} ) {
549 return $self->_send_through_temp_file( @_ );
551 elsif ( $self->{RECV_THROUGH_TEMP_FILE} ) {
552 return $self->_init_recv_through_temp_file( @_ );
555 return $self->_open_socket_pipe( @_ );
565 Barries Slaymaker <barries@slaysys.com>. Funded by Perforce Software, Inc.
569 Copyright 2001, Barrie Slaymaker, All Rights Reserved.
571 You may use this under the terms of either the GPL 2.0 or the Artistic License.