File: Win32IO.pm

package info (click to toggle)
libipc-run-perl 0.80-2
  • links: PTS, VCS
  • area: main
  • in suites: lenny
  • size: 452 kB
  • ctags: 186
  • sloc: perl: 5,317; makefile: 44
file content (556 lines) | stat: -rwxr-xr-x 16,274 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
package IPC::Run::Win32IO;

=head1 NAME

IPC::Run::Win32IO - helper routines for IPC::Run on Win32 platforms.

=head1 SYNOPSIS

    use IPC::Run::Win32IO;   # 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

=head1 DESCRIPTION

A specialized IO class used on Win32.

=cut

use strict ;
use Carp ;
use IO::Handle ;
use Socket ;
require POSIX ;

use Socket qw( IPPROTO_TCP TCP_NODELAY ) ;
use Symbol ;
use Text::ParseWords ;
use Win32::Process ;
use IPC::Run::Debug qw( :default _debugging_level );
use IPC::Run::Win32Helper qw( _inherit _dont_inherit );
use Fcntl qw( O_TEXT O_RDONLY );

use base qw( IPC::Run::IO );
my @cleanup_fields;
BEGIN {
   ## These fields will be set to undef in _cleanup to close
   ## the handles.
   @cleanup_fields = (
      'SEND_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()
      'RECV_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()
      'TEMP_FILE_NAME',         ## The name of the temp file, needed for
                                ## error reporting / debugging only.

      'PARENT_HANDLE',       ## The handle of the socket for the parent
      'PUMP_SOCKET_HANDLE',  ## The socket handle for the pump
      'PUMP_PIPE_HANDLE',    ## The anon pipe handle for the pump
      'CHILD_HANDLE',        ## The anon pipe handle for the child

      'TEMP_FILE_HANDLE',    ## The Win32 filehandle for the temp file
   );
}

## REMOVE OSFHandleOpen
use Win32API::File qw(
   GetOsFHandle
   OsFHandleOpenFd
   OsFHandleOpen
   FdGetOsFHandle
   SetHandleInformation
   SetFilePointer
   HANDLE_FLAG_INHERIT
   INVALID_HANDLE_VALUE

   createFile
   WriteFile
   ReadFile
   CloseHandle

   FILE_ATTRIBUTE_TEMPORARY
   FILE_FLAG_DELETE_ON_CLOSE
   FILE_FLAG_WRITE_THROUGH

   FILE_BEGIN
) ;

#   FILE_ATTRIBUTE_HIDDEN
#   FILE_ATTRIBUTE_SYSTEM


BEGIN {
   ## Force AUTOLOADED constants to be, well, constant by getting them
   ## to AUTOLOAD before compilation continues.  Sigh.
   () = (
      SOL_SOCKET,
      SO_REUSEADDR,
      IPPROTO_TCP,
      TCP_NODELAY,
      HANDLE_FLAG_INHERIT,
      INVALID_HANDLE_VALUE,
   );
}


use constant temp_file_flags => (
   FILE_ATTRIBUTE_TEMPORARY()   |
   FILE_FLAG_DELETE_ON_CLOSE()  |
   FILE_FLAG_WRITE_THROUGH()
);

#   FILE_ATTRIBUTE_HIDDEN()    |
#   FILE_ATTRIBUTE_SYSTEM()    |
my $tmp_file_counter;
my $tmp_dir;

sub _cleanup {
    my IPC::Run::Win32IO $self = shift;
    my ( $harness ) = @_;

    $self->_recv_through_temp_file( $harness )
       if $self->{RECV_THROUGH_TEMP_FILE};

    CloseHandle( $self->{TEMP_FILE_HANDLE} )
       if defined $self->{TEMP_FILE_HANDLE};

    $self->{$_} = undef for @cleanup_fields;
}


