File Coverage

blib/lib/Paranoid/Process.pm

Criterion	Covered	Total	%
statement	170	276	61.5
branch	38	88	43.1
condition	22	36	61.1
subroutine	27	34	79.4
pod	15	15	100.0
total	272	449	60.5

# Paranoid::Process -- Process management support for paranoid programs
#
# $Id: lib/Paranoid/Process.pm, 2.09 2021/12/28 15:46:49 acorliss Exp $
#
# This software is free software.  Similar to Perl, you can redistribute it
# and/or modify it under the terms of either:
#
#   a)     the GNU General Public License
#           as published by the
#          Free Software Foundation ; either version 1
#          , or any later version
#          , or
#   b)     the Artistic License 2.0
#          ,
#
# subject to the following additional term:  No trademark rights to
# "Paranoid" have been or are conveyed under any of the above licenses.
# However, "Paranoid" may be used fairly to describe this unmodified
# software, in good faith, but not as a trademark.
#
# (c) 2005 - 2020, Arthur Corliss ([e-mail])
# (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com)
#
#####################################################################

#####################################################################
#
# Environment definitions
#
#####################################################################

package Paranoid::Process;

use 5.008;

use strict;
use warnings;
use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
use base qw(Exporter);
use Paranoid;
use Paranoid::Debug qw(:all);
use POSIX qw(getuid setuid setgid WNOHANG setsid);
use Carp;

($VERSION) = ( q$Revision: 2.09 $ =~ /(\d+(?:\.\d+)+)/sm );

@EXPORT    = qw(switchUser daemonize);
@EXPORT_OK = (
    @EXPORT, qw(MAXCHILDREN childrenCount installChldHandler
        sigchld pfork pcommFork ptranslateUser ptranslateGroup pcapture
        installSIGH uninstallSIGH installSIGD uninstallSIGD
        ) );
%EXPORT_TAGS = (
    all   => [@EXPORT_OK],
    misc  => [qw(pcapture)],
    pfork => [
        qw(MAXCHILDREN childrenCount installChldHandler
            sigchld pfork pcommFork daemonize)
        ],
    signal => [qw(installSIGH uninstallSIGH installSIGD uninstallSIGD)],
    user   => [qw(switchUser ptranslateUser ptranslateGroup)],
    );

#####################################################################
#
# Module code follows
#
#####################################################################

