view release on metacpan or  search on metacpan

lib/App/Base/Daemon/Supervisor.pm  view on Meta::CPAN

            exit 0;
        }
        Time::HiRes::usleep(1_000_000 * $self->delay_before_respawn);
    }

    # for critic
    return;
}

# this initializes SIGUSR2 handler to perform hot reload
sub _set_hot_reload_handler {
    my $self = shift;

    return unless $self->can_do_hot_reload;
    my $upgrading;

    ## no critic (RequireLocalizedPunctuationVars)
    $SIG{USR2} = sub {
        return unless $ENV{APP_BASE_DAEMON_PID} == $$;
        if ($upgrading) {
            warn("Received USR2, but hot reload is already in progress") unless $self->getOption('no-warn');
            return;
        }
        warn("Received USR2, initiating hot reload") unless $self->getOption('no-warn');
        my $pid;
        unless (defined($pid = fork)) {
            warn("Could not fork, cancelling reload") unless $self->getOption('no-warn');
        }
        unless ($pid) {
            exec($ENV{APP_BASE_SCRIPT_EXE}, @{$self->{orig_args}})
                or $self->error("Couldn't exec: $!");
        }
        $upgrading = time;
        if ($SIG{ALRM}) {
            warn("ALRM handler is already defined!") unless $self->getOption('no-warn');
        }
        $SIG{ALRM} = sub {
            warn("Hot reloading timed out, cancelling") unless $self->getOption('no-warn');
            kill KILL => $pid;
            undef $upgrading;
        };
        alarm 60;
    };
    {
        my $usr2 = POSIX::SigSet->new(POSIX::SIGUSR2());
        my $old  = POSIX::SigSet->new();
        POSIX::sigprocmask(POSIX::SIG_UNBLOCK(), $usr2, $old);
    }

    return;
}

my $pid;

# kill the old daemon and lock pid file
sub _control_takeover {
    my $self = shift;

    ## no critic (RequireLocalizedPunctuationVars)

    # if it is first generation, when pid file should be already locked in App::Base::Daemon
    if ($ENV{APP_BASE_DAEMON_GEN} > 1 and $ENV{APP_BASE_DAEMON_PID} != $$) {
        kill QUIT => $ENV{APP_BASE_DAEMON_PID};
        if ($self->getOption('no-pid-file')) {

            # we don't have pid file, so let's just poke it to death
            my $attempts = 14;
            while (kill(($attempts == 1 ? 'KILL' : 'ZERO') => $ENV{APP_BASE_DAEMON_PID})
                and $attempts--)
            {
                Time::HiRes::usleep(500_000);
            }
        } else {
            local $SIG{ALRM} = sub {
                warn("Couldn't lock the file. Sending KILL to previous generation process") unless $self->getOption('no-warn');
            };
            alarm 5;

            # We may fail because two reasons:
            # a) previous process didn't exit and still holds the lock
            # b) new process was started and locked pid
            $pid = eval { File::Flock::Tiny->lock($self->pid_file) };
            unless ($pid) {

                # So let's try killing old process, if after that locking still will fail
                # then probably it is the case b) and we should exit
                kill KILL => $ENV{APP_BASE_DAEMON_PID};
                $SIG{ALRM} = sub { $self->error("Still couldn't lock pid file, aborting") };
                alarm 5;
                $pid = File::Flock::Tiny->lock($self->pid_file);
            }
            alarm 0;
            $pid->write_pid;
        }
    }
    $ENV{APP_BASE_DAEMON_PID} = $$;
    return;
}

=head2 $self->handle_shutdown

See L<App::Base::Daemon>

=cut

sub handle_shutdown {
    my $self = shift;
    if ($self->is_supervisor) {
        kill TERM => $self->_child_pid if $self->_child_pid;
    } else {
        $self->supervised_shutdown;
    }

    return;
}

=head2 DEMOLISH

=cut

sub DEMOLISH {
    my $self = shift;
    shutdown $self->supervisor_pipe, 2 if $self->supervisor_pipe;
    return;
}

no Moose::Role;
1;

__END__

=head1 LICENSE AND COPYRIGHT

Copyright (C) 2010-2014 Binary.com

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.