sub _create_temp_file {
   my IPC::Run::Win32IO $self = shift;

   ## Create a hidden temp file that Win32 will delete when we close
   ## it.
   unless ( defined $tmp_dir ) {
      $tmp_dir = File::Spec->catdir(
         File::Spec->tmpdir, "IPC-Run.tmp"
      );

      ## Trust in the user's umask.
      ## This could possibly be a security hole, perhaps
      ## we should offer an option.  Hmmmm, really, people coding
      ## security conscious apps should audit this code and
      ## tell me how to make it better.  Nice cop-out :).
      unless ( -d $tmp_dir ) {
         mkdir $tmp_dir or croak "$!: $tmp_dir";
      }
   }

   $self->{TEMP_FILE_NAME} = File::Spec->catfile(
      ## File name is designed for easy sorting and not conflicting
      ## with other processes.  This should allow us to use "t"runcate
      ## access in CreateFile in case something left some droppings
      ## around (which should never happen because we specify
      ## FLAG_DELETE_ON_CLOSE.
      ## heh, belt and suspenders are better than bug reports; God forbid
      ## that NT should ever crash before a temp file gets deleted!
      $tmp_dir, sprintf "Win32io-%06d-%08d", $$, $tmp_file_counter++
   );

   $self->{TEMP_FILE_HANDLE} = createFile(
      $self->{TEMP_FILE_NAME},
      "trw",         ## new, truncate, read, write
      {
         Flags      => temp_file_flags,
      },
   ) or croak "Can't create temporary file, $self->{TEMP_FILE_NAME}: $^E";

   $self->{TFD} = OsFHandleOpenFd $self->{TEMP_FILE_HANDLE}, 0;
   $self->{FD} = undef;

   _debug
      "Win32 Optimizer: temp file (",
      $self->{KFD},
      $self->{TYPE},
      $self->{TFD},
      ", fh ",
      $self->{TEMP_FILE_HANDLE},
      "): ",
      $self->{TEMP_FILE_NAME}
      if _debugging_details;
}


sub _reset_temp_file_pointer {
   my $self = shift;
   SetFilePointer( $self->{TEMP_FILE_HANDLE}, 0, 0, FILE_BEGIN )
      or confess "$^E seeking on (fd $self->{TFD}) $self->{TEMP_FILE_NAME} for kid's fd $self->{KFD}";
}


sub _send_through_temp_file {
   my IPC::Run::Win32IO $self = shift;

   _debug
      "Win32 optimizer: optimizing "
      . " $self->{KFD} $self->{TYPE} temp file instead of ",
         ref $self->{SOURCE} || $self->{SOURCE}
      if _debugging_details;

   $self->_create_temp_file;

   if ( defined ${$self->{SOURCE}} ) {
      my $bytes_written = 0;
      my $data_ref;
      if ( $self->binmode ) {
	 $data_ref = $self->{SOURCE};
      }
      else {
         my $data = ${$self->{SOURCE}};  # Ugh, a copy.
	 $data =~ s/(?<!\r)\n/\r\n/g;
	 $data_ref = \$data;
      }

      WriteFile(
         $self->{TEMP_FILE_HANDLE},
         $$data_ref,
         0,              ## Write entire buffer
         $bytes_written,
         [],             ## Not overlapped.
      ) or croak
         "$^E writing $self->{TEMP_FILE_NAME} for kid to read on fd $self->{KFD}";
      _debug
         "Win32 optimizer: wrote $bytes_written to temp file $self->{TEMP_FILE_NAME}"
         if _debugging_data;

      $self->_reset_temp_file_pointer;

   }


   _debug "Win32 optimizer: kid to read $self->{KFD} from temp file on $self->{TFD}"
      if _debugging_details;
}


sub _init_recv_through_temp_file {
   my IPC::Run::Win32IO $self = shift;

   $self->_create_temp_file;
}


