File Coverage

File:lib/IO/CaptureOutput.pm
Coverage:66.0%

linestmtbrancondsubcode
1package IO::CaptureOutput;
2
3
3
3
3
use strict;
3
3
3
3
3
use vars qw/$VERSION @ISA @EXPORT_OK %EXPORT_TAGS/;
4
3
3
3
3
use Exporter;
5@ISA = 'Exporter';
6@EXPORT_OK = qw/capture capture_exec qxx capture_exec_combined qxy/;
7%EXPORT_TAGS = (all => \@EXPORT_OK);
8$VERSION = '1.06';
9
10 - 18
=head1 NAME

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

=head1 DESCRIPTION

Included from CPAN.  Thanks to David Golden for reviving this useful module.

=cut
19
20sub capture (&@) { ## no critic
21
8
8
    my ($code, $output, $error) = @_;
22
8
    for ($output, $error) {
23
16
0
0
50
        $_ = \do { my $s; $s = ''} unless ref $_;
24
16
50
        $$_ = '' unless defined($$_);
25    }
26
8
    my $capture_out = IO::CaptureOutput::_proxy->new('STDOUT', $output);
27
8
50
    my $capture_err = IO::CaptureOutput::_proxy->new(
28        'STDERR', $error, $output == $error ? 'STDOUT' : undef
29    );
30
8
    &$code();
31}
32
33sub capture_exec {
34
0
0
    my @args = @_;
35
0
    my ($output, $error);
36
0
0
0
    capture sub { system _shell_quote(@args) }, \$output, \$error;
37
0
0
    return wantarray ? ($output, $error) : $output;
38}
39
40*qxx = \&capture_exec;
41
42sub capture_exec_combined {
43
0
0
    my @args = @_;
44
0
    my $output;
45
0
0
0
    capture sub { system _shell_quote(@args) }, \$output, \$output;
46
0
    return $output;
47}
48
49*qxy = \&capture_exec_combined;
50
51# extra quoting required on Win32 systems
52
0
0
*_shell_quote = ($^O =~ /MSWin32/) ? \&_shell_quote_win32 : sub {@_};
53sub _shell_quote_win32 {
54
0
0
    my @args;
55
0
    for (@_) {
56
0
0
        if (/[ \"]/) { # TODO: check if ^ requires escaping
57
0
            (my $escaped = $_) =~ s/([\"])/\\$1/g;
58
0
            push @args, '"' . $escaped . '"';
59
0
            next;
60        }
61
0
        push @args, $_
62    }
63
0
    return @args;
64}
65
66# Captures everything printed to a filehandle for the lifetime of the object
67# and then transfers it to a scalar reference
68package IO::CaptureOutput::_proxy;
69
3
3
3
3
use File::Temp 'tempfile';
70
3
3
3
3
use File::Basename qw/basename/;
71
3
3
3
3
use Symbol qw/gensym qualify qualify_to_ref/;
72
3
3
3
3
use Carp;
73
74
16
50
16
sub _is_wperl { $^O eq 'MSWin32' && basename($^X) eq 'wperl.exe' }
75
76sub new {
77
16
16
    my $class = shift;
78
16
    my ($fh, $capture, $merge_fh) = @_;
79
16
    $fh = qualify($fh); # e.g. main::STDOUT
80
16
    my $fhref = qualify_to_ref($fh); # e.g. \*STDOUT
81
82    # Duplicate the filehandle
83
16
    my $saved;
84    {
85
3
3
3
16
3
        no strict 'refs'; ## no critic - needed for 5.005
86
16
50
33
        if ( defined fileno($fh) && ! _is_wperl() ) {
87
16
            $saved = gensym;
88
16
50
            open $saved, ">&$fh" or croak "Can't redirect <$fh> - $!";
89        }
90    }
91
92    # Create replacement filehandle if not merging
93
16
    my ($newio, $newio_file);
94
16
50
    if ( ! $merge_fh ) {
95
16
        $newio = gensym;
96
16
        (undef, $newio_file) = tempfile;
97
16
50
        open $newio, "+>$newio_file" or croak "Can't create temp file for $fh - $!";
98    }
99    else {
100
0
        $newio = qualify($merge_fh);
101    }
102
103    # Redirect (or merge)
104    {
105
3
3
3
16
3
        no strict 'refs'; ## no critic -- needed for 5.005
106
16
50
        open $fhref, ">&".fileno($newio) or croak "Can't redirect $fh - $!";
107    }
108
109
16
    bless [$$, $fh, $saved, $capture, $newio, $newio_file], $class;
110}
111
112sub DESTROY {
113
16
16
    my $self = shift;
114
115
16
16
    my ($pid, $fh, $saved) = @{$self}[0..2];
116
16
50
    return unless $pid eq $$; # only cleanup in the process that is capturing
117
118    # restore the original filehandle
119
16
    my $fh_ref = Symbol::qualify_to_ref($fh);
120
16
    select((select ($fh_ref), $|=1)[0]);
121
16
50
    if (defined $saved) {
122
16
50
        open $fh_ref, ">&". fileno($saved) or croak "Can't restore $fh - $!";
123    }
124    else {
125
0
        close $fh_ref;
126    }
127
128    # transfer captured data to the scalar reference if we didn't merge
129
16
16
    my ($capture, $newio, $newio_file) = @{$self}[3..5];
130
16
50
    if ($newio_file) {
131        # some versions of perl complain about reading from fd 1 or 2
132        # which could happen if STDOUT and STDERR were closed when $newio
133        # was opened, so we just squelch warnings here and continue
134
16
        local $^W;
135
16
        seek $newio, 0, 0;
136
16
16
16
        $$capture = do {local $/; <$newio>};
137
16
        close $newio;
138    }
139
140    # Cleanup
141
16
50
33
    return unless defined $newio_file && -e $newio_file;
142
16
50
    unlink $newio_file or carp "Couldn't remove temp file '$newio_file' - $!";
143}
144
1451;
146