1package IPC::Run::IO; 2 3=head1 NAME 4 5IPC::Run::IO -- I/O channels for IPC::Run. 6 7=head1 SYNOPSIS 8 9B<NOT IMPLEMENTED YET ON Win32! Win32 does not allow select() on 10normal file descriptors; IPC::RUN::IO needs to use IPC::Run::Win32Helper 11to 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 48This class and module allows filehandles and filenames to be harnessed for 49I/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 51doing). 52 53=head1 SUBCLASSING 54 55INCOMPATIBLE CHANGE: due to the awkwardness introduced in ripping pseudohashes 56out 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 65use strict; 66use Carp; 67use Fcntl; 68use Symbol; 69 70use IPC::Run::Debug; 71use IPC::Run qw( Win32_MODE ); 72 73use vars qw{$VERSION}; 74 75BEGIN { 76 $VERSION = '20200505.0'; 77 if (Win32_MODE) { 78 eval "use IPC::Run::Win32Helper; require IPC::Run::Win32IO; 1" 79 or ( $@ && die ) 80 or die "$!"; 81 } 82} 83 84sub _empty($); 85*_empty = \&IPC::Run::_empty; 86 87=head1 SUBROUTINES 88 89=over 4 90 91=item new 92 93I think it takes >> or << along with some other data. 94 95TODO: Needs more thorough documentation. Patches welcome. 96 97=cut 98 99sub new { 100 my $class = shift; 101 $class = ref $class || $class; 102 103 my ( $external, $type, $internal ) = ( shift, shift, pop ); 104 105 croak "$class: '$_' is not a valid I/O operator" 106 unless $type =~ /^(?:<<?|>>?)$/; 107 108 my IPC::Run::IO $self = $class->_new_internal( $type, undef, undef, $internal, undef, @_ ); 109 110 if ( !ref $external ) { 111 $self->{FILENAME} = $external; 112 } 113 elsif ( ref $external 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## IPC::Run uses this ctor, since it preparses things and needs more 125## smarts. 126sub _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=item filename 224 225Gets/sets the filename. Returns the value after the name change, if 226any. 227 228=cut 229 230sub filename { 231 my IPC::Run::IO $self = shift; 232 $self->{FILENAME} = shift if @_; 233 return $self->{FILENAME}; 234} 235 236=item init 237 238Does initialization required before this can be run. This includes open()ing 239the file, if necessary, and clearing the destination scalar if necessary. 240 241=cut 242 243sub init { 244 my IPC::Run::IO $self = shift; 245 246 $self->{SOURCE_EMPTY} = 0; 247 ${ $self->{DEST} } = '' 248 if $self->mode =~ /r/ && ref $self->{DEST} eq 'SCALAR'; 249 250 $self->open if defined $self->filename; 251 $self->{FD} = $self->fileno; 252 253 if ( !$self->{FILTERS} ) { 254 $self->{FBUFS} = undef; 255 } 256 else { 257 @{ $self->{FBUFS} } = map { 258 my $s = ""; 259 \$s; 260 } ( @{ $self->{FILTERS} }, '' ); 261 262 $self->{FBUFS}->[0] = $self->{DEST} 263 if $self->{DEST} && ref $self->{DEST} eq 'SCALAR'; 264 push @{ $self->{FBUFS} }, $self->{SOURCE}; 265 } 266 267 return undef; 268} 269 270=item open 271 272If a filename was passed in, opens it. Determines if the handle is open 273via fileno(). Throws an exception on error. 274 275=cut 276 277my %open_flags = ( 278 '>' => O_RDONLY, 279 '>>' => O_RDONLY, 280 '<' => O_WRONLY | O_CREAT | O_TRUNC, 281 '<<' => O_WRONLY | O_CREAT | O_APPEND, 282); 283 284sub open { 285 my IPC::Run::IO $self = shift; 286 287 croak "IPC::Run::IO: Can't open() a file with no name" 288 unless defined $self->{FILENAME}; 289 $self->{HANDLE} = gensym unless $self->{HANDLE}; 290 291 _debug "opening '", $self->filename, "' mode '", $self->mode, "'" 292 if _debugging_data; 293 sysopen( 294 $self->{HANDLE}, 295 $self->filename, 296 $open_flags{ $self->op }, 297 ) or croak "IPC::Run::IO: $! opening '$self->{FILENAME}', mode '" . $self->mode . "'"; 298 299 return undef; 300} 301 302=item open_pipe 303 304If this is a redirection IO object, this opens the pipe in a platform 305independent manner. 306 307=cut 308 309sub _do_open { 310 my $self = shift; 311 my ( $child_debug_fd, $parent_handle ) = @_; 312 313 if ( $self->dir eq "<" ) { 314 ( $self->{TFD}, $self->{FD} ) = IPC::Run::_pipe_nb; 315 if ($parent_handle) { 316 CORE::open $parent_handle, ">&=$self->{FD}" 317 or croak "$! duping write end of pipe for caller"; 318 } 319 } 320 else { 321 ( $self->{FD}, $self->{TFD} ) = IPC::Run::_pipe; 322 if ($parent_handle) { 323 CORE::open $parent_handle, "<&=$self->{FD}" 324 or croak "$! duping read end of pipe for caller"; 325 } 326 } 327} 328 329sub open_pipe { 330 my IPC::Run::IO $self = shift; 331 332 ## Hmmm, Maybe allow named pipes one day. But until then... 333 croak "IPC::Run::IO: Can't pipe() when a file name has been set" 334 if defined $self->{FILENAME}; 335 336 $self->_do_open(@_); 337 338 ## return ( child_fd, parent_fd ) 339 return $self->dir eq "<" 340 ? ( $self->{TFD}, $self->{FD} ) 341 : ( $self->{FD}, $self->{TFD} ); 342} 343 344sub _cleanup { ## Called from Run.pm's _cleanup 345 my $self = shift; 346 undef $self->{FAKE_PIPE}; 347} 348 349=item close 350 351Closes the handle. Throws an exception on failure. 352 353 354=cut 355 356sub close { 357 my IPC::Run::IO $self = shift; 358 359 if ( defined $self->{HANDLE} ) { 360 close $self->{HANDLE} 361 or croak( 362 "IPC::Run::IO: $! closing " 363 . ( 364 defined $self->{FILENAME} 365 ? "'$self->{FILENAME}'" 366 : "handle" 367 ) 368 ); 369 } 370 else { 371 IPC::Run::_close( $self->{FD} ); 372 } 373 374 $self->{FD} = undef; 375 376 return undef; 377} 378 379=item fileno 380 381Returns the fileno of the handle. Throws an exception on failure. 382 383 384=cut 385 386sub fileno { 387 my IPC::Run::IO $self = shift; 388 389 my $fd = fileno $self->{HANDLE}; 390 croak( 391 "IPC::Run::IO: $! " 392 . ( 393 defined $self->{FILENAME} 394 ? "'$self->{FILENAME}'" 395 : "handle" 396 ) 397 ) unless defined $fd; 398 399 return $fd; 400} 401 402=item mode 403 404Returns the operator in terms of 'r', 'w', and 'a'. There is a state 405'ra', unlike Perl's open(), which indicates that data read from the 406handle or file will be appended to the output if the output is a scalar. 407This is only meaningful if the output is a scalar, it has no effect if 408the output is a subroutine. 409 410The redirection operators can be a little confusing, so here's a reference 411table: 412 413 > r Read from handle in to process 414 < w Write from process out to handle 415 >> ra Read from handle in to process, appending it to existing 416 data if the destination is a scalar. 417 << wa Write from process out to handle, appending to existing 418 data if IPC::Run::IO opened a named file. 419 420=cut 421 422sub mode { 423 my IPC::Run::IO $self = shift; 424 425 croak "IPC::Run::IO: unexpected arguments for mode(): @_" if @_; 426 427 ## TODO: Optimize this 428 return ( $self->{TYPE} =~ /</ ? 'w' : 'r' ) . ( $self->{TYPE} =~ /<<|>>/ ? 'a' : '' ); 429} 430 431=item op 432 433Returns the operation: '<', '>', '<<', '>>'. See L</mode> if you want 434to spell these 'r', 'w', etc. 435 436=cut 437 438sub op { 439 my IPC::Run::IO $self = shift; 440 441 croak "IPC::Run::IO: unexpected arguments for op(): @_" if @_; 442 443 return $self->{TYPE}; 444} 445 446=item binmode 447 448Sets/gets whether this pipe is in binmode or not. No effect off of Win32 449OSs, of course, and on Win32, no effect after the harness is start()ed. 450 451=cut 452 453sub binmode { 454 my IPC::Run::IO $self = shift; 455 456 $self->{BINMODE} = shift if @_; 457 458 return $self->{BINMODE}; 459} 460 461=item dir 462 463Returns the first character of $self->op. This is either "<" or ">". 464 465=cut 466 467sub dir { 468 my IPC::Run::IO $self = shift; 469 470 croak "IPC::Run::IO: unexpected arguments for dir(): @_" if @_; 471 472 return substr $self->{TYPE}, 0, 1; 473} 474 475## 476## Filter Scaffolding 477## 478#my $filter_op ; ## The op running a filter chain right now 479#my $filter_num; ## Which filter is being run right now. 480 481use vars ( 482 '$filter_op', ## The op running a filter chain right now 483 '$filter_num' ## Which filter is being run right now. 484); 485 486sub _init_filters { 487 my IPC::Run::IO $self = shift; 488 489 confess "\$self not an IPC::Run::IO" unless UNIVERSAL::isa( $self, "IPC::Run::IO" ); 490 $self->{FBUFS} = []; 491 492 $self->{FBUFS}->[0] = $self->{DEST} 493 if $self->{DEST} && ref $self->{DEST} eq 'SCALAR'; 494 495 return unless $self->{FILTERS} && @{ $self->{FILTERS} }; 496 497 push @{ $self->{FBUFS} }, map { 498 my $s = ""; 499 \$s; 500 } ( @{ $self->{FILTERS} }, '' ); 501 502 push @{ $self->{FBUFS} }, $self->{SOURCE}; 503} 504 505=item poll 506 507TODO: Needs confirmation that this is correct. Was previously undocumented. 508 509I 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. 510 511=cut 512 513sub poll { 514 my IPC::Run::IO $self = shift; 515 my ($harness) = @_; 516 517 if ( defined $self->{FD} ) { 518 my $d = $self->dir; 519 if ( $d eq "<" ) { 520 if ( vec $harness->{WOUT}, $self->{FD}, 1 ) { 521 _debug_desc_fd( "filtering data to", $self ) 522 if _debugging_details; 523 return $self->_do_filters($harness); 524 } 525 } 526 elsif ( $d eq ">" ) { 527 if ( vec $harness->{ROUT}, $self->{FD}, 1 ) { 528 _debug_desc_fd( "filtering data from", $self ) 529 if _debugging_details; 530 return $self->_do_filters($harness); 531 } 532 } 533 } 534 return 0; 535} 536 537sub _do_filters { 538 my IPC::Run::IO $self = shift; 539 540 ( $self->{HARNESS} ) = @_; 541 542 my ( $saved_op, $saved_num ) = ( $IPC::Run::filter_op, $IPC::Run::filter_num ); 543 $IPC::Run::filter_op = $self; 544 $IPC::Run::filter_num = -1; 545 my $redos = 0; 546 my $r; 547 { 548 $@ = ''; 549 $r = eval { IPC::Run::get_more_input(); }; 550 551 # Detect Resource temporarily unavailable and re-try 200 times (2 seconds), assuming select behaves (which it doesn't always? need ref) 552 if ( ( $@ || '' ) =~ $IPC::Run::_EAGAIN && $redos++ < 200 ) { 553 select( undef, undef, undef, 0.01 ); 554 redo; 555 } 556 } 557 ( $IPC::Run::filter_op, $IPC::Run::filter_num ) = ( $saved_op, $saved_num ); 558 $self->{HARNESS} = undef; 559 die "ack ", $@ if $@; 560 return $r; 561} 562 563=back 564 565=head1 AUTHOR 566 567Barrie Slaymaker <barries@slaysys.com> 568 569=head1 TODO 570 571Implement bidirectionality. 572 573=cut 574 5751; 576