That is true, I could just copy the module and rename it as something else and copy it directly into my script.

But if someone asked me to explain each line of the code, I will not be confident enough to answer it. Plus if someone finds out that I copied it from a CPAN module, then I would be in trouble because I will be violating our 'policy' and it would be considered as plagiarism, right?

In fact, the policy is really weird because all open source codes need to be reviewed first by our senior developers therefore it will take time to be able to install and implement this module.

And as someone mentioned, if I 'copied' a small snippet from the web, then it would be fine because it is just 'small'. So, I agree the policy is weird.

"That is true, I could just copy the module and rename it as something else and copy it directly into my script."

Don't even rename it. Dump it in any directory you feel fit and use lib.

"Plus if someone finds out that I copied it from a CPAN module, then I would be in trouble because I will be violating our 'policy' and it would be considered as plagiarism, right?"

And now you make it sound like it's a school/homework project. The module in question is licensed under the same terms as Perl, so if using Perl is considered plagiarism, yes.

"And as someone mentioned, if I 'copied' a small snippet from the web, then it would be fine because it is just 'small'."

The size of the snippet doesn't matter. If you don't know what it does exactly, the security issue still applies. I'd personally trust CPAN modules more than random "snippets".

--
b10m

# Perl Cookbook, 1st Edition, pg. 626
use strict;
use IO::Socket;
use Symbol;
use POSIX qw(:signal_h :errno_h :sys_wait_h);

my $PREFORK        = 2;     # number of kids to maintain
my %kids           = ();    # child process ids
my $kids           = 0;     # number of children
my @jobs           = qw(a b c d e f g h);

sub REAPER {
   $SIG{CHLD} = \&REAPER;
   my $pid    = waitpid(-1, &WNOHANG);
   if ($pid   == -1) {
      # ignore - no child waiting
   } elsif (&WIFEXITED($?)) {
      $kids--;
      delete($kids{$pid});
   } else {
      # false alarm
   }
   $SIG{CHLD} = \&REAPER;    # in case of unreliable signals
}

sub HUNTSMAN {
   local($SIG{CHLD}) = 'IGNORE';
   kill 'INT' => keys %kids;
   exit;
}

sub HEADCOUNT {
   $PREFORK +=5;
   print "I have $kids kids; increasing to $PREFORK...\n";
}

# install signal handlers
$SIG{CHLD}   = \&REAPER;
$SIG{INT}    = \&HUNTSMAN;
$SIG{HUP}    = \&HEADCOUNT;

print "starting $PREFORK users...\n";
for (1 .. $PREFORK) {
   &make_new_child(shift(@jobs));
}

# and maintain population
while (scalar @jobs) {   # or 'while (1)' for perpetual
   sleep;                # wait for a signal
   for ($kids .. $PREFORK) {
      &make_new_child(shift(@jobs));
   }
}

sub make_new_child {
   my $pid;
   my $sigset;

   sleep 3;

   # block signal for fork
   $sigset = POSIX::SigSet->new(SIGINT);
   sigprocmask(SIG_BLOCK, $sigset) or die("Can't block SIGINT for fork
+: $!\n");
   die "fork: $!"  unless defined ($pid = fork);

   if ($pid) {
      # parent records child and returns
      sigprocmask(SIG_UNBLOCK, $sigset) or die("Can't unblock SIGINT f
+or fork: $!\n");
      $kids{$pid} = 1;
      $kids++;
      return;

   } else {

      # child must *not* return from this subroutine
      $SIG{INT}   = 'DEFAULT';       # make it kill us as before
      $SIG{HUP}   = 'IGNORE';        # only parent needs this

      #unblock signals
      sigprocmask(SIG_UNBLOCK, $sigset) or die("Can't unblock SIGINT f
+or fork: $!\n");

      # do something
      my $job = shift;
      print "I am $$, doing job $job\n";
      sleep 10;
      exit;
   }
}
[download]

I used basically the same to stress an application by perpetually spawning connections and adding heat with HUP.

Update: Sorry! When I cut-and-pasted this, I missed three essential lines. See the three lines after the comment, "Install signal handlers".

Update2: I clarified my reference to the Cookbook. I now have the 2nd Edition, which doesn't have the same recipe.

Hi,

I tried to run your script but I'm getting this output...


starting 2 users...
I am 23687, doing job a
I am 23688, doing job b
[download]

I looked into the code and it should continue doing job c, d, etc... but it simply stopped after this. Any thoughts?

This can simply be done in Parallel::ForkManager but I cannot download and install it in our system for security reason.

My experience suggests that when management says "security" and implements a stupid policy, they are extremely unlikely to respond well to any employees who demonstrate how stupid the policy is.

Secondly copying the code and inserting it into the codebase carries very real intellectual property risks. Copying a freely available snippet from a website carries far smaller risks, particularly when the author is available to give permission.

So yeah, it is a stupid rule. But I wouldn't recommend breaking it in an obvious way.

#!/usr/bin/perl

#by Abigail of perlmonks.org
#Some times you have a need to fork of several children, but you want 
+to
#limit the maximum number of children that are alive at one time. Here
#are two little subroutines that might help you, mfork and afork. They
+ are very similar.
#They take three arguments,
#and differ in the first argument. For mfork, the first
#argument is a number, indicating how many children should be forked. 
+For
#afork, the first argument is an array - a child will be
#forked for each array element. The second argument indicates the maxi
+mum
#number of children that may be alive at one time. The third argument 
+is a
#code reference; this is the code that will be executed by the child. 
+One
#argument will be given to this code fragment; for mfork it will be an
+ increasing number,
#starting at one. Each next child gets the next number. For afork, the
+ array element is
#passed. Note that this code will assume no other children will be spa
+wned,
#and that $SIG {CHLD} hasn't been set to IGNORE.


mfork (10,10,\&hello);
sub hello{print "hello world\n";}

print "all done now\n";

###################################################
sub mfork ($$&) {
my ($count, $max, $code) = @_;
foreach my $c (1 .. $count) {
wait unless $c <= $max;
die "Fork failed: $!\n" unless defined (my $pid = fork);
exit $code -> ($c) unless $pid;
}
1 until -1 == wait;
}
##################################################
sub afork (\@$&) {
my ($data, $max, $code) = @_;
my $c = 0;
foreach my $data (@$data) {
wait unless ++ $c <= $max;
die "Fork failed: $!\n" unless defined (my $pid = fork);
exit $code -> ($data) unless $pid;
}
1 until -1 == wait;
}
#####################################################
[download]

This is wonderfully simple! Where yesterday I processed sequentially like this:

   ...
   foreach (@jobs) {
      &process($_);
   }
   ...
[download]

Today, in parallel with just a few changes ripped from 'afork':

   ...
   foreach (@jobs) {
      die "Fork failed: $!\n" unless defined (my $pid = fork);
      exit &process($_) unless $pid;
   }
   1 until -1 == wait;
   ...
[download]

And restrained parallel with three more lines:

   ...
   my $max = 4;
   my $c   = 0;
   foreach (@jobs) {
      wait unless ++$c <= $max;
      die "Fork failed: $!\n" unless defined (my $pid = fork);
      exit &process($_) unless $pid;
   }
   1 until -1 == wait;
   ...
[download]

I wonder where the once-prominent abigail is today...

This is exactly what I need. I made some modification and it works like a charm.

Thanks!