view release on metacpan or  search on metacpan

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

    {   if($] > 5.015007)
        {   setgid $gid or fault __x"cannot change to group {gid}", gid => $gid;
        }
        else   # in old versions of Perl, the uid and gid gets cached
        {   eval { $EGID = $gid };
            $@ and error __x"cannot switch to group {gid}: {err}"
               , gid => $gid, err => $@;
        }
    }

    if($uid != $EUID)
    {   if($] > 5.015007)
        {   setuid $uid or fault __x"cannot change to user {uid}", uid => $uid;
        }
        else
        {   eval { $EUID = $uid };
            $@ and error __x"cannot switch to user {uid}: {err}"
               , uid => $uid, err => $@;
        }
    }

    setsid;

    my $child_task  = $self->_mkcall($args{child_task});
    my $own_task    = $self->_mkcall($args{run_task});

    $child_task || $own_task
        or panic __x"you have to run with either child_task or run_task";

    $child_task && $own_task
        or panic __x"run with only one of child_task and run_task";

    if($bg)
    {   # no standard die and warn output anymore (Log::Report)
        dispatcher close => 'default';

        # to devnull to avoid write errors in third party modules
        open STDIN,  '<', File::Spec->devnull;
        open STDOUT, '>', File::Spec->devnull;
        open STDERR, '>', File::Spec->devnull;
    }

    if($child_task)
         { $self->_run_with_childs($child_task, %args) }
    else { $self->_run_without_childs($own_task, %args) }
}

sub _run_with_childs($%) {
    my ($self, $child_task, %args) = @_;
    my $reconfig    = $self->_mkcall($args{reconfig}    || 'reconfigDaemon');
    my $kill_childs = $self->_mkcall($args{kill_childs} || 'killChilds');
    my $child_died  = $self->_mkcall($args{child_died}  || 'childDied');
    my $max_childs  = $args{max_childs}  || 10;

    my $run_child   = sub
      { # re-seed the random number sequence per process
        srand(time+$$);

        # unhandled errors are to be treated seriously.
        my $rc = try { $child_task->(@_) };
        if(my $e = $@->wasFatal) { $e->throw(reason => 'ALERT'); $rc = 1 }
        $rc;
      };

    $SIG{CHLD} = sub { $child_died->($max_childs, $run_child) };
    $SIG{HUP}  = sub
      { notice "daemon received signal HUP";
        $reconfig->(keys %childs);
        $child_died->($max_childs, $run_child);
      };

    $SIG{TERM} = $SIG{INT} = sub
      { my $signal = shift;
        notice "daemon terminated by signal $signal";

        $SIG{TERM} = $SIG{CHLD} = 'IGNORE';
        $max_childs = 0;
        $kill_childs->(keys %childs);
        sleep 2;         # give childs some time to stop
        kill TERM => 0;  # terminate the whole process group

        my $pidfn = $self->pidFilename;
        unlink $pidfn if $pidfn;

        my $intrnr = $signal eq 'INT' ? 2 : 9;
        exit $intrnr+128;
      };

    notice __x"daemon started; proc={proc} uid={uid} gid={gid} childs={max}"
      , proc => $PID, uid => $EUID, gid => $EGID, max => $max_childs;

    $child_died->($max_childs, $run_child);

    # child manager will never die
    sleep 60 while 1;
}

sub _run_without_childs($%) {
    my ($self, $run_task, %args) = @_;
    my $reconfig    = $self->_mkcall($args{reconfig}    || 'reconfigDaemon');

    # unhandled errors are to be treated seriously.
    my $rc = try { $run_task->(@_) };
    if(my $e = $@->wasFatal) { $e->throw(reason => 'ALERT'); $rc = 1 }

    $SIG{HUP}  = sub
      { notice "daemon received signal HUP";
        $reconfig->(keys %childs);
      };

    $SIG{TERM} = $SIG{INT} = sub
      { my $signal = shift;
        notice "daemon terminated by signal $signal";

        my $pidfn = $self->pidFilename;
        unlink $pidfn if $pidfn;

        my $intrnr = $signal eq 'INT' ? 2 : 9;
        exit $intrnr+128;
      };

    notice __x"daemon started; proc={proc} uid={uid} gid={gid}"
      , proc => $PID, uid => $EUID, gid => $EGID;

    $run_task->();
}

sub reconfigDaemon(@)
{   my ($self, @childs) = @_;
    notice "HUP: reconfigure deamon not implemented";
}

sub killChilds(@)
{   my ($self, @childs) = @_;
    @childs or return;

    notice "killing ".@childs." children";
    kill TERM => @childs;
}

# standard implementation for starting new childs.
sub childDied($$)
{   my ($self, $max_childs, $run_child) = @_;

    # Clean-up zombies

  ZOMBIE:
    while(1)
    {   my $kid = waitpid -1, WNOHANG;
        last ZOMBIE if $kid <= 0;

        if($? != 0)
        {   my $err = WIFEXITED($?) ? "errno ".WEXITSTATUS($?) : "sig $?";
            notice "$kid process terminated with $err";
            # when children start to die, do not respawn too fast,
            # because usually this means serious troubles with the
            # server (like database) or implementation.
            sleep ERROR_RECOVERY_SLEEP;
        }

        delete $childs{$kid};
    }

    # Start enough childs