The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

#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;