#!/usr/bin/perl

use strict; # https://perlmonks.org/?node_id=11107627
use warnings;
use IO::Socket;
use Forking::Amazing;

my $maxforks = 20;                 # tune these ...
my $clientsperchild = 300;
my $port = 6666;

my $listen = IO::Socket::INET->new(LocalPort => $port,
  Listen => 20, Reuse => 1) or die "$@ on listen create";

Forking::Amazing::run
  $maxforks,
  sub
    {
    print "child $$\n";
    process( scalar $listen->accept or return [] ) for 1 .. $clientsperchild;
    return [];
    },
  sub { push @Forking::Amazing::ids, 1 },
  (1) x $maxforks;

sub process                                         # custom code  goes in here
  {
  my $socket = shift;
  my $query = <$socket> // return [];               # read query
  print $socket "prefork $$ is answering: $query";  # reply
  }

##</code><code>##

#!/usr/bin/perl

use strict;
use warnings;
use IO::Socket;
use Forking::Amazing;

my $forks = shift // 1;
my $sends = shift // 1;
my $totalerrors = 0;
my $transactions = 0;

Forking::Amazing::run
  $forks,
  sub
    {
    my $errors = 0;
    my $trans = 0;
    for ( 1 .. $sends )
      {
      my $s = IO::Socket::INET->new('localhost:6666') or die;
      my $key = join '', map +('a'..'z')[rand 26], 1 .. 10;
      print $s "foo|$key\n";
      my $answer = join '', <$s>;
      $answer =~ /$key/ or $errors++;
      print $answer;
      close $s;
      $trans++;
      }
    return [ $errors, $trans ];
    },
  sub
    {
    $totalerrors += $_[1][0] // 0;
    $transactions += $_[1][1] // 0;
    },
  1 .. $forks;

print "total errors: $totalerrors  transactions: $transactions\n";

##</code><code>##

package Forking::Amazing;

use strict;
use warnings;

sub run ($&&@)
  {
  ( my $maxforks, my $childcallback, my $resultcallback, our @ids ) = @_;

  use Storable qw( freeze thaw );
  use IO::Select;
  my @fh2id;
  my $sel = IO::Select->new;
  while( @ids or $sel->count ) # unstarted or active
    {
    for my $id ( splice @ids, 0, $maxforks - $sel->count ) # allowed forks
      {
      if( my $pid = open my $fh, '-|' ) # forking open
        {
        $sel->add( $fh ); # parent
        $fh2id[$fh->fileno] = $id;
        }
      elsif( defined $pid ) # child
        {
        print freeze
          do {local *STDOUT; open STDOUT, '>&STDERR'; $childcallback->($id) };
        exit;
        }
      else
        {
        $resultcallback->( $id, $childcallback->($id) );
        }
      }
    for my $fh ( $sel->can_read ) # collecting child data
      {
      $sel->remove( $fh );
      $resultcallback->($fh2id[$fh->fileno], thaw do { local $/; <$fh> });
      }
    }
  }

1;

__END__

=head1 NAME

Forking::Amazing - a fork manager

=head1 SYNOPSIS

 use Forking::Amazing;               # small example program
 use Data::Dump 'dd';

 Forking::Amazing::run(
   5,                                # max forks
   sub { +{id => pop, pid => $$} },  # runs in child
   sub {dd pop},                     # act on result of child in parent
   'a'..'z');                        # ids (one fork for each id)

=head1 DESCRIPTION

A simple fork manager that runs a limited number of forks at a time,
It does callbacks for the code to be run in the children,
and the code to be run in the parent when a child exits and returns a value.

=head1 CALLING SEQUENCE

Forking::Amazing::run( $maxforks, \&childcallback, \&returncallback, @ids);

The childcallback runs in a child.

The childcallback gets an id as argument, and must return a value
that can be processed by Storable::freeze (basically a ref).
In the childcallback, STDOUT is redirected to STDERR,

The resultcallback runs in the parent.

The resultcallback get two arguments, an id and the value returned
by a childcallback.

@ids can be any scalar including numbers, strings, or refs.
@ids can be used to pass starting parameters to a child, for
example, to pass two parameters to a child use [ $param1, $param2 ] as an id.

Additional ids can be added by pushing them to @Forking::Amazing::ids

=head1 RETURN VALUE

Forking::Amazing::run returns after all forked children have finished.
There is no return value.

=cut

##</code><code>##

#!/usr/bin/perl

use strict; # https://perlmonks.org/?node_id=11107627
use warnings;
use IO::Socket;
use Forking::Amazing;

my $maxforks = 10;                 # tune these ...
my $forks = my $minforks = 2;
my $clientsperchild = 1000;
my $lifetime = 10;
my $port = 6666;

my $listen = IO::Socket::INET->new(LocalPort => $port,
  Listen => 20, Reuse => 1) or die "$@ on listen create";

Forking::Amazing::run
  $maxforks,
  sub
    {
    print "child $$\n";
    my $idle = 0;
    $SIG{ALRM} = sub { $idle = 1 };
    alarm $lifetime;
    for (1 .. $clientsperchild)
      {
      process( scalar $listen->accept or return [ 1 ] );
      $idle and return [ 1 ]; # idle
      alarm $lifetime;                                    # reset timeout
      }
    return [ 0 ]; # not idle
    },
  sub
    {
    my $idle = pop()->[0];
    if( $idle and $forks > $minforks )
      {
      $forks--;
      print "forks: $forks\n";
      }
    elsif( ! $idle and $forks < $maxforks )
      {
      push @Forking::Amazing::ids, 1, 1;
      $forks++;
      print "forks: $forks\n";
      }
    else
      {
      push @Forking::Amazing::ids, 1;
      }
    },
  (1) x $minforks;

sub process                                         # custom code  goes in here
  {
  my $socket = shift;
  my $query = <$socket>;                                # read query
# select undef, undef, undef, 0.001;
  print $socket "prefork $$ is answering: $query";    # reply
  }