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