line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package AnyEvent::Fork::Serve; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
our $OWNER; # pid of process "owning" us |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
# commands understood: |
6
|
|
|
|
|
|
|
# e_val perlcode string... |
7
|
|
|
|
|
|
|
# f_ork |
8
|
|
|
|
|
|
|
# h_andle + fd |
9
|
|
|
|
|
|
|
# a_rgs string... |
10
|
|
|
|
|
|
|
# r_un func |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# the goal here is to keep this simple, small and efficient |
13
|
|
|
|
|
|
|
sub serve { |
14
|
3
|
|
|
3
|
0
|
67
|
local $^W = 0; # avoid spurious warnings |
15
|
|
|
|
|
|
|
|
16
|
3
|
|
|
|
|
74
|
undef &me; # free a tiny bit of memory |
17
|
|
|
|
|
|
|
|
18
|
3
|
|
|
|
|
25
|
my $master = shift; |
19
|
|
|
|
|
|
|
|
20
|
3
|
|
|
|
|
16
|
my @arg; |
21
|
|
|
|
|
|
|
|
22
|
3
|
|
|
|
|
12
|
my ($cmd, $fd); |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
my $error = sub { |
25
|
0
|
|
|
0
|
|
0
|
warn "[$0] ERROR: $_[0]\n"; |
26
|
0
|
|
|
|
|
0
|
last; |
27
|
3
|
|
|
|
|
40
|
}; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
local *run_args = sub () { # AnyEvent::Fork::Serve::run_args |
30
|
0
|
|
|
0
|
|
0
|
my (@ret, @arg) = @arg; # copy and clear @arg |
31
|
|
|
|
|
|
|
@ret |
32
|
3
|
|
|
|
|
20
|
}; |
|
0
|
|
|
|
|
0
|
|
33
|
|
|
|
|
|
|
|
34
|
3
|
|
|
|
|
11
|
while () { |
35
|
|
|
|
|
|
|
# we manually reap child processes before we sleep, as local $SIG... |
36
|
|
|
|
|
|
|
# will destroy existing child handlers instead of restoring them. |
37
|
7
|
|
|
|
|
137
|
1 while 0 < waitpid -1, 1; # WNOHANG is portably 1. prove me wrong. |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# we must not ever read "too much" data, as we might accidentally read |
40
|
|
|
|
|
|
|
# an IO::FDPass::send request. |
41
|
|
|
|
|
|
|
|
42
|
7
|
|
|
|
|
25
|
my $len; |
43
|
7
|
|
100
|
|
|
482051
|
sysread $master, $len, 5 - length $len, length $len or last |
44
|
|
|
|
|
|
|
while 5 > length $len; |
45
|
6
|
|
|
|
|
121
|
($cmd, $len) = unpack "a L", $len; |
46
|
|
|
|
|
|
|
|
47
|
6
|
|
|
|
|
31
|
my $buf; |
48
|
6
|
|
50
|
|
|
119
|
sysread $master, $buf, $len - length $buf, length $buf or last |
49
|
|
|
|
|
|
|
while $len > length $buf; |
50
|
|
|
|
|
|
|
|
51
|
6
|
100
|
|
|
|
61
|
if ($cmd eq "h") { |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
52
|
2
|
|
|
|
|
54
|
require IO::FDPass; |
53
|
2
|
|
|
|
|
130
|
$fd = IO::FDPass::recv (fileno $master); |
54
|
2
|
50
|
|
|
|
20
|
$fd >= 0 or $error->("AnyEvent::Fork::Serve: fd_recv() failed: $!"); |
55
|
2
|
50
|
|
|
|
136
|
open my $fh, "+<&=$fd" or $error->("AnyEvent::Fork::Serve: open (fd_recv) failed: $!"); |
56
|
2
|
|
|
|
|
18
|
push @arg, $fh; |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
} elsif ($cmd eq "a") { |
59
|
0
|
|
|
|
|
0
|
push @arg, unpack "(w/a*)*", $buf; |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
} elsif ($cmd eq "f") { |
62
|
2
|
|
|
|
|
2376
|
my $pid = fork; |
63
|
|
|
|
|
|
|
|
64
|
2
|
100
|
|
|
|
279
|
if ($pid eq 0) { |
65
|
1
|
|
|
|
|
103
|
$0 = "$OWNER AnyEvent::Fork"; |
66
|
1
|
|
|
|
|
103
|
$master = pop @arg; |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
} else { |
69
|
1
|
|
|
|
|
24
|
pop @arg; |
70
|
|
|
|
|
|
|
|
71
|
1
|
50
|
|
|
|
220
|
$pid |
72
|
|
|
|
|
|
|
or $error->("AnyEvent::Fork::Serve: fork() failed: $!"); |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
} elsif ($cmd eq "e") { |
76
|
2
|
|
|
|
|
38
|
($cmd, @_) = unpack "(w/a*)*", $buf; |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
# $cmd is allowed to access @_ and nothing else |
79
|
|
|
|
|
|
|
package main; |
80
|
2
|
|
|
|
|
795
|
eval $cmd; |
81
|
0
|
0
|
|
|
|
0
|
$error->("$@") if $@; |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
} elsif ($cmd eq "r") { |
84
|
|
|
|
|
|
|
# we could free &serve etc., but this might just unshare |
85
|
|
|
|
|
|
|
# memory that could be shared otherwise. |
86
|
0
|
|
|
|
|
0
|
@_ = ($master, @arg); |
87
|
0
|
|
|
|
|
0
|
$0 = "$OWNER $buf"; |
88
|
|
|
|
|
|
|
package main; |
89
|
0
|
|
|
|
|
0
|
goto &$buf; |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
} else { |
92
|
0
|
|
|
|
|
0
|
$error->("AnyEvent::Fork::Serve received unknown request '$cmd' - stream corrupted?"); |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
1
|
|
|
|
|
44
|
shutdown $master, 1; |
97
|
1
|
|
|
|
|
1392
|
exit; # work around broken win32 perls |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# the entry point for new_exec |
101
|
|
|
|
|
|
|
sub me { |
102
|
|
|
|
|
|
|
#$^F = 2; # should always be the case |
103
|
|
|
|
|
|
|
|
104
|
0
|
0
|
|
0
|
0
|
|
open my $fh, "+<&=$ARGV[0]" |
105
|
|
|
|
|
|
|
or die "AnyEvent::Fork::Serve::me unable to open communication socket: $!\n"; |
106
|
|
|
|
|
|
|
|
107
|
0
|
|
|
|
|
|
$OWNER = $ARGV[1]; |
108
|
|
|
|
|
|
|
|
109
|
0
|
|
|
|
|
|
$0 = "$OWNER AnyEvent::Fork/exec"; |
110
|
|
|
|
|
|
|
|
111
|
0
|
|
|
|
|
|
@ARGV = (); |
112
|
0
|
|
|
|
|
|
@_ = $fh; |
113
|
0
|
|
|
|
|
|
goto &serve; |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
1 |
117
|
|
|
|
|
|
|
|