#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
OP* (*orig_op_fork)(pTHX);
void
find_and_exec(pTHX)
{
SV* sva;
GV* method;
HV* stash;
dSP;
for
(sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
register
const
SV*
const
svend = &sva[SvREFCNT(sva)];
SV* svi;
for
(svi = sva + 1; svi < svend; ++svi) {
if
(SvTYPE(svi) != SVTYPEMASK && SvREFCNT(svi)) {
if
(SvOBJECT(svi)) {
stash = SvSTASH(svi);
method = gv_fetchmethod_autoload(stash,
"AFTER_FORK_OBJ"
, 0);
if
(method) {
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_inc(svi)));
PUTBACK;
call_sv((SV*)GvCV(method), G_DISCARD | G_VOID);
FREETMPS;
LEAVE;
}
}
else
if
(SvTYPE(svi) == SVt_PVHV) {
if
(HvNAME((HV*)svi)) {
method = gv_fetchmethod_autoload((HV*)svi,
"AFTER_FORK"
, 0);
if
(method) {
PUSHMARK(SP);
call_sv((SV*)GvCV(method), G_DISCARD | G_NOARGS | G_VOID);
}
}
}
}
}
}
}
static
OP* pp_fork_hook(pTHX)
{
dMARK;
dAX;
OP* op = CALL_FPTR(orig_op_fork)(aTHX);
if
(SvIOK(ST(0)) && (SvIV(ST(0)) == 0)) {
find_and_exec(aTHX);
}
return
op;
}
MODULE = fork::hook PACKAGE = fork::hook
PROTOTYPES: DISABLE
BOOT:
orig_op_fork = PL_ppaddr[OP_FORK];
PL_ppaddr[OP_FORK] = pp_fork_hook;