Add a new %{^HOOK} hash, similar to %SIG, and add support for "require__before" and "require__after" hooks.

MANIFEST

@@ -4879,6 +4879,7 @@ ext/XS-APItest/t/lvalue.t			Test XS lvalue functions
 ext/XS-APItest/t/magic.t			test attaching, finding, and removing magic
 ext/XS-APItest/t/magic_chain.t			test low-level MAGIC chain handling
 ext/XS-APItest/t/Markers.pm			Helper for ./blockhooks.t
+ext/XS-APItest/t/mortal_destructor.t		Test mortal_destructor api.
 ext/XS-APItest/t/mro.t				Test mro plugin api
 ext/XS-APItest/t/multicall.t			XS::APItest: test MULTICALL macros
 ext/XS-APItest/t/my_cxt.t			XS::APItest: test MY_CXT interface
@@ -5786,6 +5787,13 @@ t/io/tell.t				See if file seeking works
 t/io/through.t				See if pipe passes data intact
 t/io/utf8.t				See if file seeking works
 t/japh/abigail.t			Obscure tests
+t/lib/caller/Apack.pm			test Module for caller.t and t/op/hook/require.t
+t/lib/caller/Bicycle.pm			test Module for t/op/hook/require.t (cyclic)
+t/lib/caller/Bpack.pm			test Module for caller.t and t/op/hook/require.t
+t/lib/caller/Cpack.pm			test Module for caller.t and t/op/hook/require.t
+t/lib/caller/Cycle.pm			test Module for t/op/hook/require.t (cyclic)
+t/lib/caller/Foo.pm			test Module for caller.t and t/op/hook/require.t
+t/lib/caller/Tricycle.pm		test Module for t/op/hook/require.t (cyclic)
 t/lib/CannotParse.pm			For test case in op/require_errors.t
 t/lib/charnames/alias			Tests of "use charnames" with aliases.
 t/lib/Cname.pm				Test charnames in regexes (op/pat.t)
@@ -5825,10 +5833,6 @@ t/lib/feature/nonesuch			Tests for enabling/disabling nonexistent feature
 t/lib/feature/removed			Tests for enabling/disabling removed feature
 t/lib/feature/say			Tests for enabling/disabling say feature
 t/lib/feature/switch			Tests for enabling/disabling switch feature
-t/lib/GH_15109/Apack.pm			test Module for caller.t
-t/lib/GH_15109/Bpack.pm			test Module for caller.t
-t/lib/GH_15109/Cpack.pm			test Module for caller.t
-t/lib/GH_15109/Foo.pm			test Module for caller.t
 t/lib/h2ph.h				Test header file for h2ph
 t/lib/h2ph.pht				Generated output from h2ph.h by h2ph, for comparison
 t/lib/locale/latin1			Part of locale.t in Latin 1
@@ -6044,6 +6048,7 @@ t/op/hashassign.t			See if hash assignments work
 t/op/hashwarn.t				See if warnings for bad hash assignments work
 t/op/heredoc.t				See if heredoc edge and corner cases work
 t/op/hexfp.t				See if hexadecimal float literals work
+t/op/hook/require.t			See if require hooks work properly.
 t/op/inc.t				See if inc/dec of integers near 32 bit limit work
 t/op/inccode.t				See if coderefs work in @INC
 t/op/inccode-tie.t			See if tie to @INC works

dist/threads-shared/lib/threads/shared.pm

@@ -8,7 +8,7 @@ use Config;
 
 use Scalar::Util qw(reftype refaddr blessed);
 
-our $VERSION = '1.66'; # Please update the pod, too.
+our $VERSION = '1.67'; # Please update the pod, too.
 my $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
@@ -196,7 +196,7 @@ threads::shared - Perl extension for sharing data structures between threads
 
 =head1 VERSION
 
-This document describes threads::shared version 1.66
+This document describes threads::shared version 1.67
 
 =head1 SYNOPSIS
 

dist/threads-shared/shared.xs

@@ -40,7 +40,7 @@
  * proxy PVLV element with attached element magic.
  *
  * Pointers to the shared SV are squirrelled away in the mg->mg_ptr field
