Perl implementation of hooks for fork aka AFTER_FORK.

global_hook.pm

package fork::global_hook;

use strict;
use B;
use Devel::Gladiator;

use constant {
	BLESSED => 0x00100000
};

BEGIN {
    *CORE::GLOBAL::fork = sub() {
        my $ret    = CORE::fork;
        if(defined($ret) && $ret == 0) {
            find_and_call();
        }
        return $ret;
    };
}

sub find_and_call {
    my $arena = Devel::Gladiator::walk_arena;
    foreach my $sv (@$arena) {#works slowly on the big arena
        my $bsv = B::svref_2object($sv);
        if ( $bsv->isa('B::SV') ) {
            if ( $bsv->FLAGS & BLESSED) {
                if ( my $ref = $sv->can('AFTER_FORK_OBJ') ) {
                    $ref->($sv);
                }
            }
            elsif ( ref $bsv eq 'B::HV' ) {
                if ( my $named_hash = $bsv->NAME ) {
                    if ( my $ref = $named_hash->can('AFTER_FORK') ) {
                        $ref->();
                    }
                }
            }
        }
    }
    @$arena = ();#free arena
    ();
}
1;