line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
## no critic (Documentation::RequirePodAtEnd) |
2
|
|
|
|
|
|
|
## no critic (Documentation::RequirePodSections) |
3
|
|
|
|
|
|
|
## no critic (ControlStructures::ProhibitDeepNests) |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package IPC::RunExternal; |
6
|
|
|
|
|
|
|
|
7
|
1
|
|
|
1
|
|
56139
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
23
|
|
8
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
20
|
|
9
|
1
|
|
|
1
|
|
19
|
use 5.010000; |
|
1
|
|
|
|
|
3
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
# ABSTRACT: Execute an external command conveniently by hiding the details of IPC::Open3. |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
our $VERSION = '0.100'; # VERSION: generated by DZP::OurPkgVersion |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
|
16
|
1
|
|
|
1
|
|
474
|
use English '-no_match_vars'; |
|
1
|
|
|
|
|
3107
|
|
|
1
|
|
|
|
|
6
|
|
17
|
1
|
|
|
1
|
|
303
|
use Carp 'croak'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
40
|
|
18
|
1
|
|
|
1
|
|
401
|
use IPC::Open3; |
|
1
|
|
|
|
|
3352
|
|
|
1
|
|
|
|
|
49
|
|
19
|
1
|
|
|
1
|
|
385
|
use IO::Select; # for select |
|
1
|
|
|
|
|
1373
|
|
|
1
|
|
|
|
|
50
|
|
20
|
1
|
|
|
1
|
|
6
|
use Symbol 'gensym'; # for gensym |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
39
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
BEGIN { |
23
|
1
|
|
|
1
|
|
4
|
use Exporter (); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
55
|
|
24
|
1
|
|
|
1
|
|
9
|
our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); |
25
|
|
|
|
|
|
|
|
26
|
1
|
|
|
|
|
19
|
@ISA = qw(Exporter DynaLoader); |
27
|
1
|
|
|
|
|
3
|
@EXPORT = qw(runexternal); |
28
|
1
|
|
|
|
|
2
|
%EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ], |
29
|
1
|
|
|
|
|
543
|
@EXPORT_OK = qw(runexternal); |
30
|
|
|
|
|
|
|
} |
31
|
|
|
|
|
|
|
our @EXPORT_OK; |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
# CONSTANTS for this module |
34
|
|
|
|
|
|
|
my $TRUE = 1; |
35
|
|
|
|
|
|
|
my $FALSE = 0; |
36
|
|
|
|
|
|
|
my $EMPTY_STR = q{}; |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
my $DEFAULT_PRINT_PROGRESS_INDICATOR = $FALSE; |
39
|
|
|
|
|
|
|
my $DEFAULT_PROGRESS_INDICATOR_CHARACTER = q{.}; |
40
|
|
|
|
|
|
|
my $DEFAULT_EXECUTE_EVERY_SECOND_ROUTINE_POINTER = $FALSE; |
41
|
|
|
|
|
|
|
my $EXIT_STATUS_OK = 1; |
42
|
|
|
|
|
|
|
my $EXIT_STATUS_TIMEOUT = 0; |
43
|
|
|
|
|
|
|
my $EXIT_STATUS_FAILED = -1; |
44
|
|
|
|
|
|
|
my $SIGKILL = 9; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# GLOBALS |
47
|
|
|
|
|
|
|
# No global variables |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub runexternal { |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# Parameters |
55
|
7
|
|
|
7
|
1
|
14641
|
my ($command, $input, $timeout, $parameter_tags) = @_; |
56
|
|
|
|
|
|
|
|
57
|
7
|
50
|
|
|
|
38
|
if(!defined $command) { |
58
|
0
|
|
|
|
|
0
|
croak('Parameter \'command\' is not initialized!'); |
59
|
|
|
|
|
|
|
} |
60
|
7
|
50
|
|
|
|
20
|
if(!defined $input) { |
61
|
0
|
|
|
|
|
0
|
croak('Parameter \'input\' is not initialized!'); |
62
|
|
|
|
|
|
|
} |
63
|
7
|
50
|
|
|
|
20
|
if($timeout < 0) { |
64
|
0
|
|
|
|
|
0
|
croak('Parameter \'timeout\' is not valid!'); |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
|
67
|
7
|
|
|
|
|
13
|
my $print_progress_indicator = $DEFAULT_PRINT_PROGRESS_INDICATOR; |
68
|
7
|
50
|
|
|
|
18
|
if(exists $parameter_tags->{'print_progress_indicator'}) { |
69
|
0
|
0
|
0
|
|
|
0
|
if($parameter_tags->{'print_progress_indicator'} == $FALSE || |
70
|
|
|
|
|
|
|
$parameter_tags->{'print_progress_indicator'} == $TRUE) { |
71
|
0
|
|
|
|
|
0
|
$print_progress_indicator = $parameter_tags->{'print_progress_indicator'}; |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
else { |
74
|
0
|
|
|
|
|
0
|
croak('Parameter \'print_progress_indicator\' is not valid (must be 1/0)!'); |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
7
|
|
|
|
|
12
|
my $progress_indicator_char = $DEFAULT_PROGRESS_INDICATOR_CHARACTER; |
79
|
7
|
100
|
|
|
|
15
|
if(exists $parameter_tags->{'progress_indicator_char'}) { |
80
|
1
|
|
|
|
|
7
|
$progress_indicator_char = $parameter_tags->{'progress_indicator_char'}; |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
7
|
|
|
|
|
10
|
my $execute_every_second = $DEFAULT_EXECUTE_EVERY_SECOND_ROUTINE_POINTER; |
84
|
7
|
50
|
|
|
|
15
|
if(exists $parameter_tags->{'execute_every_second'}) { |
85
|
0
|
0
|
|
|
|
0
|
if(ref($parameter_tags->{'execute_every_second'}) eq 'CODE') { |
86
|
0
|
|
|
|
|
0
|
$execute_every_second = $parameter_tags->{'execute_every_second'}; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
else { |
89
|
0
|
|
|
|
|
0
|
croak('Parameter execute_every_second is not a code reference!'); |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# Variables |
94
|
7
|
|
|
|
|
10
|
my $command_exit_status = $EXIT_STATUS_OK; |
95
|
7
|
|
|
|
|
10
|
my $output_std = $EMPTY_STR; |
96
|
7
|
|
|
|
|
9
|
my $output_error = $EMPTY_STR; |
97
|
7
|
|
|
|
|
8
|
my $output_all = $EMPTY_STR; |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
# Validity check |
100
|
7
|
50
|
33
|
|
|
79
|
if( |
101
|
|
|
|
|
|
|
$command ne $EMPTY_STR |
102
|
|
|
|
|
|
|
#&& defined($input) |
103
|
|
|
|
|
|
|
&& $timeout >= 0 |
104
|
|
|
|
|
|
|
) |
105
|
|
|
|
|
|
|
{ |
106
|
7
|
|
|
|
|
25
|
$OUTPUT_AUTOFLUSH = $TRUE; # Equals to var $|. Flushes always after writing. |
107
|
7
|
|
|
|
|
9
|
my ($infh,$outfh,$errfh); # these are the FHs for our child |
108
|
7
|
|
|
|
|
52
|
$errfh = gensym(); # we create a symbol for the errfh |
109
|
|
|
|
|
|
|
# because open3 will not do that for us |
110
|
7
|
|
|
|
|
186
|
my $pid; |
111
|
|
|
|
|
|
|
# Read Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval |
112
|
|
|
|
|
|
|
# for an evil eval weakness and a dasdardly difficult eval handling. |
113
|
7
|
|
|
|
|
10
|
my $eval_ok = 1; |
114
|
|
|
|
|
|
|
eval { |
115
|
7
|
|
|
|
|
32
|
$pid = open3($infh, $outfh, $errfh, $command); |
116
|
|
|
|
|
|
|
# To cover the possiblity that an operation may correctly return a |
117
|
|
|
|
|
|
|
# false value, end the block with "1": |
118
|
6
|
|
|
|
|
19894
|
1; |
119
|
7
|
100
|
|
|
|
13
|
} or do { |
120
|
1
|
|
|
|
|
13757
|
$eval_ok = 0; |
121
|
|
|
|
|
|
|
}; |
122
|
7
|
100
|
|
|
|
36
|
if($eval_ok) { |
123
|
6
|
|
|
|
|
32
|
print $infh $input; |
124
|
6
|
|
|
|
|
50
|
close $infh; |
125
|
6
|
|
|
|
|
174
|
my $sel = new IO::Select; # create a select object to notify |
126
|
|
|
|
|
|
|
# us on reads on our FHs |
127
|
6
|
|
|
|
|
150
|
$sel->add($outfh,$errfh); # add the FHs we're interested in |
128
|
6
|
|
|
|
|
530
|
my $out_handles_open = 2; |
129
|
6
|
|
100
|
|
|
70
|
for(my $slept_secs = -1; $out_handles_open > 0 && $slept_secs < $timeout; $slept_secs++) { |
130
|
13
|
|
|
|
|
128
|
while(my @ready = $sel->can_read(1)) { # read ready, timeout after 1 second. |
131
|
16
|
|
|
|
|
5127945
|
foreach my $fh (@ready) { |
132
|
20
|
|
|
|
|
534
|
my $line = <$fh>; # read one line from this fh |
133
|
20
|
100
|
|
|
|
154
|
if( !(defined $line) ){ # EOF on this FH |
134
|
8
|
|
|
|
|
37
|
$sel->remove($fh); # remove it from the list |
135
|
8
|
|
|
|
|
355
|
$out_handles_open -= 1; |
136
|
8
|
|
|
|
|
28
|
next; # and go handle the next FH |
137
|
|
|
|
|
|
|
} |
138
|
12
|
100
|
|
|
|
125
|
if($fh == $outfh) { # if we read from the outfh |
|
|
50
|
|
|
|
|
|
139
|
5
|
|
|
|
|
24
|
$output_std .= $line; |
140
|
5
|
|
|
|
|
43
|
$output_all .= $line; |
141
|
|
|
|
|
|
|
} elsif($fh == $errfh) { # do the same for errfh |
142
|
7
|
|
|
|
|
80
|
$output_error .= $line; |
143
|
7
|
|
|
|
|
105
|
$output_all .= $line; |
144
|
|
|
|
|
|
|
} else { # we read from something else?!?! |
145
|
0
|
|
|
|
|
0
|
croak "Shouldn't be here!\n"; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
} |
149
|
13
|
100
|
|
|
|
9010081
|
if($timeout == 0) { |
150
|
|
|
|
|
|
|
# No timeout, so we lower the counter by one to keep it forever under 0. |
151
|
|
|
|
|
|
|
# Only the closing of the output handles ($out_handles_open == 0) can break the loop |
152
|
3
|
|
|
|
|
34
|
$slept_secs--; |
153
|
|
|
|
|
|
|
} |
154
|
13
|
50
|
33
|
|
|
73
|
if($print_progress_indicator == $TRUE && $out_handles_open > 0) { |
155
|
0
|
|
|
|
|
0
|
print STDOUT $progress_indicator_char; |
156
|
|
|
|
|
|
|
} |
157
|
13
|
50
|
33
|
|
|
147
|
if($execute_every_second && $out_handles_open > 0) { |
158
|
0
|
|
|
|
|
0
|
&$execute_every_second($slept_secs); |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
# It is safe to kill in all circumstances. |
162
|
|
|
|
|
|
|
# Anyway, we must reap the child process. |
163
|
6
|
|
|
|
|
345
|
my $killed = kill $SIGKILL, $pid; |
164
|
6
|
|
|
|
|
94
|
my $command_return_status = $CHILD_ERROR >> 8; |
165
|
6
|
100
|
|
|
|
184
|
if($out_handles_open > 0) { |
166
|
2
|
|
|
|
|
38
|
$output_error .= 'Timeout'; |
167
|
2
|
|
|
|
|
18
|
$output_all .= 'Timeout'; |
168
|
2
|
|
|
|
|
119
|
$command_exit_status = $EXIT_STATUS_TIMEOUT; |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
else { |
172
|
|
|
|
|
|
|
# open3 failed! |
173
|
1
|
|
|
|
|
10
|
$output_error .= 'Could not run command'; |
174
|
1
|
|
|
|
|
8
|
$output_all .= 'Could not run command'; |
175
|
1
|
|
|
|
|
28
|
$command_exit_status = $EXIT_STATUS_FAILED; |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
else { |
179
|
|
|
|
|
|
|
# Parameter check |
180
|
0
|
|
|
|
|
0
|
$output_error .= 'Invalid parameters'; |
181
|
0
|
|
|
|
|
0
|
$output_all .= 'Invalid parameters'; |
182
|
0
|
|
|
|
|
0
|
$command_exit_status = $EXIT_STATUS_FAILED; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
7
|
|
|
|
|
254
|
return ($command_exit_status, $output_std, $output_error, $output_all); |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
1; |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
__END__ |