Perl mutiple children creation

Question

My program will fork, launching $n children. When a child finishes, the parent will launch a new one, if we have more to launch.

#!/usr/bin/perl

use strict;
use warnings;
use POSIX ":sys_wait_h";

#function, that every child will run
sub func
# {{{
{
      my $i = shift;
      my $delay = shift;

      print "$i started\n";
      sleep($delay);
      print "$i finished\n";
}
# }}}

#max number of concurrent children
my $max_n = 2;

#number of seconds each child will sleep
my @delays = (8, 5, 5);
my $n_elements = scalar(@delays);

#number of currently running children
my $n;
if ($n_elements > $max_n) {
      $n = $max_n;
}
else {
      $n = $n_elements;
}

#initial children creation
my $i;
for ($i = 0; $i < $n; $i++) {
      my $pid = fork();
      if ($pid == 0) {
            #child runs the function
            func($i, $delays[$i]);
            exit(0);
      }
}

#any children still running?
while ($n > 0) {
      #wait until one of them dies
      my $dead_child_pid = wait();
      print "$dead_child_pid done\n";

      #do we need to create new children?
      if ($i < $n_elements) {
            #create a child
            my $pid = fork();
            if ($pid == 0) {
                  func($i, $delays[$i]);
                  exit(0);
            }
            else {
                  #move pointer to the next element of @delays
                  ++$i;
            }
      }
      else {
            #decrease number of running children
            $n--;
      }
}

print "parent finished\n";

When I run it, it prints:

1 started
0 started

Here I check the processes:

bash-4.2$ ps -A | grep perl
 3433 pts/2    00:00:00 perl
 3434 pts/2    00:00:00 perl
 3435 pts/2    00:00:00 perl

So, it created 3 processes: 3433 - parent, 3434 and 3435 - children. Then:

1 finished
3435 done
2 started

Now again:

bash-4.2$ ps -A | grep perl
 3433 pts/2    00:00:00 perl
 3434 pts/2    00:00:00 perl
 3438 pts/2    00:00:00 perl

It launched the 3-rd child with pid 3438 after the death of the 2-nd.

0 finished
3434 done
2 finished
3438 done
parent finished

So, everything seems to be correct with the exception of the reversed launching order of children in the 1-st loop.

Maybe, it's possible to unite children creation from the both loops into a function. As their code has similar parts:

  my $pid = fork();
  if ($pid == 0) {
        #child runs the function
        func($i, $delays[$i]);
        exit(0);
  }

Do you see any more drawbacks in my code?

Answer 1

Here are some changes,

• only one while looping until children are dead
• new children are launched if @queue has jobs
• waiting for children if empty queue or max allowed forks is reached
• forkit function which takes worker function as first parameter

Most of the time child launching is in correct order, but sometimes as you noticed, they're reversed (time() shows time difference for each event)

#!/usr/bin/perl

use strict;
use warnings;
use POSIX ":sys_wait_h";
use Time::HiRes qw/time /;

sub forkit(&) {
  my ($worker) = @_;

  my $pid = fork();
  if ($pid == 0) {
    $worker->();
    exit(0);
  }
  return $pid;
}
#function, that every child will run
sub func {
  my $i = shift;
  my $delay = shift;

  print time(), ":$i started\n";
  sleep($delay);
  print time(), ":$i finished\n";
}

#max number of concurrent children
my $max_n = 2;
#number of seconds each child will sleep
my @delays = (8, 5, 5);

my @queue = @delays;
my @dead_child;

my $active = 0;
while (@dead_child < @delays) {

  if (!@queue or $active == $max_n) {
    push @dead_child, wait();
    print time(), ":$dead_child[-1] done\n";
    $active--;
  }
  if (@queue) {
    my $i = @delays - @queue;
    my $delay = shift @queue;
    forkit {
      func($i, $delay);
    };
    $active++;
  }
}

print time(), ":parent finished\n";

Answer 2

I think this can be improved by using queues as the main construct to convey what is going on.

First, you have a pending queue:

my @pending = (8, 8, 5);

Second, you have an empty queue with the currently active workers:

my @workers;

And this queue has a size limit:

my $max_workers = 2;

This can all be run by a single while loop:

while(@workers < $max_workers) {
    ... add one more worker ...
    ... remove all workers that are done ...
    ... break out of loop is @pending and @workers are both empty
    ... wait for a worker to exit (or sleep) ...
}

When this loop exits, you're all done.