line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
=head1 NAME |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
IPC::Filter - filter data through an external process |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=head1 SYNOPSIS |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
use IPC::Filter qw(filter); |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
$compressed_data = filter($data, "bzip2"); |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
=head1 DESCRIPTION |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
The C function provided by this module passes data through an |
14
|
|
|
|
|
|
|
external command, thus providing filtering in non-pipeline situations. |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=cut |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
package IPC::Filter; |
19
|
|
|
|
|
|
|
|
20
|
1
|
|
|
1
|
|
137303
|
{ use 5.006; } |
|
1
|
|
|
|
|
4
|
|
21
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
29
|
|
22
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
28
|
|
23
|
|
|
|
|
|
|
|
24
|
1
|
|
|
1
|
|
283
|
use Errno 1.00 qw(EPIPE); |
|
1
|
|
|
|
|
1061
|
|
|
1
|
|
|
|
|
90
|
|
25
|
1
|
|
|
1
|
|
267
|
use IPC::Open3 1.01 qw(open3); |
|
1
|
|
|
|
|
2955
|
|
|
1
|
|
|
|
|
59
|
|
26
|
1
|
|
|
1
|
|
291
|
use IPC::Signal 1.00 qw(sig_name); |
|
1
|
|
|
|
|
520
|
|
|
1
|
|
|
|
|
49
|
|
27
|
1
|
|
|
1
|
|
310
|
use IO::Handle 1.12; |
|
1
|
|
|
|
|
3430
|
|
|
1
|
|
|
|
|
62
|
|
28
|
1
|
|
|
1
|
|
261
|
use IO::Poll 0.01 qw(POLLIN POLLOUT POLLERR POLLHUP); |
|
1
|
|
|
|
|
592
|
|
|
1
|
|
|
|
|
60
|
|
29
|
1
|
|
|
1
|
|
258
|
use POSIX qw(_exit); |
|
1
|
|
|
|
|
6767
|
|
|
1
|
|
|
|
|
20
|
|
30
|
1
|
|
|
1
|
|
1803
|
use Symbol qw(gensym); |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
72
|
|
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
our $VERSION = "0.005"; |
33
|
|
|
|
|
|
|
|
34
|
1
|
|
|
1
|
|
484
|
use parent "Exporter"; |
|
1
|
|
|
|
|
369
|
|
|
1
|
|
|
|
|
8
|
|
35
|
|
|
|
|
|
|
our @EXPORT_OK = qw(filter); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
=head1 FUNCTIONS |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
=over |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
=item filter(DATA, SHELL_COMMAND) |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
=item filter(DATA, PROGRAM, ARGS ...) |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
The SHELL_COMMAND, or the PROGRAM with ARGS if more arguments are |
46
|
|
|
|
|
|
|
supplied, is executed as a separate process. (The arguments other |
47
|
|
|
|
|
|
|
than DATA are ultimately passed to C; see L |
48
|
|
|
|
|
|
|
for explanation of the choice between the two forms.) The DATA (which |
49
|
|
|
|
|
|
|
must be either a simple string or a reference to a string) is supplied |
50
|
|
|
|
|
|
|
to the process on its standard input, and the process's standard output |
51
|
|
|
|
|
|
|
is captured and returned (as a simple string). |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
If the process exits with a non-zero exit code or on a signal, the |
54
|
|
|
|
|
|
|
function will C. In the case of a non-zero exit code, the C |
55
|
|
|
|
|
|
|
message will duplicate the process's standard error output; in any other |
56
|
|
|
|
|
|
|
case, the error output is discarded. |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
=cut |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
my $chunksize = 4096; |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
sub filter($@) { |
63
|
9
|
|
|
9
|
1
|
8323
|
my $data = \shift(@_); |
64
|
9
|
100
|
100
|
|
|
64
|
if(@_ == 0 || $_[0] eq "-") { |
65
|
2
|
|
|
|
|
11
|
die "filter: invalid command\n"; |
66
|
|
|
|
|
|
|
} |
67
|
7
|
50
|
|
|
|
23
|
if(ref($data) eq "REF") { |
68
|
0
|
|
|
|
|
0
|
$data = $$data; |
69
|
|
|
|
|
|
|
} |
70
|
7
|
|
|
|
|
26
|
my $stdin = gensym; |
71
|
7
|
|
|
|
|
129
|
my $stdout = gensym; |
72
|
7
|
|
|
|
|
73
|
my $stderr = gensym; |
73
|
|
|
|
|
|
|
# Note: perl bug (bug in IPC::Open3 version 1.0106, bug ID |
74
|
|
|
|
|
|
|
# #32198): if the exec fails in the subprocess created by open3(), |
75
|
|
|
|
|
|
|
# it uses die() to emit its error message and terminate. If an |
76
|
|
|
|
|
|
|
# exception handler is installed using eval {}, execution in the |
77
|
|
|
|
|
|
|
# subprocess continues there instead of the process terminating. |
78
|
|
|
|
|
|
|
# We avoid nastiness by catching the exception ourselves and |
79
|
|
|
|
|
|
|
# doing the right thing. |
80
|
7
|
|
|
|
|
73
|
my $parent_pid = $$; |
81
|
7
|
|
|
|
|
17
|
my $child_pid = eval { local $SIG{__DIE__}; |
|
7
|
|
|
|
|
21
|
|
82
|
7
|
|
|
|
|
25
|
open3($stdin, $stdout, $stderr, @_); |
83
|
|
|
|
|
|
|
}; |
84
|
7
|
50
|
|
|
|
15794
|
if($@ ne "") { |
85
|
0
|
|
|
|
|
0
|
my $err = $@; |
86
|
0
|
0
|
|
|
|
0
|
die $err if $$ == $parent_pid; |
87
|
0
|
|
|
|
|
0
|
print STDERR $err; |
88
|
0
|
|
|
|
|
0
|
_exit 255; |
89
|
|
|
|
|
|
|
} |
90
|
7
|
|
|
|
|
115
|
local $SIG{PIPE} = "IGNORE"; |
91
|
7
|
|
|
|
|
98
|
my $poll = IO::Poll->new; |
92
|
7
|
|
|
|
|
90
|
my $datalen = length($$data); |
93
|
7
|
50
|
|
|
|
28
|
if($datalen == 0) { |
94
|
0
|
|
|
|
|
0
|
$stdin->close; |
95
|
|
|
|
|
|
|
} else { |
96
|
7
|
|
|
|
|
59
|
$poll->mask($stdin => POLLOUT | POLLERR | POLLHUP); |
97
|
|
|
|
|
|
|
} |
98
|
7
|
|
|
|
|
251
|
$poll->mask($stdout => POLLIN | POLLERR | POLLHUP); |
99
|
7
|
|
|
|
|
184
|
$poll->mask($stderr => POLLIN | POLLERR | POLLHUP); |
100
|
7
|
|
|
|
|
253
|
my $datapos = 0; |
101
|
7
|
|
|
|
|
18
|
my @out; |
102
|
|
|
|
|
|
|
my @err; |
103
|
7
|
|
|
|
|
52
|
while($poll->handles) { |
104
|
21
|
|
|
|
|
297
|
$poll->poll; |
105
|
21
|
100
|
66
|
|
|
6027
|
if($datapos != $datalen && $poll->events($stdin)) { |
106
|
7
|
|
|
|
|
136
|
my $n = $stdin->syswrite($$data, $chunksize, $datapos); |
107
|
7
|
50
|
|
|
|
164
|
if(defined $n) { |
|
|
0
|
|
|
|
|
|
108
|
7
|
|
|
|
|
18
|
$datapos += $n; |
109
|
|
|
|
|
|
|
} elsif($! == EPIPE) { |
110
|
0
|
|
|
|
|
0
|
$datapos = $datalen; |
111
|
|
|
|
|
|
|
} else { |
112
|
0
|
|
|
|
|
0
|
die "filter: stdin: $!\n"; |
113
|
|
|
|
|
|
|
} |
114
|
7
|
50
|
|
|
|
15
|
if($datapos == $datalen) { |
115
|
7
|
|
|
|
|
19
|
$poll->remove($stdin); |
116
|
7
|
|
|
|
|
195
|
$stdin->close; |
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
} |
119
|
21
|
100
|
|
|
|
164
|
if($poll->events($stdout)) { |
120
|
12
|
|
|
|
|
124
|
my $output; |
121
|
12
|
50
|
|
|
|
60
|
unless(defined $stdout->sysread($output, $chunksize)) { |
122
|
0
|
|
|
|
|
0
|
die "filter: stdout: $!\n"; |
123
|
|
|
|
|
|
|
} |
124
|
12
|
100
|
|
|
|
124
|
if($output eq "") { |
125
|
7
|
|
|
|
|
17
|
$poll->remove($stdout); |
126
|
|
|
|
|
|
|
} else { |
127
|
5
|
|
|
|
|
29
|
push @out, $output; |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
} |
130
|
21
|
100
|
|
|
|
259
|
if($poll->events($stderr)) { |
131
|
9
|
|
|
|
|
138
|
my $output; |
132
|
9
|
50
|
|
|
|
24
|
unless(defined $stderr->sysread($output, $chunksize)) { |
133
|
0
|
|
|
|
|
0
|
die "filter: stderr: $!\n"; |
134
|
|
|
|
|
|
|
} |
135
|
9
|
100
|
|
|
|
82
|
if($output eq "") { |
136
|
7
|
|
|
|
|
11
|
$poll->remove($stderr); |
137
|
|
|
|
|
|
|
} else { |
138
|
2
|
|
|
|
|
10
|
push @err, $output; |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
} |
142
|
7
|
|
|
|
|
235
|
waitpid $child_pid, 0; |
143
|
7
|
|
|
|
|
44
|
my $status = $?; |
144
|
7
|
100
|
|
|
|
19
|
if($status == 0) { |
145
|
4
|
|
|
|
|
125
|
return join("", @out); |
146
|
|
|
|
|
|
|
} |
147
|
3
|
100
|
|
|
|
14
|
if($status & 127) { |
148
|
1
|
|
|
|
|
16
|
die "filter: process died on SIG".sig_name($status & 127)."\n"; |
149
|
|
|
|
|
|
|
} else { |
150
|
2
|
|
|
|
|
70
|
die join("", "filter: process exited with status ", |
151
|
|
|
|
|
|
|
$status >> 8, "\n", @err); |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
=back |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
=head1 SEE ALSO |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
L |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
=head1 AUTHOR |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
Andrew Main (Zefram) |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
=head1 COPYRIGHT |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
Copyright (C) 2004, 2007, 2010, 2011, 2017 |
168
|
|
|
|
|
|
|
Andrew Main (Zefram) |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
=head1 LICENSE |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
This module is free software; you can redistribute it and/or modify it |
173
|
|
|
|
|
|
|
under the same terms as Perl itself. |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
=cut |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
1; |