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

   1 package IPC::Run::IO;
   2
   3 =head1 NAME
   4
   5 IPC::Run::IO -- I/O channels for IPC::Run.
   6
   7 =head1 SYNOPSIS
   8
   9 B<NOT IMPLEMENTED YET ON Win32! Win32 does not allow select() on
  10 normal file descriptors; IPC::RUN::IO needs to use IPC::Run::Win32Helper
  11 to do this.>
  12
  13    use IPC::Run qw( io );
  14
  15    ## The sense of '>' and '<' is opposite of perl's open(),
  16    ## but agrees with IPC::Run.
  17    $io = io( "filename", '>',  \$recv );
  18    $io = io( "filename", 'r',  \$recv );
  19
  20    ## Append to $recv:
  21    $io = io( "filename", '>>', \$recv );
  22    $io = io( "filename", 'ra', \$recv );
  23
  24    $io = io( "filename", '<',  \$send );
  25    $io = io( "filename", 'w',  \$send );
  26
  27    $io = io( "filename", '<<', \$send );
  28    $io = io( "filename", 'wa', \$send );
  29
  30    ## Handles / IO objects that the caller opens:
  31    $io = io( \*HANDLE,   '<',  \$send );
  32
  33    $f = IO::Handle->new( ... ); # Any subclass of IO::Handle
  34    $io = io( $f, '<', \$send );
  35
  36    require IPC::Run::IO;
  37    $io = IPC::Run::IO->new( ... );
  38
  39    ## Then run(), harness(), or start():
  40    run $io, ...;
  41
  42    ## You can, of course, use io() or IPC::Run::IO->new() as an
  43    ## argument to run(), harness, or start():
  44    run io( ... );
  45
  46 =head1 DESCRIPTION
  47
  48 This class and module allows filehandles and filenames to be harnessed for
  49 I/O when used IPC::Run, independent of anything else IPC::Run is doing
  50 (except that errors & exceptions can affect all things that IPC::Run is
  51 doing).
  52
  53 =head1 SUBCLASSING
  54
  55 INCOMPATIBLE CHANGE: due to the awkwardness introduced in ripping pseudohashes
  56 out of Perl, this class I<no longer> uses the fields pragma.
  57
  58 =cut
  59
  60 ## This class is also used internally by IPC::Run in a very intimate way,
  61 ## since this is a partial factoring of code from IPC::Run plus some code
  62 ## needed to do standalone channels.  This factoring process will continue
  63 ## at some point.  Don't know how far how fast.
  64
  65 use strict;
  66 use Carp;
  67 use Fcntl;
  68 use Symbol;
  69
  70 use IPC::Run::Debug;
  71 use IPC::Run qw( Win32_MODE );
  72
  73 use vars qw{$VERSION};
  74 BEGIN {
  75         $VERSION = '0.90';
  76         if ( Win32_MODE ) {
  77                 eval "use IPC::Run::Win32Helper; require IPC::Run::Win32IO; 1"
  78                 or ( $@ && die ) or die "$!";
  79         }
  80 }
  81
  82 sub _empty($);
  83 *_empty = \&IPC::Run::_empty;
  84
  85 =head1 SUBROUTINES
  86
  87 =over 4
  88
  89 =item new
  90
  91 I think it takes >> or << along with some other data.
  92
  93 TODO: Needs more thorough documentation. Patches welcome.
  94
  95 =cut
  96
  97 sub new {
  98    my $class = shift;
  99    $class = ref $class || $class;
 100
 101    my ( $external, $type, $internal ) = ( shift, shift, pop );
 102
 103    croak "$class: '$_' is not a valid I/O operator"
 104       unless $type =~ /^(?:<<?|>>?)$/;
 105
 106    my IPC::Run::IO $self = $class->_new_internal(
 107       $type, undef, undef, $internal, undef, @_
 108    );
 109
 110    if ( ! ref $external ) {
 111       $self->{FILENAME} = $external;
 112    }
 113    elsif ( ref eq 'GLOB' || UNIVERSAL::isa( $external, 'IO::Handle' ) ) {
 114       $self->{HANDLE} = $external;
 115       $self->{DONT_CLOSE} = 1;
 116    }
 117    else {
 118       croak "$class: cannot accept " . ref( $external ) . " to do I/O with";
 119    }
 120
 121    return $self;
 122 }
 123
 124
 125 ## IPC::Run uses this ctor, since it preparses things and needs more
 126 ## smarts.
 127 sub _new_internal {
 128    my $class = shift;
 129    $class = ref $class || $class;
 130
 131    $class = "IPC::Run::Win32IO"
 132       if Win32_MODE && $class eq "IPC::Run::IO";
 133
 134    my IPC::Run::IO $self;
 135    $self = bless {}, $class;
 136
 137    my ( $type, $kfd, $pty_id, $internal, $binmode, @filters ) = @_;
 138
 139    # Older perls (<=5.00503, at least) don't do list assign to
 140    # psuedo-hashes well.
 141    $self->{TYPE}    = $type;
 142    $self->{KFD}     = $kfd;
 143    $self->{PTY_ID}  = $pty_id;
 144    $self->binmode( $binmode );
 145    $self->{FILTERS} = [ @filters ];
 146
 147    ## Add an adapter to the end of the filter chain (which is usually just the
 148    ## read/writer sub pushed by IPC::Run) to the DEST or SOURCE, if need be.
 149    if ( $self->op =~ />/ ) {
 150       croak "'$_' missing a destination" if _empty $internal;
 151       $self->{DEST} = $internal;
 152       if ( UNIVERSAL::isa( $self->{DEST}, 'CODE' ) ) {
 153          ## Put a filter on the end of the filter chain to pass the
 154          ## output on to the CODE ref.  For SCALAR refs, the last
 155          ## filter in the chain writes directly to the scalar itself.  See
 156          ## _init_filters().  For CODE refs, however, we need to adapt from
 157          ## the SCALAR to calling the CODE.
 158          unshift(
 159             @{$self->{FILTERS}},
 160             sub {
 161                my ( $in_ref ) = @_;
 162
 163                return IPC::Run::input_avail() && do {
 164                   $self->{DEST}->( $$in_ref );
 165                   $$in_ref = '';
 166                   1;
 167                }
 168             }
 169          );
 170       }
 171    }
 172    else {
 173       croak "'$_' missing a source" if _empty $internal;
 174       $self->{SOURCE} = $internal;
 175       if ( UNIVERSAL::isa( $internal, 'CODE' ) ) {
 176          push(
 177             @{$self->{FILTERS}},
 178             sub {
 179                my ( $in_ref, $out_ref ) = @_;
 180                return 0 if length $$out_ref;
 181
 182                return undef
 183                   if $self->{SOURCE_EMPTY};
 184
 185                my $in = $internal->();
 186                unless ( defined $in ) {
 187                   $self->{SOURCE_EMPTY} = 1;
 188                   return undef
 189                }
 190                return 0 unless length $in;
 191                $$out_ref = $in;
 192
 193                return 1;
 194             }
 195          );
 196       }
 197       elsif ( UNIVERSAL::isa( $internal, 'SCALAR' ) ) {
 198          push(
 199             @{$self->{FILTERS}},
 200             sub {
 201                my ( $in_ref, $out_ref ) = @_;
 202                return 0 if length $$out_ref;
 203
 204                ## pump() clears auto_close_ins, finish() sets it.
 205                return $self->{HARNESS}->{auto_close_ins} ? undef : 0
 206                   if IPC::Run::_empty ${$self->{SOURCE}}
 207                      || $self->{SOURCE_EMPTY};
 208
 209                $$out_ref = $$internal;
 210                eval { $$internal = '' }
 211                   if $self->{HARNESS}->{clear_ins};
 212
 213                $self->{SOURCE_EMPTY} = $self->{HARNESS}->{auto_close_ins};
 214
 215                return 1;
 216             }
 217          );
 218       }
 219    }
 220
 221    return $self;
 222 }
 223
 224 =item filename
 225
 226 Gets/sets the filename.  Returns the value after the name change, if
 227 any.
 228
 229 =cut
 230
 231 sub filename {
 232    my IPC::Run::IO $self = shift;
 233    $self->{FILENAME} = shift if @_;
 234    return $self->{FILENAME};
 235 }
 236
 237 =item init
 238
 239 Does initialization required before this can be run.  This includes open()ing
 240 the file, if necessary, and clearing the destination scalar if necessary.
 241
 242 =cut
 243
 244 sub init {
 245    my IPC::Run::IO $self = shift;
 246
 247    $self->{SOURCE_EMPTY} = 0;
 248    ${$self->{DEST}} = ''
 249       if $self->mode =~ /r/ && ref $self->{DEST} eq 'SCALAR';
 250
 251    $self->open if defined $self->filename;
 252    $self->{FD} = $self->fileno;
 253
 254    if ( ! $self->{FILTERS} ) {
 255       $self->{FBUFS} = undef;
 256    }
 257    else {
 258       @{$self->{FBUFS}} = map {
 259          my $s = "";
 260          \$s;
 261       } ( @{$self->{FILTERS}}, '' );
 262
 263       $self->{FBUFS}->[0] = $self->{DEST}
 264          if $self->{DEST} && ref $self->{DEST} eq 'SCALAR';
 265       push @{$self->{FBUFS}}, $self->{SOURCE};
 266    }
 267
 268    return undef;
 269 }
 270
 271
 272 =item open
 273
 274 If a filename was passed in, opens it.  Determines if the handle is open
 275 via fileno().  Throws an exception on error.
 276
 277 =cut
 278
 279 my %open_flags = (
 280    '>'  => O_RDONLY,
 281    '>>' => O_RDONLY,
 282    '<'  => O_WRONLY | O_CREAT | O_TRUNC,
 283    '<<' => O_WRONLY | O_CREAT | O_APPEND,
 284 );
 285
 286 sub open {
 287    my IPC::Run::IO $self = shift;
 288
 289    croak "IPC::Run::IO: Can't open() a file with no name"
 290       unless defined $self->{FILENAME};
 291    $self->{HANDLE} = gensym unless $self->{HANDLE};
 292
 293    _debug
 294       "opening '", $self->filename, "' mode '", $self->mode, "'"
 295    if _debugging_data;
 296    sysopen(
 297       $self->{HANDLE},
 298       $self->filename,
 299       $open_flags{$self->op},
 300    ) or croak
 301          "IPC::Run::IO: $! opening '$self->{FILENAME}', mode '" . $self->mode . "'";
 302
 303    return undef;
 304 }
 305
 306
 307 =item open_pipe
 308
 309 If this is a redirection IO object, this opens the pipe in a platform
 310 independent manner.
 311
 312 =cut
 313
 314 sub _do_open {
 315    my $self = shift;
 316    my ( $child_debug_fd, $parent_handle ) = @_;
 317
 318
 319    if ( $self->dir eq "<" ) {
 320       ( $self->{TFD}, $self->{FD} ) = IPC::Run::_pipe_nb;
 321       if ( $parent_handle ) {
 322          CORE::open $parent_handle, ">&=$self->{FD}"
 323             or croak "$! duping write end of pipe for caller";
 324       }
 325    }
 326    else {
 327       ( $self->{FD}, $self->{TFD} ) = IPC::Run::_pipe;
 328       if ( $parent_handle ) {
 329          CORE::open $parent_handle, "<&=$self->{FD}"
 330             or croak "$! duping read end of pipe for caller";
 331       }
 332    }
 333 }
 334
 335 sub open_pipe {
 336    my IPC::Run::IO $self = shift;
 337
 338    ## Hmmm, Maybe allow named pipes one day.  But until then...
 339    croak "IPC::Run::IO: Can't pipe() when a file name has been set"
 340       if defined $self->{FILENAME};
 341
 342    $self->_do_open( @_ );
 343
 344    ## return ( child_fd, parent_fd )
 345    return $self->dir eq "<"
 346       ? ( $self->{TFD}, $self->{FD} )
 347       : ( $self->{FD}, $self->{TFD} );
 348 }
 349
 350
 351 sub _cleanup { ## Called from Run.pm's _cleanup
 352    my $self = shift;
 353    undef $self->{FAKE_PIPE};
 354 }
 355
 356
 357 =item close
 358
 359 Closes the handle.  Throws an exception on failure.
 360
 361
 362 =cut
 363
 364 sub close {
 365    my IPC::Run::IO $self = shift;
 366
 367    if ( defined $self->{HANDLE} ) {
 368       close $self->{HANDLE}
 369          or croak(  "IPC::Run::IO: $! closing "
 370             . ( defined $self->{FILENAME}
 371                ? "'$self->{FILENAME}'"
 372                : "handle"
 373             )
 374          );
 375    }
 376    else {
 377       IPC::Run::_close( $self->{FD} );
 378    }
 379
 380    $self->{FD} = undef;
 381
 382    return undef;
 383 }
 384
 385 =item fileno
 386
 387 Returns the fileno of the handle.  Throws an exception on failure.
 388
 389
 390 =cut
 391
 392 sub fileno {
 393    my IPC::Run::IO $self = shift;
 394
 395    my $fd = fileno $self->{HANDLE};
 396    croak(  "IPC::Run::IO: $! "
 397          . ( defined $self->{FILENAME}
 398             ? "'$self->{FILENAME}'"
 399             : "handle"
 400          )
 401       ) unless defined $fd;
 402
 403    return $fd;
 404 }
 405
 406 =item mode
 407
 408 Returns the operator in terms of 'r', 'w', and 'a'.  There is a state
 409 'ra', unlike Perl's open(), which indicates that data read from the
 410 handle or file will be appended to the output if the output is a scalar.
 411 This is only meaningful if the output is a scalar, it has no effect if
 412 the output is a subroutine.
 413
 414 The redirection operators can be a little confusing, so here's a reference
 415 table:
 416
 417    >      r      Read from handle in to process
 418    <      w      Write from process out to handle
 419    >>     ra     Read from handle in to process, appending it to existing
 420                  data if the destination is a scalar.
 421    <<     wa     Write from process out to handle, appending to existing
 422                  data if IPC::Run::IO opened a named file.
 423
 424 =cut
 425
 426 sub mode {
 427    my IPC::Run::IO $self = shift;
 428
 429    croak "IPC::Run::IO: unexpected arguments for mode(): @_" if @_;
 430
 431    ## TODO: Optimize this
 432    return ( $self->{TYPE} =~ /</     ? 'w' : 'r' ) .
 433           ( $self->{TYPE} =~ /<<|>>/ ? 'a' : ''  );
 434 }
 435
 436
 437 =item op
 438
 439 Returns the operation: '<', '>', '<<', '>>'.  See L</mode> if you want
 440 to spell these 'r', 'w', etc.
 441
 442 =cut
 443
 444 sub op {
 445    my IPC::Run::IO $self = shift;
 446
 447    croak "IPC::Run::IO: unexpected arguments for op(): @_" if @_;
 448
 449    return $self->{TYPE};
 450 }
 451
 452 =item binmode
 453
 454 Sets/gets whether this pipe is in binmode or not.  No effect off of Win32
 455 OSs, of course, and on Win32, no effect after the harness is start()ed.
 456
 457 =cut
 458
 459 sub binmode {
 460    my IPC::Run::IO $self = shift;
 461
 462    $self->{BINMODE} = shift if @_;
 463
 464    return $self->{BINMODE};
 465 }
 466
 467
 468 =item dir
 469
 470 Returns the first character of $self->op.  This is either "<" or ">".
 471
 472 =cut
 473
 474 sub dir {
 475    my IPC::Run::IO $self = shift;
 476
 477    croak "IPC::Run::IO: unexpected arguments for dir(): @_" if @_;
 478
 479    return substr $self->{TYPE}, 0, 1;
 480 }
 481
 482
 483 ##
 484 ## Filter Scaffolding
 485 ##
 486 #my $filter_op ;        ## The op running a filter chain right now
 487 #my $filter_num;        ## Which filter is being run right now.
 488
 489 use vars (
 490 '$filter_op',        ## The op running a filter chain right now
 491 '$filter_num'        ## Which filter is being run right now.
 492 );
 493
 494 sub _init_filters {
 495    my IPC::Run::IO $self = shift;
 496
 497 confess "\$self not an IPC::Run::IO" unless UNIVERSAL::isa( $self, "IPC::Run::IO" );
 498    $self->{FBUFS} = [];
 499
 500    $self->{FBUFS}->[0] = $self->{DEST}
 501       if $self->{DEST} && ref $self->{DEST} eq 'SCALAR';
 502
 503    return unless $self->{FILTERS} && @{$self->{FILTERS}};
 504
 505    push @{$self->{FBUFS}}, map {
 506       my $s = "";
 507       \$s;
 508    } ( @{$self->{FILTERS}}, '' );
 509
 510    push @{$self->{FBUFS}}, $self->{SOURCE};
 511 }
 512
 513 =item poll
 514
 515 TODO: Needs confirmation that this is correct. Was previously undocumented.
 516
 517 I believe this is polling the IO for new input and then returns undef if there will never be any more input, 0 if there is none now, but there might be in the future, and TRUE if more input was gotten.
 518
 519 =cut
 520
 521 sub poll {
 522    my IPC::Run::IO $self = shift;
 523    my ( $harness ) = @_;
 524
 525    if ( defined $self->{FD} ) {
 526       my $d = $self->dir;
 527       if ( $d eq "<" ) {
 528          if ( vec $harness->{WOUT}, $self->{FD}, 1 ) {
 529             _debug_desc_fd( "filtering data to", $self )
 530                if _debugging_details;
 531             return $self->_do_filters( $harness );
 532          }
 533       }
 534       elsif ( $d eq ">" ) {
 535          if ( vec $harness->{ROUT}, $self->{FD}, 1 ) {
 536             _debug_desc_fd( "filtering data from", $self )
 537                if _debugging_details;
 538             return $self->_do_filters( $harness );
 539          }
 540       }
 541    }
 542    return 0;
 543 }
 544
 545
 546 sub _do_filters {
 547    my IPC::Run::IO $self = shift;
 548
 549    ( $self->{HARNESS} ) = @_;
 550
 551    my ( $saved_op, $saved_num ) =($IPC::Run::filter_op,$IPC::Run::filter_num);
 552    $IPC::Run::filter_op = $self;
 553    $IPC::Run::filter_num = -1;
 554    my $redos = 0;
 555    my $r;
 556    {
 557            $@ = '';
 558            $r = eval { IPC::Run::get_more_input(); };
 559
 560            # Detect Resource temporarily unavailable and re-try 200 times (2 seconds),  assuming select behaves (which it doesn't always? need ref)
 561            if(($@||'') =~ $IPC::Run::_EAGAIN && $redos++ < 200) {
 562                select(undef, undef, undef, 0.01);
 563                redo;
 564            }
 565    }
 566    ( $IPC::Run::filter_op, $IPC::Run::filter_num ) = ( $saved_op, $saved_num );
 567    $self->{HARNESS} = undef;
 568    die "ack ", $@ if $@;
 569    return $r;
 570 }
 571
 572 =back
 573
 574 =head1 AUTHOR
 575
 576 Barrie Slaymaker <barries@slaysys.com>
 577
 578 =head1 TODO
 579
 580 Implement bidirectionality.
 581
 582 =cut
 583
 584 1;