view release on metacpan or  search on metacpan

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

    }

    $self->{AD_wd} = $args->{workdir};
    $self;
}

#--------------------

sub workdir() {shift->{AD_wd}}
sub pidFilename() { shift->{AD_pidfn} }

#--------------------

sub _mkcall($)
{   return $_[1] if ref $_[1] eq 'CODE';
    my ($self, $what) = @_;
    sub { $self->$what(@_) };
}

sub run(@)
{   my ($self, %args) = @_;

    my $wd = $self->workdir;
    if($wd)
    {   -d $wd or mkdir $wd, 0700
            or fault __x"cannot create working directory {dir}", dir => $wd;

        chdir $wd
            or fault __x"cannot change to working directory {dir}", dir => $wd;
    }

    my $bg = exists $args{background} ? $args{background} : 1;
    if($bg)
    {   trace "backgrounding managing daemon";

        my $kid = fork;
        if($kid)
        {   # starting parent is ready to leave
            exit 0;
        }
        elsif(!defined $kid)
        {   fault __x"cannot start the managing daemon";
        }

        dispatcher('list') >= 1
            or error __x"you need to have a dispatcher to send log to";
    }

    my $pidfn = $self->pidFilename;
    if(defined $pidfn)
    {   local *PIDF;
        if(open PIDF, '>', $pidfn)
        {   print PIDF "$PID\n";
            close PIDF;
        }
    }

    my $gid = $self->{AD_gid} || $EGID;
    my $uid = $self->{AD_uid} || $EUID;

    chown $uid,$gid, $wd if $wd;   # don't check success: user may have plan

    if($gid != $EGID)
    {   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+$$);