These take the form of a vtable pushed onto the new PL_blockhooks array.
This could probably do with a API around it later. Separate pre_end and
post_end hooks are needed to capture globals before the stack is unwound
(like needblockscope in the existing code). The intention is that once
a vtable is installed it never gets removed, so where necessary
extensions using this will need to use a hinthv element to determine
whether to do anything or not.
#define PL_basetime (vTHX->Ibasetime)
#define PL_beginav (vTHX->Ibeginav)
#define PL_beginav_save (vTHX->Ibeginav_save)
+#define PL_blockhooks (vTHX->Iblockhooks)
#define PL_body_arenas (vTHX->Ibody_arenas)
#define PL_body_roots (vTHX->Ibody_roots)
#define PL_bodytarget (vTHX->Ibodytarget)
#define PL_Ibasetime PL_basetime
#define PL_Ibeginav PL_beginav
#define PL_Ibeginav_save PL_beginav_save
+#define PL_Iblockhooks PL_blockhooks
#define PL_Ibody_arenas PL_body_arenas
#define PL_Ibody_roots PL_body_roots
#define PL_Ibodytarget PL_bodytarget
retrieve a C<struct mro_alg *> */
PERLVAR(Iregistered_mros, HV *)
+/* Compile-time block start/end hooks */
+PERLVAR(Iblockhooks, AV *)
+
/* If you are adding a U8 or U16, check to see if there are 'Space' comments
* above on where there are gaps which currently will be structure padding. */
}
return o;
}
-
+
int
Perl_block_start(pTHX_ int full)
{
dVAR;
const int retval = PL_savestack_ix;
+
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
+
+ CALL_BLOCK_HOOKS(start, full);
+
return retval;
}
{
dVAR;
const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
- OP* const retval = scalarseq(seq);
+ OP* retval = scalarseq(seq);
+
+ CALL_BLOCK_HOOKS(pre_end, &retval);
+
LEAVE_SCOPE(floor);
CopHINTS_set(&PL_compiling, PL_hints);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
pad_leavemy();
+
+ CALL_BLOCK_HOOKS(post_end, &retval);
+
return retval;
}
#define FreeOp(p) PerlMemShared_free(p)
#endif
+struct block_hooks {
+ void (*bhk_start) (pTHX_ int full);
+ void (*bhk_pre_end) (pTHX_ OP **seq);
+ void (*bhk_post_end) (pTHX_ OP **seq);
+};
+
+#define CALL_BLOCK_HOOKS(which, arg) \
+ STMT_START { \
+ if (PL_blockhooks) { \
+ I32 i; \
+ for (i = av_len(PL_blockhooks); i >= 0; i--) { \
+ SV *sv = AvARRAY(PL_blockhooks)[i]; \
+ struct block_hooks *hk; \
+ \
+ assert(SvIOK(sv)); \
+ if (SvUOK(sv)) \
+ hk = INT2PTR(struct block_hooks *, SvUVX(sv)); \
+ else \
+ hk = INT2PTR(struct block_hooks *, SvIVX(sv)); \
+ \
+ if (hk->bhk_ ## which) \
+ CALL_FPTR(hk->bhk_ ## which)(aTHX_ arg); \
+ } \
+ } \
+ } STMT_END
+
#ifdef PERL_MAD
# define MAD_NULL 1
# define MAD_PV 2
#define PL_beginav (*Perl_Ibeginav_ptr(aTHX))
#undef PL_beginav_save
#define PL_beginav_save (*Perl_Ibeginav_save_ptr(aTHX))
+#undef PL_blockhooks
+#define PL_blockhooks (*Perl_Iblockhooks_ptr(aTHX))
#undef PL_body_arenas
#define PL_body_arenas (*Perl_Ibody_arenas_ptr(aTHX))
#undef PL_body_roots
}
PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
+ PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
/* Call the ->CLONE method, if it exists, for each of the stashes
identified by sv_dup() above.