Submit fork-control module to CPAN?

[reyjrar]

I've been using perl for a while now. After everything that perl has done for me, I would really like to do something for perl. A while back I was working with multiple parallel processes to perform network auditing. I was doing a lot of fork()ing around with code, as were the members of my team. Unfortunately, we fork() bombed our development servers *maybe* one or two times. I started doing some investigation into various modules out there. I looked at Parallel::ForkManager and it was simple and we started using it. Only, we still managed to bog down the servers.

I needed more control of the process. So after doing extensive research and testing, I completed the code below.

My question ( yes, I actually have one ) is whether or not members of the monastery believe my code is useful enough for me to apply for CPAN id and open a module and start maintaining this. As it stands I'd like to make it cross platform and actually implement several of the "unimplemented" features. Any advice from current CPAN Authors ?

A code2html'd version is available HERE
Here's a quick sample that demonstrates usage:

#!/usr/bin/perl


use strict;

use ForkControl;

my @hosts = qw/host1 host2 host3 host4 host5/;

my $motherforker = ForkControl->new(    Name => 'forker',
                    MaxKids => 100,
                    MinKids => 5,
                    ProcessTimeout => 30,
                    WatchLoad => 1,
                    MaxLoad => 15.00,
                    Code => \&telnet_to_host
    );

foreach my $host (@hosts) {
    $motherforker->run($host);
}

sub telnet_to_host {
    my $host = shift;
    open(FILE, "> $host");
    #
    # telnet to the thing
    print FILE "yay!";
    close FILE;
}

Here's the Module it self:

#
# This is a nonsucking forking module.
# Coded by:
#     Brad Lhotsky <[e-mail]>
# Contributions by:
#    Mark Thomas <[e-mail]>
#
package ForkControl;
$VERSION = 1.00;
use POSIX qw/:signal_h :errno_h :sys_wait_h/;
use strict;
use vars qw/ $AUTOLOAD /;

use constant TRUE => 1;
use constant FALSE => 0;

use constant DEFAULT => 0;
use constant PERMISSION => 1;
use constant PERMIT_ALL => 'init/set/get/copy';

##################
# Debug constants
use constant DB_OFF    => 0;
use constant DB_INFO    => 1;
use constant DB_LOW    => 2;
use constant DB_MED    => 3;
use constant DB_HIGH    => 4;