{
    my %signals = ( map { $_ => [] } keys %SIG );
    my %original = %SIG;

    sub _sigHandler {

        # Purpose:  Runs all code refs assigned to the signal
        # Returns:  Boolean
        # Usage:    _sigHandler($signal);

        my ( $signal, @sargs ) = @_;
        my $sref;

        local $SIG{$signal} = 'IGNORE';
        foreach $sref ( @{ $signals{$signal} } ) {
            &$sref( $signal, @sargs );
        }

        return 1;
    }

    sub installSIGD {

        # Purpose:  Installs dispatcher for sig handlers that have code refs
        #           assigned
        # Returns:  Boolean
        # Usage:    $rv = installSIGD();

        my $sig;

        pdebug( 'entering', PDLEVEL1 );
        pIn();

        foreach $sig ( keys %signals ) {
            $SIG{$sig} = \&_sigHandler if scalar @{ $signals{$sig} };
        }

        pOut();
        pdebug( 'leaving w/rv: 1', PDLEVEL1 );

        return 1;
    }

    sub uninstallSIGD {

        # Purpose:  Uninstalls the dispatcher
        # Returns:  Boolean
        # Usage:    $rv = uninstallSIGD();

        pdebug( 'entering', PDLEVEL1 );
        pIn();

        foreach ( keys %original ) {
            $SIG{$_} = $original{$_}
                if defined $SIG{$_}
                    and $SIG{$_} eq \&_sigHandler;
        }

        pOut();
        pdebug( 'leaving w/rv: 1', PDLEVEL1 );

        return 1;
    }

    sub installSIGH ($\&) {

        # Purpose:  Assigns a code ref to a signal array
        # Returns:  Boolean
        # Usage:    $rv = installSIGH($signal, $sref);

        my ( $signal, $sref ) = @_;
        my $rv = 1;

        pdebug( 'entering w/%s, %s', PDLEVEL1, $signal, $sref );
        pIn();

        if ( exists $signals{$signal} ) {
            if ( grep { $_ eq $sref } @{ $signals{$signal} } ) {
                pdebug( '%s handler already installed', PDLEVEL2, $signal );
            } else {
                push @{ $signals{$signal} }, $sref;
                pdebug( '%s handler installed', PDLEVEL2, $signal );
            }
        } else {
            pdebug( 'unknown signal: %s', PDLEVEL1, $signal );
            $rv = 0;
        }

        pOut();
        pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );

        return $rv;
    }

    sub uninstallSIGH ($\&) {

        # Purpose:  Removes a code ref for a signal array
        # Returns:  Boolean
        # Usage:    $rv = uninstallSIGH($signal, $sref);

        my ( $signal, $sref ) = @_;
        my $rv = 1;
        my ( $sigh, $i );

        pdebug( 'entering w/%s, %s', PDLEVEL1, $signal, $sref );
        pIn();

        if ( exists $signals{$signal} ) {
            if ( grep { $_ eq $sref } @{ $signals{$signal} } ) {
                $i = 0;
                foreach $sigh ( @{ $signals{$signal} } ) {
                    if ( $sigh eq $sref ) {
                        splice @{ $signals{$signal} }, $i, 1;
                        last;
                    }
                    $i++;
                }
                pdebug( '%s handler removed', PDLEVEL2, $signal );
            } else {
                pdebug( 'no %s handler to remove', PDLEVEL2, $signal );
            }
        } else {
            pdebug( 'unknown signal: %s', PDLEVEL1, $signal );
            $rv = 0;
        }

        pOut();
        pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );

        return $rv;
    }
}

{
    my $maxChildren = 0;
    my $numChildren = 0;
    my @forkedPIDs  = ();
    my $chldRef     = undef;

    sub MAXCHILDREN : lvalue {

        # Purpose:  Gets/sets $maxChildren
        # Returns:  $maxChildren
        # Usage:    $max = MAXCHILDREN;
        # Usage:    MAXCHILDREN = 20;

        $maxChildren;
    }
    sub childrenCount { return $numChildren }
    sub _incrChildren { $numChildren++ }
    sub _decrChildren { $numChildren-- }

    sub _resetChildren {
        @forkedPIDs  = ();
        $numChildren = 0;
    }

    sub installChldHandler (\&) {

        # Purpose:  Installs a code reference to execute whenever a child
        #           exits
        # Returns:  True (1)
        # Usage:    installChldHandler(&foo);

        $chldRef = shift;

        return 1;
    }
    sub _chldHandler { return $chldRef }

    sub _addPID { push @forkedPIDs, shift }

    sub _grepPID {
        my $pid = shift;
        return scalar grep { $_ == $pid } @forkedPIDs;
    }

    sub _delPID {
        my $pid = shift;
        @forkedPIDs = grep { $_ != $pid } @forkedPIDs;
        return 1;
    }
}

sub sigchld {

    # Purpose:  Default signal handler for SIGCHLD
    # Returns:  True (1)
    # Usage:    $SIG{CHLD} = \&sigchld;

    my ($pid);
    my $sref = _chldHandler();

    # Remove the signal handler so we're not preempted
    local $SIG{CHLD} = sub {1};

    # Process children exit values
    do {
        $pid = waitpid -1, WNOHANG;
        if ( $pid > 0 and _grepPID($pid) ) {
            _decrChildren();
            _delPID($pid);
            pdebug( 'child %d reaped w/rv: %s', PDLEVEL1, $pid, $? );
            pdebug( 'children remaining: %s', PDLEVEL1, childrenCount() );

            # Call the user's sig handler if defined
            &$sref( $pid, $? ) if defined $sref;
        }
    } until $pid < 1;

    return 1;
}

sub daemonize {

    # Purpose:  Daemonizes process and disassociates with the terminal
    # Returns:  True unless there are errors.
    # Usage:    daemonize();

    my ( $rv, $pid );

    pdebug( 'entering', PDLEVEL1 );
    pIn();

    $pid = fork;

    # Exit if we're the parent process
    exit 0 if $pid;

    if ( defined $pid ) {

        # Fork was successful, close parent file descriptors
        $rv = open( STDIN, '/dev/null' ) and open( STDOUT, '>/dev/null' );

        # Create a new process group
        unless ($rv) {
            setsid();
            $rv = open STDERR, '>&STDOUT';
            die "Can't dup stdout: $!" unless $rv;
            chdir '/';
        }

    } else {
        Paranoid::ERROR =
            pdebug( 'Failed to daemonize process: %s', PDLEVEL1, $! );
        $rv = 0;
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );

    return $rv;
}

sub pfork {

    # Purpose:  Replacement for Perl's fork function.  Blocks until a child
    #           exists if MAXCHILDREN is exceeded.
    # Returns:  Return value of children handler if installed, otherwise
    #           undef.
    # Usage:    $rv = pfork();

    my $max = MAXCHILDREN();
    my $rv;

    pdebug( 'entering', PDLEVEL1 );
    pIn();

    # Check children limits and wait, if necessary
    if ($max) {
        while ( $max <= childrenCount() ) { sleep 1 }
    }

    # Fork and return
    $rv = fork;
    if ( defined $rv ) {
        if ( $rv > 0 ) {
            _incrChildren();
            _addPID($rv);
        } else {
            _resetChildren();
        }
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );

    return $rv;
}

sub pcommFork (\$\$) {

    # Purpose:  Creates pipes for bi-directional communiation, then calls
    #           pfork()
    # Returns:  Return value of children handler if installed, otherwise
    #           undef.
    # Usage:    $rv = pcommFork($procr, $procw);

    my ( $procr, $procw ) = @_;
    my ( $tp, $fp, $tc, $fc, $sfd, $rv );

    pdebug( 'entering', PDLEVEL1 );
    pIn();

    if ( pipe( $fc, $tp ) and pipe( $fp, $tc ) ) {
        $sfd = select $tc;
        $|   = 1;
        select $tp;
        $| = 1;
        select $sfd;

        $rv = pfork();
        if ( defined $rv ) {
            if ($rv) {
                close $tp;
                close $fp;
                $$procw = $tc;
                $$procr = $fc;
            } else {
                close $tc;
                close $fc;
                $$procw = $tp;
                $$procr = $fp;
            }
        } else {
            $$procr = undef;
            $$procw = undef;
            close $tp;
            close $fp;
            close $tc;
            close $fc;
        }
    } else {
        pdebug( 'failed to create pipes: %s', PDLEVEL1, $! );
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );

    return $rv;
}

sub ptranslateUser {

    # Purpose:  Translates a string account name into the UID
    # Returns:  UID if found, undef if not
    # Usage:    $uid = ptranslateUser($user);

    my $user = shift;
    my ( $uuid, @pwentry, $rv );

    pdebug( 'entering w/(%s)', PDLEVEL1, $user );
    pIn();

    if ( defined $user and length $user ) {

        setpwent;
        do {
            @pwentry = getpwent;
            $uuid = $pwentry[2] if @pwentry && $user eq $pwentry[0];
        } until defined $uuid || !@pwentry;
        endpwent;
        $rv = $uuid if defined $uuid;
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );

    return $rv;
}

sub ptranslateGroup {

    # Purpose:  Translates a string group name into the UID
    # Returns:  GID if found, undef if not
    # Usage:    $gid = ptranslateGroup($group);

    my $group = shift;
    my ( $ugid, @pwentry, $rv );

    pdebug( 'entering w/(%s)', PDLEVEL1, $group );
    pIn();

    if ( defined $group and length $group ) {

        setgrent;
        do {
            @pwentry = getgrent;
            $ugid = $pwentry[2] if @pwentry && $group eq $pwentry[0];
        } until defined $ugid || !@pwentry;
        endgrent;
        $rv = $ugid if defined $ugid;
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );

    return $rv;
}

sub switchUser {

    # Purpose:  Switches to the user/group specified
    # Returns:  True (1) if successful, False (0) if not
    # Usage:    $rv = swithUser($user);
    # Usage:    $rv = swithUser($user, $group);

    my $user  = shift;
    my $group = shift;
    my $rv    = 1;
    my ( @pwentry, $duid, $dgid );

    # Validate arguments
    croak 'Mandatory argument of either user or group must be passed'
        unless defined $user || defined $group;

    pdebug( 'entering w/(%s)(%s)', PDLEVEL1, $user, $group );
    pIn();

    # First switch the group
    if ( defined $group ) {

        # Look up named group
        unless ( $group =~ /^\d+$/s ) {
            $dgid = ptranslateGroup($group);
            unless ( defined $dgid ) {
                Paranoid::ERROR = pdebug( 'couldn\'t identify group (%s)',
                    PDLEVEL1, $group );
                $rv = 0;
            }
        }

        # Switch to group
        if ($rv) {
            pdebug( 'switching to GID %s', PDLEVEL2, $dgid );
            unless ( setgid($dgid) ) {
                Paranoid::ERROR =
                    pdebug( 'couldn\'t switch to group (%s): %s',
                    PDLEVEL1, $group, $! );
                $rv = 0;
            }
        }
    }

    # Second, switch the user
    if ( $rv && defined $user ) {

        # Look up named user
        unless ( $user =~ /^\d+$/s ) {
            $duid = ptranslateUser($user);
            unless ( defined $duid ) {
                Paranoid::ERROR =
                    pdebug( 'couldn\'t identify user (%s)', PDLEVEL1, $user );
                $rv = 0;
            }
        }

        # Switch to user
        if ($rv) {
            pdebug( 'switching to UID %s', PDLEVEL2, $duid );
            unless ( setuid($duid) ) {
                Paranoid::ERROR = pdebug( 'couldn\'t switch to user (%s): %s',
                    PDLEVEL1, $user, $! );
                $rv = 0;
            }
        }
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );

    return $rv;
}

sub pcapture ($\$\$) {

    # Purpose:  Captures the output and exit code of the specified shell
    #           command.  Output incorporates STDERR via redirection.
    # Returns:  True (1) if command exits cleanly, False (0) otherwise
    # Usage:    $rv = pcapture($cmd, $crv, $out);

    my $cmd  = shift;
    my $cref = shift;
    my $oref = shift;
    my $rv   = -1;
    my ( $sigchld, $cored, $signal );

    pdebug( 'entering w/(%s)(%s)(%s)', PDLEVEL1, $cmd, $cref, $oref );
    pIn();

    if ( defined $cmd ) {

        # Massage the command string
        $cmd = "( $cmd ) 2>&1";

        # Backup SIGCHLD handler and set it to something safe
        if ( defined $SIG{CHLD} ) {
            $sigchld = $SIG{CHLD};
            $SIG{CHLD} = sub {1};
        }

        # Execute and snarf the output
        pdebug( 'executing command', PDLEVEL2 );
        $$oref  = `$cmd`;
        $$cref  = $?;
        $cored  = $$cref & 128;
        $signal = $$cref & 127;
        pdebug( 'command exited with raw rv: %s', PDLEVEL2, $$cref );

        # Restore SIGCHLD handler
        $SIG{CHLD} = $sigchld if defined $SIG{CHLD};

        # Check the return value
        if ( $$cref == -1 or $$cref == 32512 ) {

            # Command failed to execute
            Paranoid::ERROR =
                pdebug( 'command failed to execute: %s', PDLEVEL1, $! );
            $rv = -1;

        } elsif ($signal) {

            # Exited with signal (and core?)
            Paranoid::ERROR =
                pdebug( 'command died with signal: %s', PDLEVEL1, $signal );
            pdebug( "command exited with core dump", PDLEVEL1 ) if $cored;
            $rv = -1;

        } else {

            # Command exited normally
            $$cref >>= 8;
            $rv = $$cref == 0 ? 1 : 0;
            pdebug( 'command exited with rv: %s', PDLEVEL1, $$cref );
        }

        pOut();
        pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );

        return $rv;
    }
}

1;

__END__