xref: /dports/devel/p5-IO-CaptureOutput/IO-CaptureOutput-1.1105/lib/IO/CaptureOutput.pm

use strict;
use warnings;

package IO::CaptureOutput;
# ABSTRACT: (DEPRECATED) capture STDOUT and STDERR from Perl code, subprocesses or XS

our $VERSION = '1.1105';

use vars qw/@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);
$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 0.16 '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__

=pod

=encoding UTF-8

=head1 NAME

IO::CaptureOutput - (DEPRECATED) capture STDOUT and STDERR from Perl code, subprocesses or XS

=head1 VERSION

version 1.1105

=head1 SYNOPSIS

    use IO::CaptureOutput qw(capture qxx qxy);

    # STDOUT and STDERR separately
    capture { noisy_sub(@args) } \$stdout, \$stderr;

    # STDOUT and STDERR together
    capture { noisy_sub(@args) } \$combined, \$combined;

    # STDOUT and STDERR from external command
    ($stdout, $stderr, $success) = qxx( @cmd );

    # STDOUT and STDERR together from external command
    ($combined, $success) = qxy( @cmd );

=head1 DESCRIPTION

B<This module is no longer recommended by the maintainer> - see
L<Capture::Tiny> instead.

This module provides routines for capturing STDOUT and STDERR from perl
subroutines, forked system calls (e.g. C<system()>, C<fork()>) and from XS
or C modules.

=head1 NAME

=head1 FUNCTIONS

The following functions will be exported on demand.

=head2 capture()

    capture \&subroutine, \$stdout, \$stderr;

Captures everything printed to C<STDOUT> and C<STDERR> for the duration of
C<&subroutine>. C<$stdout> and C<$stderr> are optional scalars that will
contain C<STDOUT> and C<STDERR> respectively.

C<capture()> uses a code prototype so the first argument can be specified
directly within brackets if desired.

    # shorthand with prototype
    capture C< print __PACKAGE__ > \$stdout, \$stderr;

Returns the return value(s) of C<&subroutine>. The sub is called in the
same context as C<capture()> was called e.g.:

    @rv = capture C< wantarray > ; # returns true
    $rv = capture C< wantarray > ; # returns defined, but not true
    capture C< wantarray >;       # void, returns undef

C<capture()> is able to capture output from subprocesses and C code, which
traditional C<tie()> methods of output capture are unable to do.

B<Note:> C<capture()> will only capture output that has been written or
flushed to the filehandle.

If the two scalar references refer to the same scalar, then C<STDERR> will
be merged to C<STDOUT> before capturing and the scalar will hold the
combined output of both.

    capture \&subroutine, \$combined, \$combined;

Normally, C<capture()> uses anonymous, temporary files for capturing
output.  If desired, specific file names may be provided instead as
additional options.

    capture \&subroutine, \$stdout, \$stderr, $out_file, $err_file;

Files provided will be clobbered, overwriting any previous data, but will
persist after the call to C<capture()> for inspection or other
manipulation.

By default, when no references are provided to hold STDOUT or STDERR,
output is captured and silently discarded.

    # Capture STDOUT, discard STDERR
    capture \&subroutine, \$stdout;

    # Discard STDOUT, capture STDERR
    capture \&subroutine, undef, \$stderr;

However, even when using C<undef>, output can be captured to specific
files.

    # Capture STDOUT to a specific file, discard STDERR
    capture \&subroutine, \$stdout, undef, $outfile;

    # Discard STDOUT, capture STDERR to a specific file
    capture \&subroutine, undef, \$stderr, undef, $err_file;

    # Discard both, capture merged output to a specific file
    capture \&subroutine, undef, undef, $mergedfile;

It is a fatal error to merge STDOUT and STDERR and request separate,
specific files for capture.

    # ERROR:
    capture \&subroutine, \$stdout, \$stdout, $out_file, $err_file;
    capture \&subroutine, undef, undef, $out_file, $err_file;

If either STDOUT or STDERR should be passed through to the terminal instead
of captured, provide a reference to undef -- C<\undef> -- instead of a
capture variable.

    # Capture STDOUT, display STDERR
    capture \&subroutine, \$stdout, \undef;

    # Display STDOUT, capture STDERR
    capture \&subroutine, \undef, \$stderr;

=head2 capture_exec()

    ($stdout, $stderr, $success, $exit_code) = capture_exec(@args);

Captures and returns the output from C<system(@args)>. In scalar context,
C<capture_exec()> will return what was printed to C<STDOUT>. In list
context, it returns what was printed to C<STDOUT> and C<STDERR> as well as
a success flag and the exit value.

    $stdout = capture_exec('perl', '-e', 'print "hello world"');

    ($stdout, $stderr, $success, $exit_code) =
        capture_exec('perl', '-e', 'warn "Test"');

C<capture_exec> passes its arguments to C<system()> and on MSWin32 will
protect arguments with shell quotes if necessary.  This makes it a handy
and slightly more portable alternative to backticks, piped C<open()> and
C<IPC::Open3>.

The C<$success> flag returned will be true if the command ran successfully
and false if it did not (if the command could not be run or if it ran and
returned a non-zero exit value).  On failure, the raw exit value of the
C<system()> call is available both in the C<$exit_code> returned and in the
C<$?> variable.

  ($stdout, $stderr, $success, $exit_code) =
      capture_exec('perl', '-e', 'warn "Test" and exit 1');

  if ( ! $success ) {
      print "The exit code was " . ($exit_code >> 8) . "\n";
  }

See L<perlvar> for more information on interpreting a child process exit
code.

=head2 capture_exec_combined()

    ($combined, $success, $exit_code) = capture_exec_combined(
        'perl', '-e', 'print "hello\n"', 'warn "Test\n"
    );

This is just like C<capture_exec()>, except that it merges C<STDERR> with
C<STDOUT> before capturing output.

B<Note:> there is no guarantee that text printed to C<STDOUT> and C<STDERR>
in the subprocess will be appear in order. The actual order will depend on
how IO buffering is handled in the subprocess.

=head2 qxx()

This is an alias for C<capture_exec()>.

=head2 qxy()

This is an alias for C<capture_exec_combined()>.

=head1 SEE ALSO

=over 4

=item *

L<Capture::Tiny>

=item *

L<IPC::Open3>

=item *

L<IO::Capture>

=item *

L<IO::Utils>

=item *

L<IPC::System::Simple>

=back

=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan

=head1 SUPPORT

=head2 Bugs / Feature Requests

Please report any bugs or feature requests through the issue tracker
at L<https://github.com/dagolden/IO-CaptureOutput/issues>.
You will be notified automatically of any progress on your issue.

=head2 Source Code

This is open source software.  The code repository is available for
public review and contribution under the terms of the license.

L<https://github.com/dagolden/IO-CaptureOutput>

  git clone https://github.com/dagolden/IO-CaptureOutput.git

=head1 AUTHORS

=over 4

=item *

Simon Flack <simonflk@cpan.org>

=item *

David Golden <dagolden@cpan.org>

=back

=head1 CONTRIBUTORS

=for stopwords David Golden José Joaquín Atria Mike Latimer Olivier Mengué Tony Cook

=over 4

=item *

David Golden <xdg@xdg.me>

=item *

José Joaquín Atria <jjatria@gmail.com>

=item *

Mike Latimer <mlatimer@suse.com>

=item *

Olivier Mengué <dolmen@cpan.org>

=item *

Tony Cook <tony@develop-help.com>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2019 by Simon Flack and David Golden.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut