view release on metacpan or  search on metacpan

lib/Daemon/Device.pm  view on Meta::CPAN

package Daemon::Device;
# ABSTRACT: Forking daemon device construct

use 5.012;
use strict;
use warnings;

use Daemon::Control;
use Carp qw( croak carp );
use POSIX ":sys_wait_h";
use IO::Pipe;

our $VERSION = '1.11'; # VERSION

sub new {
    my $class = shift;
    croak 'new() called with uneven number of parameters' if ( @_ % 2 );

    my $self = bless( {@_}, $class );

    $self->{ '_' . $_ } = delete $self->{$_} for ( qw(
        daemon
        spawn
        replace_children
        parent_hup_to_child
        parent
        child
        on_startup
        on_shutdown
        on_spawn
        on_parent_hup
        on_child_hup
        on_parent_death
        on_child_death
        on_replace_child
        on_message
        data
    ) );

    if ( not $self->{_daemon}{user} ) {
        my $user = getlogin || getpwuid($<) || 'root';
        $self->{_daemon}{user} ||= $user;
    }
    $self->{_daemon}{group} ||= ( getgrgid( (getpwnam( $self->{_daemon}{user} ) )[3] ) )[0];

    croak 'new() called without "daemon" parameter as a hashref' unless ( ref( $self->{_daemon} ) eq 'HASH' );
    for ( qw( program program_args ) ) {
        croak qq{new() called with "daemon" hashref containing "$_" key} if ( $self->{_daemon}{$_} );
    }
    for ( qw(
        parent child
        on_startup on_shutdown on_spawn on_parent_hup on_child_hup
        on_parent_death on_child_death on_replace_child
    ) ) {
        croak qq{new() called with "$_" parameter not a coderef}
            if ( exists $self->{$_} and ref( $self->{$_} ) ne 'CODE' );
    }

    $self->{_daemon}{program}      = \&_parent;
    $self->{_daemon}{program_args} = [$self];

    $self->{_spawn}               ||= 1;
    $self->{_replace_children}    //= 1;
    $self->{_parent_hup_to_child} //= 1;
    $self->{_data}                //= {};

    $self->{_children} = [];
    $self->{_daemon}   = Daemon::Control->new( %{ $self->{_daemon} } );

    return $self;
}

sub run {
    my ($self) = @_;
    return $self->{_daemon}->run;
}

sub daemon {
    my ($self) = @_;
    return $self->{_daemon};
}

sub _parent {
    my ( $daemon, $self ) = @_;

    $self->{_ppid} = $$;

    $SIG{'HUP'} = sub {
        $self->{_on_parent_hup}->($self) if ( $self->{_on_parent_hup} );
        if ( $self->{_parent_hup_to_child} ) {
            kill( 'HUP', $_->{pid} ) for ( @{ $self->{_children} } );
        }
    };

    my $terminate = sub {
        $self->{_on_parent_death}->($self) if ( $self->{_on_parent_death} );
        kill( 'TERM', $_->{pid} ) for ( @{ $self->{_children} } );
        $self->{_on_shutdown}->($self) if ( $self->{_on_shutdown} );
        exit;
    };
    $SIG{$_} = $terminate for ( qw( TERM INT ABRT QUIT ) );