## TODO: USe the Win32 API in the select loop to see if the file has grown
## and read it incrementally if it has.
sub _recv_through_temp_file {
   my IPC::Run::Win32IO $self = shift;

   ## This next line kicks in if the run() never got to initting things
   ## and needs to clean up.
   return undef unless defined $self->{TEMP_FILE_HANDLE};

   push @{$self->{FILTERS}}, sub {
      my ( undef, $out_ref ) = @_;

      return undef unless defined $self->{TEMP_FILE_HANDLE};

      my $r;
      my $s;
      ReadFile(
	 $self->{TEMP_FILE_HANDLE},
	 $s,
	 999_999,  ## Hmmm, should read the size.
	 $r,
	 []
      ) or croak "$^E reading from $self->{TEMP_FILE_NAME}";

      _debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data ;

      return undef unless $r;

      $s =~ s/\r\n/\n/g unless $self->binmode;

      my $pos = pos $$out_ref;
      $$out_ref .= $s;
      pos( $out_ref ) = $pos;
      return 1;
   };

   my ( $harness ) = @_;

   $self->_reset_temp_file_pointer;

   1 while $self->_do_filters( $harness );

   pop @{$self->{FILTERS}};

   IPC::Run::_close( $self->{TFD} );
}


sub poll {
   my IPC::Run::Win32IO $self = shift;

   return if $self->{SEND_THROUGH_TEMP_FILE} || $self->{RECV_THROUGH_TEMP_FILE};

   return $self->SUPER::poll( @_ );
}


## When threaded Perls get good enough, we should use threads here.
## The problem with threaded perls is that they dup() all sorts of
## filehandles and fds and don't allow sufficient control over
## closing off the ones we don't want.

sub _spawn_pumper {
   my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_ ;
   my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout ) ;

   _debug "pumper stdin = ", $stdin_fd if _debugging_details;
   _debug "pumper stdout = ", $stdout_fd if _debugging_details;
   _inherit $stdin_fd, $stdout_fd, $debug_fd ;
   my @I_options = map qq{"-I$_"}, @INC;

   my $cmd_line = join( " ",
      qq{"$^X"},
      @I_options,
      qw(-MIPC::Run::Win32Pump -e 1 ),
## I'm using this clunky way of passing filehandles to the child process
## in order to avoid some kind of premature closure of filehandles
## problem I was having with VCP's test suite when passing them
## via CreateProcess.  All of the ## REMOVE code is stuff I'd like
## to be rid of and the ## ADD code is what I'd like to use.
      FdGetOsFHandle( $stdin_fd ), ## REMOVE
      FdGetOsFHandle( $stdout_fd ), ## REMOVE
      FdGetOsFHandle( $debug_fd ), ## REMOVE
      $binmode ? 1 : 0,
      $$, $^T, _debugging_level, qq{"$child_label"},
      @opts
   ) ;

#   open SAVEIN,  "<&STDIN"  or croak "$! saving STDIN" ;       #### ADD
#   open SAVEOUT, ">&STDOUT" or croak "$! saving STDOUT" ;       #### ADD
#   open SAVEERR, ">&STDERR" or croak "$! saving STDERR" ;       #### ADD
#   _dont_inherit \*SAVEIN ;       #### ADD
#   _dont_inherit \*SAVEOUT ;       #### ADD
#   _dont_inherit \*SAVEERR ;       #### ADD
#   open STDIN,  "<&$stdin_fd"  or croak "$! dup2()ing $stdin_fd (pumper's STDIN)" ;       #### ADD
#   open STDOUT, ">&$stdout_fd" or croak "$! dup2()ing $stdout_fd (pumper's STDOUT)" ;       #### ADD
#   open STDERR, ">&$debug_fd" or croak "$! dup2()ing $debug_fd (pumper's STDERR/debug_fd)" ;       #### ADD

   _debug "pump cmd line: ", $cmd_line if _debugging_details;

   my $process ;
   Win32::Process::Create( 
      $process,
      $^X,
      $cmd_line,
      1,  ## Inherit handles
      NORMAL_PRIORITY_CLASS,
      ".",
   ) or croak "$!: Win32::Process::Create()" ;

