tools/cmake/scripts/IPC/Run/Win32IO.pm

   1 package IPC::Run::Win32IO;
   2
   3 =pod
   4
   5 =head1 NAME
   6
   7 IPC::Run::Win32IO - helper routines for IPC::Run on Win32 platforms.
   8
   9 =head1 SYNOPSIS
  10
  11     use IPC::Run::Win32IO;   # Exports all by default
  12
  13 =head1 DESCRIPTION
  14
  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!.
  19
  20 =head1 DESCRIPTION
  21
  22 A specialized IO class used on Win32.
  23
  24 =cut
  25
  26 use strict;
  27 use Carp;
  28 use IO::Handle;
  29 use Socket;
  30 require POSIX;
  31
  32 use vars qw{$VERSION};
  33 BEGIN {
  34         $VERSION = '0.90';
  35 }
  36
  37 use Socket qw( IPPROTO_TCP TCP_NODELAY );
  38 use Symbol;
  39 use Text::ParseWords;
  40 use Win32::Process;
  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 );
  44
  45 use base qw( IPC::Run::IO );
  46 my @cleanup_fields;
  47 BEGIN {
  48    ## These fields will be set to undef in _cleanup to close
  49    ## the handles.
  50    @cleanup_fields = (
  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.
  55
  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
  60
  61       'TEMP_FILE_HANDLE',    ## The Win32 filehandle for the temp file
  62    );
  63 }
  64
  65 ## REMOVE OSFHandleOpen
  66 use Win32API::File qw(
  67    GetOsFHandle
  68    OsFHandleOpenFd
  69    OsFHandleOpen
  70    FdGetOsFHandle
  71    SetHandleInformation
  72    SetFilePointer
  73    HANDLE_FLAG_INHERIT
  74    INVALID_HANDLE_VALUE
  75
  76    createFile
  77    WriteFile
  78    ReadFile
  79    CloseHandle
  80
  81    FILE_ATTRIBUTE_TEMPORARY
  82    FILE_FLAG_DELETE_ON_CLOSE
  83    FILE_FLAG_WRITE_THROUGH
  84
  85    FILE_BEGIN
  86 );
  87
  88 #   FILE_ATTRIBUTE_HIDDEN
  89 #   FILE_ATTRIBUTE_SYSTEM
  90
  91
  92 BEGIN {
  93    ## Force AUTOLOADED constants to be, well, constant by getting them
  94    ## to AUTOLOAD before compilation continues.  Sigh.
  95    () = (
  96       SOL_SOCKET,
  97       SO_REUSEADDR,
  98       IPPROTO_TCP,
  99       TCP_NODELAY,
 100       HANDLE_FLAG_INHERIT,
 101       INVALID_HANDLE_VALUE,
 102    );
 103 }
 104
 105 use constant temp_file_flags => (
 106    FILE_ATTRIBUTE_TEMPORARY()   |
 107    FILE_FLAG_DELETE_ON_CLOSE()  |
 108    FILE_FLAG_WRITE_THROUGH()
 109 );
 110
 111 #   FILE_ATTRIBUTE_HIDDEN()    |
 112 #   FILE_ATTRIBUTE_SYSTEM()    |
 113 my $tmp_file_counter;
 114 my $tmp_dir;
 115
 116 sub _cleanup {
 117     my IPC::Run::Win32IO $self = shift;
 118     my ( $harness ) = @_;
 119
 120     $self->_recv_through_temp_file( $harness )
 121        if $self->{RECV_THROUGH_TEMP_FILE};
 122
 123     CloseHandle( $self->{TEMP_FILE_HANDLE} )
 124        if defined $self->{TEMP_FILE_HANDLE};
 125
 126     close( $self->{CHILD_HANDLE} )
 127        if defined $self->{CHILD_HANDLE};
 128
 129     $self->{$_} = undef for @cleanup_fields;
 130 }
 131
 132
 133 sub _create_temp_file {
 134    my IPC::Run::Win32IO $self = shift;
 135
 136    ## Create a hidden temp file that Win32 will delete when we close
 137    ## it.
 138    unless ( defined $tmp_dir ) {
 139       $tmp_dir = File::Spec->catdir(
 140          File::Spec->tmpdir, "IPC-Run.tmp"
 141       );
 142
 143       ## Trust in the user's umask.
 144       ## This could possibly be a security hole, perhaps
 145       ## we should offer an option.  Hmmmm, really, people coding
 146       ## security conscious apps should audit this code and
 147       ## tell me how to make it better.  Nice cop-out :).
 148       unless ( -d $tmp_dir ) {
 149          mkdir $tmp_dir or croak "$!: $tmp_dir";
 150       }
 151    }
 152
 153    $self->{TEMP_FILE_NAME} = File::Spec->catfile(
 154       ## File name is designed for easy sorting and not conflicting
 155       ## with other processes.  This should allow us to use "t"runcate
 156       ## access in CreateFile in case something left some droppings
 157       ## around (which should never happen because we specify
 158       ## FLAG_DELETE_ON_CLOSE.
 159       ## heh, belt and suspenders are better than bug reports; God forbid
 160       ## that NT should ever crash before a temp file gets deleted!
 161       $tmp_dir, sprintf "Win32io-%06d-%08d", $$, $tmp_file_counter++
 162    );
 163
 164    $self->{TEMP_FILE_HANDLE} = createFile(
 165       $self->{TEMP_FILE_NAME},
 166       "trw",         ## new, truncate, read, write
 167       {
 168          Flags      => temp_file_flags,
 169       },
 170    ) or croak "Can't create temporary file, $self->{TEMP_FILE_NAME}: $^E";
 171
 172    $self->{TFD} = OsFHandleOpenFd $self->{TEMP_FILE_HANDLE}, 0;
 173    $self->{FD} = undef;
 174
 175    _debug
 176       "Win32 Optimizer: temp file (",
 177       $self->{KFD},
 178       $self->{TYPE},
 179       $self->{TFD},
 180       ", fh ",
 181       $self->{TEMP_FILE_HANDLE},
 182       "): ",
 183       $self->{TEMP_FILE_NAME}
 184       if _debugging_details;
 185 }
 186
 187
 188 sub _reset_temp_file_pointer {
 189    my $self = shift;
 190    SetFilePointer( $self->{TEMP_FILE_HANDLE}, 0, 0, FILE_BEGIN )
 191       or confess "$^E seeking on (fd $self->{TFD}) $self->{TEMP_FILE_NAME} for kid's fd $self->{KFD}";
 192 }
 193
 194
 195 sub _send_through_temp_file {
 196    my IPC::Run::Win32IO $self = shift;
 197
 198    _debug
 199       "Win32 optimizer: optimizing "
 200       . " $self->{KFD} $self->{TYPE} temp file instead of ",
 201          ref $self->{SOURCE} || $self->{SOURCE}
 202       if _debugging_details;
 203
 204    $self->_create_temp_file;
 205
 206    if ( defined ${$self->{SOURCE}} ) {
 207       my $bytes_written = 0;
 208       my $data_ref;
 209       if ( $self->binmode ) {
 210          $data_ref = $self->{SOURCE};
 211       }
 212       else {
 213          my $data = ${$self->{SOURCE}};  # Ugh, a copy.
 214          $data =~ s/(?<!\r)\n/\r\n/g;
 215          $data_ref = \$data;
 216       }
 217
 218       WriteFile(
 219          $self->{TEMP_FILE_HANDLE},
 220          $$data_ref,
 221          0,              ## Write entire buffer
 222          $bytes_written,
 223          [],             ## Not overlapped.
 224       ) or croak
 225          "$^E writing $self->{TEMP_FILE_NAME} for kid to read on fd $self->{KFD}";
 226       _debug
 227          "Win32 optimizer: wrote $bytes_written to temp file $self->{TEMP_FILE_NAME}"
 228          if _debugging_data;
 229
 230       $self->_reset_temp_file_pointer;
 231
 232    }
 233
 234
 235    _debug "Win32 optimizer: kid to read $self->{KFD} from temp file on $self->{TFD}"
 236       if _debugging_details;
 237 }
 238
 239
 240 sub _init_recv_through_temp_file {
 241    my IPC::Run::Win32IO $self = shift;
 242
 243    $self->_create_temp_file;
 244 }
 245
 246
 247 ## TODO: Use the Win32 API in the select loop to see if the file has grown
 248 ## and read it incrementally if it has.
 249 sub _recv_through_temp_file {
 250    my IPC::Run::Win32IO $self = shift;
 251
 252    ## This next line kicks in if the run() never got to initting things
 253    ## and needs to clean up.
 254    return undef unless defined $self->{TEMP_FILE_HANDLE};
 255
 256    push @{$self->{FILTERS}}, sub {
 257       my ( undef, $out_ref ) = @_;
 258
 259       return undef unless defined $self->{TEMP_FILE_HANDLE};
 260
 261       my $r;
 262       my $s;
 263       ReadFile(
 264          $self->{TEMP_FILE_HANDLE},
 265          $s,
 266          999_999,  ## Hmmm, should read the size.
 267          $r,
 268          []
 269       ) or croak "$^E reading from $self->{TEMP_FILE_NAME}";
 270
 271       _debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data;
 272
 273       return undef unless $r;
 274
 275       $s =~ s/\r\n/\n/g unless $self->binmode;
 276
 277       my $pos = pos $$out_ref;
 278       $$out_ref .= $s;
 279       pos( $out_ref ) = $pos;
 280       return 1;
 281    };
 282
 283    my ( $harness ) = @_;
 284
 285    $self->_reset_temp_file_pointer;
 286
 287    1 while $self->_do_filters( $harness );
 288
 289    pop @{$self->{FILTERS}};
 290
 291    IPC::Run::_close( $self->{TFD} );
 292 }
 293
 294 =head1 SUBROUTINES
 295
 296 =over
 297
 298 =item poll
 299
 300 Windows version of IPC::Run::IP::poll.
 301
 302 =back
 303
 304 =cut
 305
 306 sub poll {
 307    my IPC::Run::Win32IO $self = shift;
 308
 309    return if $self->{SEND_THROUGH_TEMP_FILE} || $self->{RECV_THROUGH_TEMP_FILE};
 310
 311    return $self->SUPER::poll( @_ );
 312 }
 313
 314
 315 ## When threaded Perls get good enough, we should use threads here.
 316 ## The problem with threaded perls is that they dup() all sorts of
 317 ## filehandles and fds and don't allow sufficient control over
 318 ## closing off the ones we don't want.
 319
 320 sub _spawn_pumper {
 321    my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_;
 322    my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout );
 323
 324    _debug "pumper stdin = ", $stdin_fd if _debugging_details;
 325    _debug "pumper stdout = ", $stdout_fd if _debugging_details;
 326    _inherit $stdin_fd, $stdout_fd, $debug_fd;
 327    my @I_options = map qq{"-I$_"}, @INC;
 328
 329    my $cmd_line = join( " ",
 330       qq{"$^X"},
 331       @I_options,
 332       qw(-MIPC::Run::Win32Pump -e 1 ),
 333 ## I'm using this clunky way of passing filehandles to the child process
 334 ## in order to avoid some kind of premature closure of filehandles
 335 ## problem I was having with VCP's test suite when passing them
 336 ## via CreateProcess.  All of the ## REMOVE code is stuff I'd like
 337 ## to be rid of and the ## ADD code is what I'd like to use.
 338       FdGetOsFHandle( $stdin_fd ), ## REMOVE
 339       FdGetOsFHandle( $stdout_fd ), ## REMOVE
 340       FdGetOsFHandle( $debug_fd ), ## REMOVE
 341       $binmode ? 1 : 0,
 342       $$, $^T, _debugging_level, qq{"$child_label"},
 343       @opts
 344    );
 345
 346 #   open SAVEIN,  "<&STDIN"  or croak "$! saving STDIN";       #### ADD
 347 #   open SAVEOUT, ">&STDOUT" or croak "$! saving STDOUT";       #### ADD
 348 #   open SAVEERR, ">&STDERR" or croak "$! saving STDERR";       #### ADD
 349 #   _dont_inherit \*SAVEIN;       #### ADD
 350 #   _dont_inherit \*SAVEOUT;       #### ADD
 351 #   _dont_inherit \*SAVEERR;       #### ADD
 352 #   open STDIN,  "<&$stdin_fd"  or croak "$! dup2()ing $stdin_fd (pumper's STDIN)";       #### ADD
 353 #   open STDOUT, ">&$stdout_fd" or croak "$! dup2()ing $stdout_fd (pumper's STDOUT)";       #### ADD
 354 #   open STDERR, ">&$debug_fd" or croak "$! dup2()ing $debug_fd (pumper's STDERR/debug_fd)";       #### ADD
 355
 356    _debug "pump cmd line: ", $cmd_line if _debugging_details;
 357
 358    my $process;
 359    Win32::Process::Create(
 360       $process,
 361       $^X,
 362       $cmd_line,
 363       1,  ## Inherit handles
 364       NORMAL_PRIORITY_CLASS,
 365       ".",
 366    ) or croak "$!: Win32::Process::Create()";
 367
 368 #   open STDIN,  "<&SAVEIN"  or croak "$! restoring STDIN";       #### ADD
 369 #   open STDOUT, ">&SAVEOUT" or croak "$! restoring STDOUT";       #### ADD
 370 #   open STDERR, ">&SAVEERR" or croak "$! restoring STDERR";       #### ADD
 371 #   close SAVEIN             or croak "$! closing SAVEIN";       #### ADD
 372 #   close SAVEOUT            or croak "$! closing SAVEOUT";       #### ADD
 373 #   close SAVEERR            or croak "$! closing SAVEERR";       #### ADD
 374
 375    close $stdin  or croak "$! closing pumper's stdin in parent";
 376    close $stdout or croak "$! closing pumper's stdout in parent";
 377    # Don't close $debug_fd, we need it, as do other pumpers.
 378
 379    # Pause a moment to allow the child to get up and running and emit
 380    # debug messages.  This does not always work.
 381    #   select undef, undef, undef, 1 if _debugging_details;
 382
 383    _debug "_spawn_pumper pid = ", $process->GetProcessID
 384       if _debugging_data;
 385 }
 386
 387
 388 my $next_port = 2048;
 389 my $loopback  = inet_aton "127.0.0.1";
 390 my $tcp_proto = getprotobyname('tcp');
 391 croak "$!: getprotobyname('tcp')" unless defined $tcp_proto;
 392
 393 sub _socket {
 394    my ( $server ) = @_;
 395    $server ||= gensym;
 396    my $client = gensym;
 397
 398    my $listener = gensym;
 399    socket $listener, PF_INET, SOCK_STREAM, $tcp_proto
 400       or croak "$!: socket()";
 401    setsockopt $listener, SOL_SOCKET, SO_REUSEADDR, pack("l", 0)
 402       or croak "$!: setsockopt()";
 403
 404    my $port;
 405    my @errors;
 406 PORT_FINDER_LOOP:
 407    {
 408       $port = $next_port;
 409       $next_port = 2048 if ++$next_port > 65_535;
 410       unless ( bind $listener, sockaddr_in( $port, $loopback ) ) {
 411          push @errors, "$! on port $port";
 412          croak join "\n", @errors if @errors > 10;
 413          goto PORT_FINDER_LOOP;
 414       }
 415    }
 416
 417    _debug "win32 port = $port" if _debugging_details;
 418
 419    listen $listener, my $queue_size = 1
 420       or croak "$!: listen()";
 421
 422    {
 423       socket $client, PF_INET, SOCK_STREAM, $tcp_proto
 424          or croak "$!: socket()";
 425
 426       my $paddr = sockaddr_in($port, $loopback );
 427
 428       connect $client, $paddr
 429          or croak "$!: connect()";
 430
 431       croak "$!: accept" unless defined $paddr;
 432
 433       ## The windows "default" is SO_DONTLINGER, which should make
 434       ## sure all socket data goes through.  I have my doubts based
 435       ## on experimentation, but nothing prompts me to set SO_LINGER
 436       ## at this time...
 437       setsockopt $client, IPPROTO_TCP, TCP_NODELAY, pack("l", 0)
 438          or croak "$!: setsockopt()";
 439    }
 440
 441    {
 442       _debug "accept()ing on port $port" if _debugging_details;
 443       my $paddr = accept( $server, $listener );
 444       croak "$!: accept()" unless defined $paddr;
 445    }
 446
 447    _debug
 448       "win32 _socket = ( ", fileno $server, ", ", fileno $client, " ) on port $port"
 449       if _debugging_details;
 450    return ( $server, $client );
 451 }
 452
 453
 454 sub _open_socket_pipe {
 455    my IPC::Run::Win32IO $self = shift;
 456    my ( $debug_fd, $parent_handle ) = @_;
 457
 458    my $is_send_to_child = $self->dir eq "<";
 459
 460    $self->{CHILD_HANDLE}     = gensym;
 461    $self->{PUMP_PIPE_HANDLE} = gensym;
 462
 463    (
 464       $self->{PARENT_HANDLE},
 465       $self->{PUMP_SOCKET_HANDLE}
 466    ) = _socket $parent_handle;
 467
 468    ## These binmodes seem to have no effect on Win2K, but just to be safe
 469    ## I do them.
 470    binmode $self->{PARENT_HANDLE}      or die $!;
 471    binmode $self->{PUMP_SOCKET_HANDLE} or die $!;
 472
 473 _debug "PUMP_SOCKET_HANDLE = ", fileno $self->{PUMP_SOCKET_HANDLE}
 474    if _debugging_details;
 475 ##my $buf;
 476 ##$buf = "write on child end of " . fileno( $self->{WRITE_HANDLE} ) . "\n\n\n\n\n";
 477 ##POSIX::write(fileno $self->{WRITE_HANDLE}, $buf, length $buf) or warn "$! in syswrite";
 478 ##$buf = "write on parent end of " . fileno( $self->{CHILD_HANDLE} ) . "\r\n";
 479 ##POSIX::write(fileno $self->{CHILD_HANDLE},$buf, length $buf) or warn "$! in syswrite";
 480 ##   $self->{CHILD_HANDLE}->autoflush( 1 );
 481 ##   $self->{WRITE_HANDLE}->autoflush( 1 );
 482
 483    ## Now fork off a data pump and arrange to return the correct fds.
 484    if ( $is_send_to_child ) {
 485       pipe $self->{CHILD_HANDLE}, $self->{PUMP_PIPE_HANDLE}
 486          or croak "$! opening child pipe";
 487 _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
 488    if _debugging_details;
 489 _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
 490    if _debugging_details;
 491    }
 492    else {
 493       pipe $self->{PUMP_PIPE_HANDLE}, $self->{CHILD_HANDLE}
 494          or croak "$! opening child pipe";
 495 _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
 496    if _debugging_details;
 497 _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
 498    if _debugging_details;
 499    }
 500
 501    ## These binmodes seem to have no effect on Win2K, but just to be safe
 502    ## I do them.
 503    binmode $self->{CHILD_HANDLE};
 504    binmode $self->{PUMP_PIPE_HANDLE};
 505
 506    ## No child should ever see this.
 507    _dont_inherit $self->{PARENT_HANDLE};
 508
 509    ## We clear the inherit flag so these file descriptors are not inherited.
 510    ## It'll be dup()ed on to STDIN/STDOUT/STDERR before CreateProcess is
 511    ## called and *that* fd will be inheritable.
 512    _dont_inherit $self->{PUMP_SOCKET_HANDLE};
 513    _dont_inherit $self->{PUMP_PIPE_HANDLE};
 514    _dont_inherit $self->{CHILD_HANDLE};
 515
 516    ## Need to return $self so the HANDLEs don't get freed.
 517    ## Return $self, $parent_fd, $child_fd
 518    my ( $parent_fd, $child_fd ) = (
 519       fileno $self->{PARENT_HANDLE},
 520       fileno $self->{CHILD_HANDLE}
 521    );
 522
 523    ## Both PUMP_..._HANDLEs will be closed, no need to worry about
 524    ## inheritance.
 525    _debug "binmode on" if _debugging_data && $self->binmode;
 526    _spawn_pumper(
 527       $is_send_to_child
 528          ? ( $self->{PUMP_SOCKET_HANDLE}, $self->{PUMP_PIPE_HANDLE} )
 529          : ( $self->{PUMP_PIPE_HANDLE}, $self->{PUMP_SOCKET_HANDLE} ),
 530       $debug_fd,
 531       $self->binmode,
 532       $child_fd . $self->dir . "pump" . $self->dir . $parent_fd,
 533    );
 534
 535 {
 536 my $foo;
 537 confess "PARENT_HANDLE no longer open"
 538    unless POSIX::read( $parent_fd, $foo, 0 );
 539 }
 540
 541    _debug "win32_fake_pipe = ( $parent_fd, $child_fd )"
 542       if _debugging_details;
 543
 544    $self->{FD}  = $parent_fd;
 545    $self->{TFD} = $child_fd;
 546 }
 547
 548 sub _do_open {
 549    my IPC::Run::Win32IO $self = shift;
 550
 551    if ( $self->{SEND_THROUGH_TEMP_FILE} ) {
 552       return $self->_send_through_temp_file( @_ );
 553    }
 554    elsif ( $self->{RECV_THROUGH_TEMP_FILE} ) {
 555       return $self->_init_recv_through_temp_file( @_ );
 556    }
 557    else {
 558       return $self->_open_socket_pipe( @_ );
 559    }
 560 }
 561
 562 1;
 563
 564 =pod
 565
 566 =head1 AUTHOR
 567
 568 Barries Slaymaker <barries@slaysys.com>.  Funded by Perforce Software, Inc.
 569
 570 =head1 COPYRIGHT
 571
 572 Copyright 2001, Barrie Slaymaker, All Rights Reserved.
 573
 574 You may use this under the terms of either the GPL 2.0 or the Artistic License.
 575
 576 =cut