line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Proc::Launcher; |
2
|
22
|
|
|
22
|
|
62302
|
use strict; |
|
22
|
|
|
|
|
46
|
|
|
22
|
|
|
|
|
959
|
|
3
|
22
|
|
|
22
|
|
108
|
use warnings; |
|
22
|
|
|
|
|
36
|
|
|
22
|
|
|
|
|
916
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
our $VERSION = '0.0.35'; # VERSION |
6
|
|
|
|
|
|
|
|
7
|
22
|
|
|
22
|
|
17300
|
use Mouse; |
|
22
|
|
|
|
|
676756
|
|
|
22
|
|
|
|
|
178
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
#_* Libraries |
10
|
|
|
|
|
|
|
|
11
|
22
|
|
|
22
|
|
7887
|
use File::Path; |
|
22
|
|
|
|
|
43
|
|
|
22
|
|
|
|
|
1883
|
|
12
|
22
|
|
|
22
|
|
22024
|
use File::Tail; |
|
22
|
|
|
|
|
823945
|
|
|
22
|
|
|
|
|
1479
|
|
13
|
22
|
|
|
22
|
|
18762
|
use POSIX qw(setsid :sys_wait_h); |
|
22
|
|
|
|
|
173598
|
|
|
22
|
|
|
|
|
175
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
#_* POD |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
=head1 NAME |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
Proc::Launcher - yet another forking process controller |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
=head1 VERSION |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
version 0.0.35 |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
=head1 SYNOPSIS |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
use Proc::Launcher; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
# define a method to start your application if it isn't already running |
31
|
|
|
|
|
|
|
use MyApp; |
32
|
|
|
|
|
|
|
my $start_myapp = sub { MyApp->new( context => $some_shared_data )->run() }; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
# create a new launcher object |
35
|
|
|
|
|
|
|
my $launcher = Proc::Launcher->new( start_method => $start_myapp, |
36
|
|
|
|
|
|
|
daemon_name => 'myapp', |
37
|
|
|
|
|
|
|
); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# an alternate version of the same thing without the subroutine reference |
40
|
|
|
|
|
|
|
my $launcher = Proc::Launcher->new( class => 'MyApp', |
41
|
|
|
|
|
|
|
start_method => 'run' |
42
|
|
|
|
|
|
|
context => $some_shared_data, |
43
|
|
|
|
|
|
|
daemon_name => 'myapp', |
44
|
|
|
|
|
|
|
); |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# check if the process was already running |
47
|
|
|
|
|
|
|
if ( $launcher->is_running() ) { warn "Already running!\n" } |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
# start the process if there isn't already one running |
50
|
|
|
|
|
|
|
$launcher->start(); |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
# shut down the process if it is already running. start a new process. |
53
|
|
|
|
|
|
|
$launcher->restart(); |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
# get the process pid |
56
|
|
|
|
|
|
|
my $pid = $launcher->pid(); |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
# kill -HUP |
59
|
|
|
|
|
|
|
$launcher->stop(); |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# kill -9 |
62
|
|
|
|
|
|
|
$launcher->force_stop(); |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
# get the process log file path |
65
|
|
|
|
|
|
|
my $log = $launcher->log_file; |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
=head1 DESCRIPTION |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
This library is designed to fork one or more long-running background |
70
|
|
|
|
|
|
|
processes and to manage them. This includes starting, stopping, and |
71
|
|
|
|
|
|
|
automatically restarting processes--even those that don't behave well. |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
The pid of the forked child processes are written to pid files and |
74
|
|
|
|
|
|
|
persist across multiple restarts of the launcher. This means that |
75
|
|
|
|
|
|
|
stdout/stderr/stdin of the children are not directly connected to the |
76
|
|
|
|
|
|
|
launching process. All stdout and stderr from the child processes is |
77
|
|
|
|
|
|
|
written to a log file. |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
For more useful functions (e.g. a supervisor to restart processes that |
80
|
|
|
|
|
|
|
die), see L. |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
=head1 RELATED WORK |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
There are a large number of modules already on CPAN for forking and |
85
|
|
|
|
|
|
|
managing child processes, and also for managing daemon processes |
86
|
|
|
|
|
|
|
(apachectl style). After doing a lot of reading and experimentation, |
87
|
|
|
|
|
|
|
I unfortunately ended up deciding to write yet another one. Here is a |
88
|
|
|
|
|
|
|
bit of information on related modules and how this one differs. |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
While it is possible to exec() and manage external executables in the |
91
|
|
|
|
|
|
|
child processes, that is merely an afterthought in this module. If |
92
|
|
|
|
|
|
|
you are looking for a module to start and manage external executables, |
93
|
|
|
|
|
|
|
you might also want to check out L, L, |
94
|
|
|
|
|
|
|
L, or L on CPAN, or ControlFreak on github. |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
If you are looking to investigate and/or kill running processes IDs, |
97
|
|
|
|
|
|
|
see L, L, or L. This |
98
|
|
|
|
|
|
|
module only manages processes that have been forked by this module. |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
If you only want to read and write a PID file, see L. |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
On the other hand, if you're looking for a library to fork dependent |
103
|
|
|
|
|
|
|
child processes that maintain stdout/stderr/stdin connected to the |
104
|
|
|
|
|
|
|
child, check out L, L, L, |
105
|
|
|
|
|
|
|
L, L, etc. This module assumes that all |
106
|
|
|
|
|
|
|
child processes will close stdin/stdout/stderr and will continue to |
107
|
|
|
|
|
|
|
live even after the launching process has exited. Furthermore the |
108
|
|
|
|
|
|
|
launched process will be manageable by launchers that are started |
109
|
|
|
|
|
|
|
after the launched process is already running. |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
This library does not do anything like forking/pre-forking multiple |
112
|
|
|
|
|
|
|
processes for a single daemon (e.g. for a high-volume server, see |
113
|
|
|
|
|
|
|
L) or limiting the maximum number of running |
114
|
|
|
|
|
|
|
child processes (see L or L). Instead |
115
|
|
|
|
|
|
|
it is assumed that you are dealing with is a fixed set of named |
116
|
|
|
|
|
|
|
daemons, each of which is associated with a single process to be |
117
|
|
|
|
|
|
|
managed. Of course any managed processes could fork it's own |
118
|
|
|
|
|
|
|
children. Note that only the process id of the immediate child will |
119
|
|
|
|
|
|
|
be managed--any child processes created by child process |
120
|
|
|
|
|
|
|
(grandchildren of the launcher) are not tracked. |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
Similarly your child process should never do a fork() and exit() or |
123
|
|
|
|
|
|
|
otherwise daemonize on it's own. When the child does this, the |
124
|
|
|
|
|
|
|
launcher will lose track of the grandchild pid and assume it has shut |
125
|
|
|
|
|
|
|
down. This may result in restarting your service while it is already |
126
|
|
|
|
|
|
|
running. |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
This library does not handle command line options--that is left to |
129
|
|
|
|
|
|
|
your application/script. It does not export any methods nor require |
130
|
|
|
|
|
|
|
you to inherit from any classes or to build any subclasses. This |
131
|
|
|
|
|
|
|
means that you can launch a process from any normal perl subroutine or |
132
|
|
|
|
|
|
|
object method--the launched class/method/subroutine does not have to |
133
|
|
|
|
|
|
|
be modified to be daemonized. |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
This library does not use or require an event loop (e.g. AnyEvent, |
136
|
|
|
|
|
|
|
POE, etc.), but is fully usable from with an event loop since objects |
137
|
|
|
|
|
|
|
of this class avoid calling sleep() (doing so inside a single-threaded |
138
|
|
|
|
|
|
|
event loop causes everything else running in the event loop to wait). |
139
|
|
|
|
|
|
|
This does mean that methods such as stop() will return immediately |
140
|
|
|
|
|
|
|
without providing a status. See more about this in the note below in |
141
|
|
|
|
|
|
|
rm_zombies(). |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
For compatibility with the planned upcoming L module |
144
|
|
|
|
|
|
|
(which uses L), this module and it's dependencies are |
145
|
|
|
|
|
|
|
written in pure perl. |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
The intended use for this library is that a supervising process will |
148
|
|
|
|
|
|
|
acquire some (immutable) global configuration data which is then |
149
|
|
|
|
|
|
|
passed (at fork time) to one or more long-running component daemon |
150
|
|
|
|
|
|
|
processes. In the Panoptes project, this library is used for starting |
151
|
|
|
|
|
|
|
and managing the various Panoptes components on each node |
152
|
|
|
|
|
|
|
(L, L, L, |
153
|
|
|
|
|
|
|
etc.) and also for managing connections to the remote agents. |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
If you are aware of any other noteworthy modules in this vein, please |
156
|
|
|
|
|
|
|
let me know! |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
=cut |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
#_* Roles |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
with 'Proc::Launcher::Roles::Launchable'; |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
#_* Attributes |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
=head1 CONSTRUCTOR OPTIONS |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
The constructor supports the following options, e.g.: |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
my $launcher = Proc::Launcher->new( debug => 1, ... ); |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
Each of these attributes will also have a getter, e.g.: |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
if ( $launcher->debug ) { print "DEBUGGING ENABLED!\n" } |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
All attributes are read-only unless otherwise specified. Read/write |
177
|
|
|
|
|
|
|
attributes may be set like so: |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
$launcher->debug( 1 ); |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=over 8 |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
=item debug => 0 |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
Enable debugging messages to STDOUT. This attribute is read/write. |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
=cut |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
has 'debug' => ( is => 'rw', isa => 'Bool', default => 0 ); |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
=item daemon_name => 'somename' |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
Specify the name of the daemon. This will be used as the prefix for |
194
|
|
|
|
|
|
|
the log file, pid file, etc. |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
=cut |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
has 'daemon_name' => ( is => 'ro', isa => 'Str', required => 1 ); |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
=item context => $data |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
Context data to be passed to the forked processes. This could be any |
203
|
|
|
|
|
|
|
complex data structure and may contain things like configuration data. |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
=cut |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
has 'context' => ( is => 'ro', default => sub { {} } ); |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
=item class => 'My::App' |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
Name of the class where the start method is located. An object of |
212
|
|
|
|
|
|
|
this class will be created, passing in your context data. Then the |
213
|
|
|
|
|
|
|
start_method will be called on the object. |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
=cut |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
has 'class' => ( is => 'ro', isa => 'Str' ); |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
=item start_method => 'start_me' |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
If a class is specified, this is the name of the start method in that |
222
|
|
|
|
|
|
|
class. |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
If no class is specified, this must be a subroutine reference. |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
=cut |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
has 'start_method' => ( is => 'ro', required => 1 ); |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
=item pid_dir => "$ENV{HOME}/logs" |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
Specify the directory where the pid file should live. |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
=cut |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
has 'pid_dir' => ( is => 'ro', |
237
|
|
|
|
|
|
|
isa => 'Str', |
238
|
|
|
|
|
|
|
lazy => 1, |
239
|
|
|
|
|
|
|
default => sub { |
240
|
|
|
|
|
|
|
my $dir = join "/", $ENV{HOME}, "logs"; |
241
|
|
|
|
|
|
|
unless ( -d $dir ) { mkpath( $dir ); } |
242
|
|
|
|
|
|
|
return $dir; |
243
|
|
|
|
|
|
|
}, |
244
|
|
|
|
|
|
|
); |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
=item pid_file => "$pid_dir/$daemon_name.pid" |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
Name of the pid file. |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
=cut |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
has 'pid_file' => ( is => 'ro', |
253
|
|
|
|
|
|
|
isa => 'Str', |
254
|
|
|
|
|
|
|
lazy => 1, |
255
|
|
|
|
|
|
|
default => sub { |
256
|
|
|
|
|
|
|
my ( $self ) = @_; |
257
|
|
|
|
|
|
|
my $daemon = $self->daemon_name; |
258
|
|
|
|
|
|
|
return join "/", $self->pid_dir, "$daemon.pid"; |
259
|
|
|
|
|
|
|
}, |
260
|
|
|
|
|
|
|
); |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
=item disable_file => "$pid_dir/$daemon_name.disabled" |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
Location to the 'disable' file. If this file exists, the daemon will |
265
|
|
|
|
|
|
|
not be started when start() is called. |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
=cut |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
has 'disable_file' => ( is => 'ro', |
270
|
|
|
|
|
|
|
isa => 'Str', |
271
|
|
|
|
|
|
|
lazy => 1, |
272
|
|
|
|
|
|
|
default => sub { |
273
|
|
|
|
|
|
|
my ( $self ) = @_; |
274
|
|
|
|
|
|
|
my $daemon = $self->daemon_name; |
275
|
|
|
|
|
|
|
return join "/", $self->pid_dir, "$daemon.disabled"; |
276
|
|
|
|
|
|
|
}, |
277
|
|
|
|
|
|
|
); |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
=item log_file => "$pid_dir/$daemon_name.log" |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
Path to the daemon log file. The daemon process will have both stdout |
282
|
|
|
|
|
|
|
and stderr redirected to this log file. |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
=cut |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
has 'log_file' => ( is => 'ro', |
287
|
|
|
|
|
|
|
isa => 'Str', |
288
|
|
|
|
|
|
|
lazy => 1, |
289
|
|
|
|
|
|
|
default => sub { |
290
|
|
|
|
|
|
|
my $self = shift; |
291
|
|
|
|
|
|
|
my $daemon = $self->daemon_name; |
292
|
|
|
|
|
|
|
return join "/", $self->pid_dir, "$daemon.log"; |
293
|
|
|
|
|
|
|
}, |
294
|
|
|
|
|
|
|
); |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
has 'file_tail' => ( is => 'ro', |
297
|
|
|
|
|
|
|
isa => 'File::Tail', |
298
|
|
|
|
|
|
|
lazy => 1, |
299
|
|
|
|
|
|
|
default => sub { |
300
|
|
|
|
|
|
|
my $self = shift; |
301
|
|
|
|
|
|
|
unless ( -r $self->log_file ) { system( 'touch', $self->log_file ) } |
302
|
|
|
|
|
|
|
return File::Tail->new( name => $self->log_file, |
303
|
|
|
|
|
|
|
nowait => 1, |
304
|
|
|
|
|
|
|
interval => 1, |
305
|
|
|
|
|
|
|
maxinterval => 1, |
306
|
|
|
|
|
|
|
resetafter => 600, |
307
|
|
|
|
|
|
|
); |
308
|
|
|
|
|
|
|
}, |
309
|
|
|
|
|
|
|
); |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
=item pipe => 0 |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
If set to true, specifies that the forked process should create a |
315
|
|
|
|
|
|
|
named pipe. The forked process can then read from the named pipe on |
316
|
|
|
|
|
|
|
STDIN. If your forked process does not read from and process STDIN, |
317
|
|
|
|
|
|
|
then there's no use in enabling this option. |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
=cut |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
has 'pipe' => ( is => 'ro', |
322
|
|
|
|
|
|
|
isa => 'Bool', |
323
|
|
|
|
|
|
|
default => 0, |
324
|
|
|
|
|
|
|
); |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
=item pipe_file => "$pid_dir/$daemon_name.cmd" |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
Path to the named pipe. |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
=cut |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
has 'pipe_file' => ( is => 'ro', |
333
|
|
|
|
|
|
|
isa => 'Str', |
334
|
|
|
|
|
|
|
lazy => 1, |
335
|
|
|
|
|
|
|
default => sub { |
336
|
|
|
|
|
|
|
my $self = shift; |
337
|
|
|
|
|
|
|
my $daemon = $self->daemon_name; |
338
|
|
|
|
|
|
|
return join "/", $self->pid_dir, "$daemon.cmd"; |
339
|
|
|
|
|
|
|
}, |
340
|
|
|
|
|
|
|
); |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
#_* Methods |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
=back |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
=head1 METHODS |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
=over 8 |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
=item start( $data ) |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
Fork a child process. The process id of the forked child will be |
353
|
|
|
|
|
|
|
written to a pid file. |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
The child process will close STDIN and redirect all stdout and stderr |
356
|
|
|
|
|
|
|
to a log file, and then will execute the child start method and will |
357
|
|
|
|
|
|
|
be passed any optional $data that was passed to the start method. |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
Note that there is no ongoing communication channel set up with the |
360
|
|
|
|
|
|
|
child process. Changes to $data in the supervising process will never |
361
|
|
|
|
|
|
|
be available to the child process(es). In order to force the child to |
362
|
|
|
|
|
|
|
pick up the new data, you must stop the child process and then start a |
363
|
|
|
|
|
|
|
new process with a copy of the new data. |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
If the process is found already running, then the method will |
366
|
|
|
|
|
|
|
immediately return null. If a process was successfully forked, |
367
|
|
|
|
|
|
|
success will be returned. Success does not imply that the daemon was |
368
|
|
|
|
|
|
|
started successfully--for that, check is_running(). |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
=cut |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
sub start { |
373
|
29
|
|
|
29
|
1
|
87
|
my ( $self, $args ) = @_; |
374
|
|
|
|
|
|
|
|
375
|
29
|
100
|
|
|
|
173
|
unless ( $self->is_enabled ) { |
376
|
4
|
|
|
|
|
814
|
print $self->daemon_name, " daemon disabled, not starting\n"; |
377
|
4
|
|
|
|
|
25
|
return; |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
|
380
|
25
|
100
|
|
|
|
104
|
if ( $self->is_running() ) { |
381
|
1
|
|
|
|
|
4
|
$self->_debug( "Already running, no start needed" ); |
382
|
1
|
|
|
|
|
7
|
return; |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
|
385
|
24
|
|
|
|
|
165
|
my $log = $self->log_file; |
386
|
|
|
|
|
|
|
|
387
|
24
|
100
|
|
|
|
41169
|
if ( my $pid = fork ) { # PARENT |
388
|
|
|
|
|
|
|
|
389
|
19
|
|
|
|
|
8200
|
print "LAUNCHED CHILD PROCESS: pid=$pid log=$log\n"; |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
CHECK_PID: |
392
|
19
|
|
|
|
|
840
|
for ( 1 .. 5 ) { |
393
|
|
|
|
|
|
|
|
394
|
44
|
|
|
|
|
1056
|
$self->_debug( "Checking if our child locked the pidfile" ); |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
# attempt to read the pidfile |
397
|
44
|
|
|
|
|
715
|
my $locked_pid = $self->pid(); |
398
|
|
|
|
|
|
|
|
399
|
44
|
|
|
|
|
401
|
$self->_debug( "Got locked pid: $locked_pid" ); |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
# check if the pidfile is locked by a valid process |
402
|
44
|
100
|
100
|
|
|
886
|
if ( $locked_pid && $self->is_running( $pid ) ) { |
403
|
|
|
|
|
|
|
|
404
|
17
|
|
|
|
|
146
|
$self->_debug( "Pid is running: $pid" ); |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
# check if the pid that has the lock is our child process |
407
|
17
|
50
|
|
|
|
91
|
if ( $locked_pid == $pid ) { |
408
|
|
|
|
|
|
|
|
409
|
17
|
|
|
|
|
75
|
$self->_debug( "Locked pid is our child pid: $pid" ); |
410
|
17
|
|
|
|
|
973
|
return $pid; |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
else { |
413
|
0
|
|
|
|
|
0
|
$self->_debug( "Locked pid is NOT our child pid: $pid" ); |
414
|
0
|
|
|
|
|
0
|
print "CHILD PROCESS ALREADY RUNNING\n"; |
415
|
0
|
|
|
|
|
0
|
return; |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
|
419
|
27
|
|
|
|
|
29004923
|
sleep 1; |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
else { # CHILD |
423
|
|
|
|
|
|
|
|
424
|
5
|
50
|
|
|
|
576
|
unless ( $self->write_my_pid( $$ ) ) { |
425
|
0
|
|
|
|
|
0
|
$self->_debug( "CHILD FAILED TO LOCK PIDFILE: $pid" ); |
426
|
0
|
|
|
|
|
0
|
exit 1; |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
#chdir '/' or die "Can't chdir to /: $!"; |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
# wu - ugly bug fix - when closing STDIN, it becomes free and |
432
|
|
|
|
|
|
|
# may later get reused when calling open (resulting in error |
433
|
|
|
|
|
|
|
# 'Filehandle STDIN reopened as $fh only for output'). :/ So |
434
|
|
|
|
|
|
|
# instead of closing, just re-open to /dev/null. |
435
|
5
|
50
|
|
|
|
774
|
open STDIN, '<', '/dev/null' or die "$!"; |
436
|
|
|
|
|
|
|
|
437
|
5
|
50
|
|
|
|
1152
|
open STDOUT, '>>', $self->log_file or die "Can't write stdout to $log: $!"; |
438
|
5
|
50
|
|
|
|
289
|
open STDERR, '>>', $self->log_file or die "Can't write stderr to $log: $!"; |
439
|
|
|
|
|
|
|
|
440
|
5
|
50
|
|
|
|
264
|
setsid or die "Can't start a new session: $!"; |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
#umask 0; |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
# this doesn't work on most platforms |
445
|
5
|
|
|
|
|
299
|
$0 = join " - ", "perl", "Proc::Launcher", $self->daemon_name; |
446
|
|
|
|
|
|
|
|
447
|
5
|
|
|
|
|
464
|
print "\n\n", ">" x 77, "\n"; |
448
|
5
|
|
|
|
|
1449
|
print "Starting process: pid = $$: ", scalar localtime, "\n\n"; |
449
|
|
|
|
|
|
|
|
450
|
5
|
100
|
|
|
|
194
|
if ( $self->pipe ) { |
451
|
1
|
|
|
|
|
111
|
my $named_pipe = $self->pipe_file; |
452
|
1
|
|
|
|
|
31
|
print "CREATING NAMED PIPE: $named_pipe\n"; |
453
|
1
|
50
|
|
|
|
55
|
unless (-p $named_pipe) { |
454
|
1
|
|
|
|
|
35
|
unlink $named_pipe; |
455
|
1
|
50
|
|
|
|
103
|
POSIX::mkfifo( $named_pipe, 0700) or die "can't mkfifo $named_pipe: $!"; ## no critic - leading zero |
456
|
|
|
|
|
|
|
} |
457
|
1
|
50
|
|
|
|
6821470
|
open STDIN, '<', $named_pipe or die "$!"; |
458
|
|
|
|
|
|
|
} |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
# child |
461
|
5
|
100
|
|
|
|
52
|
if ( $self->class ) { |
462
|
|
|
|
|
|
|
|
463
|
2
|
|
|
|
|
15
|
my $class = $self->class; |
464
|
2
|
|
|
|
|
28
|
print "Loading Class: $class\n"; |
465
|
|
|
|
|
|
|
|
466
|
2
|
|
|
|
|
1045
|
eval "require $class"; ## no critic |
467
|
|
|
|
|
|
|
|
468
|
2
|
|
|
|
|
4285
|
my $error = $@; |
469
|
2
|
50
|
|
|
|
9
|
if ( $error ) { |
470
|
0
|
|
|
|
|
0
|
$self->stopped(); |
471
|
0
|
|
|
|
|
0
|
die "FATAL ERROR LOADING $class: $error\n"; |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
else { |
474
|
2
|
|
|
|
|
67
|
print "Successfully loaded class\n"; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
|
477
|
2
|
|
|
|
|
28
|
print "Creating an instance of $class\n"; |
478
|
2
|
|
|
|
|
5
|
my $obj; |
479
|
|
|
|
|
|
|
eval { # try |
480
|
2
|
|
|
|
|
50
|
$obj = $class->new( context => $self->context ); |
481
|
2
|
|
|
|
|
137
|
1; |
482
|
2
|
50
|
|
|
|
7
|
} or do { # catch |
483
|
0
|
|
|
|
|
0
|
$self->stopped(); |
484
|
0
|
|
|
|
|
0
|
die "FATAL: unable to create an instance: $@\n"; |
485
|
|
|
|
|
|
|
}; |
486
|
2
|
|
|
|
|
32
|
print "Created\n"; |
487
|
|
|
|
|
|
|
|
488
|
2
|
|
|
|
|
15
|
my $method = $self->start_method; |
489
|
2
|
|
|
|
|
25
|
print "Calling method on instance: $method\n"; |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
eval { # try |
492
|
2
|
|
|
|
|
7
|
$obj->$method( $args ); |
493
|
2
|
|
|
|
|
10000536
|
1; |
494
|
2
|
50
|
|
|
|
5
|
} or do { # catch |
495
|
0
|
|
|
|
|
0
|
$self->stopped(); |
496
|
0
|
|
|
|
|
0
|
die "FATAL: $@\n"; |
497
|
|
|
|
|
|
|
}; |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
else { |
501
|
3
|
|
|
|
|
98
|
print "STARTING\n"; |
502
|
|
|
|
|
|
|
eval { # try |
503
|
3
|
|
|
|
|
161
|
$self->start_method->( $args ); |
504
|
1
|
|
|
|
|
163
|
1; |
505
|
3
|
50
|
|
|
|
78
|
} or do { # catch |
506
|
|
|
|
|
|
|
# error |
507
|
0
|
|
|
|
|
0
|
print "ERROR: $@\n"; |
508
|
|
|
|
|
|
|
}; |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
} |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
# cleanup |
513
|
3
|
|
|
|
|
146
|
print "EXITED\n"; |
514
|
3
|
|
|
|
|
59
|
$self->stopped(); |
515
|
|
|
|
|
|
|
|
516
|
3
|
|
|
|
|
1774
|
exit; |
517
|
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
=item stop() |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
If the process id is active, send it a kill -HUP. |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
=cut |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
sub stop { |
527
|
10
|
|
|
10
|
1
|
45
|
my ( $self ) = @_; |
528
|
|
|
|
|
|
|
|
529
|
10
|
100
|
|
|
|
57
|
if ( ! $self->is_running() ) { |
530
|
1
|
|
|
|
|
6
|
$self->_debug( "Process not found running" ); |
531
|
1
|
|
|
|
|
1
|
return 1; |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
|
534
|
9
|
|
|
|
|
36
|
my $pid = $self->pid(); |
535
|
|
|
|
|
|
|
|
536
|
9
|
|
|
|
|
76
|
$self->_debug( "Killing process: $pid" ); |
537
|
9
|
|
|
|
|
1639
|
my $status = kill 1 => $pid; |
538
|
|
|
|
|
|
|
|
539
|
9
|
|
|
|
|
49
|
return $status; |
540
|
|
|
|
|
|
|
} |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
=item restart( $data, $sleep ) |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
Calls the stop() method, followed by the start() method, optionally |
545
|
|
|
|
|
|
|
passing some $data to the start() method. |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
This method is not recommended since it doesn't check the status of |
548
|
|
|
|
|
|
|
stop(). Instead, call stop(), wait a bit, and then check that the |
549
|
|
|
|
|
|
|
process has shut down before trying to start it again. |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
WARNING: this method calls sleep to allow a process to shut down |
552
|
|
|
|
|
|
|
before trying to start it again. If sleep is set to 0, the child |
553
|
|
|
|
|
|
|
process won't have time to exit, and thus the start() method will |
554
|
|
|
|
|
|
|
never run. As a result, this method is not recommended for use in a |
555
|
|
|
|
|
|
|
single-threaded cooperative multitasking environments such as POE. |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
=cut |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
sub restart { |
560
|
3
|
|
|
3
|
1
|
936
|
my ( $self, $data, $sleep ) = @_; |
561
|
|
|
|
|
|
|
|
562
|
3
|
|
|
|
|
16
|
$self->stop(); |
563
|
|
|
|
|
|
|
|
564
|
3
|
100
|
|
|
|
10
|
$sleep = $sleep ? $sleep : 1; |
565
|
3
|
|
|
|
|
4000483
|
sleep $sleep; |
566
|
|
|
|
|
|
|
|
567
|
3
|
|
|
|
|
42
|
$self->start( $data ); |
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
=item is_running() |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
Check if a process is running by sending it a 'kill -0' and checking |
574
|
|
|
|
|
|
|
the return status. |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
Before checking the process, rm_zombies() will be called to allow any |
577
|
|
|
|
|
|
|
child processes that have exited to be reaped. See a note at the |
578
|
|
|
|
|
|
|
rm_zombies() method about the leaky abstraction here. |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
If the pid is not active, the stopped() method will also be called to |
581
|
|
|
|
|
|
|
ensure the pid file has been removed. |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
=cut |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
sub is_running { |
586
|
131
|
|
|
131
|
1
|
172024
|
my ( $self, $pid ) = @_; |
587
|
|
|
|
|
|
|
|
588
|
131
|
100
|
|
|
|
758
|
unless ( $pid ) { $pid = $self->pid() } |
|
112
|
|
|
|
|
536
|
|
589
|
|
|
|
|
|
|
|
590
|
131
|
100
|
|
|
|
799
|
return unless $pid; |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
# clean up deceased child processes before checking if processes |
593
|
|
|
|
|
|
|
# are running. |
594
|
64
|
|
|
|
|
513
|
$self->rm_zombies(); |
595
|
|
|
|
|
|
|
|
596
|
64
|
|
|
|
|
691
|
$self->_debug( "CHECKING PID: $pid" ); |
597
|
|
|
|
|
|
|
|
598
|
64
|
100
|
|
|
|
1021
|
if ( kill 0 => $pid ) { |
599
|
22
|
50
|
|
22
|
|
83836
|
if ( $!{EPERM} ) { |
|
22
|
|
|
|
|
28854
|
|
|
22
|
|
|
|
|
28527
|
|
|
50
|
|
|
|
|
1535
|
|
600
|
|
|
|
|
|
|
# if process id isn't owned by us, it is assumed to have |
601
|
|
|
|
|
|
|
# been recycled, i.e. our process died and the process id |
602
|
|
|
|
|
|
|
# was assigned to another process. |
603
|
0
|
|
|
|
|
0
|
$self->_debug( "Process id active but owned by someone else" ); |
604
|
|
|
|
|
|
|
} |
605
|
|
|
|
|
|
|
else { |
606
|
50
|
|
|
|
|
1668
|
$self->_debug( "STILL RUNNING" ); |
607
|
50
|
|
|
|
|
696
|
return $self->daemon_name; |
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
} |
610
|
|
|
|
|
|
|
|
611
|
14
|
|
|
|
|
125
|
$self->_debug( "PROCESS NOT RUNNING" ); |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
# process is not running, ensure the pidfile has been cleaned up |
614
|
14
|
|
|
|
|
59
|
$self->stopped(); |
615
|
|
|
|
|
|
|
|
616
|
14
|
|
|
|
|
105
|
return; |
617
|
|
|
|
|
|
|
} |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
=item rm_zombies() |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
Calls waitpid to clean up any child processes that have exited. |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
waitpid is called with the WNOHANG option so that it will always |
624
|
|
|
|
|
|
|
return instantly to prevent hanging. |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
Normally this is called when the is_running() method is called (to |
627
|
|
|
|
|
|
|
allow child processes to exit before polling if they are still |
628
|
|
|
|
|
|
|
active). If you are using a Proc::Launcher in a long-lived process, |
629
|
|
|
|
|
|
|
after stopping a daemon you should always call is_running() until you |
630
|
|
|
|
|
|
|
get a false response (i.e. the process has successfully stopped). If |
631
|
|
|
|
|
|
|
you do not call is_running() until the process exits, you will create |
632
|
|
|
|
|
|
|
zombies. |
633
|
|
|
|
|
|
|
|
634
|
|
|
|
|
|
|
=cut |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
sub rm_zombies { |
637
|
74
|
|
|
74
|
1
|
1087
|
waitpid(-1, WNOHANG); |
638
|
|
|
|
|
|
|
} |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
=item force_stop() |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
If the process id is active, then send a 'kill -9'. |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
=cut |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
sub force_stop { |
647
|
9
|
|
|
9
|
1
|
962
|
my ( $self ) = @_; |
648
|
|
|
|
|
|
|
|
649
|
9
|
100
|
|
|
|
51
|
if ( ! $self->is_running() ) { |
650
|
3
|
|
|
|
|
28
|
$self->_debug( "Process not found running" ); |
651
|
3
|
|
|
|
|
983
|
return 1; |
652
|
|
|
|
|
|
|
} |
653
|
|
|
|
|
|
|
|
654
|
6
|
|
|
|
|
40
|
$self->_debug( "Process still running, executing with kill -9" ); |
655
|
6
|
|
|
|
|
31
|
my $status = kill 9 => $self->pid(); |
656
|
|
|
|
|
|
|
|
657
|
6
|
|
|
|
|
581
|
return $status; |
658
|
|
|
|
|
|
|
} |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
=item stopped() |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
This method is called when a process has been detected as successfully |
664
|
|
|
|
|
|
|
shut down. The pidfile will be removed if it still exists. |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
=cut |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
sub stopped { |
669
|
17
|
|
|
17
|
1
|
57
|
my ( $self ) = @_; |
670
|
|
|
|
|
|
|
|
671
|
17
|
|
|
|
|
88
|
$self->_debug( "Process exited" ); |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
# remove the pidfile |
674
|
17
|
|
|
|
|
111
|
$self->remove_pidfile(); |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
# remove the named pipe if one was enabled |
677
|
17
|
100
|
|
|
|
216
|
if ( $self->pipe ) { unlink $self->pipe_file } |
|
1
|
|
|
|
|
98
|
|
678
|
|
|
|
|
|
|
} |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
=item pid() |
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
Read and return the pid from the pidfile. |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
The pid is validated to ensure it is a number. If an invalid pid is |
685
|
|
|
|
|
|
|
found, 0 is returned. |
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
=cut |
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
sub pid { |
690
|
176
|
|
|
176
|
1
|
519
|
my ( $self ) = @_; |
691
|
|
|
|
|
|
|
|
692
|
176
|
|
|
|
|
1371
|
my $path = $self->pid_file; |
693
|
|
|
|
|
|
|
|
694
|
176
|
100
|
|
|
|
7196
|
unless ( -r $path ) { |
695
|
92
|
|
|
|
|
547
|
return 0; |
696
|
|
|
|
|
|
|
} |
697
|
|
|
|
|
|
|
|
698
|
84
|
|
|
|
|
896
|
$self->_debug( "READING PID FROM: $path" ); |
699
|
|
|
|
|
|
|
|
700
|
84
|
50
|
|
|
|
6848
|
open(my $fh, "<", $path) |
701
|
|
|
|
|
|
|
or die "Couldn't open $path for reading: $!\n"; |
702
|
|
|
|
|
|
|
|
703
|
84
|
|
|
|
|
2722
|
my $line = <$fh>; |
704
|
|
|
|
|
|
|
|
705
|
84
|
50
|
|
|
|
1609
|
close $fh or die "Error closing file: $!\n"; |
706
|
|
|
|
|
|
|
|
707
|
84
|
100
|
|
|
|
263
|
return 0 unless $line; |
708
|
83
|
|
|
|
|
242
|
chomp $line; |
709
|
83
|
50
|
|
|
|
250
|
return 0 unless $line; |
710
|
|
|
|
|
|
|
|
711
|
83
|
50
|
|
|
|
1311
|
unless ( $line =~ m|^\d+$| ) { |
712
|
0
|
|
|
|
|
0
|
warn "ERROR: PID doesn't look like a number: $line"; |
713
|
0
|
|
|
|
|
0
|
return 0; |
714
|
|
|
|
|
|
|
} |
715
|
|
|
|
|
|
|
|
716
|
83
|
|
|
|
|
911
|
return $line; |
717
|
|
|
|
|
|
|
} |
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
=item write_my_pid() |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
Write the pid to the pid file. |
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
This operation involves checking a couple of times to make sure that |
724
|
|
|
|
|
|
|
no other process is running or trying to start another process at the |
725
|
|
|
|
|
|
|
same time. The pid is actually written to a temporary file and then |
726
|
|
|
|
|
|
|
renamed. Since rename() is an atomic operation on most filesystems, |
727
|
|
|
|
|
|
|
this serves as a basic but effective locking mechanism that doesn't |
728
|
|
|
|
|
|
|
require OS-level locking. This should prevent two processes from both |
729
|
|
|
|
|
|
|
starting a daemon at the same time. |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
=cut |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
sub write_my_pid { |
734
|
5
|
|
|
5
|
1
|
263
|
my ( $self, $pid ) = @_; |
735
|
|
|
|
|
|
|
|
736
|
5
|
50
|
|
|
|
135
|
unless ( $pid ) { $pid = $$ } |
|
0
|
|
|
|
|
0
|
|
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
# try to read the pidfile and see if the pid therein is active |
739
|
5
|
50
|
|
|
|
295
|
return if $self->is_running(); |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
# write the pid to a temporary file |
742
|
5
|
|
|
|
|
172
|
my $path = join ".", $self->pid_file, $pid; |
743
|
5
|
|
|
|
|
327
|
$self->_debug( "WRITING PID TO: $path" ); |
744
|
5
|
50
|
|
|
|
2590
|
open(my $pid_fh, ">", $path) |
745
|
|
|
|
|
|
|
or die "Couldn't open $path for writing: $!\n"; |
746
|
5
|
|
|
|
|
133
|
print $pid_fh $pid; |
747
|
5
|
50
|
|
|
|
504
|
close $pid_fh or die "Error closing file: $!\n"; |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
# if some other process has created a pidfile since we last |
750
|
|
|
|
|
|
|
# checked, then it won and we lost |
751
|
5
|
50
|
|
|
|
179
|
if ( -r $self->pid_file ) { |
752
|
0
|
|
|
|
|
0
|
$self->_debug( "Pidfile already created by another process" ); |
753
|
|
|
|
|
|
|
return |
754
|
0
|
|
|
|
|
0
|
} |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
# atomic operation |
757
|
5
|
50
|
|
|
|
873
|
unless ( rename $path, $self->pid_file ) { |
758
|
0
|
|
|
|
|
0
|
$self->_debug( "Unable to lock pidfile $path for $pid" ); |
759
|
0
|
|
|
|
|
0
|
return; |
760
|
|
|
|
|
|
|
} |
761
|
|
|
|
|
|
|
|
762
|
5
|
|
|
|
|
55
|
$self->_debug( "Successfully renamed pidfile to $path: $pid" ); |
763
|
|
|
|
|
|
|
|
764
|
5
|
|
|
|
|
82
|
return 1; |
765
|
|
|
|
|
|
|
} |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
=item remove_pidfile |
768
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
Remove the pidfile. This should only be done after the process has |
770
|
|
|
|
|
|
|
been verified as shut down. |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
Failure to remove the pidfile is not a fatal error. |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
=cut |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
sub remove_pidfile { |
777
|
18
|
|
|
18
|
1
|
50
|
my ( $self ) = @_; |
778
|
|
|
|
|
|
|
|
779
|
18
|
50
|
|
|
|
816
|
return unless -r $self->pid_file; |
780
|
|
|
|
|
|
|
|
781
|
18
|
|
|
|
|
402
|
$self->_debug( "REMOVING PIDFILE: " . $self->pid_file ); |
782
|
18
|
|
|
|
|
448089
|
unlink $self->pid_file; |
783
|
|
|
|
|
|
|
} |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
=item read_log |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
Return any new log data since the last offset was written. If there |
788
|
|
|
|
|
|
|
was no offset, set the offset to the current end of file. |
789
|
|
|
|
|
|
|
|
790
|
|
|
|
|
|
|
You may want to call this before performing any operation on the |
791
|
|
|
|
|
|
|
daemon in order to set the position to the end of the file. Then |
792
|
|
|
|
|
|
|
perform your operation, wait a moment, and then call read_log() to get |
793
|
|
|
|
|
|
|
any output generated from your command while you waited. |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
=cut |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
sub read_log { |
798
|
4
|
|
|
4
|
1
|
8
|
my ( $self, $subref ) = @_; |
799
|
|
|
|
|
|
|
|
800
|
4
|
|
|
|
|
18
|
my $name = $self->daemon_name; |
801
|
|
|
|
|
|
|
|
802
|
4
|
|
|
|
|
24
|
while ( my $line=$self->file_tail->read ) { |
803
|
0
|
|
|
|
|
0
|
chomp $line; |
804
|
0
|
|
|
|
|
0
|
$subref->( "$name: $line" ); |
805
|
|
|
|
|
|
|
} |
806
|
|
|
|
|
|
|
|
807
|
4
|
|
|
|
|
10290
|
return 1; |
808
|
|
|
|
|
|
|
} |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
=item write_pipe( $string ) |
811
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
Write text to the process's named pipe. The child can then read this |
813
|
|
|
|
|
|
|
data from it's STDIN. |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
Simply returns false if a named pipe was not enabled. |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
=cut |
818
|
|
|
|
|
|
|
|
819
|
|
|
|
|
|
|
sub write_pipe { |
820
|
1
|
|
|
1
|
1
|
6
|
my ( $self, $string ) = @_; |
821
|
|
|
|
|
|
|
|
822
|
1
|
50
|
|
|
|
19
|
return unless $self->pipe; |
823
|
1
|
|
|
|
|
26
|
$self->_debug( "Writing to pipe" ); |
824
|
|
|
|
|
|
|
|
825
|
1
|
50
|
|
|
|
42
|
unless ( -r $self->pipe_file ) { |
826
|
0
|
|
|
|
|
0
|
$self->_debug( "Pipe found but not readable" ); |
827
|
0
|
|
|
|
|
0
|
return; |
828
|
|
|
|
|
|
|
} |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
# remove any trailing whitespace |
831
|
1
|
|
|
|
|
25
|
chomp $string; |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
# blast the string out to the named pipe |
834
|
1
|
50
|
|
|
|
3
|
print { sysopen (my $fh , $self->pipe_file, &POSIX::O_WRONLY) or die "$!\n"; $fh } $string, "\n"; |
|
1
|
|
|
|
|
172
|
|
|
1
|
|
|
|
|
31
|
|
835
|
|
|
|
|
|
|
|
836
|
1
|
|
|
|
|
103
|
return 1; |
837
|
|
|
|
|
|
|
} |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
=item disable() |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
Create the disable flag file unless it already exists. |
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
=cut |
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
sub disable { |
846
|
5
|
|
|
5
|
1
|
18
|
my ( $self ) = @_; |
847
|
|
|
|
|
|
|
|
848
|
5
|
100
|
|
|
|
43
|
if ( $self->is_enabled() ) { |
849
|
4
|
|
|
|
|
26126
|
system( "touch", $self->disable_file ); |
850
|
|
|
|
|
|
|
} |
851
|
|
|
|
|
|
|
|
852
|
5
|
|
|
|
|
233
|
return 1; |
853
|
|
|
|
|
|
|
} |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
=item enable() |
856
|
|
|
|
|
|
|
|
857
|
|
|
|
|
|
|
If the disable flag file exists, remove it. |
858
|
|
|
|
|
|
|
|
859
|
|
|
|
|
|
|
=cut |
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
sub enable { |
862
|
5
|
|
|
5
|
1
|
11
|
my ( $self ) = @_; |
863
|
|
|
|
|
|
|
|
864
|
5
|
100
|
|
|
|
18
|
unless ( $self->is_enabled() ) { |
865
|
4
|
|
|
|
|
397
|
unlink $self->disable_file; |
866
|
|
|
|
|
|
|
} |
867
|
|
|
|
|
|
|
|
868
|
5
|
|
|
|
|
28
|
return 1; |
869
|
|
|
|
|
|
|
} |
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
=item is_enabled() |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
Check if the launcher is enabled. |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
If the disable flag file exists, then the launcher will be considered |
876
|
|
|
|
|
|
|
disabled. |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
=cut |
879
|
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
sub is_enabled { |
881
|
44
|
|
|
44
|
1
|
105
|
my ( $self ) = @_; |
882
|
|
|
|
|
|
|
|
883
|
44
|
100
|
|
|
|
1011
|
return if -r $self->disable_file; |
884
|
|
|
|
|
|
|
|
885
|
33
|
|
|
|
|
163
|
return 1; |
886
|
|
|
|
|
|
|
} |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
# debugging output |
889
|
|
|
|
|
|
|
sub _debug { |
890
|
400
|
|
|
400
|
|
1819802
|
my ( $self, @lines ) = @_; |
891
|
|
|
|
|
|
|
|
892
|
400
|
100
|
|
|
|
2480
|
return unless $self->debug; |
893
|
|
|
|
|
|
|
|
894
|
18
|
|
|
|
|
82
|
for my $line ( @lines ) { |
895
|
18
|
|
|
|
|
87
|
chomp $line; |
896
|
18
|
|
|
|
|
3889
|
print "$line\n"; |
897
|
|
|
|
|
|
|
} |
898
|
|
|
|
|
|
|
} |
899
|
|
|
|
|
|
|
|
900
|
22
|
|
|
22
|
|
172
|
no Mouse; |
|
22
|
|
|
|
|
56
|
|
|
22
|
|
|
|
|
239
|
|
901
|
|
|
|
|
|
|
|
902
|
|
|
|
|
|
|
1; |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
__END__ |