From 1930840b26541ab67ff111a47ceab4753d798617 Mon Sep 17 00:00:00 2001
From: Ben Morrow <ben@morrow.me.uk>
Date: Thu, 26 Nov 2009 17:18:29 +0000
Subject: [PATCH] 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.
---
 embedvar.h |  2 ++
 intrpvar.h |  3 +++
 op.c       | 14 ++++++++++++--
 op.h       | 26 ++++++++++++++++++++++++++
 perlapi.h  |  2 ++
 sv.c       |  1 +
 6 files changed, 46 insertions(+), 2 deletions(-)

diff --git a/embedvar.h b/embedvar.h
index 428147f..dde1f27 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 138895a..1e01e43 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.  */
 
diff --git a/op.c b/op.c
index c50111c..dc18a2d 100644
--- 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
--- 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
--- 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
--- 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.
-- 
1.8.3.1