File Coverage

blib/lib/Fsdb/Support/Freds.pm
Criterion Covered Total %
statement 17 61 27.8
branch 3 26 11.5
condition 1 10 10.0
subroutine 5 12 41.6
pod 8 8 100.0
total 34 117 29.0


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2              
3             #
4             # Fsdb::Support::Freds.pm
5             # Copyright (C) 2013 by John Heidemann
6             # $Id: 30850e6477d5618974cfc18edaca6fd4b70b8a71 $
7             #
8             # This program is distributed under terms of the GNU general
9             # public license, version 2. See the file COPYING
10             # in $dblib for details.
11             #
12              
13             package Fsdb::Support::Freds;
14              
15              
16             =head1 NAME
17              
18             Fsdb::Support::Freds - an abstraction over fork and/or ithreads
19              
20             =head1 SYNOPSIS
21              
22             use Fsdb::Support::Freds;
23             my $fred = new Fsdb::Support::Freds('new thread to do foo');
24             # or
25             my $fred = new Fsdb::Support::Freds('demo_fred',
26             sub { child_stuff(); exit 0; },
27             sub { say "child is done\n"; } );
28             $fred->join();
29             # or
30             $fred->detach();
31              
32             This package provides an abstraction over fork that is something
33             like Perl's ithreads. Our goal is to abstract process creation
34             and collection, but none of the shared data like ithreads.
35              
36             (Why "Freds"? Because it's fork-based thread-like things,
37             and "Tasks" seems too generic.)
38              
39             =cut
40             #'
41              
42             @ISA = ();
43             ($VERSION) = 1.0;
44              
45 1     1   25 use strict;
  1         2  
  1         27  
46              
47 1     1   3 use POSIX ":sys_wait_h";
  1         1  
  1         6  