- * of magic (with mg_len == 0), and in the IV2PTR(SvIV(sv)) field of tied
+ * of magic (with mg_len == 0), and in the INT2PTR(SvIV(sv)) field of tied
  * object SVs. These pointers have to be hidden like this because they
  * cross interpreter boundaries, and we don't want sv_clear() and friends
  * following them.

embed.fnc

@@ -1789,6 +1789,11 @@ dp	|int	|magic_clearhint|NN SV *sv				\
 dp	|int	|magic_clearhints					\
 				|NN SV *sv				\
 				|NN MAGIC *mg
+p	|int	|magic_clearhook|NULLOK SV *sv				\
+				|NN MAGIC *mg
+p	|int	|magic_clearhookall					\
+				|NULLOK SV *sv				\
+				|NN MAGIC *mg
 p	|int	|magic_clearisa |NULLOK SV *sv				\
 				|NN MAGIC *mg
 p	|int	|magic_clearpack|NN SV *sv				\
@@ -1808,6 +1813,9 @@ p	|int	|magic_existspack					\
 p	|int	|magic_freearylen_p					\
 				|NN SV *sv				\
 				|NN MAGIC *mg
+dp	|int	|magic_freedestruct					\
+				|NN SV *sv				\
+				|NN MAGIC *mg
 p	|int	|magic_freemglob|NN SV *sv				\
 				|NN MAGIC *mg
 p	|int	|magic_freeovrld|NN SV *sv				\
@@ -1886,6 +1894,11 @@ p	|int	|magic_setenv	|NN SV *sv				\
 				|NN MAGIC *mg
 dp	|int	|magic_sethint	|NN SV *sv				\
 				|NN MAGIC *mg
+p	|int	|magic_sethook	|NULLOK SV *sv				\
+				|NN MAGIC *mg
+p	|int	|magic_sethookall					\
+				|NN SV *sv				\
+				|NN MAGIC *mg
 p	|int	|magic_setisa	|NN SV *sv				\
 				|NN MAGIC *mg
 p	|int	|magic_setlvref |NN SV *sv				\
@@ -1970,7 +1983,12 @@ Cop	|void * |more_bodies	|const svtype sv_type			\
 				|const size_t arena_size
 Cp	|const char *|moreswitches					\
 				|NN const char *s
+Adp	|void	|mortal_destructor_sv					\
+				|NN SV *coderef 			\
+				|NULLOK SV *args
 CRTXip	|char * |mortal_getenv	|NN const char *str
+Cdp	|void	|mortal_svfunc_x|SVFUNC_t f				\
+				|NULLOK SV *p
 Adop	|const struct mro_alg *|mro_get_from_name			\
 				|NN SV *name
 Adp	|AV *	|mro_get_linear_isa					\
@@ -3202,6 +3220,10 @@ Adp	|SV *	|sv_ref 	|NULLOK SV *dst 			\
 				|const int ob
 AMdip	|void	|SvREFCNT_dec	|NULLOK SV *sv
 AMdip	|void	|SvREFCNT_dec_NN|NN SV *sv
+Adip	|SV *	|SvREFCNT_dec_ret_NULL					\
+				|NULLOK SV *sv
+Adm	|void	|SvREFCNT_dec_set_NULL					\
+				|NULLOK SV *sv
 AMTdip	|SV *	|SvREFCNT_inc	|NULLOK SV *sv
 AMTdip	|SV *	|SvREFCNT_inc_NN|NN SV *sv
 AMTdip	|void	|SvREFCNT_inc_void					\

embed.h

@@ -107,6 +107,7 @@
 # define SvNV(a)                                Perl_SvNV(aTHX_ a)
 # define SvNV_nomg(a)                           Perl_SvNV_nomg(aTHX_ a)
 # define SvPVXtrue(a)                           Perl_SvPVXtrue(aTHX_ a)
+# define SvREFCNT_dec_ret_NULL(a)               Perl_SvREFCNT_dec_ret_NULL(aTHX_ a)
 # define SvTRUE(a)                              Perl_SvTRUE(aTHX_ a)
 # define SvTRUE_NN(a)                           Perl_SvTRUE_NN(aTHX_ a)
 # define SvTRUE_common(a,b)                     Perl_SvTRUE_common(aTHX_ a,b)
@@ -358,7 +359,9 @@
 # define mg_size(a)                             Perl_mg_size(aTHX_ a)
 # define mini_mktime                            Perl_mini_mktime
 # define moreswitches(a)                        Perl_moreswitches(aTHX_ a)
+# define mortal_destructor_sv(a,b)              Perl_mortal_destructor_sv(aTHX_ a,b)
 # define mortal_getenv                          Perl_mortal_getenv
+# define mortal_svfunc_x(a,b)                   Perl_mortal_svfunc_x(aTHX_ a,b)
 # define mro_get_linear_isa(a)                  Perl_mro_get_linear_isa(aTHX_ a)
 # define mro_method_changed_in(a)               Perl_mro_method_changed_in(aTHX_ a)
 # define msbit_pos32                            Perl_msbit_pos32
@@ -954,12 +957,15 @@
 #   define magic_clearenv(a,b)                  Perl_magic_clearenv(aTHX_ a,b)
 #   define magic_clearhint(a,b)                 Perl_magic_clearhint(aTHX_ a,b)
 #   define magic_clearhints(a,b)                Perl_magic_clearhints(aTHX_ a,b)
+#   define magic_clearhook(a,b)                 Perl_magic_clearhook(aTHX_ a,b)
+#   define magic_clearhookall(a,b)              Perl_magic_clearhookall(aTHX_ a,b)
 #   define magic_clearisa(a,b)                  Perl_magic_clearisa(aTHX_ a,b)
 #   define magic_clearpack(a,b)                 Perl_magic_clearpack(aTHX_ a,b)
 #   define magic_clearsig(a,b)                  Perl_magic_clearsig(aTHX_ a,b)
 #   define magic_copycallchecker(a,b,c,d,e)     Perl_magic_copycallchecker(aTHX_ a,b,c,d,e)
 #   define magic_existspack(a,b)                Perl_magic_existspack(aTHX_ a,b)
 #   define magic_freearylen_p(a,b)              Perl_magic_freearylen_p(aTHX_ a,b)
+#   define magic_freedestruct(a,b)              Perl_magic_freedestruct(aTHX_ a,b)
 #   define magic_freemglob(a,b)                 Perl_magic_freemglob(aTHX_ a,b)
 #   define magic_freeovrld(a,b)                 Perl_magic_freeovrld(aTHX_ a,b)
 #   define magic_freeutf8(a,b)                  Perl_magic_freeutf8(aTHX_ a,b)
@@ -988,6 +994,8 @@
 #   define magic_setdefelem(a,b)                Perl_magic_setdefelem(aTHX_ a,b)
 #   define magic_setenv(a,b)                    Perl_magic_setenv(aTHX_ a,b)
 #   define magic_sethint(a,b)                   Perl_magic_sethint(aTHX_ a,b)
+#   define magic_sethook(a,b)                   Perl_magic_sethook(aTHX_ a,b)
+#   define magic_sethookall(a,b)                Perl_magic_sethookall(aTHX_ a,b)
 #   define magic_setisa(a,b)                    Perl_magic_setisa(aTHX_ a,b)
 #   define magic_setlvref(a,b)                  Perl_magic_setlvref(aTHX_ a,b)
 #   define magic_setmglob(a,b)                  Perl_magic_setmglob(aTHX_ a,b)

ext/XS-APItest/APItest.pm

@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '1.31';
+our $VERSION = '1.32';
 
 require XSLoader;
 

ext/XS-APItest/APItest.xs

@@ -1515,6 +1515,11 @@ test_bool_internals_func(SV *true_sv, SV *false_sv, const char *msg) {
 }
 #include "const-c.inc"
 
