Generic hooks into Perl_block_{start,end}.

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.

diff --git a/embedvar.h b/embedvar.h
index 428147f..dde1f27 100644 (file)
--- 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 138895a..1e01e43 100644 (file)
--- 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.  */
 

diff --git a/op.c b/op.c
index c50111c..dc18a2d 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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;
 }
 

diff --git a/op.h b/op.h
index 712039c..7de236f 100644 (file)
--- a/op.h
+++ b/op.h
@@ -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

diff --git a/perlapi.h b/perlapi.h
index 506d72c..742bb3a 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -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

diff --git a/sv.c b/sv.c
index 2f13091..3e99d9c 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -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.