File Coverage

blib/lib/Daemon/Device.pm
Criterion Covered Total %
statement 88 193 45.6
branch 21 76 27.6
condition 8 25 32.0
subroutine 15 30 50.0
pod 11 12 91.6
total 143 336 42.5


line stmt bran cond sub pod time code
1             package Daemon::Device;
2             # ABSTRACT: Forking daemon device construct
3              
4 6     6   742800 use 5.012;
  6         90  
5 6     6   30 use strict;
  6         12  
  6         120  
6 6     6   30 use warnings;
  6         12  
  6         210  
7              
8 6     6   3342 use Daemon::Control;
  6         81810  
  6         228  
9 6     6   60 use Carp qw( croak carp );
  6         12  
  6         300  
10 6     6   42 use POSIX ":sys_wait_h";
  6         12  
  6         30  
11 6     6   3948 use IO::Pipe;
  6         49170  
  6         14082  
12              
13             our $VERSION = '1.08'; # VERSION
14              
15             sub new {
16 6     6 1 4554 my $class = shift;
17 6 50       36 croak 'new() called with uneven number of parameters' if ( @_ % 2 );
18              
19 6         60 my $self = bless( {@_}, $class );
20              
21 6         168 $self->{ '_' . $_ } = delete $self->{$_} for ( qw(
22             daemon
23             spawn
24             replace_children
25             parent_hup_to_child
26             parent
27             child
28             on_startup
29             on_shutdown
30             on_spawn
31             on_parent_hup
32             on_child_hup
33             on_parent_death
34             on_child_death
35             on_replace_child
36             on_message
37             data
38             ) );
39              
40 6 50       30 if ( not $self->{_daemon}{user} ) {
41 6   50     4968 my $user = getlogin || getpwuid($<) || 'root';
42 6   33     60 $self->{_daemon}{user} ||= $user;
43             }
44 6   33     1452 $self->{_daemon}{group} ||= ( getgrgid( (getpwnam( $self->{_daemon}{user} ) )[3] ) )[0];
45              
46 6 50       54 croak 'new() called without "daemon" parameter as a hashref' unless ( ref( $self->{_daemon} ) eq 'HASH' );
47 6         24 for ( qw( program program_args ) ) {
48 12 50       42 croak qq{new() called with "daemon" hashref containing "$_" key} if ( $self->{_daemon}{$_} );
49             }
50 6         18 for ( qw(
51             parent child
52             on_startup on_shutdown on_spawn on_parent_hup on_child_hup
53             on_parent_death on_child_death on_replace_child
54             ) ) {
55             croak qq{new() called with "$_" parameter not a coderef}
56 60 50 33     144 if ( exists $self->{$_} and ref( $self->{$_} ) ne 'CODE' );
57             }
58              
59 6         150 $self->{_daemon}{program} = \&_parent;
60 6         30 $self->{_daemon}{program_args} = [$self];
61              
62 6   50     24 $self->{_spawn} ||= 1;
63 6   50     36 $self->{_replace_children} //= 1;
64 6   50     30 $self->{_parent_hup_to_child} //= 1;
65 6   50     36 $self->{_data} //= {};
66              
67 6         12 $self->{_children} = [];
68 6         18 $self->{_daemon} = Daemon::Control->new( %{ $self->{_daemon} } );
  6         78  
69              
70 6         828 return $self;
71             }
72              
73             sub run {
74 0     0 1 0 my ($self) = @_;
75 0         0 return $self->{_daemon}->run;
76             }
77              
78             sub daemon {
79 0     0 1 0 my ($self) = @_;
80 0         0 return $self->{_daemon};
81             }
82              
83             sub _parent {
84 5     5   19780 my ( $daemon, $self ) = @_;
85              
86 5         275 $self->{_ppid} = $$;
87              
88             $SIG{'HUP'} = sub {
89 0 0   0   0 $self->{_on_parent_hup}->($self) if ( $self->{_on_parent_hup} );
90 0 0       0 if ( $self->{_parent_hup_to_child} ) {
91 0         0 kill( 'HUP', $_->{pid} ) for ( @{ $self->{_children} } );
  0         0  
92             }
93 5         370 };
94              
95             my $terminate = sub {
96 1 50   1   77 $self->{_on_parent_death}->($self) if ( $self->{_on_parent_death} );
97 1         97 kill( 'TERM', $_->{pid} ) for ( @{ $self->{_children} } );
  1         146  
98 1 50       61 $self->{_on_shutdown}->($self) if ( $self->{_on_shutdown} );
99 1         692 exit;
100 5         140 };
101 5         275 $SIG{$_} = $terminate for ( qw( TERM INT ABRT QUIT ) );
102              
103             $SIG{'CHLD'} = sub {
104 5 50   5   3008715 if ( $self->{_replace_children} ) {
105 5 50       128 $self->{_on_replace_child}->($self) if ( $self->{_on_replace_child} );
106 5         295 for ( @{ $self->{_children} } ) {
  5         85  
107 13 100       680492 $_ = _spawn($self) if ( waitpid( $_->{pid}, WNOHANG ) );
108             }
109             }
110 5         220 };
111              
112             $SIG{'URG'} = sub {
113 0 0   0   0 if ( $self->{_on_message} ) {
114 0         0 my @messages = map { split(/\r?\n/) } map { $_->{io_up}->getlines } @{ $self->{_children} };
  0         0  
  0         0  
  0         0  
115 0         0 $self->{_on_message}->( $self, @messages );
116             }
117 5         175 };
118              
119 5 50       130 $self->{_on_startup}->($self) if ( $self->{_on_startup} );
120              
121 5         330 for ( 1 .. $self->{_spawn} ) {
122 12         68 push( @{ $self->{_children} }, _spawn($self) );
  12         204  
123             }
124              
125 3 50       93 if ( $self->{_parent} ) {
126 3         171 $self->{_parent}->($self);
127             }
128             else {
129 0         0 wait;
130             }
131              
132 0         0 return;
133             }
134              
135             sub _spawn {
136 17     17   73 my ($self) = @_;
137              
138 17 50       444 $self->{_on_spawn}->($self) if ( $self->{_on_spawn} );
139              
140 17         568 my ( $io_up, $io_dn );
141 17 50       111 if ( $self->{_on_message} ) {
142 0         0 $io_up = IO::Pipe->new;
143 0         0 $io_dn = IO::Pipe->new;
144             }
145              
146 17 100       12591 if ( my $pid = fork ) {
147 13         559 my $child_data = { pid => $pid };
148              
149 13 50       205 if ( $self->{_on_message} ) {
150 0         0 $io_up->reader;
151 0         0 $io_dn->writer;
152 0         0 for ( $io_up, $io_dn ) {
153 0         0 $_->autoflush;
154 0         0 $_->blocking(0);
155             }
156 0         0 $child_data->{io_up} = $io_up;
157 0         0 $child_data->{io_dn} = $io_dn;
158             }
159              
160 13         633594 return $child_data;
161             }
162             else {
163 4 50       393 if ( $self->{_on_message} ) {
164 0         0 $io_up->writer;
165 0         0 $io_dn->reader;
166 0         0 for ( $io_up, $io_dn ) {
167 0         0 $_->autoflush;
168 0         0 $_->blocking(0);
169             }
170 0         0 $self->{_io_up} = $io_up;
171 0         0 $self->{_io_dn} = $io_dn;
172             }
173              
174 4         232 $self->{_cpid} = $$;
175 4         146 _child($self);
176 0         0 exit;
177             }
178              
179 0         0 return;
180             }
181              
182             sub _child {
183 4     4   49 my ($self) = @_;
184              
185             $SIG{'HUP'} = sub {
186 0 0   0   0 $self->{_on_child_hup}->($self) if ( $self->{_on_child_hup} );
187 4         442 };
188              
189             my $terminate = sub {
190 4 50   4   2690813 $self->{_on_child_death}->($self) if ( $self->{_on_child_death} );
191 4         2648 exit;
192 4         205 };
193 4         228 $SIG{$_} = $terminate for ( qw( TERM INT ABRT QUIT ) );
194              
195             $SIG{'URG'} = sub {
196 0 0   0   0 if ( $self->{_on_message} ) {
197 0         0 my @messages = map { split(/\r?\n/) } $self->{_io_dn}->getlines;
  0         0  
198 0         0 $self->{_on_message}->( $self, @messages );
199             }
200 4         187 };
201              
202 4 50       138 if ( $self->{_child} ) {
203 4         124 $self->{_child}->($self);
204             }
205             else {
206 0         0 while (1) {
207 0 0       0 exit unless ( $self->parent_alive );
208 0         0 sleep 1;
209             }
210             }
211              
212 0         0 return;
213             }
214              
215             sub ppid {
216 0     0 1 0 return shift->{_ppid};
217             }
218              
219             sub cpid {
220 0     0 1 0 return shift->{_cpid};
221             }
222              
223             sub children {
224 0     0 1 0 return [ map { $_->{pid} } @{ shift->{_children} } ];
  0         0  
  0         0  
225             }
226              
227             sub adjust_spawn {
228 0     0 1 0 my ( $self, $new_spawn_count ) = @_;
229 0         0 $self->{_spawn} = $new_spawn_count;
230              
231 0 0 0     0 if ( @{ $self->{_children} } > 0 and @{ $self->{_children} } < $self->{_spawn} ) {
  0 0 0     0  
  0         0  
232 0         0 push( @{ $self->{_children} }, _spawn($self) ) while ( @{ $self->{_children} } < $self->{_spawn} );
  0         0  
  0         0  
233             }
234 0         0 elsif ( @{ $self->{_children} } > 0 and @{ $self->{_children} } > $self->{_spawn} ) {
  0         0  
235 0         0 my $set_replace_children = $self->{_replace_children};
236 0         0 $self->{_replace_children} = 0;
237              
238 0         0 my @killed_pids;
239 0         0 while ( @{ $self->{_children} } > $self->{_spawn} ) {
  0         0  
240 0         0 my $child = shift @{ $self->{_children} };
  0         0  
241 0         0 kill( 'TERM', $child->{pid} );
242 0         0 push( @killed_pids, $child->{pid} );
243             }
244              
245 0         0 waitpid( $_, 0 ) for (@killed_pids);
246 0         0 $self->{_replace_children} = $set_replace_children;
247             }
248              
249 0         0 return;
250             }
251              
252             sub replace_children {
253 0     0 1 0 my $self = shift;
254 0 0       0 $self->{_replace_children} = $_[0] if (@_);
255 0         0 return $self->{_replace_children};
256             }
257              
258             sub parent_hup_to_child {
259 0     0 1 0 my $self = shift;
260 0 0       0 $self->{_parent_hup_to_child} = $_[0] if (@_);
261 0         0 return $self->{_parent_hup_to_child};
262             }
263              
264             sub parent_alive {
265 6     6 1 2003732 my ($self) = @_;
266 6         385 return kill( 0, $self->{_ppid} );
267             }
268              
269             sub data {
270 0     0 0   my $self = shift;
271 0 0         return $self->{'_data'} unless (@_);
272              
273 0 0         if ( @_ == 1 ) {
274 0 0         return $self->{'_data'}{ $_[0] } if ( not ref $_[0] );
275 0           $self->{'_data'}{$_} = $_[0]->{$_} for ( keys %{ $_[0] } );
  0            
276 0           return $self;
277             }
278              
279 0 0         if ( @_ % 2 != 0 ) {
280 0           carp( 'data() called with uneven number of parameters' );
281             }
282             else {
283 0           my %params = @_;
284 0           $self->{'_data'}{$_} = $params{$_} for ( keys %params );
285             }
286              
287 0           return $self;
288             }
289              
290             sub message {
291 0     0 1   my ( $self, $pid, $message ) = @_;
292              
293 0 0         unless ( $self->{_on_message} ) {
294 0           carp('message() called without an on_message handler set');
295 0           return;
296             }
297              
298 0           my $io;
299 0           eval {
300             $io = ( $self->{_ppid} == $pid )
301             ? $self->{_io_up}
302 0           : ( grep { $_->{pid} == $pid } @{ $self->{_children} } )[0]->{io_dn}
  0            
303 0 0         };
304 0 0         if ($@) {
305 0           carp("Failed to find IO path for message to $pid");
306 0           return;
307             }
308              
309 0 0         $io->say($message) or carp("Failed to send message to $pid");
310 0 0         kill( 'URG', $pid ) or carp("Failed to signal process $pid to new message");
311             }
312              
313             our $AUTOLOAD;
314             sub AUTOLOAD {
315 0     0     my $self = shift;
316 0           my $key = ( split( '::', $AUTOLOAD ) )[-1];
317 0           return $self->data($key);
318             }
319              
320             1;
321              
322             __END__