Being short of time, I'm thinking of a shade of mod_perl on Steriods.

This example is a synchronization primitive, called a promise.
Or at least it looks like that.

I've got some more posts coming...

Were you able to run the example?
Did it deadlock for you?

Cheers,
Jambo

Update: Changed max_age from 3 seconds to 1 hour. Was missed before posting.

Hi Jambo Hamon,

The following is a FCGI::ProcManager + MCE::Shared demonstration. One can make use of MCE::Shared and have a fast cache. Perhaps a nosql-like object is handy as well for session data during multi-page HTTP requests.

The MCE::Shared::Cache module is a hybrid LRU-plain implementation.

The MCE::Shared::Minidb nosql-like module is Redis-like for the API.

#!/usr/bin/perl

# http://127.0.0.1/cgi-bin/test_shared.fcgi
# http://127.0.0.1/cgi-bin/test_shared.fcgi?param1=foo&param2=baz

use strict;
use warnings;

use MCE::Shared;

use CGI::Fast;
use FCGI::ProcManager;

# construct any shared objects and mutexes (optional)

my $cache = MCE::Shared->cache( max_keys => 500, max_age => 3600 );
my $count = MCE::Shared->scalar( 0 );
my $nosql = MCE::Shared->minidb();

# launch FCGI manager next

my $proc_manager = FCGI::ProcManager->new({ n_processes => 4 });
   $proc_manager->pm_manage();

# calling init enables parallel IPC for data flow
# worker is assigned 1 of 12 channels

MCE::Shared->init();

# at last, the loop

while ( my $query = CGI::Fast->new() ) {
   $proc_manager->pm_pre_dispatch();

   print "Content-type: text/html\r\n\r\n";

   print "<hr>\n";
   print "$_ = $ENV{$_}<br>\n" foreach sort keys %ENV;
   print "<hr>\n";

   my %params;

   foreach ( sort $query->param() ) {
      $params{$_} = $query->param($_);
      print $_, " = ", $params{$_}, "<br>\n";
   }

   print "<hr>\n";

   print "$$: ", $count->incr(), "<br>\n";

   my $val = $cache->get('foo') // do {
       $cache->set( foo => 'bar'.$count->get() )
   };

   print "$$: ", $val, "<br>\n";

   $proc_manager->pm_post_dispatch();
}
[download]

For maximum performance, ensure Perl has Sereal::Encoder/Decoder 3.015+ installed. IO::FDPass 1.2+ is beneficial if wanting to construct a shared queue.

All was done in MCE::Shared::Cache and MCE::Shared::Minidb to run with low memory consumption and maximum performance. For example, MCE::Shared::Cache makes use of dualvar to hold the time expiration along with the key internally. Only enable what you want. Basically, do not enable max_age if not needed for maximum performance.

The OO interface for shared objects saves you from having to handle mutex at the application level, unless of course wanting to wrap a mutex (enter) around multiple shared actions.

Regards, Mario

I like you, Mario.

