local-lib5/lib/perl5/IPC/Run/IO.pm

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