refactor duplicative code and fix up poor style
David Golden
12 years ago
| 275 | 275 | my ($name, $stash) = @_; |
| 276 | 276 | my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/; |
| 277 | 277 | _debug( "# slurping captured $name from $pos with layers: @{[PerlIO::get_layers($fh)]}\n"); |
| 278 | seek $fh,$pos,0; local $/; return scalar readline $fh | |
| 278 | return do { local $/; seek $fh,$pos,0; scalar readline $fh }; | |
| 279 | 279 | } |
| 280 | 280 | |
| 281 | 281 | #--------------------------------------------------------------------------# |
| 285 | 285 | sub _capture_tee { |
| 286 | 286 | _debug( "# starting _capture_tee with (@_)...\n" ); |
| 287 | 287 | my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_; |
| 288 | my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ()); | |
| 288 | 289 | Carp::confess("Custom capture options must be given as key/value pairs\n") |
| 289 | 290 | unless @opts % 2 == 0; |
| 290 | 291 | my $stash = { capture => { @opts } }; |
| 291 | for my $n ( keys %{$stash->{capture}} ) { | |
| 292 | my $fh = $stash->{capture}{$n}; | |
| 293 | Carp::confess "Custom handle for $n must be seekable\n" | |
| 292 | for ( keys %{$stash->{capture}} ) { | |
| 293 | my $fh = $stash->{capture}{$_}; | |
| 294 | Carp::confess "Custom handle for $_ must be seekable\n" | |
| 294 | 295 | unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable")); |
| 295 | 296 | } |
| 296 | 297 | # save existing filehandles and setup captures |
| 335 | 336 | # store old handles and setup handles for capture |
| 336 | 337 | $stash->{old} = _copy_std(); |
| 337 | 338 | $stash->{new} = { %{$stash->{old}} }; # default to originals |
| 338 | if ($do_stdout) { | |
| 339 | $stash->{new}{stdout} = ($stash->{capture}{stdout} ||= File::Temp->new); | |
| 340 | seek $stash->{capture}{stdout}, 0, 2; | |
| 341 | $stash->{pos}{stdout} = tell $stash->{capture}{stdout}; | |
| 342 | } | |
| 343 | if ($do_stderr) { | |
| 344 | $stash->{new}{stderr} = ($stash->{capture}{stderr} ||= File::Temp->new); | |
| 345 | seek $stash->{capture}{stderr}, 0, 2; | |
| 346 | $stash->{pos}{stderr} = tell $stash->{capture}{stderr}; | |
| 347 | } | |
| 348 | _debug("# will capture stdout on " . fileno($stash->{capture}{stdout})."\n" ) if $do_stdout; | |
| 349 | _debug("# will capture stderr on " . fileno($stash->{capture}{stderr})."\n" ) if $do_stderr; | |
| 350 | # get handles for capture and apply existing IO layers | |
| 351 | # tees may change $stash->{new} | |
| 352 | _start_tee( stdout => $stash ) if $do_stdout && $do_tee; | |
| 353 | _start_tee( stderr => $stash ) if $do_stderr && $do_tee; | |
| 339 | for ( keys %do ) { | |
| 340 | $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new); | |
| 341 | seek $stash->{capture}{$_}, 0, 2; | |
| 342 | $stash->{pos}{$_} = tell $stash->{capture}{$_}; | |
| 343 | _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" ); | |
| 344 | _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new} | |
| 345 | } | |
| 354 | 346 | _wait_for_tees( $stash ) if $do_tee; |
| 355 | 347 | # finalize redirection |
| 356 | 348 | $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge; |
| 378 | 370 | _debug( "# killing tee subprocesses ...\n" ) if $do_tee; |
| 379 | 371 | _kill_tees( $stash ) if $do_tee; |
| 380 | 372 | # return captured output |
| 381 | _relayer($stash->{capture}{stdout}, $layers{stdout}) if $do_stdout; | |
| 382 | _relayer($stash->{capture}{stderr}, $layers{stderr}) if $do_stderr; | |
| 383 | my $got_out = $do_stdout ? _slurp('stdout', $stash) : q(); | |
| 384 | my $got_err = $do_stderr ? _slurp('stderr', $stash) : q(); | |
| 385 | _debug("# slurped " . length($got_out) . " bytes from stdout\n"); | |
| 386 | _debug("# slurped " . length($got_err) . " bytes from stderr\n"); | |
| 387 | print CT_ORIG_STDOUT $got_out | |
| 373 | my %got; | |
| 374 | for ( keys %do ) { | |
| 375 | _relayer($stash->{capture}{$_}, $layers{$_}); | |
| 376 | $got{$_} = _slurp($_, $stash); | |
| 377 | _debug("# slurped " . length($got{$_}) . " bytes from $_\n"); | |
| 378 | } | |
| 379 | print CT_ORIG_STDOUT $got{stdout} | |
| 388 | 380 | if $do_stdout && $do_tee && $localize{stdout}; |
| 389 | print CT_ORIG_STDERR $got_err | |
| 381 | print CT_ORIG_STDERR $got{stderr} | |
| 390 | 382 | if $do_stderr && $do_tee && $localize{stderr}; |
| 391 | 383 | $? = $exit_code; |
| 392 | 384 | $@ = $inner_error if $inner_error; |
| 393 | 385 | die $outer_error if $outer_error; |
| 394 | 386 | _debug( "# ending _capture_tee with (@_)...\n" ); |
| 395 | 387 | my @return; |
| 396 | push @return, $got_out if $do_stdout; | |
| 397 | push @return, $got_err if $do_stderr; | |
| 388 | push @return, $got{stdout} if $do_stdout; | |
| 389 | push @return, $got{stderr} if $do_stderr; | |
| 398 | 390 | push @return, @result; |
| 399 | 391 | return wantarray ? @return : $return[0]; |
| 400 | 392 | } |