#   open STDIN,  "<&SAVEIN"  or croak "$! restoring STDIN" ;       #### ADD
#   open STDOUT, ">&SAVEOUT" or croak "$! restoring STDOUT" ;       #### ADD
#   open STDERR, ">&SAVEERR" or croak "$! restoring STDERR" ;       #### ADD
#   close SAVEIN             or croak "$! closing SAVEIN" ;       #### ADD
#   close SAVEOUT            or croak "$! closing SAVEOUT" ;       #### ADD
#   close SAVEERR            or croak "$! closing SAVEERR" ;       #### ADD

   close $stdin  or croak "$! closing pumper's stdin in parent" ;
   close $stdout or croak "$! closing pumper's stdout in parent" ;
   # Don't close $debug_fd, we need it, as do other pumpers.

   # Pause a moment to allow the child to get up and running and emit
   # debug messages.  This does not always work.
   #   select undef, undef, undef, 1 if _debugging_details ;

   _debug "_spawn_pumper pid = ", $process->GetProcessID 
      if _debugging_data;
}


my $next_port = 2048 ;
my $loopback  = inet_aton "127.0.0.1" ;
my $tcp_proto = getprotobyname('tcp');
croak "$!: getprotobyname('tcp')" unless defined $tcp_proto ;

sub _socket {
   my ( $server ) = @_ ;
   $server ||= gensym ;
   my $client = gensym ;

   my $listener = gensym ;
   socket $listener, PF_INET, SOCK_STREAM, $tcp_proto
      or croak "$!: socket()";
   setsockopt $listener, SOL_SOCKET, SO_REUSEADDR, pack("l", 0)
      or croak "$!: setsockopt()";

   my $port ;
   my @errors ;
PORT_FINDER_LOOP:
   {
      $port = $next_port ;
      $next_port = 2048 if ++$next_port > 65_535 ; 
      unless ( bind $listener, sockaddr_in( $port, INADDR_ANY ) ) {
	 push @errors, "$! on port $port" ;
	 croak join "\n", @errors if @errors > 10 ;
         goto PORT_FINDER_LOOP;
      }
   }

   _debug "win32 port = $port" if _debugging_details;

   listen $listener, my $queue_size = 1
      or croak "$!: listen()" ;

   {
      socket $client, PF_INET, SOCK_STREAM, $tcp_proto
         or croak "$!: socket()";

      my $paddr = sockaddr_in($port, $loopback );

      connect $client, $paddr
         or croak "$!: connect()" ;
    
      croak "$!: accept" unless defined $paddr ;

      ## The windows "default" is SO_DONTLINGER, which should make
      ## sure all socket data goes through.  I have my doubts based
      ## on experimentation, but nothing prompts me to set SO_LINGER
      ## at this time...
      setsockopt $client, IPPROTO_TCP, TCP_NODELAY, pack("l", 0)
	 or croak "$!: setsockopt()";
   }

   {
      _debug "accept()ing on port $port" if _debugging_details;
      my $paddr = accept( $server, $listener ) ;
      croak "$!: accept()" unless defined $paddr ;
   }

   _debug
      "win32 _socket = ( ", fileno $server, ", ", fileno $client, " ) on port $port" 
      if _debugging_details;
   return ( $server, $client ) ;
}


