line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package # Trick xt/ tests into working |
2
|
|
|
|
|
|
|
Sys::Cmd::Mo; |
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
BEGIN { |
5
|
|
|
|
|
|
|
#<<< No perltidy |
6
|
|
|
|
|
|
|
# use Mo qw/build is required default import/; |
7
|
|
|
|
|
|
|
# The following line of code was produced from the previous line by |
8
|
|
|
|
|
|
|
# Mo::Inline version 0.39 |
9
|
4
|
0
|
66
|
4
|
|
52009
|
no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{my$c=shift;my$s=bless{@_},$c;my%n=%{$c.::.':E'};map{$s->{$_}=$n{$_}->()if!exists$s->{$_}}keys%n;$s};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};@_=(default,@_)if!($#_%2);$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'build::e'}=sub{my($P,$e)=@_;$e->{new}=sub{$c=shift;my$s=&{$M.Object::new}($c,@_);my@B;do{@B=($c.::BUILD,@B)}while($c)=@{$c.::ISA};exists&$_&&&$_($s)for@B;$s}};*{$M.'is::e'}=sub{my($P,$e,$o)=@_;$o->{is}=sub{my($m,$n,%a)=@_;$a{is}or return$m;sub{$#_&&$a{is}eq'ro'&&caller ne'Mo::coerce'?die$n.' is ro':$m->(@_)}}};*{$M.'required::e'}=sub{my($P,$e,$o)=@_;$o->{required}=sub{my($m,$n,%a)=@_;if($a{required}){my$C=*{$P."new"}{CODE}||*{$M.Object::new}{CODE};no warnings 'redefine';*{$P."new"}=sub{my$s=$C->(@_);my%a=@_[1..$#_];if(!exists$a{$n}){require Carp;Carp::croak($n." required")}$s}}$m}};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;exists$a{default}or return$m;my($d,$r)=$a{default};my$g='HASH'eq($r=ref$d)?sub{+{%$d}}:'ARRAY'eq$r?sub{[@$d]}:'CODE'eq$r?$d:sub{$d};my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=$g and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$g->(@_):$m->(@_)}}};my$i=\&import;*{$M.import}=sub{(@_==2 and not$_[1])?pop@_:@_==1?push@_,grep!/import/,@f:();goto&$i};@f=qw[build is required default import];use strict;use warnings; |
|
3
|
50
|
33
|
4
|
|
6
|
|
|
3
|
100
|
50
|
3
|
|
2487
|
|
|
4
|
50
|
0
|
3
|
|
174
|
|
|
3
|
50
|
33
|
3
|
|
6
|
|
|
3
|
50
|
|
3
|
|
1742
|
|
|
3
|
50
|
|
3
|
|
24
|
|
|
3
|
100
|
|
3
|
|
6
|
|
|
3
|
100
|
|
3
|
|
79
|
|
|
3
|
50
|
|
918
|
|
46
|
|
|
3
|
50
|
|
|
|
10
|
|
|
3
|
50
|
|
|
|
157
|
|
|
3
|
50
|
|
|
|
10
|
|
|
3
|
50
|
|
|
|
24
|
|
|
3
|
100
|
|
|
|
24
|
|
|
21
|
50
|
|
|
|
53
|
|
|
21
|
100
|
|
|
|
87
|
|
|
21
|
50
|
|
|
|
46
|
|
|
21
|
|
|
|
|
120
|
|
|
21
|
|
|
|
|
119
|
|
|
0
|
|
|
|
|
0
|
|
|
21
|
|
|
|
|
66
|
|
|
3
|
|
|
|
|
34
|
|
|
3
|
|
|
|
|
14
|
|
|
4
|
|
|
|
|
49
|
|
|
4
|
|
|
|
|
11
|
|
|
4
|
|
|
|
|
14
|
|
|
4
|
|
|
|
|
21
|
|
|
4
|
|
|
|
|
230
|
|
|
14
|
|
|
|
|
83
|
|
|
4
|
|
|
|
|
15
|
|
|
4
|
|
|
|
|
33
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
44
|
|
|
|
|
61
|
|
|
44
|
|
|
|
|
122
|
|
|
822
|
|
|
|
|
8476
|
|
|
44
|
|
|
|
|
108
|
|
|
44
|
|
|
|
|
183
|
|
|
44
|
|
|
|
|
60
|
|
|
44
|
|
|
|
|
195
|
|
|
4
|
|
|
|
|
12
|
|
|
11
|
|
|
|
|
58
|
|
|
4
|
|
|
|
|
11
|
|
|
4
|
|
|
|
|
8542
|
|
|
3
|
|
|
|
|
42
|
|
|
3
|
|
|
|
|
29
|
|
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
198
|
|
|
20
|
|
|
|
|
56
|
|
|
20
|
|
|
|
|
42
|
|
|
20
|
|
|
|
|
162
|
|
|
20
|
|
|
|
|
40
|
|
|
20
|
|
|
|
|
38
|
|
|
40
|
|
|
|
|
252
|
|
|
40
|
|
|
|
|
138
|
|
|
20
|
|
|
|
|
200
|
|
|
17
|
|
|
|
|
162
|
|
|
3
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
20
|
|
|
4
|
|
|
|
|
11
|
|
|
4
|
|
|
|
|
264
|
|
|
44
|
|
|
|
|
128
|
|
|
44
|
|
|
|
|
87
|
|
|
44
|
|
|
|
|
238
|
|
|
900
|
|
|
|
|
490264
|
|
|
3
|
|
|
|
|
23
|
|
|
3
|
|
|
|
|
17
|
|
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
164
|
|
|
39
|
|
|
|
|
94
|
|
|
39
|
|
|
|
|
78
|
|
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
13
|
|
|
3
|
|
|
|
|
9
|
|
|
20
|
|
|
|
|
104
|
|
|
17
|
|
|
|
|
126
|
|
|
17
|
|
|
|
|
71
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
17
|
|
|
|
|
101
|
|
|
39
|
|
|
|
|
85
|
|
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
17
|
|
|
4
|
|
|
|
|
11
|
|
|
4
|
|
|
|
|
30
|
|
|
44
|
|
|
|
|
156
|
|
|
44
|
|
|
|
|
139
|
|
|
13
|
|
|
|
|
27
|
|
|
13
|
|
|
|
|
54
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
13
|
|
|
|
|
21
|
|
|
13
|
|
|
|
|
53
|
|
|
13
|
|
|
|
|
28
|
|
|
0
|
|
|
|
|
0
|
|
|
13
|
|
|
|
|
99
|
|
|
431
|
|
|
|
|
1687
|
|
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
56
|
|
|
4
|
|
|
|
|
39
|
|
|
4
|
|
|
|
|
16
|
|
|
3
|
|
|
|
|
25
|
|
|
3
|
|
|
|
|
719
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
426
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
429
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
3
|
|
|
|
|
422
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
10
|
3
|
|
|
|
|
108
|
$INC{'Sys/Cmd/Mo.pm'} = __FILE__; |
11
|
|
|
|
|
|
|
#>>> |
12
|
|
|
|
|
|
|
} |
13
|
|
|
|
|
|
|
1; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
package Sys::Cmd; |
16
|
3
|
|
|
3
|
|
19
|
use strict; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
88
|
|
17
|
3
|
|
|
3
|
|
20
|
use warnings; |
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
92
|
|
18
|
3
|
|
|
3
|
|
56
|
use 5.006; |
|
3
|
|
|
|
|
9
|
|
19
|
3
|
|
|
3
|
|
18
|
use Carp; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
213
|
|
20
|
3
|
|
|
3
|
|
2173
|
use Exporter::Tidy all => [qw/spawn run runx/]; |
|
3
|
|
|
|
|
48
|
|
|
3
|
|
|
|
|
20
|
|
21
|
3
|
|
|
3
|
|
184
|
use File::Spec; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
76
|
|
22
|
3
|
|
|
3
|
|
565
|
use IO::Handle; |
|
3
|
|
|
|
|
6309
|
|
|
3
|
|
|
|
|
130
|
|
23
|
3
|
|
|
3
|
|
1448
|
use Log::Any qw/$log/; |
|
3
|
|
|
|
|
30500
|
|
|
3
|
|
|
|
|
12
|
|
24
|
3
|
|
|
3
|
|
6455
|
use Sys::Cmd::Mo; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
12
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
our $VERSION = '0.99.0_1'; |
27
|
|
|
|
|
|
|
our $CONFESS; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
sub run { |
30
|
0
|
|
|
0
|
1
|
0
|
my $proc = spawn(@_); |
31
|
0
|
|
|
|
|
0
|
my @out = $proc->stdout->getlines; |
32
|
0
|
|
|
|
|
0
|
my @err = $proc->stderr->getlines; |
33
|
|
|
|
|
|
|
|
34
|
0
|
|
|
|
|
0
|
$proc->wait_child; |
35
|
|
|
|
|
|
|
|
36
|
0
|
0
|
|
|
|
0
|
if ( $proc->exit != 0 ) { |
37
|
0
|
0
|
|
|
|
0
|
Carp::confess( |
38
|
|
|
|
|
|
|
join( '', @err ) . 'Command exited with value ' . $proc->exit ) |
39
|
|
|
|
|
|
|
if $CONFESS; |
40
|
0
|
|
|
|
|
0
|
Carp::croak( |
41
|
|
|
|
|
|
|
join( '', @err ) . 'Command exited with value ' . $proc->exit ); |
42
|
|
|
|
|
|
|
} |
43
|
|
|
|
|
|
|
|
44
|
0
|
0
|
|
|
|
0
|
warn @err if @err; |
45
|
|
|
|
|
|
|
|
46
|
0
|
0
|
|
|
|
0
|
if (wantarray) { |
47
|
0
|
|
|
|
|
0
|
return @out; |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
else { |
50
|
0
|
|
|
|
|
0
|
return join( '', @out ); |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
sub runx { |
55
|
0
|
|
|
0
|
1
|
0
|
my $proc = spawn(@_); |
56
|
0
|
|
|
|
|
0
|
my @out = $proc->stdout->getlines; |
57
|
0
|
|
|
|
|
0
|
my @err = $proc->stderr->getlines; |
58
|
|
|
|
|
|
|
|
59
|
0
|
|
|
|
|
0
|
$proc->wait_child; |
60
|
|
|
|
|
|
|
|
61
|
0
|
0
|
|
|
|
0
|
if ( $proc->exit != 0 ) { |
62
|
0
|
0
|
|
|
|
0
|
Carp::confess( |
63
|
|
|
|
|
|
|
join( '', @err ) . 'Command exited with value ' . $proc->exit ) |
64
|
|
|
|
|
|
|
if $CONFESS; |
65
|
0
|
|
|
|
|
0
|
Carp::croak( |
66
|
|
|
|
|
|
|
join( '', @err ) . 'Command exited with value ' . $proc->exit ); |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
|
69
|
0
|
0
|
|
|
|
0
|
if (wantarray) { |
70
|
0
|
|
|
|
|
0
|
return @out, @err; |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
else { |
73
|
0
|
|
|
|
|
0
|
return join( '', @out, @err ); |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
sub spawn { |
78
|
26
|
|
|
26
|
1
|
76916
|
my @cmd = grep { ref $_ ne 'HASH' } @_; |
|
54
|
|
|
|
|
204
|
|
79
|
|
|
|
|
|
|
|
80
|
26
|
50
|
|
|
|
140
|
defined $cmd[0] || Carp::confess '$cmd must be defined'; |
81
|
|
|
|
|
|
|
|
82
|
26
|
100
|
|
|
|
128
|
unless ( ref $cmd[0] eq 'CODE' ) { |
83
|
|
|
|
|
|
|
|
84
|
24
|
100
|
|
|
|
318
|
if ( File::Spec->splitdir( $cmd[0] ) == 1 ) { |
85
|
4
|
|
|
|
|
1510
|
require File::Which; |
86
|
4
|
|
33
|
|
|
2584
|
$cmd[0] = File::Which::which( $cmd[0] ) |
87
|
|
|
|
|
|
|
|| Carp::confess 'command not found: ' . $cmd[0]; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
20
|
100
|
|
|
|
1000
|
if ( !-x $cmd[0] ) { |
91
|
2
|
|
|
|
|
500
|
Carp::confess 'command not executable: ' . $cmd[0]; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
|
95
|
20
|
|
|
|
|
92
|
my @opts = grep { ref $_ eq 'HASH' } @_; |
|
48
|
|
|
|
|
160
|
|
96
|
20
|
50
|
|
|
|
80
|
if ( @opts > 2 ) { |
97
|
0
|
|
|
|
|
0
|
Carp::confess __PACKAGE__ . ": only a single hashref allowed"; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
20
|
100
|
|
|
|
68
|
my %args = @opts ? %{ $opts[0] } : (); |
|
14
|
|
|
|
|
76
|
|
101
|
20
|
|
|
|
|
68
|
$args{cmd} = \@cmd; |
102
|
|
|
|
|
|
|
|
103
|
20
|
|
|
|
|
282
|
return Sys::Cmd->new(%args); |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
has 'cmd' => ( |
107
|
|
|
|
|
|
|
is => 'ro', |
108
|
|
|
|
|
|
|
isa => sub { |
109
|
|
|
|
|
|
|
ref $_[0] eq 'ARRAY' || Carp::confess "cmd must be ARRAYREF"; |
110
|
|
|
|
|
|
|
@{ $_[0] } || Carp::confess "Missing cmd elements"; |
111
|
|
|
|
|
|
|
if ( grep { !defined $_ } @{ $_[0] } ) { |
112
|
|
|
|
|
|
|
Carp::confess 'cmd array cannot contain undef elements'; |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
}, |
115
|
|
|
|
|
|
|
required => 1, |
116
|
|
|
|
|
|
|
); |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
has 'encoding' => ( |
119
|
|
|
|
|
|
|
is => 'ro', |
120
|
|
|
|
|
|
|
default => sub { ':utf8' }, |
121
|
|
|
|
|
|
|
); |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
has 'env' => ( |
124
|
|
|
|
|
|
|
is => 'ro', |
125
|
|
|
|
|
|
|
isa => sub { ref $_[0] eq 'HASH' || Carp::confess "env must be HASHREF" }, |
126
|
|
|
|
|
|
|
); |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
has 'dir' => ( is => 'ro', ); |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
has 'input' => ( is => 'ro', ); |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
has 'pid' => ( |
133
|
|
|
|
|
|
|
is => 'rw', |
134
|
|
|
|
|
|
|
init_arg => undef, |
135
|
|
|
|
|
|
|
); |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
has 'stdin' => ( |
138
|
|
|
|
|
|
|
is => 'rw', |
139
|
|
|
|
|
|
|
init_arg => undef, |
140
|
|
|
|
|
|
|
default => sub { IO::Handle->new }, |
141
|
|
|
|
|
|
|
); |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
has 'stdout' => ( |
144
|
|
|
|
|
|
|
is => 'rw', |
145
|
|
|
|
|
|
|
init_arg => undef, |
146
|
|
|
|
|
|
|
default => sub { IO::Handle->new }, |
147
|
|
|
|
|
|
|
); |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
has 'stderr' => ( |
150
|
|
|
|
|
|
|
is => 'rw', |
151
|
|
|
|
|
|
|
init_arg => undef, |
152
|
|
|
|
|
|
|
default => sub { IO::Handle->new }, |
153
|
|
|
|
|
|
|
); |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
has on_exit => ( |
156
|
|
|
|
|
|
|
is => 'rw', |
157
|
|
|
|
|
|
|
init_arg => 'on_exit', |
158
|
|
|
|
|
|
|
); |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
has 'exit' => ( |
161
|
|
|
|
|
|
|
is => 'rw', |
162
|
|
|
|
|
|
|
init_arg => undef, |
163
|
|
|
|
|
|
|
); |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
has 'signal' => ( |
166
|
|
|
|
|
|
|
is => 'rw', |
167
|
|
|
|
|
|
|
init_arg => undef, |
168
|
|
|
|
|
|
|
); |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
has 'core' => ( |
171
|
|
|
|
|
|
|
is => 'rw', |
172
|
|
|
|
|
|
|
init_arg => undef, |
173
|
|
|
|
|
|
|
); |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
sub BUILD { |
176
|
20
|
|
|
20
|
0
|
44
|
my $self = shift; |
177
|
20
|
|
|
|
|
86
|
my $dir = $self->dir; |
178
|
|
|
|
|
|
|
|
179
|
20
|
100
|
|
|
|
1386
|
require File::chdir if $dir; |
180
|
20
|
100
|
|
|
|
7576
|
local $File::chdir::CWD = $dir if $dir; |
181
|
|
|
|
|
|
|
|
182
|
18
|
|
|
|
|
1840
|
local %ENV = %ENV; |
183
|
|
|
|
|
|
|
|
184
|
18
|
100
|
|
|
|
108
|
if ( defined( my $x = $self->env ) ) { |
185
|
10
|
|
|
|
|
68
|
while ( my ( $key, $val ) = each %$x ) { |
186
|
16
|
100
|
|
|
|
48
|
if ( defined $val ) { |
187
|
12
|
|
|
|
|
82
|
$ENV{$key} = $val; |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
else { |
190
|
4
|
|
|
|
|
24
|
delete $ENV{$key}; |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
18
|
100
|
|
|
|
172
|
if ( ref $self->cmd->[0] eq 'CODE' ) { |
196
|
2
|
|
|
|
|
12
|
$self->_fork; |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
else { |
199
|
16
|
|
|
|
|
68
|
$self->_spawn; |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
17
|
|
|
|
|
68
|
my $enc = $self->encoding; |
203
|
17
|
50
|
|
|
|
47
|
binmode( $self->stdin, $enc ) or warn "binmode stdin: $!"; |
204
|
17
|
50
|
|
|
|
59
|
binmode( $self->stdout, $enc ) or warn "binmode stdout: $!"; |
205
|
17
|
50
|
|
|
|
59
|
binmode( $self->stderr, $enc ) or warn "binmode stderr: $!"; |
206
|
|
|
|
|
|
|
|
207
|
17
|
|
|
|
|
49
|
$log->debugf( '[%d][%s] %s', $self->pid, $enc, scalar $self->cmdline ); |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
# some input was provided |
210
|
17
|
100
|
|
|
|
103
|
if ( defined( my $input = $self->input ) ) { |
211
|
|
|
|
|
|
|
local $SIG{PIPE} = |
212
|
4
|
|
|
0
|
|
164
|
sub { warn "Broken pipe when writing to:" . $self->cmdline }; |
|
0
|
|
|
|
|
0
|
|
213
|
|
|
|
|
|
|
|
214
|
4
|
100
|
|
|
|
32
|
$self->stdin->print($input) if length $input; |
215
|
|
|
|
|
|
|
|
216
|
4
|
|
|
|
|
98
|
$self->stdin->close; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
17
|
|
|
|
|
969
|
return; |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
sub _spawn { |
223
|
16
|
|
|
16
|
|
36
|
my $self = shift; |
224
|
16
|
|
|
|
|
2690
|
require Proc::FastSpawn; |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
# Get new handles to descriptors 0,1,2 |
227
|
16
|
|
|
|
|
1350
|
my $fd0 = IO::Handle->new_from_fd( 0, 'r' ); |
228
|
16
|
|
|
|
|
1848
|
my $fd1 = IO::Handle->new_from_fd( 1, 'w' ); |
229
|
16
|
|
|
|
|
1056
|
my $fd2 = IO::Handle->new_from_fd( 2, 'w' ); |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
# Backup the original 0,1,2 file descriptors |
232
|
16
|
|
|
|
|
1340
|
open my $old_fd0, '<&', 0; |
233
|
16
|
|
|
|
|
306
|
open my $old_fd1, '>&', 1; |
234
|
16
|
|
|
|
|
292
|
open my $old_fd2, '>&', 2; |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
# Pipe our filehandles to new child filehandles |
237
|
16
|
50
|
|
|
|
114
|
pipe( my $child_in, $self->stdin ) || die "pipe: $!"; |
238
|
16
|
50
|
|
|
|
1112
|
pipe( $self->stdout, my $child_out ) || die "pipe: $!"; |
239
|
16
|
50
|
|
|
|
848
|
pipe( $self->stderr, my $child_err ) || die "pipe: $!"; |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
# Make sure that 0,1,2 are inherited (probably are anyway) |
242
|
16
|
|
|
|
|
1006
|
Proc::FastSpawn::fd_inherit( $_, 1 ) for 0, 1, 2; |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
# But don't inherit the rest |
245
|
|
|
|
|
|
|
Proc::FastSpawn::fd_inherit( fileno($_), 0 ) |
246
|
16
|
|
|
|
|
76
|
for $old_fd0, $old_fd1, $old_fd2, $child_in, $child_out, $child_err, |
247
|
|
|
|
|
|
|
$self->stdin, $self->stdout, $self->stderr; |
248
|
|
|
|
|
|
|
|
249
|
16
|
|
|
|
|
48
|
eval { |
250
|
|
|
|
|
|
|
# Re-open 0,1,2 by duping the child pipe ends |
251
|
16
|
|
|
|
|
358
|
open $fd0, '<&', fileno($child_in); |
252
|
16
|
|
|
|
|
304
|
open $fd1, '>&', fileno($child_out); |
253
|
16
|
|
|
|
|
376
|
open $fd2, '>&', fileno($child_err); |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
# Kick off the new process |
256
|
|
|
|
|
|
|
$self->pid( |
257
|
|
|
|
|
|
|
Proc::FastSpawn::spawn( |
258
|
|
|
|
|
|
|
$self->cmd->[0], |
259
|
|
|
|
|
|
|
$self->cmd, |
260
|
|
|
|
|
|
|
[ |
261
|
16
|
50
|
|
|
|
86
|
map { $_ . '=' . ( defined $ENV{$_} ? $ENV{$_} : '' ) } |
|
584
|
|
|
|
|
7806
|
|
262
|
|
|
|
|
|
|
keys %ENV |
263
|
|
|
|
|
|
|
] |
264
|
|
|
|
|
|
|
) |
265
|
|
|
|
|
|
|
); |
266
|
|
|
|
|
|
|
}; |
267
|
16
|
|
|
|
|
188
|
my $err = $@; |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
# Restore our local 0,1,2 to the originals |
270
|
16
|
|
|
|
|
486
|
open $fd0, '<&', fileno($old_fd0); |
271
|
16
|
|
|
|
|
320
|
open $fd1, '>&', fileno($old_fd1); |
272
|
16
|
|
|
|
|
298
|
open $fd2, '>&', fileno($old_fd2); |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
# Complain if the spawn failed for some reason |
275
|
16
|
50
|
|
|
|
64
|
Carp::croak $err if $err; |
276
|
16
|
50
|
|
|
|
58
|
Carp::croak 'Unable to spawn child' unless defined $self->pid; |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
# Parent doesn't need to see the child or backup descriptors anymore |
279
|
|
|
|
|
|
|
close($_) |
280
|
16
|
|
|
|
|
404
|
for $old_fd0, $old_fd1, $old_fd2, $child_in, $child_out, $child_err; |
281
|
|
|
|
|
|
|
|
282
|
16
|
|
|
|
|
62
|
$self->stdin->autoflush(1); |
283
|
|
|
|
|
|
|
|
284
|
16
|
|
|
|
|
1348
|
return; |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
sub _fork { |
288
|
2
|
|
|
2
|
|
84
|
my $self = shift; |
289
|
|
|
|
|
|
|
|
290
|
2
|
50
|
|
|
|
24
|
pipe( my $child_in, $self->stdin ) || die "pipe: $!"; |
291
|
2
|
50
|
|
|
|
174
|
pipe( $self->stdout, my $child_out ) || die "pipe: $!"; |
292
|
2
|
50
|
|
|
|
106
|
pipe( $self->stderr, my $child_err ) || die "pipe: $!"; |
293
|
|
|
|
|
|
|
|
294
|
2
|
|
|
|
|
2828
|
$self->pid( fork() ); |
295
|
2
|
50
|
|
|
|
49
|
if ( !defined $self->pid ) { |
296
|
0
|
|
|
|
|
0
|
my $why = $!; |
297
|
0
|
|
|
|
|
0
|
die "fork: $why"; |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
2
|
100
|
|
|
|
65
|
if ( $self->pid > 0 ) { # parent |
301
|
1
|
|
|
|
|
38
|
close $child_in; |
302
|
1
|
|
|
|
|
13
|
close $child_out; |
303
|
1
|
|
|
|
|
25
|
close $child_err; |
304
|
|
|
|
|
|
|
|
305
|
1
|
|
|
|
|
24
|
$self->stdin->autoflush(1); |
306
|
1
|
|
|
|
|
289
|
return; |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
# Child |
310
|
|
|
|
|
|
|
|
311
|
1
|
|
|
|
|
42
|
$self->exit(0); # stop DESTROY() from trying to reap |
312
|
1
|
|
|
|
|
115
|
$child_out->autoflush(1); |
313
|
1
|
|
|
|
|
209
|
$child_err->autoflush(1); |
314
|
|
|
|
|
|
|
|
315
|
1
|
|
|
|
|
63
|
my $enc = $self->encoding; |
316
|
|
|
|
|
|
|
|
317
|
1
|
|
|
|
|
47
|
foreach my $h ( |
318
|
|
|
|
|
|
|
[ \*STDIN, '<&=' . $enc, $child_in ], |
319
|
|
|
|
|
|
|
[ \*STDOUT, '>&=' . $enc, $child_out ], |
320
|
|
|
|
|
|
|
[ \*STDERR, '>&=' . $enc, $child_err ] |
321
|
|
|
|
|
|
|
) |
322
|
|
|
|
|
|
|
{ |
323
|
3
|
50
|
|
|
|
139
|
open( $h->[0], $h->[1], fileno( $h->[2] ) ) |
324
|
|
|
|
|
|
|
or print $child_err sprintf '[%d] open %s: %s', $self->pid, |
325
|
|
|
|
|
|
|
$h->[0], $!; |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
1
|
|
|
|
|
13
|
close $self->stdin; |
329
|
1
|
|
|
|
|
11
|
close $self->stdout; |
330
|
1
|
|
|
|
|
9
|
close $self->stderr; |
331
|
1
|
|
|
|
|
8
|
close $child_in; |
332
|
1
|
|
|
|
|
22
|
close $child_out; |
333
|
1
|
|
|
|
|
8
|
close $child_err; |
334
|
|
|
|
|
|
|
|
335
|
1
|
50
|
|
|
|
27
|
if ( ref( my $code = $self->cmd->[0] ) eq 'CODE' ) { |
336
|
1
|
|
|
|
|
14
|
$code->(); |
337
|
0
|
|
|
|
|
0
|
_exit(0); |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
|
340
|
0
|
|
|
|
|
0
|
exec( @{ $self->cmd } ); |
|
0
|
|
|
|
|
0
|
|
341
|
0
|
|
|
|
|
0
|
die "exec: $!"; |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
sub cmdline { |
345
|
29
|
|
|
29
|
1
|
4437
|
my $self = shift; |
346
|
29
|
100
|
|
|
|
80
|
if (wantarray) { |
347
|
12
|
|
|
|
|
24
|
return @{ $self->cmd }; |
|
12
|
|
|
|
|
56
|
|
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
else { |
350
|
17
|
|
|
|
|
32
|
return join( ' ', @{ $self->cmd } ); |
|
17
|
|
|
|
|
45
|
|
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
sub wait_child { |
355
|
37
|
|
|
37
|
1
|
99
|
my $self = shift; |
356
|
|
|
|
|
|
|
|
357
|
37
|
100
|
|
|
|
105
|
return unless defined $self->pid; |
358
|
35
|
100
|
|
|
|
112
|
return $self->exit if defined $self->exit; |
359
|
|
|
|
|
|
|
|
360
|
17
|
|
|
|
|
99
|
local $?; |
361
|
17
|
|
|
|
|
73
|
local $!; |
362
|
|
|
|
|
|
|
|
363
|
17
|
|
|
|
|
41
|
my $pid = waitpid $self->pid, 0; |
364
|
17
|
|
|
|
|
85
|
my $ret = $?; |
365
|
|
|
|
|
|
|
|
366
|
17
|
50
|
|
|
|
55
|
if ( $pid != $self->pid ) { |
367
|
0
|
|
|
|
|
0
|
warn sprintf( 'Could not reap child process %d (waitpid returned: %d)', |
368
|
|
|
|
|
|
|
$self->pid, $pid ); |
369
|
0
|
|
|
|
|
0
|
$pid = $self->pid; |
370
|
0
|
|
|
|
|
0
|
$ret = 0; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
17
|
50
|
|
|
|
63
|
if ( $ret == -1 ) { |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
# So waitpid returned a PID but then sets $? to this |
376
|
|
|
|
|
|
|
# strange value? (Strange in that tests randomly show it to |
377
|
|
|
|
|
|
|
# be invalid.) Most likely a perl bug; I think that waitpid |
378
|
|
|
|
|
|
|
# got interrupted and when it restarts/resumes the status |
379
|
|
|
|
|
|
|
# is lost. |
380
|
|
|
|
|
|
|
# |
381
|
|
|
|
|
|
|
# See http://www.perlmonks.org/?node_id=641620 for a |
382
|
|
|
|
|
|
|
# possibly related discussion. |
383
|
|
|
|
|
|
|
# |
384
|
|
|
|
|
|
|
# However, since I localised $? and $! above I haven't seen |
385
|
|
|
|
|
|
|
# this problem again, so I hope that is a good enough work |
386
|
|
|
|
|
|
|
# around. Lets warn any way so that we know when something |
387
|
|
|
|
|
|
|
# dodgy is going on. |
388
|
0
|
|
|
|
|
0
|
warn __PACKAGE__ |
389
|
|
|
|
|
|
|
. ' received invalid child exit status for pid ' |
390
|
|
|
|
|
|
|
. $pid |
391
|
|
|
|
|
|
|
. ' Setting to 0'; |
392
|
0
|
|
|
|
|
0
|
$ret = 0; |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
$log->debugf( |
397
|
17
|
|
|
|
|
58
|
'(PID %d) exit: %d signal: %d core: %d', |
398
|
|
|
|
|
|
|
$pid, |
399
|
|
|
|
|
|
|
$self->exit( $ret >> 8 ), |
400
|
|
|
|
|
|
|
$self->signal( $ret & 127 ), |
401
|
|
|
|
|
|
|
$self->core( $ret & 128 ) |
402
|
|
|
|
|
|
|
); |
403
|
|
|
|
|
|
|
|
404
|
17
|
100
|
|
|
|
104
|
if ( my $subref = $self->on_exit ) { |
405
|
2
|
|
|
|
|
10
|
$subref->($self); |
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
|
408
|
17
|
|
|
|
|
49
|
return $self->exit; |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
sub close { |
412
|
33
|
|
|
33
|
1
|
797
|
my $self = shift; |
413
|
|
|
|
|
|
|
|
414
|
33
|
|
|
|
|
123
|
foreach my $h (qw/stdin stdout stderr/) { |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
# may not be defined during global destruction |
417
|
99
|
50
|
|
|
|
1372
|
my $fh = $self->$h or next; |
418
|
99
|
100
|
|
|
|
458
|
$fh->opened or next; |
419
|
47
|
100
|
|
|
|
345
|
if ( $h eq 'stderr' ) { |
420
|
|
|
|
|
|
|
warn sprintf( '[%d] uncollected stderr: %s', $self->pid, $_ ) |
421
|
17
|
|
|
|
|
43
|
for $self->stderr->getlines; |
422
|
|
|
|
|
|
|
} |
423
|
47
|
50
|
|
|
|
621807
|
$fh->close || Carp::carp "error closing $h: $!"; |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
33
|
|
|
|
|
487
|
return; |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
sub DESTROY { |
430
|
20
|
|
|
20
|
|
21727
|
my $self = shift; |
431
|
20
|
|
|
|
|
81
|
$self->close; |
432
|
20
|
|
|
|
|
72
|
$self->wait_child; |
433
|
20
|
|
|
|
|
312
|
return; |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
1; |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
__END__ |