diff options
| -rw-r--r-- | embedvar.h | 2 | ||||
| -rw-r--r-- | intrpvar.h | 3 | ||||
| -rw-r--r-- | op.c | 14 | ||||
| -rw-r--r-- | op.h | 26 | ||||
| -rw-r--r-- | perlapi.h | 2 | ||||
| -rw-r--r-- | sv.c | 1 |
6 files changed, 46 insertions, 2 deletions
diff --git a/embedvar.h b/embedvar.h index 428147f636..dde1f279d8 100644 --- a/embedvar.h +++ b/embedvar.h @@ -71,6 +71,7 @@ #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) @@ -400,6 +401,7 @@ #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 diff --git a/intrpvar.h b/intrpvar.h index 138895a2fd..1e01e43892 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -722,6 +722,9 @@ PERLVARI(Isv_serial, U32, 0) /* SV serial number, used in sv.c */ 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. */ @@ -2305,17 +2305,21 @@ Perl_scope(pTHX_ OP *o) } 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; } @@ -2324,12 +2328,18 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) { 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; } @@ -645,6 +645,32 @@ struct loop { #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 @@ -178,6 +178,8 @@ END_EXTERN_C #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 @@ -12649,6 +12649,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } 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. |