view release on metacpan or  search on metacpan

lib/Proc/Daemontools/Service.pm  view on Meta::CPAN

use warnings;
use strict;
use Config;

my (%SIGNUM, %SIGMETH);
BEGIN {
  my $i = 0;
  for my $name (split ' ', $Config{sig_name}) {
    $SIGNUM{$name} = $i++;
  }

  %SIGMETH = (
    INT  => 'svc_interrupt',
    HUP  => 'svc_hangup',
    TERM => 'svc_terminate',
    ALRM => 'svc_alarm',
  );
}

=head1 NAME

Proc::Daemontools::Service - services that play nicely with daemontools

=head1 VERSION

 0.02

=cut

our $VERSION = '0.02';

=head1 SYNOPSIS

  package Foo::Service;
  use base qw(Proc::Daemontools::Service);

  sub svc_up { ... }

  # In other code...

  my $serv = Foo::Service->new;
  $serv->run;

=head1 DESCRIPTION

See the daemontools page, at
L<http://cr.yp.to/daemontools.html>, and particularly the
svc page, at L<http://cr.yp.to/daemontools/svc.html>.

=head1 METHODS

=head2 C<< new >>

Takes no arguments (yet).

=cut

sub new {
  my $class = shift;
  die "no arguments to new" if @_;
  return bless {} => $class;
}

=head2 C<< run >>

Install signal handlers and call C<< svc_run >>, which
may continue indefinitely.

If C<< svc_run >> ever finishes, calls C<< exit >>.

=cut

sub run {
  my $self = shift;
  $self->install_handlers;
  $self->svc_run;
  $self->exit(0);
}

=head2 C<< exit >>

  $serv->exit($exit_status);

Exit, calling C<< svc_exit >> first if it exists.  Default
signal handlers call this.

=cut

sub exit {
  my $self = shift;
  if ($self->can('svc_exit')) {
    $self->svc_exit;
  }
  exit(shift);
}

=head2 C<< install_handlers >>

Install signal handlers to queue signals for processing by
C<< svc_* >> methods, below.

NOTE: signal handlers are global.  This means that two
instances of Proc::Daemontools::Service will fight with each
other.  Don't do that.

=cut

sub install_handlers {
  my $self = shift;
  require sigtrap;
  my @args;
  for my $sig (qw(HUP INT TERM ALRM)) {
    push @args, handler => sub { $self->_handle_signal($sig) } => $sig;
  }
  sigtrap->import(@args);
}

sub _handle_signal {
  my ($self, $signame) = @_;
  my $arg = {
    signame => $signame,