line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
6
|
|
|
6
|
|
102156
|
use strict; |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
246
|
|
2
|
6
|
|
|
6
|
|
26
|
use warnings; |
|
6
|
|
|
|
|
8
|
|
|
6
|
|
|
|
|
356
|
|
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
package IO::CaptureOutput; |
5
|
|
|
|
|
|
|
# ABSTRACT: capture STDOUT and STDERR from Perl code, subprocesses or XS |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $VERSION = '1.1104'; |
8
|
|
|
|
|
|
|
|
9
|
6
|
|
|
6
|
|
30
|
use vars qw/@ISA @EXPORT_OK %EXPORT_TAGS $CarpLevel/; |
|
6
|
|
|
|
|
26
|
|
|
6
|
|
|
|
|
452
|
|
10
|
6
|
|
|
6
|
|
30
|
use Exporter; |
|
6
|
|
|
|
|
10
|
|
|
6
|
|
|
|
|
296
|
|
11
|
6
|
|
|
6
|
|
30
|
use Carp qw/croak/; |
|
6
|
|
|
|
|
10
|
|
|
6
|
|
|
|
|
4781
|
|
12
|
|
|
|
|
|
|
@ISA = 'Exporter'; |
13
|
|
|
|
|
|
|
@EXPORT_OK = qw/capture capture_exec qxx capture_exec_combined qxy/; |
14
|
|
|
|
|
|
|
%EXPORT_TAGS = (all => \@EXPORT_OK); |
15
|
|
|
|
|
|
|
$CarpLevel = 0; # help capture report errors at the right level |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
sub _capture (&@) { ## no critic |
18
|
60
|
|
|
60
|
|
113
|
my ($code, $output, $error, $output_file, $error_file) = @_; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
# check for valid combinations of input |
21
|
|
|
|
|
|
|
{ |
22
|
60
|
|
|
|
|
75
|
local $Carp::CarpLevel = 1; |
|
60
|
|
|
|
|
108
|
|
23
|
60
|
|
|
|
|
160
|
my $error = _validate($output, $error, $output_file, $error_file); |
24
|
60
|
100
|
|
|
|
741
|
croak $error if $error; |
25
|
|
|
|
|
|
|
} |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
# if either $output or $error are defined, then we need a variable for |
28
|
|
|
|
|
|
|
# results; otherwise we only capture to files and don't waste memory |
29
|
58
|
100
|
100
|
|
|
181
|
if ( defined $output || defined $error ) { |
30
|
48
|
|
|
|
|
79
|
for ($output, $error) { |
31
|
96
|
100
|
|
|
|
193
|
$_ = \do { my $s; $s = ''} unless ref $_; |
|
10
|
|
|
|
|
49
|
|
|
10
|
|
|
|
|
22
|
|
32
|
96
|
100
|
100
|
|
|
515
|
$$_ = '' if $_ != \undef && !defined($$_); |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
# merge if same refs for $output and $error or if both are undef -- |
37
|
|
|
|
|
|
|
# i.e. capture \&foo, undef, undef, $merged_file |
38
|
|
|
|
|
|
|
# this means capturing into separate files *requires* at least one |
39
|
|
|
|
|
|
|
# capture variable |
40
|
58
|
|
100
|
|
|
621
|
my $should_merge = |
41
|
|
|
|
|
|
|
(defined $error && defined $output && $output == $error) || |
42
|
|
|
|
|
|
|
( !defined $output && !defined $error ) || |
43
|
|
|
|
|
|
|
0; |
44
|
|
|
|
|
|
|
|
45
|
58
|
|
|
|
|
65
|
my ($capture_out, $capture_err); |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# undef means capture anonymously; anything other than \undef means |
48
|
|
|
|
|
|
|
# capture to that ref; \undef means skip capture |
49
|
58
|
100
|
100
|
|
|
307
|
if ( !defined $output || $output != \undef ) { |
50
|
56
|
|
|
|
|
324
|
$capture_out = IO::CaptureOutput::_proxy->new( |
51
|
|
|
|
|
|
|
'STDOUT', $output, undef, $output_file |
52
|
|
|
|
|
|
|
); |
53
|
|
|
|
|
|
|
} |
54
|
58
|
100
|
100
|
|
|
347
|
if ( !defined $error || $error != \undef ) { |
55
|
56
|
100
|
|
|
|
274
|
$capture_err = IO::CaptureOutput::_proxy->new( |
56
|
|
|
|
|
|
|
'STDERR', $error, ($should_merge ? 'STDOUT' : undef), $error_file |
57
|
|
|
|
|
|
|
); |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
# now that output capture is setup, call the subroutine |
61
|
|
|
|
|
|
|
# results get read when IO::CaptureOutput::_proxy objects go out of scope |
62
|
58
|
|
|
|
|
416
|
&$code(); |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
# Extra indirection for symmetry with capture_exec, etc. Gets error reporting |
66
|
|
|
|
|
|
|
# to the right level |
67
|
|
|
|
|
|
|
sub capture (&@) { ## no critic |
68
|
50
|
|
|
50
|
1
|
42880
|
return &_capture; |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
sub capture_exec { |
72
|
5
|
|
|
5
|
1
|
9391
|
my @args = @_; |
73
|
5
|
|
|
|
|
12
|
my ($output, $error); |
74
|
5
|
|
|
5
|
|
39
|
my $exit = _capture sub { system _shell_quote(@args) }, \$output, \$error; |
|
5
|
|
|
|
|
16
|
|
75
|
5
|
100
|
|
|
|
69
|
my $success = ($exit == 0 ) ? 1 : 0 ; |
76
|
5
|
|
|
|
|
28
|
$? = $exit; |
77
|
5
|
100
|
|
|
|
67
|
return wantarray ? ($output, $error, $success, $exit) : $output; |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
*qxx = \&capture_exec; |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
sub capture_exec_combined { |
83
|
5
|
|
|
5
|
1
|
9412
|
my @args = @_; |
84
|
5
|
|
|
|
|
12
|
my $output; |
85
|
5
|
|
|
5
|
|
47
|
my $exit = _capture sub { system _shell_quote(@args) }, \$output, \$output; |
|
5
|
|
|
|
|
24
|
|
86
|
5
|
100
|
|
|
|
70
|
my $success = ($exit == 0 ) ? 1 : 0 ; |
87
|
5
|
|
|
|
|
23
|
$? = $exit; |
88
|
5
|
100
|
|
|
|
54
|
return wantarray ? ($output, $success, $exit) : $output; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
*qxy = \&capture_exec_combined; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# extra quoting required on Win32 systems |
94
|
10
|
|
|
10
|
|
34198
|
*_shell_quote = ($^O =~ /MSWin32/) ? \&_shell_quote_win32 : sub {@_}; |
95
|
|
|
|
|
|
|
sub _shell_quote_win32 { |
96
|
0
|
|
|
0
|
|
0
|
my @args; |
97
|
0
|
|
|
|
|
0
|
for (@_) { |
98
|
0
|
0
|
|
|
|
0
|
if (/[ \"]/) { # TODO: check if ^ requires escaping |
99
|
0
|
|
|
|
|
0
|
(my $escaped = $_) =~ s/([\"])/\\$1/g; |
100
|
0
|
|
|
|
|
0
|
push @args, '"' . $escaped . '"'; |
101
|
0
|
|
|
|
|
0
|
next; |
102
|
|
|
|
|
|
|
} |
103
|
0
|
|
|
|
|
0
|
push @args, $_ |
104
|
|
|
|
|
|
|
} |
105
|
0
|
|
|
|
|
0
|
return @args; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
# detect errors and return an error message or empty string; |
109
|
|
|
|
|
|
|
sub _validate { |
110
|
60
|
|
|
60
|
|
81
|
my ($output, $error, $output_file, $error_file) = @_; |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
# default to "ok" |
113
|
60
|
|
|
|
|
158
|
my $msg = q{}; |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
# \$out, \$out, $outfile, $errfile |
116
|
60
|
100
|
100
|
|
|
829
|
if ( defined $output && defined $error |
|
|
100
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
117
|
|
|
|
|
|
|
&& defined $output_file && defined $error_file |
118
|
|
|
|
|
|
|
&& $output == $error |
119
|
|
|
|
|
|
|
&& $output != \undef |
120
|
|
|
|
|
|
|
&& $output_file ne $error_file |
121
|
|
|
|
|
|
|
) { |
122
|
1
|
|
|
|
|
3
|
$msg = "Merged STDOUT and STDERR, but specified different output and error files"; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
# undef, undef, $outfile, $errfile |
125
|
|
|
|
|
|
|
elsif ( !defined $output && !defined $error |
126
|
|
|
|
|
|
|
&& defined $output_file && defined $error_file |
127
|
|
|
|
|
|
|
&& $output_file ne $error_file |
128
|
|
|
|
|
|
|
) { |
129
|
1
|
|
|
|
|
3
|
$msg = "Merged STDOUT and STDERR, but specified different output and error files"; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
60
|
|
|
|
|
128
|
return $msg; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
# Captures everything printed to a filehandle for the lifetime of the object |
136
|
|
|
|
|
|
|
# and then transfers it to a scalar reference |
137
|
|
|
|
|
|
|
package IO::CaptureOutput::_proxy; |
138
|
6
|
|
|
6
|
|
4766
|
use File::Temp 0.16 'tempfile'; |
|
6
|
|
|
|
|
116246
|
|
|
6
|
|
|
|
|
434
|
|
139
|
6
|
|
|
6
|
|
45
|
use File::Basename qw/basename/; |
|
6
|
|
|
|
|
8
|
|
|
6
|
|
|
|
|
449
|
|
140
|
6
|
|
|
6
|
|
31
|
use Symbol qw/gensym qualify qualify_to_ref/; |
|
6
|
|
|
|
|
8
|
|
|
6
|
|
|
|
|
320
|
|
141
|
6
|
|
|
6
|
|
34
|
use Carp; |
|
6
|
|
|
|
|
8
|
|
|
6
|
|
|
|
|
754
|
|
142
|
|
|
|
|
|
|
|
143
|
110
|
50
|
|
110
|
|
623
|
sub _is_wperl { $^O eq 'MSWin32' && basename($^X) eq 'wperl.exe' } |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
sub new { |
146
|
112
|
|
|
112
|
|
154
|
my $class = shift; |
147
|
112
|
|
|
|
|
186
|
my ($orig_fh, $capture_var, $merge_fh, $capture_file) = @_; |
148
|
112
|
|
|
|
|
301
|
$orig_fh = qualify($orig_fh); # e.g. main::STDOUT |
149
|
112
|
|
|
|
|
1933
|
my $fhref = qualify_to_ref($orig_fh); # e.g. \*STDOUT |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
# Duplicate the filehandle |
152
|
112
|
|
|
|
|
982
|
my $saved_fh; |
153
|
|
|
|
|
|
|
{ |
154
|
6
|
|
|
6
|
|
76
|
no strict 'refs'; ## no critic - needed for 5.005 |
|
6
|
|
|
|
|
8
|
|
|
6
|
|
|
|
|
982
|
|
|
112
|
|
|
|
|
104
|
|
155
|
112
|
100
|
66
|
|
|
462
|
if ( defined fileno($orig_fh) && ! _is_wperl() ) { |
156
|
110
|
|
|
|
|
230
|
$saved_fh = gensym; |
157
|
110
|
50
|
|
|
|
2273
|
open $saved_fh, ">&$orig_fh" or croak "Can't redirect <$orig_fh> - $!"; |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# Create replacement filehandle if not merging |
162
|
112
|
|
|
|
|
134
|
my ($newio_fh, $newio_file); |
163
|
112
|
100
|
|
|
|
205
|
if ( ! $merge_fh ) { |
164
|
92
|
|
|
|
|
159
|
$newio_fh = gensym; |
165
|
92
|
100
|
|
|
|
856
|
if ($capture_file) { |
166
|
19
|
|
|
|
|
29
|
$newio_file = $capture_file; |
167
|
|
|
|
|
|
|
} else { |
168
|
73
|
|
|
|
|
222
|
(undef, $newio_file) = tempfile; |
169
|
|
|
|
|
|
|
} |
170
|
92
|
50
|
|
|
|
27104
|
open $newio_fh, "+>$newio_file" or croak "Can't write temp file for $orig_fh - $!"; |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
else { |
173
|
20
|
|
|
|
|
49
|
$newio_fh = qualify($merge_fh); |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
# Redirect (or merge) |
177
|
|
|
|
|
|
|
{ |
178
|
6
|
|
|
6
|
|
31
|
no strict 'refs'; ## no critic -- needed for 5.005 |
|
6
|
|
|
|
|
9
|
|
|
6
|
|
|
|
|
1642
|
|
|
112
|
|
|
|
|
386
|
|
179
|
112
|
50
|
|
|
|
1320
|
open $fhref, ">&".fileno($newio_fh) or croak "Can't redirect $orig_fh - $!"; |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
|
182
|
112
|
|
|
|
|
724
|
bless [$$, $orig_fh, $saved_fh, $capture_var, $newio_fh, $newio_file, $capture_file], $class; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
sub DESTROY { |
186
|
112
|
|
|
112
|
|
224782
|
my $self = shift; |
187
|
|
|
|
|
|
|
|
188
|
112
|
|
|
|
|
418
|
my ($pid, $orig_fh, $saved_fh, $capture_var, $newio_fh, |
189
|
|
|
|
|
|
|
$newio_file, $capture_file) = @$self; |
190
|
112
|
100
|
|
|
|
724
|
return unless $pid eq $$; # only cleanup in the process that is capturing |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
# restore the original filehandle |
193
|
110
|
|
|
|
|
342
|
my $fh_ref = Symbol::qualify_to_ref($orig_fh); |
194
|
110
|
|
|
|
|
1652
|
select((select ($fh_ref), $|=1)[0]); |
195
|
110
|
100
|
|
|
|
223
|
if (defined $saved_fh) { |
196
|
108
|
50
|
|
|
|
1333
|
open $fh_ref, ">&". fileno($saved_fh) or croak "Can't restore $orig_fh - $!"; |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
else { |
199
|
2
|
|
|
|
|
9
|
close $fh_ref; |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# transfer captured data to the scalar reference if we didn't merge |
203
|
|
|
|
|
|
|
# $newio_file is undef if this file handle is merged to another |
204
|
110
|
100
|
100
|
|
|
527
|
if (ref $capture_var && $newio_file) { |
205
|
|
|
|
|
|
|
# some versions of perl complain about reading from fd 1 or 2 |
206
|
|
|
|
|
|
|
# which could happen if STDOUT and STDERR were closed when $newio |
207
|
|
|
|
|
|
|
# was opened, so we just squelch warnings here and continue |
208
|
80
|
|
|
|
|
297
|
local $^W; |
209
|
80
|
|
|
|
|
199
|
seek $newio_fh, 0, 0; |
210
|
80
|
|
|
|
|
82
|
$$capture_var = do {local $/; <$newio_fh>}; |
|
80
|
|
|
|
|
233
|
|
|
80
|
|
|
|
|
1522
|
|
211
|
|
|
|
|
|
|
} |
212
|
110
|
100
|
|
|
|
652
|
close $newio_fh if $newio_file; |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
# Cleanup |
215
|
110
|
100
|
66
|
|
|
1686
|
return unless defined $newio_file && -e $newio_file; |
216
|
90
|
100
|
|
|
|
353
|
return if $capture_file; # the "temp" file was explicitly named |
217
|
71
|
50
|
|
|
|
4819
|
unlink $newio_file or carp "Couldn't remove temp file '$newio_file' - $!"; |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
1; |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
__END__ |