File Coverage

blib/lib/AnyEvent/Fork/Serve.pm
Criterion Covered Total %
statement 30 46 65.2
branch 11 22 50.0
condition 3 4 75.0
subroutine 1 4 25.0
pod 0 2 0.0
total 45 78 57.6


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