+void
+destruct_test(pTHX_ void *p) {
+    warn("In destruct_test: %" SVf "\n", (SV*)p);
+}
+
 MODULE = XS::APItest            PACKAGE = XS::APItest
 
 INCLUDE: const-xs.inc
@@ -4908,6 +4913,24 @@ sv_refcnt(SV *sv)
     OUTPUT:
         RETVAL
 
+void
+test_mortal_destructor_sv(SV *coderef, SV *args)
+    CODE:
+        MORTALDESTRUCTOR_SV(coderef,args);
+
+void
+test_mortal_destructor_av(SV *coderef, AV *args)
+    CODE:
+        /* passing in an AV cast to SV is different from a SV ref to an AV */
+        MORTALDESTRUCTOR_SV(coderef, (SV *)args);
+
+void
+test_mortal_svfunc_x(SV *args)
+    CODE:
+        MORTALSVFUNC_X(&destruct_test,args);
+
+
+
 
 MODULE = XS::APItest            PACKAGE = XS::APItest
 

ext/XS-APItest/t/mortal_destructor.t

@@ -0,0 +1,30 @@
+use XS::APItest;
+use Test::More tests => 1;
+use Data::Dumper;
+my $warnings = "";
+$SIG{__WARN__} = sub { $warnings .= $_[0]; };
+
+warn "Before test_mortal_destructor_sv\n";
+test_mortal_destructor_sv(sub { warn "in perl callback: ", $_[0],"\n" }, {});
+warn "After test_mortal_destructor_sv\n";
+
+warn "Before test_mortal_destructor_av\n";
+test_mortal_destructor_av(sub { warn "in perl callback: @_\n" }, ["a","b","c"]);
+warn "After test_mortal_destructor_av\n";
+
+warn "Before test_mortal_destructor_x\n";
+test_mortal_svfunc_x("this is an argument");
+warn "After test_mortal_destructor_x\n";
+
+$warnings=~s/0x[A-Fa-f0-9]+/0xDEADBEEF/g;
+is($warnings, <<'EXPECT');
+Before test_mortal_destructor_sv
+in perl callback: HASH(0xDEADBEEF)
+After test_mortal_destructor_sv
+Before test_mortal_destructor_av
+in perl callback: a b c
+After test_mortal_destructor_av
+Before test_mortal_destructor_x
+In destruct_test: this is an argument
+After test_mortal_destructor_x
+EXPECT

gv.c

@@ -2219,6 +2219,13 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
                 if (memEQs(name, len, "\007LOBAL_PHASE"))
                     goto ro_magicalize;
                 break;
+            case '\010':        /* %{^HOOK} */
+                if (memEQs(name, len, "\010OOK")) {
+                    GvMULTI_on(gv);
+                    HV *hv = GvHVn(gv);
+                    hv_magic(hv, NULL, PERL_MAGIC_hook);
+                }
+                break;
             case '\014':
                 if ( memEQs(name, len, "\014AST_FH") ||               /* ${^LAST_FH} */
                      memEQs(name, len, "\014AST_SUCCESSFUL_PATTERN")) /* ${^LAST_SUCCESSFUL_PATTERN} */

intrpvar.h

@@ -130,7 +130,8 @@ thread's copy.
 =cut
 */
 
-PERLVAR(I, localizing,	U8)		/* are we processing a local() list? */
+PERLVAR(I, localizing,  U8)             /* are we processing a local() list?
+                                           0 = no, 1 = localizing, 2 = delocalizing */
 PERLVAR(I, in_eval,	U8)		/* trap "fatal" errors? */
 PERLVAR(I, defgv,	GV *)           /* the *_ glob */
 
@@ -495,6 +496,9 @@ PERLVAR(I, origfilename, char *)
 PERLVARI(I, xsubfilename, const char *, NULL)
 PERLVAR(I, diehook,	SV *)
 PERLVAR(I, warnhook,	SV *)
+/* keyword hooks*/
+PERLVARI(I, hook__require__before, SV *,NULL)
+PERLVARI(I, hook__require__after, SV *,NULL)
 
 /* switches */
 PERLVAR(I, patchlevel,	SV *)