{
 # private data members
    my %_attributes = (
        # Name                 # defaults            # permissions
        '_name'            => [ 'Unnamed Child',        PERMIT_ALL    
+],
        '_processtimeout'    => [ 120,            PERMIT_ALL    ],
        '_maxkids'        => [ 5,                PERMIT_ALL    ],
        '_minkids'        => [ 1,                PERMIT_ALL    ],
        '_maxload'        => [ 4.50,            PERMIT_ALL    ],
        '_maxmem'        => [ 10.0,            PERMIT_ALL    ],    # n
+on functional
        '_maxcpu'        => [ 25.0,            PERMIT_ALL    ],
        '_method'        => [ 'cycle',            PERMIT_ALL    ],
        '_watchcount'        => [ TRUE,            PERMIT_ALL    ],
        '_watchload'        => [ FALSE,            PERMIT_ALL    ],
        '_watchmem'        => [ FALSE,            PERMIT_ALL    ],    
+# non functional
        '_watchcpu'        => [ FALSE,            PERMIT_ALL    ],    
+# non functional
        '_parentpid'        => [ $$,            'get/set'    ],
        '_code'            => [ undef,            'init/get/set'    ],
        '_debug'        => [ DB_OFF,            'init/get/set'    ],
        '_check_at'        => [ 50,            PERMIT_ALL     ],
        '_checked'        => [ 0,                'get/init'    ]
    );
    
    my %_KIDS=();
    my $_KIDS=0;
 # private member accessors
    sub _attributes {
        # return an array of our attributes
        return keys %_attributes;
    }
    sub _default {
        # return the default for a set attribute
        my ($self,$attr) = @_;
        $attr =~ tr/[A-Z]/[a-z]/;
        $attr =~ s/^\s*_?/_/;
        return unless exists $_attributes{$attr};
        return $_attributes{$attr}->[DEFAULT];
    }
    sub _can {
        # return TRUE if we can $perm the $attr
        my ($self,$perm,$attr) = @_;    
        $attr =~ tr/[A-Z]/[a-z]/;
        $attr =~ s/^\s*_?/_/;
        return unless exists $_attributes{$attr};
        $perm =~ tr/[A-Z]/[a-z/;
        return TRUE if $_attributes{$attr}->[PERMISSION] =~ /$perm/;
        return FALSE;
    }
    sub _kidstarted {
        # keep records of our children
        my ($self,$kid) = @_;
        $self->_dbmsg(DB_LOW,"CHILD: $kid STARTING");
        #
        # use time() here to implement the process time out
        $_KIDS{$kid} = time;
        return ++$_KIDS;
    }
    sub _kidstopped {
        # keep track
        my ($self,$kid) = @_;
        return unless exists $_KIDS{$kid};
        $self->_dbmsg(DB_LOW,"CHILD: $kid ENDING");
        delete $_KIDS{$kid};
        return --$_KIDS;
    }
    sub kids {
        return wantarray() ? keys %_KIDS : $_KIDS;
    }
    sub kids_time_hash {
        my %hash = %_KIDS;
        return \%hash;
    }
    sub _pid {
        return $$;
    }
}

# Class Methods
sub DESTROY {
    # load this into the symbol table immediately!
}

sub new {
    # Constructor
    # Builds our initial Fork Object;
    my ($proto,@args) = @_;
    my $proto_is_obj = ref $proto;
    my $class = $proto_is_obj || $proto;
    my $self = bless {}, $class;
    # take care of capitalization:
    my %args=();
    while(@args) { 
        my $k = shift @args;
        my $v = shift @args;
        ($k) = ($k =~ /^\s*_?(.*)$/);
        $args{lc($k)}=$v;
    }
    # now take care of our initialization
    foreach my $attr ($self->_attributes()) {
        my ($arg) = ($attr =~ /^_?(.*)/);
        # first see its in our argument list
        if(exists $args{$arg} && $self->_can('init',$attr)) {
            $self->{$attr} = $args{$arg};
        }
        # if not, check to see if we're copying an
        # object. Also, make sure we can copy it!
        elsif($proto_is_obj && $self->_can('copy', $attr)) {
            $self->{$attr} = $proto->{$attr};
        }
        # or, just use the default!
        else {
            $self->{$attr} = $self->_default($attr);
        }
    }
    # set the parent pid
    $self->set_parentpid($$);
    $self->_dbmsg(DB_HIGH,'FORK OBJECT CREATED');
    return $self;
}


sub _overLoad {
    # this is a cheap linux only hack
    # I will be replacing this as soon as I have time
    my $CMDTOCHECK = '/usr/bin/uptime';
    my ($self) = shift;
    return FALSE unless $self->get_watchload();
    open(LOAD, "$CMDTOCHECK |") or return FALSE;
    local $_ = <LOAD>;
    close LOAD;
    chomp;
    if(/load average\:\s+(\d+\.\d+)/) {
        my $current = $1;
        my $MAXLOAD = $self->get_maxload();
        if ($current >= $MAXLOAD) {
            $self->_dbmsg(DB_LOW,"OVERLOAD: Current: $current, Max: $M
+AXLOAD, RETURNING TRUE");
            return TRUE;
        }
        $self->_dbmsg(DB_LOW,"OVERLOAD: Current: $current, Max: $MAXLO
+AD, RETURNING FALSE");
        return FALSE;
    }
    $self->_dbmsg(DB_LOW,'OVERLOAD: ERROR READING LOAD AVERAGE, RETURN
+ING FALSE');
    return FALSE;
}

sub _tooManyKids {
    # determine if there are too many forks
    my ($self) = @_;
    my $kids = $self->kids;
    my $MAXKIDS = $self->get_maxkids();
    my $MINKIDS = $self->get_minkids();
    unless(    $self->get_watchload() ||
        $self->get_watchmem() ||
        $self->get_watchcpu()
    ) {
        # not watching the load, stick to the
        # maxforks attribute
        $self->_dbmsg(DB_LOW,"TOOMANYKIDS - NOT CHECKING LOAD/MEM/CPU 
+- Kids: $kids MAX: $MAXKIDS");
        if($kids >= $self->get_maxkids()) {
            $self->_dbmsg(DB_MED,'TOOMANYKIDS - RETURN TRUE');
            return TRUE;
        } else {
            $self->_dbmsg(DB_MED,'TOOMANYKIDS - RETURN FALSE');
            return FALSE;
        }
    }
    if($self->get_watchload) {
        $self->_dbmsg(DB_MED,'TOOMANYKIDS - LOAD CHECKING');
        if($self->get_watchcount) {
            if(!$self->_overLoad && ($kids < $MAXKIDS)) {
                $self->_dbmsg(DB_LOW,"TOOMANYKIDS - MAX: $MAXKIDS, Kid
+s: $kids, Return: FALSE");
                return FALSE;
            }
            $self->_dbmsg(DB_LOW,"TOOMANYKIDS - MAX: $MAXKIDS, Kids: $
+kids, Return: TRUE");
            return TRUE;
        }
        else {
            $self->_dbmsg(DB_MED,'TOOMANYKIDS - CHECKING LOAD, NOT CHE
+CKING COUNT');
            if(!$self->_overLoad) {
                $self->_dbmsg(DB_LOW,"TOOMANYKIDS - Kids: $kids, UNCHE
+CKED RETURNING FALSE");
                return FALSE;
            }
            if($self->kids < $self->get_minkids) {
                $self->_dbmsg(DB_LOW, "TOOMANYKIDS - OVERLOAD BUT REAC
+HING MINIMUM KIDS!");
                return FALSE;
            }
            $self->_dbmsg(DB_LOW,"TOOMANYKIDS - Kids: $kids, UNCHECKED
+ RETURNING TRUE");
            return TRUE;
        }
    } # end of watchload

    # if we get to this point something is wrong, return true
    return TRUE;
}

sub _check {
    #
    # this function is here to make sure we don't
    # freeze up eventually.  It should be all good.
    my $self = shift;
    $self->{_checked}++;
    return if $self->get_check_at > $self->get_checked;
    foreach my $pid ( $self->kids ) {
        my $alive = kill 0, $pid;
        next if $alive;
        $self->_dbmsg(DB_INFO, "Child ($pid) evaded the reaper. Caught
+ by _check()\n");
        $self->_kidstopped($pid);
    }
    $self->{_checked} = 0;
}

sub run {
    # self and args go in, run the code ref or die if
    # the code ref isn't set
    my ($self,@args) = @_;
    my $ref = ref $self->get_code;
    die "CANNOT RUN A $ref IN RUN()\n" unless $ref eq 'CODE';
    # return if our parent has died
    unless($self->_parentAlive()) {
        $self->_dbmsg(DB_MED, 'PARENT IS NOT ALIVE: ' . $self->get_par
+entpid);
        return;
    }
    # wait for childern to die if we have too many
    if($self->get_method =~ /block/) {
        $self->cleanup() if $self->_tooManyKids;
    }
    else {
        $self->_kidstopped(wait) if $self->_tooManyKids;
    }
    # Protect us from zombies
    $SIG{'CHLD'} =  sub { $self->_REAPER };
    my $pid = fork();
    # check for errors
    die "*\n* FORK ERROR !!\n*\n" unless defined $pid;
    # if we're the parent return
    if($pid > 0) {
        return $self->_kidstarted($pid);
    }
    # we're the child, run and exit
    local $0 = '[ ' . $self->get_name . ' ]';
    $self->_dbmsg(DB_HIGH,'Running Fork Code');
    eval {
        local $SIG{ALRM} = sub { die "timeout"; };
        alarm $self->get_processtimeout if $self->get_processtimeout;
        $self->get_code()->(@args);
    };
    alarm 0;
    $self->_dbmsg(DB_LOW, "Child $$ timed out!") if $@ =~ /timeout/;
    exit $@ ? 1 : 0;
}

sub cleanup {
    # We'll just rely on our SIG{'CHLD'} handler to actually
    # disperse of the children, so all we have to do is wait
    # here.
    my $self = shift;
    # using select here because it doesn't interfere
    # with any signals in the program
    while( $self->kids ) {
        $self->_check;
        select undef, undef, undef, 1;
    }
    return TRUE;
}

sub _REAPER {
    # our SIGCHLD Handler
    # Code from the Perl Cookbook page 592
    my $self = shift;
    my $pid = waitpid(-1, &WNOHANG);
    if($pid > 0) {
        # a pid did something,
        if(WIFEXITED($?)) {
            # the pid exited
            $self->_kidstopped($pid);
        }
        else {
            $self->_dbmsg(DB_INFO, "Child ($pid) exitted abnormally");
            $self->_kidstopped($pid);
        }
    }
    $SIG{'CHLD'} =  sub { $self->_REAPER };
}

sub _parentAlive {
    # check to see if the parent is still alive
    my $self = shift;
    return kill 0, $self->get_parentpid();
}

sub AUTOLOAD {
    # AUTOLOAD our get/set methods
    no strict 'refs';
    return if $AUTOLOAD =~ /DESTROY/;
    my ($self,$arg) = @_;

    # get routines
    if($AUTOLOAD =~ /get(_.*)/ && $self->_can('get', $1)) {
        my $attr = lc($1);
        *{$AUTOLOAD} = sub { return $_[0]->{$attr}; };
        return $self->{$attr};
    }

    # set routines
    if($AUTOLOAD =~ /set(_.*)/ && $self->_can('set', $1)){
        my $attr = lc($1);
        *{$AUTOLOAD} = sub {
                    my ($self,$val) = @_;
                    $self->{$attr} = $val;
                    return $self->{$attr};
                };
        $self->{$attr} = $arg;
        return $self->{$attr};
    }

    warn "AUTOLOAD Could not find method $AUTOLOAD\n";
    return;
}

# DEBUG AND TESTING SUBS
sub print_me {
    my $self = shift;
    my $class = ref $self;
    print "$class Object:\n";
    foreach my $attr ($self->_attributes) {
        my ($pa) = ($attr =~ /^_(.*)/);
        $pa = "\L\u$pa";
        my $val = ref $self->{$attr} || $self->{$attr};
        print "\t$pa: $val\n";
    }
    print "\n";
}

sub _dbmsg {
    # print debugging messages:
    my ($self,$pri,@MSGS) = @_;
    return unless $self->get_debug() >= $pri;
    foreach my $msg (@MSGS) {
        $msg =~ s/[\cM\r\n]+//g;
        my $date = scalar localtime;
        print STDERR "$date - $msg\n";
    }
    return TRUE;
}

# return 1;
1;

Thanks in advance!

-brad..

janitored by ybiC: Retitle from "Seeking Direction.." for future searchability, add balanced <readmore> tags around long codeblock

[Abigail-II]

My question ( yes, I actually have one ) is whether or not members of the monastery believe my code is useful enough for me to apply for CPAN id and open a module and start maintaining this.

Please don't get the impression CPAN only hosts quality code, or that it only should host quality code. The only requirement for code to live on CPAN is that it should be freely distributable.

Don't let your decision whether to upload or not depend on what a handful of people here will say. Perlmonks isn't CPAN, and CPAN isn't perlmonks. I'd say, upload it to CPAN if you are satisfied with it, and then just let history run its course. If people like it, they'll use it. If they don't, you might get suggestions for improvement, but if not, then it's just taking up a bit of diskspace.

Abigail

[jdtoronto]

That having been said, if CPAN is to be Perl's greatest advantage then we must at least try to have good code there!

Abigail-II's point is, however, well taken, if the community likes it and you maintain it, then great, if not, well you still learned something in the process didn't you!

jdtoronto

[tachyon]

You may find How to make a CPAN Module Distribution and the links of use. I personally find the makemanifest.pl wiidget very handy for crating a clean distro.

The one glaring omission that I see is NO DOCUMENTATION. A module is worth using because it WORKS and is EASY TO USE. If I have to RTFS to work out how to use it.... Many modules on CPAN suffer from this flaw BTW. Especially a number of core ones. I use a number of say URI and LWP idioms that work fine but are essentially completely undocumented outside of RTFS. Generally I found them because merlyn or some other programmer has demonstratated them. Bad docs are also discouraging, especially code snippets that don't work as advertised, not naming any names.

The other important thing is tests. You code will probably have some issues. Fixing one may lead to another. When you release version 2 it is good for you to know it passes all the tests for version 1. It is however potentially vital to your end users. See Autogenerate Test Scripts for a handy widget.

And as Abigail-II says upload it and see what people think.

cheers

tachyon

s&&rsenoyhcatreve&&&s&n.+t&"$'$`$\"$\&"&ee&&y&srve&&d&&print