lib/MooseX/Daemonize.pm

   1 package MooseX::Daemonize;
   2 use strict;    # because Kwalitee is pedantic
   3 use Moose::Role;
   4
   5 use MooseX::Daemonize::Types;
   6
   7 our $VERSION = 0.05;
   8
   9 with qw[
  10     MooseX::Daemonize::Core
  11     MooseX::Daemonize::WithSignalHandling
  12     MooseX::Daemonize::WithPidFile
  13     MooseX::Getopt
  14 ];
  15
  16 has progname => (
  17     isa      => 'Str',
  18     is       => 'ro',
  19     lazy     => 1,
  20     required => 1,
  21     default  => sub {
  22         ( my $name = lc $_[0]->meta->name ) =~ s/::/_/g;
  23         return $name;
  24     },
  25 );
  26
  27 has pidbase => (
  28     isa      => 'Path::Class::Dir',
  29     is       => 'ro',
  30     coerce   => 1,
  31     required => 1,
  32     lazy     => 1,
  33     default  => sub { Path::Class::Dir->new('var', 'run') },
  34 );
  35
  36 has basedir => (
  37     isa      => 'Path::Class::Dir',
  38     is       => 'ro',
  39     coerce   => 1,
  40     required => 1,
  41     lazy     => 1,
  42     default  => sub { Path::Class::Dir->new('/') },
  43 );
  44
  45 has foreground => (
  46     metaclass   => 'Getopt',
  47     cmd_aliases => 'f',
  48     isa         => 'Bool',
  49     is          => 'ro',
  50     default     => sub { 0 },
  51 );
  52
  53 has stop_timeout => (
  54     isa     => 'Int',
  55     is      => 'rw',
  56     default => sub { 2 }
  57 );
  58
  59 sub init_pidfile {
  60     my $self = shift;
  61     my $file = $self->pidbase . '/' . $self->progname . '.pid';
  62     confess "Cannot write to $file" unless (-e $file ? -w $file : -w $self->pidbase);
  63     MooseX::Daemonize::Pid::File->new( file => $file );
  64 }
  65
  66 sub start {
  67     my ($self) = @_;
  68
  69     confess "instance already running" if $self->pidfile->is_running;
  70
  71     $self->daemonize unless $self->foreground;
  72
  73     return unless $self->is_daemon;
  74
  75     $self->pidfile->pid($$);
  76
  77     # Change to basedir
  78     chdir $self->basedir;
  79
  80     $self->pidfile->write;
  81     $self->setup_signals;
  82     return $$;
  83 }
  84
  85 # Make _kill *really* private
  86 my $_kill;
  87
  88 sub stop {
  89     my ( $self, %args ) = @_;
  90     my $pid = $self->pidfile->pid;
  91     $self->$_kill($pid) unless $self->foreground();
  92     $self->pidfile->remove;
  93     return 1 if $args{no_exit};
  94     exit;
  95 }
  96
  97 sub restart {
  98     my ($self) = @_;
  99     $self->stop( no_exit => 1 );
 100     $self->start();
 101 }
 102
 103 sub handle_signal {
 104     my ($self, $signal) = @_;
 105     return $self->handle_sigint if $signal eq 'INT';
 106     return $self->handle_sighup if $signal eq 'HUP';
 107 }
 108
 109 sub handle_sigint { $_[0]->stop; }
 110 sub handle_sighup { $_[0]->restart; }
 111
 112 $_kill = sub {
 113     my ( $self, $pid ) = @_;
 114     return unless $pid;
 115     unless ( CORE::kill 0 => $pid ) {
 116
 117         # warn "$pid already appears dead.";
 118         return;
 119     }
 120
 121     if ( $pid eq $$ ) {
 122
 123         # warn "$pid is us! Can't commit suicide.";
 124         return;
 125     }
 126
 127     my $timeout = $self->stop_timeout;
 128
 129     # kill 0 => $pid returns 0 if the process is dead
 130     # $!{EPERM} could also be true if we cant kill it (permission error)
 131
 132     # Try SIGINT ... 2s ... SIGTERM ... 2s ... SIGKILL ... 3s ... UNDEAD!
 133     for ( [ 2, $timeout ], [15, $timeout], [9, $timeout * 1.5] ) {
 134         my ($signal, $timeout) = @$_;
 135         $timeout = int $timeout;
 136
 137         CORE::kill($signal, $pid);
 138
 139         last unless CORE::kill 0 => $pid or $!{EPERM};
 140
 141         while ($timeout) {
 142             sleep(1);
 143             last unless CORE::kill 0 => $pid or $!{EPERM};
 144             $timeout--;
 145         }
 146     }
 147
 148     return unless ( CORE::kill 0 => $pid or $!{EPERM} );
 149
 150     # IF it is still running
 151     Carp::carp "$pid doesn't seem to want to die.";     # AHH EVIL DEAD!
 152 };
 153
 154 1;
 155 __END__
 156
 157 =head1 NAME
 158
 159 MooseX::Daemonize - provides a Role that daemonizes your Moose based
 160 application.
 161
 162 =head1 VERSION
 163
 164 This document describes MooseX::Daemonize version 0.04
 165
 166 =head1 SYNOPSIS
 167
 168     package FileMaker;
 169     use Moose;
 170     with qw(MooseX::Daemonize);
 171
 172     sub create_file {
 173         my ( $self, $file ) = @_;
 174         open( FILE, ">$file" ) || die;
 175         close(FILE);
 176     }
 177
 178     no Moose;
 179
 180     # then in the main package ...
 181
 182     my $daemon = FileMaker->new();
 183     $daemon->start();
 184     $daemon->create_file($file);
 185     $daemon->stop();
 186
 187 =head1 DESCRIPTION
 188
 189 Often you want to write a persistant daemon that has a pid file, and responds
 190 appropriately to Signals.  This module helps provide the basic infrastructure
 191 to do that.
 192
 193 =head1 ATTRIBUTES
 194
 195 =over
 196
 197 =item progname Path::Class::Dir | Str
 198
 199 The name of our daemon, defaults to $self->meta->name =~ s/::/_/;
 200
 201 =item pidbase Path::Class::Dir | Str
 202
 203 The base for our bid, defaults to /var/run/$progname
 204
 205 =item pidfile MooseX::Daemonize::Pid::File | Str
 206
 207 The file we store our PID in, defaults to /var/run/$progname
 208
 209 =item foreground Bool
 210
 211 If true, the process won't background. Useful for debugging. This option can
 212 be set via Getopt's -f.
 213
 214 =item is_daemon Bool
 215
 216 If true, the process is the backgrounded process. This is useful for example
 217 in an after 'start' => sub { } block
 218
 219 =item stop_timeout
 220
 221 Number of seconds to wait for the process to stop, before trying harder to kill
 222 it. Defaults to 2 seconds
 223
 224 =back
 225
 226 =head1 METHODS
 227
 228 =over
 229
 230 =item start()
 231
 232 Setup a pidfile, fork, then setup the signal handlers.
 233
 234 =item stop()
 235
 236 Stop the process matching the pidfile, and unlinks the pidfile.
 237
 238 =item restart()
 239
 240 Litterally
 241
 242     $self->stop();
 243     $self->start();
 244
 245 =item daemonize()
 246
 247 Calls C<Proc::Daemon::Init> to daemonize this process.
 248
 249 =item setup_signals()
 250
 251 Setup the signal handlers, by default it only sets up handlers for SIGINT and SIGHUP
 252
 253 =item handle_sigint()
 254
 255 Handle a INT signal, by default calls C<$self->stop()>
 256
 257 =item handle_sighup()
 258
 259 Handle a HUP signal. By default calls C<$self->restart()>
 260
 261 =item meta()
 262
 263 The C<meta()> method from L<Class::MOP::Class>
 264
 265 =back
 266
 267 =head1 DEPENDENCIES
 268
 269 =for author to fill in:
 270     A list of all the other modules that this module relies upon,
 271     including any restrictions on versions, and an indication whether
 272     the module is part of the standard Perl distribution, part of the
 273     module's distribution, or must be installed separately. ]
 274
 275 Obviously L<Moose>, and L<Proc::Daemon>
 276
 277 =head1 INCOMPATIBILITIES
 278
 279 =for author to fill in:
 280     A list of any modules that this module cannot be used in conjunction
 281     with. This may be due to name conflicts in the interface, or
 282     competition for system or program resources, or due to internal
 283     limitations of Perl (for example, many modules that use source code
 284     filters are mutually incompatible).
 285
 286 None reported.
 287
 288
 289 =head1 BUGS AND LIMITATIONS
 290
 291 =for author to fill in:
 292     A list of known problems with the module, together with some
 293     indication Whether they are likely to be fixed in an upcoming
 294     release. Also a list of restrictions on the features the module
 295     does provide: data types that cannot be handled, performance issues
 296     and the circumstances in which they may arise, practical
 297     limitations on the size of data sets, special cases that are not
 298     (yet) handled, etc.
 299
 300 No bugs have been reported.
 301
 302 Please report any bugs or feature requests to
 303 C<bug-acme-dahut-call@rt.cpan.org>, or through the web interface at
 304 L<http://rt.cpan.org>.
 305
 306 =head1 SEE ALSO
 307
 308 L<Proc::Daemon>, L<Daemon::Generic>, L<MooseX::Getopt>
 309
 310 =head1 AUTHOR
 311
 312 Chris Prather  C<< <perigrin@cpan.org> >>
 313
 314 =head1 THANKS
 315
 316 Mike Boyko, Matt S. Trout, Stevan Little, Brandon Black, Ash Berlin and the
 317 #moose denzians
 318
 319 Some bug fixes sponsored by Takkle Inc.
 320
 321 =head1 LICENCE AND COPYRIGHT
 322
 323 Copyright (c) 2007, Chris Prather C<< <perigrin@cpan.org> >>. All rights
 324 reserved.
 325
 326 This module is free software; you can redistribute it and/or
 327 modify it under the same terms as Perl itself. See L<perlartistic>.
 328
 329
 330 =head1 DISCLAIMER OF WARRANTY
 331
 332 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
 333 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
 334 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
 335 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
 336 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 337 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
 338 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
 339 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
 340 NECESSARY SERVICING, REPAIR, OR CORRECTION.
 341
 342 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
 343 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
 344 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
 345 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
 346 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
 347 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
 348 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
 349 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
 350 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
 351 SUCH DAMAGES.