IO::CaptureOutput

# $Id: CaptureOutput.pm,v 1.3 2005/03/25 12:44:14 simonflack Exp $
package IO::CaptureOutput;
use strict;
use vars qw/$VERSION @ISA @EXPORT_OK %EXPORT_TAGS $CarpLevel/;
use Exporter;
use Carp qw/croak/;
@ISA = 'Exporter';
@EXPORT_OK = qw/capture capture_exec qxx capture_exec_combined qxy/;
%EXPORT_TAGS = (all => \@EXPORT_OK);
$VERSION = '1.1102';
$VERSION = eval $VERSION; ## no critic
$CarpLevel = 0; # help capture report errors at the right level

sub _capture (&@) { ## no critic
    my ($code, $output, $error, $output_file, $error_file) = @_;

    # check for valid combinations of input
    {
      local $Carp::CarpLevel = 1;
      my $error = _validate($output, $error, $output_file, $error_file);
      croak $error if $error;
    }

    # if either $output or $error are defined, then we need a variable for 
    # results; otherwise we only capture to files and don't waste memory
    if ( defined $output || defined $error ) {
      for ($output, $error) {
          $_ = \do { my $s; $s = ''} unless ref $_;
          $$_ = '' if $_ != \undef && !defined($$_);
      }
    }

    # merge if same refs for $output and $error or if both are undef -- 
    # i.e. capture \&foo, undef, undef, $merged_file
    # this means capturing into separate files *requires* at least one
    # capture variable
    my $should_merge = 
      (defined $error && defined $output && $output == $error) || 
      ( !defined $output && !defined $error ) || 
      0;

    my ($capture_out, $capture_err);

    # undef means capture anonymously; anything other than \undef means 
    # capture to that ref; \undef means skip capture
    if ( !defined $output || $output != \undef ) { 
        $capture_out = IO::CaptureOutput::_proxy->new(
            'STDOUT', $output, undef, $output_file
        );
    }
    if ( !defined $error || $error != \undef ) { 
        $capture_err = IO::CaptureOutput::_proxy->new(
            'STDERR', $error, ($should_merge ? 'STDOUT' : undef), $error_file
        );
    }

    # now that output capture is setup, call the subroutine
    # results get read when IO::CaptureOutput::_proxy objects go out of scope
    &$code();
}

# Extra indirection for symmetry with capture_exec, etc.  Gets error reporting
# to the right level
sub capture (&@) { ## no critic
    return &_capture; 
}

sub capture_exec {
    my @args = @_;
    my ($output, $error);
    my $exit = _capture sub { system _shell_quote(@args) }, \$output, \$error;
    my $success = ($exit == 0 ) ? 1 : 0 ;
    $? = $exit;
    return wantarray ? ($output, $error, $success, $exit) : $output;
}

*qxx = \&capture_exec;

sub capture_exec_combined {
    my @args = @_;
    my $output;
    my $exit = _capture sub { system _shell_quote(@args) }, \$output, \$output;
    my $success = ($exit == 0 ) ? 1 : 0 ;
    $? = $exit;
    return wantarray ? ($output, $success, $exit) : $output;
}

*qxy = \&capture_exec_combined;

# extra quoting required on Win32 systems
*_shell_quote = ($^O =~ /MSWin32/) ? \&_shell_quote_win32 : sub {@_};
sub _shell_quote_win32 {
    my @args;
    for (@_) {
        if (/[ \"]/) { # TODO: check if ^ requires escaping
            (my $escaped = $_) =~ s/([\"])/\\$1/g;
            push @args, '"' . $escaped . '"';
            next;
        }
        push @args, $_
    }
    return @args;
}

# detect errors and return an error message or empty string;
sub _validate {
    my ($output, $error, $output_file, $error_file) = @_;

    # default to "ok"
    my $msg = q{};

    # \$out, \$out, $outfile, $errfile
    if (    defined $output && defined $error  
        &&  defined $output_file && defined $error_file
        &&  $output == $error
        &&  $output != \undef
        &&  $output_file ne $error_file
    ) {
      $msg = "Merged STDOUT and STDERR, but specified different output and error files";
    }
    # undef, undef, $outfile, $errfile
    elsif ( !defined $output && !defined $error  
        &&  defined $output_file && defined $error_file
        &&  $output_file ne $error_file
    ) {
      $msg = "Merged STDOUT and STDERR, but specified different output and error files";
    }

    return $msg;
}

# Captures everything printed to a filehandle for the lifetime of the object
# and then transfers it to a scalar reference
package IO::CaptureOutput::_proxy;
use File::Temp 'tempfile';
use File::Basename qw/basename/;
use Symbol qw/gensym qualify qualify_to_ref/;
use Carp;

sub _is_wperl { $^O eq 'MSWin32' && basename($^X) eq 'wperl.exe' }

sub new {
    my $class = shift;
    my ($orig_fh, $capture_var, $merge_fh, $capture_file) = @_;
    $orig_fh       = qualify($orig_fh);         # e.g. main::STDOUT
    my $fhref = qualify_to_ref($orig_fh);  # e.g. \*STDOUT

    # Duplicate the filehandle
    my $saved_fh;
    {
        no strict 'refs'; ## no critic - needed for 5.005
        if ( defined fileno($orig_fh) && ! _is_wperl() ) {
            $saved_fh = gensym;
            open $saved_fh, ">&$orig_fh" or croak "Can't redirect <$orig_fh> - $!";
        }
    }

    # Create replacement filehandle if not merging
    my ($newio_fh, $newio_file);
    if ( ! $merge_fh ) {
        $newio_fh = gensym;
        if ($capture_file) {
            $newio_file = $capture_file;
        } else {
            (undef, $newio_file) = tempfile;
        }
        open $newio_fh, "+>$newio_file" or croak "Can't write temp file for $orig_fh - $!";
    }
    else {
        $newio_fh = qualify($merge_fh);
    }

    # Redirect (or merge)
    {
        no strict 'refs'; ## no critic -- needed for 5.005
        open $fhref, ">&".fileno($newio_fh) or croak "Can't redirect $orig_fh - $!";
    }

    bless [$$, $orig_fh, $saved_fh, $capture_var, $newio_fh, $newio_file, $capture_file], $class;
}

sub DESTROY {
    my $self = shift;

    my ($pid, $orig_fh, $saved_fh, $capture_var, $newio_fh, 
      $newio_file, $capture_file) = @$self;
    return unless $pid eq $$; # only cleanup in the process that is capturing

    # restore the original filehandle
    my $fh_ref = Symbol::qualify_to_ref($orig_fh);
    select((select ($fh_ref), $|=1)[0]);
    if (defined $saved_fh) {
        open $fh_ref, ">&". fileno($saved_fh) or croak "Can't restore $orig_fh - $!";
    }
    else {
        close $fh_ref;
    }

    # transfer captured data to the scalar reference if we didn't merge
    # $newio_file is undef if this file handle is merged to another
    if (ref $capture_var && $newio_file) {
        # some versions of perl complain about reading from fd 1 or 2
        # which could happen if STDOUT and STDERR were closed when $newio
        # was opened, so we just squelch warnings here and continue
        local $^W; 
        seek $newio_fh, 0, 0;
        $$capture_var = do {local $/; <$newio_fh>};
    }
    close $newio_fh if $newio_file;

    # Cleanup
    return unless defined $newio_file && -e $newio_file;
    return if $capture_file; # the "temp" file was explicitly named
    unlink $newio_file or carp "Couldn't remove temp file '$newio_file' - $!";
}

1;

__END__