sort { "You cut to the chase." cmp "I'm frying something here for a se
+cond." } @beers
[download]

Do you think the following is proof of the promises mechanism?

I cannot wait to have a few "@beers" on the dock.

Man, I slay me.

Now I could show you. Is it possible that the index $t{index}->{prev}{cur}{rgy} is being mis-counted or not?

That's the one I am hunting.

All the Best,
Jambo

$VAR1 = {
          'index' => {
                       'rg' => {
                                 'ry' => '4995',
                                 'rgy' => '2243',
                                 'rg' => '2904'
                               },
                       'ry' => {
                                 'rg' => '5010',
                                 'ry' => '2877',
                                 'rgy' => '2212'
                               },
                       'rgy' => {
                                  'rg' => '2051',
                                  'ry' => '1959'
                                },
                       'null' => {
                                   'rg' => '1'
                                 }
                     },
          'mothersbaugh' => {
                              'rg' => '5000',
                              'rgy' => '5000',
                              'r' => '5000',
                              'g' => '10000',
                              'gy' => '5000'
                            },
          'fork2' => {
                       'r' => '10000',
                       'g' => '5000',
                       'y' => '5000',
                       'rg' => '5000',
                       'ry' => '5000'
                     },
          'fork1' => {
                       'ry' => '5000',
                       'rg' => '5000',
                       'y' => '5000',
                       'g' => '5000',
                       'r' => '10000'
                     },
          'starttime' => '1499821117',
          'prev' => 'ry',
          'cur' => 'ry'
        };
$ 
$ ~
$ perl  def4.pl --iterations 5000 -stats 1
[download]

#!/usr/bin/perl

use strict;
use warnings;
use v5.20;    # oh yeah

use Time::HiRes qw(usleep);
use Data::Dumper;

my $ITER       = 200;
my $IS_SLEEP   = 0;
my $RAND_SLEEP = 200;
my $DEBUG      = 0;
my $STATS      = 0;

# IS_SLEEP CONSTANTS
use constant PROMISES_INNER   => 1;
use constant PROMISES_INSIDE  => 2;
use constant PROMISES_BETWEEN => 4;

use Getopt::Long;
GetOptions(
    "iterations=i"  => \$ITER,          # numeric
    "sleep=i"       => \$IS_SLEEP,      #numeric
    "randomsleep=i" => \$RAND_SLEEP,    #numeric
    "debug=i"       => \$DEBUG,         #numeric
    "stats=i"       => \$STATS,         #numeric
  )
  or die(
"Usage $0:\t--iterations NUMBER --sleep NUMBER  --randomsleep INTERVAL
+ --debug NUMBER --stats NUMBER --ofile STRING\n"
  );

use Mutex;
use MCE::Shared;

my $red    = Mutex->new;
my $yellow = Mutex->new;
my $green  = Mutex->new;

$red->lock;
$yellow->lock;
$green->lock;

$|++;

sub spin {

    #   print Dumper(\@_);
    # Mutex, subroutine reference, ...Jazz
    return shift->enter( shift, @_ );
}

sub make_promise {
    my $mutex = shift;
    my $sub   = shift;

    my $promise;
    if (@_) {
        $promise = spin( $mutex, $sub, make_promise(@_) );
    }
    else {
        $promise = spin( $mutex, $sub );
    }
    return $promise;
}

tie my %t, 'MCE::Shared';
$t{starttime} = time;
$t{prev}      = "null";

my $sleep_inside = sub {
    usleep int( rand($RAND_SLEEP) ) if ( $IS_SLEEP & PROMISES_INSIDE )
+;
};

my $sleep_between = sub {
    usleep int( rand($RAND_SLEEP) ) if ( $IS_SLEEP & PROMISES_BETWEEN 
+);
};

my $sleep_inner = sub {
    usleep int( rand($RAND_SLEEP) ) if ( $IS_SLEEP & PROMISES_INNER );
};

my $rg = sub {
    my $name = shift || die;
    print "(rg)" if ( $name eq "fork1" );
    print "[rg]" if ( $name eq "fork2" );

    $t{$name}->{r}++;
    $t{$name}->{rg}++;
    $t{$name}->{g}++;

    $t{cur} = "rg";
    $t{index}->{ $t{prev} }{ $t{cur} }++;
    $t{prev} = "rg";

    $sleep_inside->();
};

my $ry = sub {
    my $name = shift || die;
    print "(ry)" if ( $name eq "fork1" );
    print "[ry]" if ( $name eq "fork2" );

    $t{$name}->{r}++;
    $t{$name}->{ry}++;
    $t{$name}->{y}++;

    $t{cur} = "ry";
    $t{index}->{ $t{prev} }{ $t{cur} }++;
    $t{prev} = "ry";

    $sleep_inside->();
};

my $rgy = sub {
    my $name = shift || die;
    say "{rgy}" if ( $name eq "mothersbaugh" );

    # yeah a few beers
    $t{$name}->{r}++;
    $t{$name}->{rg}++;
    $t{$name}->{g}++;
    $t{$name}->{gy}++;
    $t{$name}->{g}++;
    $t{$name}->{rgy}++;

    $t{cur} = "rgy";
    $t{index}->{ $t{prev} }{ $t{cur} }++;
    $t{prev} = "rgy";

    $sleep_inside->();
};

my $promise_rgy =
  sub { make_promise( $red, shift, $green, shift, $yellow, shift ); };
+ # or die
my $promise_ry = sub { make_promise( $red, shift, $yellow, shift ); };
my $promise_rg = sub { make_promise( $red, shift, $green,  shift ); };



my $pid = fork;

die "$!: who knows me?" if not defined $pid;

if ( $pid == 0 ) {
    #say "fork1 here: $$";
    #child: fork1
    #child: fork1
    #child: fork1
    #child: fork1
    #child: fork1



    my $pid = fork;

    die "$!: who knows me?" if not defined $pid;
    my $cnt;  

    if ( $pid == 0 ) {
        #say "fork2 here: $$";
        #child: fork2
        #child: fork2
        #child: fork2
        #child: fork2
        #child: fork2



        while ( $cnt++ < $ITER ) {


            $promise_rg->( $sleep_inside, $rg->("fork2") );
            $sleep_between->();
            $promise_ry->( $sleep_inside, $ry->("fork2") );
            $sleep_between->();
        }

    }
    else {
        # fork1
        # fork1
        # fork1
        # fork1
        # fork1

        while ( $cnt++ < $ITER ) {

            $promise_rg->( $sleep_inside, $rg->("fork1") );
            $sleep_between->();
            $promise_ry->( $sleep_inside, $ry->("fork1") );
            $sleep_between->();
        }
        wait;    # for fork2
    }

}
else {
    #mothersbaugh ship
    #mothersbaugh ship
    #mothersbaugh ship
    #mothersbaugh ship
    #mothersbaugh ship

    my $cnt;

    # sleep works wonders # sleep 2;
    while ( $cnt++ < $ITER ) {    # adjust to taste

      # no one can get red, cos it's locked until i unlock it. PID bas
+ed switch.
      # only true on the first iteration.
        $sleep_between->();

        $promise_rgy->( $sleep_inner, $sleep_inner, $rgy->("mothersbau
+gh") );
    }

    wait;    # fork1

    print "\n";
    print Dumper( tied(%t)->export( { unbless => 1 } ) ) if ($STATS);
}
[download]

Now the evidence is tampered with.
I just found a bug.

Counting g twice in $rgy.

124d123
<     $t{$name}->{g}++;
[download]