48              
49             # keep track of all of them, for reaping
50             our %freds;
51              
52             =head2 new
53              
54             $fsdb = new Fsdb::Support::Freds($description, $child_sub, $ending_sub);
55              
56             For a process, labeling it with optional $DESCRIPTION
57             then running optional $CHILD_SUB in the subprocess,
58             then running optional $ENDING_SUB in the parent process when it exits.
59              
60             $ENDING_SUB is passed three arguments, the fred,
61             the shell exit code (typically 0 for success or non-zero for failure),
62             and the wait return code (the shell exit code shifted, plus signal number).
63              
64             It is the job of the $CHILD_SUB to exit if it wants.
65             Otherwise this function returns to the caller.
66              
67             =cut
68              
69             sub new(;$$$) {
70 0     0 1 0 my($class, $desc, $child_sub, $ending_sub) = @_;
71 0   0     0 my $self = bless {
72             _description => $desc // "no description",
73             _error => undef,
74             _exit_code => undef,
75             _wait_code => undef,
76             _parent => $$,
77             _active => 1,
78             _ending_sub => $ending_sub,
79             }, $class;
80 0         0 my $pid = fork();
81 0 0       0 if (!defined($pid)) {
82 0         0 $self->{_error} = 'cannot fork';
83 0         0 $self->{_active} = undef;
84 0         0 return $self;
85             };
86 0         0 $self->{_pid} = $pid;
87 0         0 $freds{$pid} = $self;
88 0 0 0     0 if ($pid == 0 && defined($child_sub)) {
89 0         0 &$child_sub();
90             }
91 0         0 return $self;
92             }
93              
94             =head2 is_child
95              
96             $fred->is_child();
97              
98             Are we the child? Returns undef if parent.
99              
100             =cut
101              
102             sub is_child($) {
103 0     0 1 0 my $self = shift @_;
104 0         0 return $self->{_pid} == 0;
105             }
106              
107             =head2 info
108              
109             $info = $fred->info();
110              
111             Return a string description of the Fred.
112              
113             =cut
114              
115             sub info($) {
116 0     0 1 0 my $self = shift @_;
117 0         0 return $self->{_description} . "/" . $self->{_pid};
118             }
119              
120             =head2 error
121              
122             $fred->error();
123              
124             Non-zero if in error state.
125              
126             =cut
127              
128             sub error($) {
129 0     0 1 0 my $self = shift @_;
130 0         0 return $self->{_error};
131             }
132              
133             =head2 exit_code
134              
135             $fred->exit_code($full);
136              
137             Exit code of a termintated fred.
138             With $FULL, turn the full version (including errors).
139             Typically "0" means success.
140              
141             =cut
142              
143             sub exit_code($) {
144 0     0 1 0 my($self, $full) = @_;
145 0 0       0 return $full ? $self->{_wait_code} : $self->{_exit_code};
146             }
147              
148             =head2 _post_join
149              
150             $fred->_post_join();
151              
152             Internal cleanup after $FRED is terminated.
153              
154             =cut
155              
156             sub _post_join($$) {
157 0     0   0 my($self, $wait_code) = @_;
158 0   0     0 $wait_code //= 0;
159 0         0 my $exit_code = ($wait_code >> 8);
160              
161             # assert(pid has terminated)
162              
163 0 0       0 return -1 if ($self->{_parent} != $$);
164              
165 0         0 $self->{_active} = 0;
166 0         0 $self->{_exit_code} = $exit_code;
167 0         0 $self->{_wait_code} = $wait_code;
168              
169 0         0 delete $freds{$self->{_pid}};
170              
171 0 0       0 if ($self->{_ending_sub}) {
172 0         0 &{$self->{_ending_sub}}($self, $exit_code, $wait_code);
  0         0  
173             };
174              
175 0         0 return $exit_code;
176             }
177              
178             =head2 join
179              
180             $fred->join();
181              
182             Join a fred (wait for the process to finish).
183             Returns -1 on error
184             (Including if not in the parent.)
185              
186              
187             =cut
188              
189             sub join() {
190 0     0 1 0 my($self) = @_;
191 0 0       0 return -1 if ($self->{_parent} != $$);
192 0 0       0 return $self->{_exit_code} if (!$self->{_active});
193              
194 0         0 waitpid $self->{_pid}, 0;
195 0         0 return $self->_post_join($?);
196             }
197              
198             =head2 join_any
199              
200             my $fred = Fsdb::Support::Freds::join_any($BLOCK);
201              
202             Join on some pending fred,
203             without blocking (default) or blocking (if $BLOCK) is set.
204             Returns -1 on error.
205             Returns 0 if something is running but not finished.
206              
207             Returns the $FRED that ends.
208              
209             =cut
210              
211             sub join_any(;$) {
212 1     1 1 2 my($block) = @_;
213              
214 1 50       9 my $pid = waitpid(-1, ($block ? 0 : WNOHANG));
215 1 50 33     7 return $pid if ($pid == -1 || $pid == 0);
216              
217             # find it
218 0         0 my $fred = $freds{$pid};
219 0 0       0 return 0 if (!defined($fred)); # not ours
220              
221 0         0 $fred->_post_join();
222 0         0 return $fred;
223             }
224              
225             =head2 join_all
226              
227             my $fred = Fsdb::Support::Freds::join_all();
228              
229             Reap all pending threads.
230              
231             =cut
232              
233             sub join_all() {
234 1     1 1 2 for(;;) {
235 1         3 my $fred = Fsdb::Support::Freds::join_any();
236 1 50       6 last if (ref($fred) eq '');
237             };
238             }
239              
240             =head2 END
241              
242             Detect any non-repeaed processes.
243              
244             =cut
245              
246             END {
247 1     1   15153 my $fred;
248 1         3 my $old_exit = $?;
249 1         3 Fsdb::Support::Freds::join_all();
250 1         3 foreach $fred (values (%freds)) {
251 0 0       0 next if (!$fred->{_active});
252 0 0       0 next if ($fred->{_parent} != $$); # not my problem
253 0         0 warn "Fsdb::Support::Freds: ending, but running process: " . $fred->{_description} . "\n";
254             };
255 1         6 $? = $old_exit;
256             }
257              
258             1;