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     $self->{$_} = undef for @cleanup_fields;
 127 }
 128
 129
 130 sub _create_temp_file {
 131    my IPC::Run::Win32IO $self = shift;
 132
 133    ## Create a hidden temp file that Win32 will delete when we close
 134    ## it.
 135    unless ( defined $tmp_dir ) {
 136       $tmp_dir = File::Spec->catdir(
 137          File::Spec->tmpdir, "IPC-Run.tmp"
 138       );
 139
 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";
 147       }
 148    }
 149
 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++
 159    );
 160
 161    $self->{TEMP_FILE_HANDLE} = createFile(
 162       $self->{TEMP_FILE_NAME},
 163       "trw",         ## new, truncate, read, write
 164       {
 165          Flags      => temp_file_flags,
 166       },
 167    ) or croak "Can't create temporary file, $self->{TEMP_FILE_NAME}: $^E";
 168
 169    $self->{TFD} = OsFHandleOpenFd $self->{TEMP_FILE_HANDLE}, 0;
 170    $self->{FD} = undef;
 171
 172    _debug
 173       "Win32 Optimizer: temp file (",
 174       $self->{KFD},
 175       $self->{TYPE},
 176       $self->{TFD},
 177       ", fh ",
 178       $self->{TEMP_FILE_HANDLE},
 179       "): ",
 180       $self->{TEMP_FILE_NAME}
 181       if _debugging_details;
 182 }
 183
 184
 185 sub _reset_temp_file_pointer {
 186    my $self = shift;
 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}";
 189 }
 190
 191
 192 sub _send_through_temp_file {
 193    my IPC::Run::Win32IO $self = shift;
 194
 195    _debug
 196       "Win32 optimizer: optimizing "
 197       . " $self->{KFD} $self->{TYPE} temp file instead of ",
 198          ref $self->{SOURCE} || $self->{SOURCE}
 199       if _debugging_details;
 200
 201    $self->_create_temp_file;
 202
 203    if ( defined ${$self->{SOURCE}} ) {
 204       my $bytes_written = 0;
 205       my $data_ref;
 206       if ( $self->binmode ) {
 207          $data_ref = $self->{SOURCE};
 208       }
 209       else {
 210          my $data = ${$self->{SOURCE}};  # Ugh, a copy.
 211          $data =~ s/(?<!\r)\n/\r\n/g;
 212          $data_ref = \$data;
 213       }
 214
 215       WriteFile(
 216          $self->{TEMP_FILE_HANDLE},
 217          $$data_ref,
 218          0,              ## Write entire buffer
 219          $bytes_written,
 220          [],             ## Not overlapped.
 221       ) or croak
 222          "$^E writing $self->{TEMP_FILE_NAME} for kid to read on fd $self->{KFD}";
 223       _debug
 224          "Win32 optimizer: wrote $bytes_written to temp file $self->{TEMP_FILE_NAME}"
 225          if _debugging_data;
 226
 227       $self->_reset_temp_file_pointer;
 228
 229    }
 230
 231
 232    _debug "Win32 optimizer: kid to read $self->{KFD} from temp file on $self->{TFD}"
 233       if _debugging_details;
 234 }
 235
 236
 237 sub _init_recv_through_temp_file {
 238    my IPC::Run::Win32IO $self = shift;
 239
 240    $self->_create_temp_file;
 241 }
 242
 243
 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;
 248
 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};
 252
 253    push @{$self->{FILTERS}}, sub {
 254       my ( undef, $out_ref ) = @_;
 255
 256       return undef unless defined $self->{TEMP_FILE_HANDLE};
 257
 258       my $r;
 259       my $s;
 260       ReadFile(
 261          $self->{TEMP_FILE_HANDLE},
 262          $s,
 263          999_999,  ## Hmmm, should read the size.
 264          $r,
 265          []
 266       ) or croak "$^E reading from $self->{TEMP_FILE_NAME}";
 267
 268       _debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data;
 269
 270       return undef unless $r;
 271
 272       $s =~ s/\r\n/\n/g unless $self->binmode;
 273
 274       my $pos = pos $$out_ref;
 275       $$out_ref .= $s;
 276       pos( $out_ref ) = $pos;
 277       return 1;
 278    };
 279
 280    my ( $harness ) = @_;
 281
 282    $self->_reset_temp_file_pointer;
 283
 284    1 while $self->_do_filters( $harness );
 285
 286    pop @{$self->{FILTERS}};
 287
 288    IPC::Run::_close( $self->{TFD} );
 289 }
 290
 291 =head1 SUBROUTINES
 292
 293 =over
 294
 295 =item poll
 296
 297 Windows version of IPC::Run::IP::poll.
 298
 299 =back
 300
 301 =cut
 302
 303 sub poll {
 304    my IPC::Run::Win32IO $self = shift;
 305
 306    return if $self->{SEND_THROUGH_TEMP_FILE} || $self->{RECV_THROUGH_TEMP_FILE};
 307
 308    return $self->SUPER::poll( @_ );
 309 }
 310
 311
 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.
 316
 317 sub _spawn_pumper {
 318    my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_;
 319    my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout );
 320
 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;
 325
 326    my $cmd_line = join( " ",
 327       qq{"$^X"},
 328       @I_options,
 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
 338       $binmode ? 1 : 0,
 339       $$, $^T, _debugging_level, qq{"$child_label"},
 340       @opts
 341    );
 342
 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
 352
 353    _debug "pump cmd line: ", $cmd_line if _debugging_details;
 354
 355    my $process;
 356    Win32::Process::Create(
 357       $process,
 358       $^X,
 359       $cmd_line,
 360       1,  ## Inherit handles
 361       NORMAL_PRIORITY_CLASS,
 362       ".",
 363    ) or croak "$!: Win32::Process::Create()";
 364
 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
 371
 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.
 375
 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;
 379
 380    _debug "_spawn_pumper pid = ", $process->GetProcessID
 381       if _debugging_data;
 382 }
 383
 384
 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;
 389
 390 sub _socket {
 391    my ( $server ) = @_;
 392    $server ||= gensym;
 393    my $client = gensym;
 394
 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()";
 400
 401    my $port;
 402    my @errors;
 403 PORT_FINDER_LOOP:
 404    {
 405       $port = $next_port;
 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;
 411       }
 412    }
 413
 414    _debug "win32 port = $port" if _debugging_details;
 415
 416    listen $listener, my $queue_size = 1
 417       or croak "$!: listen()";
 418
 419    {
 420       socket $client, PF_INET, SOCK_STREAM, $tcp_proto
 421          or croak "$!: socket()";
 422
 423       my $paddr = sockaddr_in($port, $loopback );
 424
 425       connect $client, $paddr
 426          or croak "$!: connect()";
 427
 428       croak "$!: accept" unless defined $paddr;
 429
 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
 433       ## at this time...
 434       setsockopt $client, IPPROTO_TCP, TCP_NODELAY, pack("l", 0)
 435          or croak "$!: setsockopt()";
 436    }
 437
 438    {
 439       _debug "accept()ing on port $port" if _debugging_details;
 440       my $paddr = accept( $server, $listener );
 441       croak "$!: accept()" unless defined $paddr;
 442    }
 443
 444    _debug
 445       "win32 _socket = ( ", fileno $server, ", ", fileno $client, " ) on port $port"
 446       if _debugging_details;
 447    return ( $server, $client );
 448 }
 449
 450
 451 sub _open_socket_pipe {
 452    my IPC::Run::Win32IO $self = shift;
 453    my ( $debug_fd, $parent_handle ) = @_;
 454
 455    my $is_send_to_child = $self->dir eq "<";
 456
 457    $self->{CHILD_HANDLE}     = gensym;
 458    $self->{PUMP_PIPE_HANDLE} = gensym;
 459
 460    (
 461       $self->{PARENT_HANDLE},
 462       $self->{PUMP_SOCKET_HANDLE}
 463    ) = _socket $parent_handle;
 464
 465    ## These binmodes seem to have no effect on Win2K, but just to be safe
 466    ## I do them.
 467    binmode $self->{PARENT_HANDLE}      or die $!;
 468    binmode $self->{PUMP_SOCKET_HANDLE} or die $!;
 469
 470 _debug "PUMP_SOCKET_HANDLE = ", fileno $self->{PUMP_SOCKET_HANDLE}
 471    if _debugging_details;
 472 ##my $buf;
 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 );
 479
 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;
 488    }
 489    else {
 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;
 496    }
 497
 498    ## These binmodes seem to have no effect on Win2K, but just to be safe
 499    ## I do them.
 500    binmode $self->{CHILD_HANDLE};
 501    binmode $self->{PUMP_PIPE_HANDLE};
 502
 503    ## No child should ever see this.
 504    _dont_inherit $self->{PARENT_HANDLE};
 505
 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};
 512
 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}
 518    );
 519
 520    ## Both PUMP_..._HANDLEs will be closed, no need to worry about
 521    ## inheritance.
 522    _debug "binmode on" if _debugging_data && $self->binmode;
 523    _spawn_pumper(
 524       $is_send_to_child
 525          ? ( $self->{PUMP_SOCKET_HANDLE}, $self->{PUMP_PIPE_HANDLE} )
 526          : ( $self->{PUMP_PIPE_HANDLE}, $self->{PUMP_SOCKET_HANDLE} ),
 527       $debug_fd,
 528       $self->binmode,
 529       $child_fd . $self->dir . "pump" . $self->dir . $parent_fd,
 530    );
 531
 532 {
 533 my $foo;
 534 confess "PARENT_HANDLE no longer open"
 535    unless POSIX::read( $parent_fd, $foo, 0 );
 536 }
 537
 538    _debug "win32_fake_pipe = ( $parent_fd, $child_fd )"
 539       if _debugging_details;
 540
 541    $self->{FD}  = $parent_fd;
 542    $self->{TFD} = $child_fd;
 543 }
 544
 545 sub _do_open {
 546    my IPC::Run::Win32IO $self = shift;
 547
 548    if ( $self->{SEND_THROUGH_TEMP_FILE} ) {
 549       return $self->_send_through_temp_file( @_ );
 550    }
 551    elsif ( $self->{RECV_THROUGH_TEMP_FILE} ) {
 552       return $self->_init_recv_through_temp_file( @_ );
 553    }
 554    else {
 555       return $self->_open_socket_pipe( @_ );
 556    }
 557 }
 558
 559 1;
 560
 561 =pod
 562
 563 =head1 AUTHOR
 564
 565 Barries Slaymaker <barries@slaysys.com>.  Funded by Perforce Software, Inc.
 566
 567 =head1 COPYRIGHT
 568
 569 Copyright 2001, Barrie Slaymaker, All Rights Reserved.
 570
 571 You may use this under the terms of either the GPL 2.0 or the Artistic License.
 572
 573 =cut