line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Shell::Run; |
2
|
|
|
|
|
|
|
|
3
|
4
|
|
|
4
|
|
560830
|
use strict; |
|
4
|
|
|
|
|
24
|
|
|
4
|
|
|
|
|
115
|
|
4
|
4
|
|
|
4
|
|
20
|
use warnings; |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
99
|
|
5
|
|
|
|
|
|
|
|
6
|
4
|
|
|
4
|
|
1988
|
use Exporter::Tiny; |
|
4
|
|
|
|
|
13729
|
|
|
4
|
|
|
|
|
24
|
|
7
|
4
|
|
|
4
|
|
2400
|
use IPC::Open2; |
|
4
|
|
|
|
|
18816
|
|
|
4
|
|
|
|
|
220
|
|
8
|
4
|
|
|
4
|
|
2020
|
use IO::Select; |
|
4
|
|
|
|
|
6795
|
|
|
4
|
|
|
|
|
194
|
|
9
|
4
|
|
|
4
|
|
1951
|
use File::Which; |
|
4
|
|
|
|
|
3940
|
|
|
4
|
|
|
|
|
224
|
|
10
|
4
|
|
|
4
|
|
1226
|
use Encode qw(encode decode); |
|
4
|
|
|
|
|
22816
|
|
|
4
|
|
|
|
|
245
|
|
11
|
4
|
|
|
4
|
|
27
|
use Carp; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
214
|
|
12
|
|
|
|
|
|
|
|
13
|
4
|
|
|
4
|
|
24
|
use constant BLKSIZE => 1024; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
5367
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
our |
16
|
|
|
|
|
|
|
$VERSION = '0.10'; |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
our @ISA = qw(Exporter::Tiny); |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
sub new { |
21
|
4
|
|
|
4
|
1
|
91
|
my $class = shift; |
22
|
4
|
|
|
|
|
7
|
my @cmd; |
23
|
|
|
|
|
|
|
|
24
|
4
|
|
|
|
|
11
|
my $shell = _get_shell(@_); |
25
|
4
|
|
|
|
|
12
|
return bless $shell, $class; |
26
|
|
|
|
|
|
|
} |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
sub _exporter_expand_sub { |
29
|
3
|
|
|
3
|
|
279
|
my $class = shift; |
30
|
3
|
|
|
|
|
7
|
my ($name, $args, $globals) = @_; |
31
|
3
|
|
66
|
|
|
20
|
my $as = $args->{as} || $name; |
32
|
3
|
50
|
|
|
|
20
|
croak "$as: not a valid subroutine name" unless $as =~ /^[a-z][\w]*$/; |
33
|
3
|
|
|
|
|
12
|
my $shell = $class->new(name => $name, %$args); |
34
|
3
|
|
|
11
|
|
19
|
return ($as => sub {return $shell->run(@_);}); |
|
11
|
|
|
|
|
30583
|
|
35
|
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
sub _get_shell { |
38
|
4
|
|
|
4
|
|
13
|
my %args = @_; |
39
|
4
|
|
|
|
|
5
|
my @cmd; |
40
|
|
|
|
|
|
|
|
41
|
4
|
100
|
|
|
|
25
|
if ($args{exe}) { |
42
|
1
|
50
|
|
|
|
23
|
croak "$args{exe}: not an excutable file" unless -x $args{exe}; |
43
|
1
|
|
|
|
|
3
|
$cmd[0] = $args{exe}; |
44
|
|
|
|
|
|
|
} else { |
45
|
3
|
|
50
|
|
|
8
|
my $name = $args{name} || 'sh'; |
46
|
3
|
|
|
|
|
16
|
$cmd[0] = which $name; |
47
|
3
|
50
|
|
|
|
741
|
croak "$name: not found in PATH" unless $cmd[0]; |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
|
50
|
4
|
100
|
|
|
|
15
|
if (defined $args{args}) { |
51
|
1
|
|
|
|
|
1
|
push @cmd, @{$args{args}}; |
|
1
|
|
|
|
|
3
|
|
52
|
|
|
|
|
|
|
} else { |
53
|
3
|
|
|
|
|
7
|
push @cmd, '-c'; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
4
|
|
|
|
|
4
|
my $shell; |
57
|
4
|
|
|
|
|
13
|
$shell->{shell} = \@cmd; |
58
|
4
|
|
|
|
|
8
|
$shell->{debug} = $args{debug}; |
59
|
4
|
|
50
|
|
|
23
|
$shell->{encoding} = $args{encoding} // 'UTF-8'; |
60
|
4
|
|
|
|
|
13
|
return $shell; |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
sub run { |
64
|
14
|
|
|
14
|
1
|
9707
|
my $self = shift; |
65
|
|
|
|
|
|
|
# command to execute |
66
|
14
|
|
|
|
|
37
|
my $cmd = shift; |
67
|
14
|
50
|
|
|
|
116
|
print STDERR "using shell: @{$self->{shell}}\n" if $self->{debug}; |
|
0
|
|
|
|
|
0
|
|
68
|
14
|
50
|
|
|
|
52
|
print STDERR "executing cmd:\n$cmd\n" if $self->{debug}; |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
# cmd output, make $output an alias to the second argument |
71
|
14
|
|
|
|
|
21
|
our $output; |
72
|
14
|
|
|
|
|
82
|
local *output = \$_[0]; |
73
|
14
|
|
|
|
|
45
|
$output = ''; |
74
|
14
|
|
|
|
|
23
|
shift; |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
# cmd input |
77
|
14
|
|
|
|
|
64
|
my $input = encode($self->{encoding}, shift); |
78
|
14
|
50
|
|
3
|
|
1738
|
open my $inh, '<', \$input or croak "cannot open input data"; |
|
3
|
|
|
|
|
19
|
|
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
19
|
|
79
|
14
|
50
|
33
|
|
|
2356
|
print STDERR "have input data\n" if $self->{debug} && $input; |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# additional environment entries for use as shell variables |
82
|
14
|
|
|
|
|
44
|
my %env = @_; |
83
|
14
|
|
|
|
|
953
|
local %ENV = %ENV; |
84
|
14
|
|
|
|
|
87
|
$ENV{$_} = $env{$_} foreach keys %env; |
85
|
14
|
50
|
33
|
|
|
49
|
if ($self->{debug} && %env) { |
86
|
0
|
|
|
|
|
0
|
print STDERR "setting env variables:\n"; |
87
|
0
|
|
|
|
|
0
|
print STDERR "$_=$env{$_}\n" foreach keys %env; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# start cmd |
91
|
14
|
|
|
|
|
29
|
my ($c_in, $c_out); |
92
|
14
|
100
|
|
|
|
116
|
$c_in = '' unless $input; |
93
|
14
|
|
|
|
|
27
|
my $pid = open2($c_out, $c_in, @{$self->{shell}}, $cmd); |
|
14
|
|
|
|
|
66
|
|
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
# ensure filehandles are blocking |
96
|
14
|
|
|
|
|
54847
|
$c_in->blocking(1); |
97
|
14
|
|
|
|
|
25768
|
$c_out->blocking(1); |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
# create selectors for read and write filehandles |
100
|
14
|
|
|
|
|
359
|
my $sin = IO::Select->new; |
101
|
14
|
|
|
|
|
341
|
$sin->add($c_out); |
102
|
14
|
|
|
|
|
1359
|
my $sout = IO::Select->new; |
103
|
14
|
100
|
|
|
|
263
|
$sout->add($c_in) if $input; |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
# catch SIGPIPE on input pipe to cmd |
106
|
14
|
|
|
|
|
133
|
my $pipe_closed; |
107
|
|
|
|
|
|
|
local $SIG{PIPE} = sub { |
108
|
1
|
|
|
1
|
|
8
|
$pipe_closed = 1; |
109
|
1
|
50
|
|
|
|
62
|
print STDERR "got SIGPIPE\n" if $self->{debug}; |
110
|
14
|
|
|
|
|
748
|
}; |
111
|
|
|
|
|
|
|
|
112
|
14
|
50
|
|
|
|
89
|
print STDERR "\n" if $self->{debug}; |
113
|
|
|
|
|
|
|
loop: |
114
|
14
|
|
|
|
|
28
|
while (1) { |
115
|
|
|
|
|
|
|
# get filehandles ready to read or write |
116
|
32
|
|
|
|
|
286
|
my ($read, $write) = IO::Select->select($sin, $sout, undef); |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
# read from cmd |
119
|
32
|
|
|
|
|
16457
|
foreach my $rh (@$read) { |
120
|
22
|
|
|
|
|
45
|
my $data; |
121
|
22
|
|
|
|
|
257
|
my $bytes = sysread $rh, $data, BLKSIZE; |
122
|
22
|
50
|
|
|
|
80
|
unless (defined $bytes) { |
123
|
0
|
0
|
|
|
|
0
|
print STDERR "read from cmd failed\n" if $self->{debug}; |
124
|
0
|
|
|
|
|
0
|
carp "read from cmd failed"; |
125
|
0
|
|
|
|
|
0
|
return 1; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
print STDERR "read $bytes bytes from cmd\n" |
128
|
22
|
50
|
33
|
|
|
104
|
if $self->{debug} && $bytes; |
129
|
22
|
|
|
|
|
289
|
$output .= decode($self->{encoding}, $data); |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
# finish on eof from cmd |
132
|
22
|
100
|
|
|
|
3231
|
if (! $bytes) { |
133
|
14
|
50
|
|
|
|
41
|
print STDERR "closing output from cmd\n" if $self->{debug}; |
134
|
14
|
|
|
|
|
214
|
close($rh); |
135
|
14
|
|
|
|
|
76
|
$sin->remove($rh); |
136
|
14
|
|
|
|
|
960
|
last loop; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
# write to cmd |
141
|
18
|
|
|
|
|
81
|
foreach my $wh (@$write) { |
142
|
|
|
|
|
|
|
# stop writing to input on write error / SIGPIPE |
143
|
11
|
50
|
|
|
|
39
|
if ($pipe_closed) { |
144
|
|
|
|
|
|
|
print STDERR "closing input to cmd as pipe is closed\n" |
145
|
0
|
0
|
|
|
|
0
|
if $self->{debug}; |
146
|
0
|
|
|
|
|
0
|
close $wh; |
147
|
0
|
|
|
|
|
0
|
$sout->remove($wh); |
148
|
0
|
|
|
|
|
0
|
next loop; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
# save position in case of partial writes |
152
|
11
|
|
|
|
|
39
|
my $pos = tell $inh; |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
# try to write chunk of data |
155
|
11
|
|
|
|
|
462
|
my $data = $inh->getline; |
156
|
11
|
100
|
|
|
|
1753
|
my $to_be_written = length($data) < BLKSIZE ? |
157
|
|
|
|
|
|
|
length($data) : BLKSIZE; |
158
|
|
|
|
|
|
|
print STDERR "writing $to_be_written bytes to cmd\n" |
159
|
11
|
50
|
33
|
|
|
49
|
if $self->{debug} && $data; |
160
|
11
|
|
|
|
|
354
|
my $bytes = syswrite $wh, $data, BLKSIZE; |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
# write failure mostly because of broken pipe |
163
|
11
|
100
|
|
|
|
107
|
unless (defined $bytes) { |
164
|
1
|
50
|
|
|
|
15
|
print STDERR "write to cmd failed\n" if $self->{debug}; |
165
|
1
|
|
|
|
|
856
|
carp "write to cmd failed"; |
166
|
1
|
|
|
|
|
14
|
$pipe_closed = 1; |
167
|
1
|
|
|
|
|
13
|
next loop; |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# log partial write |
171
|
|
|
|
|
|
|
print STDERR "wrote $bytes bytes to cmd\n" |
172
|
10
|
50
|
33
|
|
|
29
|
if $self->{debug} && $bytes < $to_be_written; |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# adjust input data position |
175
|
10
|
100
|
|
|
|
30
|
if ($bytes < length($data)) { |
176
|
7
|
|
|
|
|
34
|
seek $inh, $pos + $bytes, 0; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
# close cmd input when data is exhausted |
180
|
10
|
100
|
|
|
|
52
|
if (eof($inh)) { |
181
|
|
|
|
|
|
|
print STDERR "closing input to cmd on end of data\n" |
182
|
1
|
50
|
|
|
|
14
|
if $self->{debug}; |
183
|
1
|
|
|
|
|
15
|
close $wh; |
184
|
1
|
|
|
|
|
6
|
$sout->remove($wh); |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
# avoid zombies and get return status |
191
|
14
|
|
|
|
|
289
|
waitpid $pid, 0; |
192
|
14
|
|
|
|
|
167
|
my $status = $? >> 8; |
193
|
14
|
50
|
|
|
|
66
|
print STDERR "cmd exited with rc=$status\n\n" if $self->{debug}; |
194
|
|
|
|
|
|
|
|
195
|
14
|
|
|
|
|
2938
|
return ($status, !$status); |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
1; |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
# vi:ts=4: |
201
|
|
|
|
|
|
|
__END__ |