sub _open_socket_pipe {
   my IPC::Run::Win32IO $self = shift;
   my ( $debug_fd, $parent_handle ) = @_ ;

   my $is_send_to_child = $self->dir eq "<";

   $self->{CHILD_HANDLE}     = gensym;
   $self->{PUMP_PIPE_HANDLE} = gensym;

   ( 
      $self->{PARENT_HANDLE},
      $self->{PUMP_SOCKET_HANDLE}
   ) = _socket $parent_handle ;

   ## These binmodes seem to have no effect on Win2K, but just to be safe
   ## I do them.
   binmode $self->{PARENT_HANDLE}      or die $!;
   binmode $self->{PUMP_SOCKET_HANDLE} or die $!;

_debug "PUMP_SOCKET_HANDLE = ", fileno $self->{PUMP_SOCKET_HANDLE}
   if _debugging_details;
##my $buf ;
##$buf = "write on child end of " . fileno( $self->{WRITE_HANDLE} ) . "\n\n\n\n\n" ;
##POSIX::write(fileno $self->{WRITE_HANDLE}, $buf, length $buf) or warn "$! in syswrite" ;
##$buf = "write on parent end of " . fileno( $self->{CHILD_HANDLE} ) . "\r\n" ;
##POSIX::write(fileno $self->{CHILD_HANDLE},$buf, length $buf) or warn "$! in syswrite" ;
##   $self->{CHILD_HANDLE}->autoflush( 1 ) ;
##   $self->{WRITE_HANDLE}->autoflush( 1 ) ;

   ## Now fork off a data pump and arrange to return the correct fds.
   if ( $is_send_to_child ) {
      pipe $self->{CHILD_HANDLE}, $self->{PUMP_PIPE_HANDLE}
         or croak "$! opening child pipe" ;
_debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
   if _debugging_details;
_debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
   if _debugging_details;
   }
   else {
      pipe $self->{PUMP_PIPE_HANDLE}, $self->{CHILD_HANDLE}
         or croak "$! opening child pipe" ;
_debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
   if _debugging_details;
_debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
   if _debugging_details;
   }

   ## These binmodes seem to have no effect on Win2K, but just to be safe
   ## I do them.
   binmode $self->{CHILD_HANDLE};
   binmode $self->{PUMP_PIPE_HANDLE};

   ## No child should ever see this.
   _dont_inherit $self->{PARENT_HANDLE} ;

   ## We clear the inherit flag so these file descriptors are not inherited.
   ## It'll be dup()ed on to STDIN/STDOUT/STDERR before CreateProcess is
   ## called and *that* fd will be inheritable.
   _dont_inherit $self->{PUMP_SOCKET_HANDLE} ;
   _dont_inherit $self->{PUMP_PIPE_HANDLE} ;
   _dont_inherit $self->{CHILD_HANDLE} ;

   ## Need to return $self so the HANDLEs don't get freed.
   ## Return $self, $parent_fd, $child_fd
   my ( $parent_fd, $child_fd ) = (
      fileno $self->{PARENT_HANDLE},
      fileno $self->{CHILD_HANDLE}
   ) ;

   ## Both PUMP_..._HANDLEs will be closed, no need to worry about
   ## inheritance.
   _debug "binmode on" if _debugging_data && $self->binmode;
   _spawn_pumper(
      $is_send_to_child
	 ? ( $self->{PUMP_SOCKET_HANDLE}, $self->{PUMP_PIPE_HANDLE} )
	 : ( $self->{PUMP_PIPE_HANDLE}, $self->{PUMP_SOCKET_HANDLE} ),
      $debug_fd,
      $self->binmode,
      $child_fd . $self->dir . "pump" . $self->dir . $parent_fd,
   ) ;

{
my $foo ;
confess "PARENT_HANDLE no longer open"
   unless POSIX::read( $parent_fd, $foo, 0 ) ;
}

   _debug "win32_fake_pipe = ( $parent_fd, $child_fd )"
      if _debugging_details;

   $self->{FD}  = $parent_fd;
   $self->{TFD} = $child_fd;
}

sub _do_open {
   my IPC::Run::Win32IO $self = shift;

   if ( $self->{SEND_THROUGH_TEMP_FILE} ) {
      return $self->_send_through_temp_file( @_ );
   }
   elsif ( $self->{RECV_THROUGH_TEMP_FILE} ) {
      return $self->_init_recv_through_temp_file( @_ );
   }
   else {
      return $self->_open_socket_pipe( @_ );
   }
}

=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 ir the Artistic License.

=cut

1;