line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# $Id: Fork.pm,v 1.12 2010/02/09 08:40:41 dk Exp $ |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
package IO::Lambda::Fork; |
4
|
|
|
|
|
|
|
|
5
|
9
|
|
|
9
|
|
7848
|
use base qw(IO::Lambda); |
|
9
|
|
|
|
|
18
|
|
|
9
|
|
|
|
|
1071
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $DEBUG = $IO::Lambda::DEBUG{fork} || 0; |
8
|
|
|
|
|
|
|
|
9
|
9
|
|
|
9
|
|
54
|
use strict; |
|
9
|
|
|
|
|
18
|
|
|
9
|
|
|
|
|
198
|
|
10
|
9
|
|
|
9
|
|
45
|
use warnings; |
|
9
|
|
|
|
|
9
|
|
|
9
|
|
|
|
|
207
|
|
11
|
9
|
|
|
9
|
|
36
|
use Exporter; |
|
9
|
|
|
|
|
162
|
|
|
9
|
|
|
|
|
306
|
|
12
|
9
|
|
|
9
|
|
7857
|
use Socket; |
|
9
|
|
|
|
|
34506
|
|
|
9
|
|
|
|
|
6174
|
|
13
|
9
|
|
|
9
|
|
6732
|
use POSIX; |
|
9
|
|
|
|
|
59841
|
|
|
9
|
|
|
|
|
45
|
|
14
|
9
|
|
|
9
|
|
40284
|
use Storable qw(thaw freeze); |
|
9
|
|
|
|
|
30285
|
|
|
9
|
|
|
|
|
648
|
|
15
|
9
|
|
|
9
|
|
7794
|
use IO::Handle; |
|
9
|
|
|
|
|
62028
|
|
|
9
|
|
|
|
|
432
|
|
16
|
9
|
|
|
9
|
|
63
|
use IO::Lambda qw(:all :dev); |
|
9
|
|
|
|
|
9
|
|
|
9
|
|
|
|
|
2970
|
|
17
|
9
|
|
|
9
|
|
5535
|
use IO::Lambda::Signal qw(pid); |
|
9
|
|
|
|
|
27
|
|
|
9
|
|
|
|
|
9144
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
our @ISA = qw(Exporter); |
20
|
|
|
|
|
|
|
our @EXPORT_OK = qw(new_process process new_forked forked); |
21
|
|
|
|
|
|
|
our %EXPORT_TAGS = (all => \@EXPORT_OK); |
22
|
|
|
|
|
|
|
|
23
|
0
|
|
|
0
|
|
0
|
sub _d { "forked(" . _o($_[0]) . ")" } |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# return pid and socket |
26
|
|
|
|
|
|
|
sub new_process(&) |
27
|
|
|
|
|
|
|
{ |
28
|
44
|
|
|
44
|
1
|
69
|
my $cb = shift; |
29
|
|
|
|
|
|
|
|
30
|
44
|
|
|
|
|
654
|
my $r = IO::Handle-> new; |
31
|
44
|
|
|
|
|
2128
|
my $w = IO::Handle-> new; |
32
|
44
|
|
|
|
|
2390
|
socketpair( $r, $w, AF_UNIX, SOCK_STREAM, PF_UNSPEC); |
33
|
44
|
|
|
|
|
278
|
$w-> blocking(0); |
34
|
|
|
|
|
|
|
|
35
|
44
|
|
|
|
|
58972
|
my $pid = fork; |
36
|
44
|
50
|
|
|
|
1495
|
unless ( defined $pid) { |
37
|
0
|
0
|
|
|
|
0
|
warn "fork() failed:$!\n" if $DEBUG; |
38
|
0
|
|
|
|
|
0
|
close($w); |
39
|
0
|
|
|
|
|
0
|
close($r); |
40
|
0
|
|
|
|
|
0
|
return ( undef, $! ); |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
44
|
100
|
|
|
|
490
|
if ( $pid == 0) { |
44
|
8
|
|
|
|
|
1062
|
close($w); |
45
|
8
|
50
|
|
|
|
518
|
warn "process($$) started\n" if $DEBUG; |
46
|
8
|
50
|
|
|
|
337
|
eval { $cb-> ($r) if $cb; }; |
|
8
|
|
|
|
|
460
|
|
47
|
8
|
50
|
|
|
|
2421
|
warn "process($$) ended\n" if $DEBUG; |
48
|
8
|
50
|
|
|
|
64
|
warn $@ if $@; |
49
|
8
|
|
|
|
|
4226
|
close($r); |
50
|
8
|
50
|
|
|
|
1148
|
POSIX::exit($@ ? 1 : 0); |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
36
|
50
|
|
|
|
280
|
warn "forked pid=$pid\n" if $DEBUG; |
54
|
|
|
|
|
|
|
|
55
|
36
|
|
|
|
|
1399
|
close($r); |
56
|
|
|
|
|
|
|
|
57
|
36
|
|
|
|
|
3494
|
return ($pid, $w); |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
# simple fork, return only $? and $! |
61
|
|
|
|
|
|
|
sub process(&) |
62
|
|
|
|
|
|
|
{ |
63
|
0
|
|
|
0
|
1
|
0
|
my $cb = shift; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
lambda { |
66
|
0
|
|
|
0
|
|
0
|
my $pid = fork; |
67
|
0
|
0
|
|
|
|
0
|
return undef, $! unless defined $pid; |
68
|
0
|
0
|
|
|
|
0
|
unless ( $pid) { |
69
|
0
|
0
|
|
|
|
0
|
warn "process($$) started\n" if $DEBUG; |
70
|
0
|
|
|
|
|
0
|
eval { $cb->(); }; |
|
0
|
|
|
|
|
0
|
|
71
|
0
|
0
|
|
|
|
0
|
warn "process($$) ended\n" if $DEBUG; |
72
|
0
|
0
|
|
|
|
0
|
warn $@ if $@; |
73
|
0
|
0
|
|
|
|
0
|
POSIX::exit($@ ? 1 : 0); |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
0
|
0
|
|
|
|
0
|
warn "forked pid=$pid\n" if $DEBUG; |
77
|
0
|
|
|
|
|
0
|
context $pid; |
78
|
0
|
|
|
|
|
0
|
&pid(); |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
0
|
|
|
|
|
0
|
} |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
# return output from a subprocess |
84
|
|
|
|
|
|
|
sub new_forked(&) |
85
|
|
|
|
|
|
|
{ |
86
|
44
|
|
|
44
|
1
|
77
|
my $cb = shift; |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
my ( $pid, $r) = new_process { |
89
|
8
|
|
|
8
|
|
186
|
my @ret; |
90
|
8
|
|
|
|
|
224
|
my $socket = shift; |
91
|
8
|
50
|
|
|
|
105
|
eval { @ret = $cb-> () if $cb }; |
|
8
|
|
|
|
|
453
|
|
92
|
8
|
50
|
|
|
|
1702766
|
my $msg = $@ ? [ 0, $@ ] : [ 1, @ret ]; |
93
|
8
|
50
|
|
|
|
121
|
warn "process($$) ended: [@$msg]\n" if $DEBUG > 1; |
94
|
8
|
|
|
|
|
477
|
print $socket freeze($msg); |
95
|
44
|
|
|
|
|
302
|
}; |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
lambda { |
98
|
36
|
50
|
|
36
|
|
89
|
return undef, undef, $r unless defined $pid; |
99
|
|
|
|
|
|
|
|
100
|
36
|
|
|
|
|
77
|
my $buf = ''; |
101
|
36
|
|
|
|
|
732
|
context readbuf, $r, \ $buf, undef; |
102
|
|
|
|
|
|
|
tail { |
103
|
32
|
|
|
|
|
69
|
my ( $ok, $error) = @_; |
104
|
32
|
|
|
|
|
46
|
my @ret; |
105
|
|
|
|
|
|
|
|
106
|
32
|
50
|
|
|
|
618
|
($ok,$error) = (0,$!) unless close($r); |
107
|
|
|
|
|
|
|
|
108
|
32
|
50
|
|
|
|
77
|
unless ( $ok) { |
109
|
0
|
|
|
|
|
0
|
@ret = ( undef, $error); |
110
|
|
|
|
|
|
|
} else { |
111
|
32
|
|
|
|
|
47
|
my $msg; |
112
|
32
|
|
|
|
|
64
|
eval { $msg = thaw $buf }; |
|
32
|
|
|
|
|
476
|
|
113
|
32
|
50
|
33
|
|
|
1608
|
unless ( $msg and ref($msg) and ref($msg) eq 'ARRAY') { |
|
|
50
|
|
|
|
|
|
114
|
0
|
|
|
|
|
0
|
@ret = ( undef, $@); |
115
|
|
|
|
|
|
|
} elsif ( 0 == shift @$msg) { |
116
|
0
|
|
|
|
|
0
|
@ret = ( undef, @$msg); |
117
|
|
|
|
|
|
|
} else { |
118
|
32
|
|
|
|
|
118
|
@ret = ( 1, @$msg); |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
32
|
|
|
|
|
91
|
context $pid; |
123
|
|
|
|
|
|
|
pid { |
124
|
31
|
50
|
|
|
|
158
|
warn "pid($pid): exitcode=$?, [@ret]\n" if $DEBUG > 1; |
125
|
31
|
|
|
|
|
108
|
return shift, @ret; |
126
|
36
|
|
|
|
|
780
|
}}} |
|
32
|
|
|
|
|
580
|
|
127
|
36
|
|
|
|
|
4378
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
# simpler version of new_forked |
130
|
|
|
|
|
|
|
sub forked(&) |
131
|
|
|
|
|
|
|
{ |
132
|
48
|
|
|
48
|
1
|
1882
|
my $cb = shift; |
133
|
|
|
|
|
|
|
lambda { |
134
|
44
|
|
|
44
|
|
141
|
context &new_forked($cb); |
135
|
|
|
|
|
|
|
tail { |
136
|
31
|
|
|
|
|
73
|
my ( $pid, $ok, @ret) = @_; |
137
|
31
|
|
|
|
|
97
|
return @ret; |
138
|
36
|
|
|
|
|
1400
|
}} |
139
|
48
|
|
|
|
|
322
|
} |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
1; |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
__DATA__ |