Source/t/lib/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
  47 =head1 DESCRIPTION
  48
  49 This class and module allows filehandles and filenames to be harnessed for
  50 I/O when used IPC::Run, independant of anything else IPC::Run is doing
  51 (except that errors & exceptions can affect all things that IPC::Run is
  52 doing).
  53
  54 =head1 SUBCLASSING
  55
  56 INCOMPATIBLE CHANGE: due to the awkwardness introduced in ripping pseudohashes
  57 out of Perl, this class I<no longer> uses the fields pragma.
  58
  59 =head1 TODO
  60
  61 Implement bidirectionality.
  62
  63 =head1 AUTHOR
  64
  65 Barrie Slaymaker <barries@slaysys.com>
  66
  67 =cut ;
  68
  69 ## This class is also used internally by IPC::Run in a very initimate way,
  70 ## since this is a partial factoring of code from IPC::Run plus some code
  71 ## needed to do standalone channels.  This factoring process will continue
  72 ## at some point.  Don't know how far how fast.
  73
  74 use strict ;
  75 use Carp ;
  76 use Fcntl ;
  77 use Symbol ;
  78 use UNIVERSAL qw( isa ) ;
  79
  80 use IPC::Run::Debug;
  81 use IPC::Run qw( Win32_MODE );
  82
  83 BEGIN {
  84    if ( Win32_MODE ) {
  85       eval "use IPC::Run::Win32Helper; require IPC::Run::Win32IO; 1"
  86          or ( $@ && die ) or die "$!" ;
  87    }
  88 }
  89
  90 sub _empty($) ;
  91
  92 *_empty          = \&IPC::Run::_empty ;
  93
  94
  95 sub new {
  96    my $class = shift ;
  97    $class = ref $class || $class ;
  98
  99    my ( $external, $type, $internal ) = ( shift, shift, pop ) ;
 100
 101    croak "$class: '$_' is not a valid I/O operator"
 102       unless $type =~ /^(?:<<?|>>?)$/ ;
 103
 104    my IPC::Run::IO $self = $class->_new_internal(
 105       $type, undef, undef, $internal, undef, @_
 106    ) ;
 107
 108    if ( ! ref $external ) {
 109       $self->{FILENAME} = $external ;
 110    }
 111    elsif ( ref eq 'GLOB' || isa( $external, 'IO::Handle' ) ) {
 112       $self->{HANDLE} = $external ;
 113       $self->{DONT_CLOSE} = 1 ;
 114    }
 115    else {
 116       croak "$class: cannot accept " . ref( $external ) . " to do I/O with" ;
 117    }
 118
 119    return $self ;
 120 }
 121
 122
 123 ## IPC::Run uses this ctor, since it preparses things and needs more
 124 ## smarts.
 125 sub _new_internal {
 126    my $class = shift ;
 127    $class = ref $class || $class ;
 128
 129    $class = "IPC::Run::Win32IO"
 130       if Win32_MODE && $class eq "IPC::Run::IO";
 131
 132    my IPC::Run::IO $self ;
 133    $self = bless {}, $class ;
 134
 135    my ( $type, $kfd, $pty_id, $internal, $binmode, @filters ) = @_ ;
 136
 137    # Older perls (<=5.00503, at least) don't do list assign to
 138    # psuedo-hashes well.
 139    $self->{TYPE}    = $type ;
 140    $self->{KFD}     = $kfd ;
 141    $self->{PTY_ID}  = $pty_id ;
 142    $self->binmode( $binmode ) ;
 143    $self->{FILTERS} = [ @filters ] ;
 144
 145    ## Add an adapter to the end of the filter chain (which is usually just the
 146    ## read/writer sub pushed by IPC::Run) to the DEST or SOURCE, if need be.
 147    if ( $self->op =~ />/ ) {
 148       croak "'$_' missing a destination" if _empty $internal ;
 149       $self->{DEST} = $internal ;
 150       if ( isa( $self->{DEST}, 'CODE' ) ) {
 151          ## Put a filter on the end of the filter chain to pass the
 152          ## output on to the CODE ref.  For SCALAR refs, the last
 153          ## filter in the chain writes directly to the scalar itself.  See
 154          ## _init_filters().  For CODE refs, however, we need to adapt from
 155          ## the SCALAR to calling the CODE.
 156          unshift(
 157             @{$self->{FILTERS}},
 158             sub {
 159                my ( $in_ref ) = @_ ;
 160
 161                return IPC::Run::input_avail() && do {
 162                   $self->{DEST}->( $$in_ref ) ;
 163                   $$in_ref = '' ;
 164                   1 ;
 165                }
 166             }
 167          ) ;
 168       }
 169    }
 170    else {
 171       croak "'$_' missing a source" if _empty $internal ;
 172       $self->{SOURCE} = $internal ;
 173       if ( isa( $internal, 'CODE' ) ) {
 174          push(
 175             @{$self->{FILTERS}},
 176             sub {
 177                my ( $in_ref, $out_ref ) = @_ ;
 178                return 0 if length $$out_ref ;
 179
 180                return undef
 181                   if $self->{SOURCE_EMPTY} ;
 182
 183                my $in = $internal->() ;
 184                unless ( defined $in ) {
 185                   $self->{SOURCE_EMPTY} = 1 ;
 186                   return undef
 187                }
 188                return 0 unless length $in ;
 189                $$out_ref = $in ;
 190
 191                return 1 ;
 192             }
 193          ) ;
 194       }
 195       elsif ( isa( $internal, 'SCALAR' ) ) {
 196          push(
 197             @{$self->{FILTERS}},
 198             sub {
 199                my ( $in_ref, $out_ref ) = @_ ;
 200                return 0 if length $$out_ref ;
 201
 202                ## pump() clears auto_close_ins, finish() sets it.
 203                return $self->{HARNESS}->{auto_close_ins} ? undef : 0
 204                   if IPC::Run::_empty ${$self->{SOURCE}}
 205                      || $self->{SOURCE_EMPTY} ;
 206
 207                $$out_ref = $$internal ;
 208                eval { $$internal = '' }
 209                   if $self->{HARNESS}->{clear_ins} ;
 210
 211                $self->{SOURCE_EMPTY} = $self->{HARNESS}->{auto_close_ins} ;
 212
 213                return 1 ;
 214             }
 215          ) ;
 216       }
 217    }
 218
 219    return $self ;
 220 }
 221
 222
 223 =item filename
 224
 225 Gets/sets the filename.  Returns the value after the name change, if
 226 any.
 227
 228 =cut
 229
 230 sub filename {
 231    my IPC::Run::IO $self = shift ;
 232    $self->{FILENAME} = shift if @_ ;
 233    return $self->{FILENAME} ;
 234 }
 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 independant 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 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
 514 sub poll {
 515    my IPC::Run::IO $self = shift;
 516    my ( $harness ) = @_;
 517
 518    if ( defined $self->{FD} ) {
 519       my $d = $self->dir;
 520       if ( $d eq "<" ) {
 521          if ( vec $harness->{WOUT}, $self->{FD}, 1 ) {
 522             _debug_desc_fd( "filtering data to", $self )
 523                if _debugging_details ;
 524             return $self->_do_filters( $harness );
 525          }
 526       }
 527       elsif ( $d eq ">" ) {
 528          if ( vec $harness->{ROUT}, $self->{FD}, 1 ) {
 529             _debug_desc_fd( "filtering data from", $self )
 530                if _debugging_details ;
 531             return $self->_do_filters( $harness );
 532          }
 533       }
 534    }
 535    return 0;
 536 }
 537
 538
 539 sub _do_filters {
 540    my IPC::Run::IO $self = shift ;
 541
 542    ( $self->{HARNESS} ) = @_ ;
 543
 544    my ( $saved_op, $saved_num ) =($IPC::Run::filter_op,$IPC::Run::filter_num) ;
 545    $IPC::Run::filter_op = $self ;
 546    $IPC::Run::filter_num = -1 ;
 547    my $c = 0;
 548    my $r;
 549    {
 550            $@ = '';
 551            $r = eval { IPC::Run::get_more_input() ; } ;
 552            $c++;
 553            ##$@ and warn "redo ", substr($@, 0, 20) , " ";
 554            (($c < 200) and ($@||'')=~ m/^Resource temporarily/) and redo;
 555    }
 556    ( $IPC::Run::filter_op, $IPC::Run::filter_num ) = ( $saved_op, $saved_num ) ;
 557    $self->{HARNESS} = undef ;
 558    die "ack ", $@ if $@ ;
 559    return $r ;
 560 }
 561
 562 1 ;