pp_ctl.c - add support for hooking require.

This defines a new magic hash C<%{^HOOK}> which is intended to be used for
hooking keywords. It is similar to %SIG in that the values it contains
are validated on set, and it is not allowed to store something in
C<%{^HOOK}> that isn't supposed to be there. Hooks are expected to be
coderefs (people can use currying if they really want to put an object
in there, the API is deliberately simple.)

The C<%{^HOOK}> hash is documented to have keys of the form
"${keyword}__${phase}" where $phase is either "before" or "after"
and in this initial release two hooks are supported,
"require__before" and "require__after":

The C<require__before> hook is called before require is executed,
including any @inc hooks that might be fired. It is called with the path
of the file being required, just as would be stored in %INC. The hook
may alter the filename by writing to $_[0] and it may return a coderef
to be executed *after* the require has completed, otherwise the return
is ignored.  This coderef is also called with the path of the file which
was required, and it will be called regardless as to whether the require
(or its dependencies) die during execution.  This mechanism makes it
trivial and safe to share state between the initial hook and the coderef
it returns.

The C<require__after> hook is similar to the C<require__before> hook
however except that it is called after the require completes
(successfully or not), and its return is ignored always.

Author: demerphq

MANIFEST

@@ -5786,10 +5786,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
-t/lib/caller/Bpack.pm			test Module for caller.t
-t/lib/caller/Cpack.pm			test Module for caller.t
-t/lib/caller/Foo.pm			test Module for caller.t
+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)
@@ -6044,6 +6047,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

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				\
@@ -1886,6 +1891,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				\
@@ -4792,6 +4802,8 @@ p	|UV	|_to_upper_title_latin1 				\
 				|const char S_or_s
 #endif /* defined(PERL_IN_PP_C) || defined(PERL_IN_UTF8_C) */
 #if defined(PERL_IN_PP_CTL_C)
+S	|void	|call_post_require_hook 				\
+				|NN SV *hook_arg_av
 RS	|PerlIO *|check_type_and_open					\
 				|NN SV *name
 S	|void	|destroy_matcher|NN PMOP *matcher

embed.h

@@ -955,6 +955,8 @@
 #   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)
@@ -989,6 +991,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)
@@ -1469,6 +1473,7 @@
 #     define _to_upper_title_latin1(a,b,c,d)    Perl__to_upper_title_latin1(aTHX_ a,b,c,d)
 #   endif /* defined(PERL_IN_PP_C) || defined(PERL_IN_UTF8_C) */
 #   if defined(PERL_IN_PP_CTL_C)
+#     define call_post_require_hook(a)          S_call_post_require_hook(aTHX_ a)
 #     define check_type_and_open(a)             S_check_type_and_open(aTHX_ a)
 #     define destroy_matcher(a)                 S_destroy_matcher(aTHX_ a)
 #     define do_smartmatch(a,b,c)               S_do_smartmatch(aTHX_ a,b,c)

embedvar.h

@@ -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} */

gv.c

@@ -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 *)

intrpvar.h

@@ -1748,7 +1748,8 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
                For magic_clearsig, we don't change the warnings handler if it's
                set to the &PL_warnhook.  */
             svp = &PL_warnhook;
-        } else if (sv) {
+        }
+        else if (sv) {
             SV *tmp = sv_newmortal();
             Perl_croak(aTHX_ "No such hook: %s",
                                 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
@@ -1820,8 +1821,9 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
         if (i) {
             (void)rsignal(i, PL_csighandlerp);
         }
-        else
+        else {
             *svp = SvREFCNT_inc_simple_NN(sv);
+        }
     } else {
         if (sv && SvOK(sv)) {
             s = SvPV_force(sv, len);
@@ -1891,6 +1893,92 @@ Perl_magic_setsigall(pTHX_ SV* sv, MAGIC* mg)
     return 0;
 }
 
+int
+Perl_magic_clearhook(pTHX_ SV *sv, MAGIC *mg)
+{
+    PERL_ARGS_ASSERT_MAGIC_CLEARHOOK;
+
+    magic_sethook(NULL, mg);
+    return sv_unmagic(sv, mg->mg_type);
+}
+
+/* sv of NULL signifies that we're acting as magic_clearhook.  */
+int
+Perl_magic_sethook(pTHX_ SV *sv, MAGIC *mg)
+{
+    SV** svp = NULL;
+    STRLEN len;
+    const char *s = MgPV_const(mg,len);
+
+    PERL_ARGS_ASSERT_MAGIC_SETHOOK;
+
+    if (memEQs(s, len, "require__before")) {
+        svp = &PL_hook__require__before;
+    }
+    else if (memEQs(s, len, "require__after")) {
+        svp = &PL_hook__require__after;
+    }
+    else {
+        SV *tmp = sv_newmortal();
+        Perl_croak(aTHX_ "Attempt to set unknown hook '%s' in %%{^HOOK}",
+                            pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
+    }
+    if (sv && SvOK(sv) && (!SvROK(sv) || SvTYPE(SvRV(sv))!= SVt_PVCV))
+        croak("${^HOOK}{%.*s} may only be a CODE reference or undef", (int)len, s);
+
+    if (svp) {
+        if (*svp)
+            SvREFCNT_dec(*svp);
+
+        if (sv)
+            *svp = SvREFCNT_inc_simple_NN(sv);
+        else
+            *svp = NULL;
+    }
+
+    return 0;
+}
+
+int
+Perl_magic_sethookall(pTHX_ SV* sv, MAGIC* mg)
+{
+    PERL_ARGS_ASSERT_MAGIC_SETHOOKALL;
+    PERL_UNUSED_ARG(mg);
+
+    if (PL_localizing == 1) {
+        SAVEGENERICSV(PL_hook__require__before);
+        PL_hook__require__before = NULL;
+        SAVEGENERICSV(PL_hook__require__after);
+        PL_hook__require__after = NULL;
+    }
+    else
+    if (PL_localizing == 2) {
+        HV* hv = (HV*)sv;
+        HE* current;
+        hv_iterinit(hv);
+        while ((current = hv_iternext(hv))) {
+            SV* hookelem = hv_iterval(hv, current);
+            mg_set(hookelem);
+        }
+    }
+    return 0;
+}
+
+int
+Perl_magic_clearhookall(pTHX_ SV* sv, MAGIC* mg)
+{
+    PERL_ARGS_ASSERT_MAGIC_CLEARHOOKALL;
+    PERL_UNUSED_ARG(mg);
+    PERL_UNUSED_ARG(sv);
+
+    SvREFCNT_dec_set_NULL(PL_hook__require__before);
+
+    SvREFCNT_dec_set_NULL(PL_hook__require__after);
+
+    return 0;
+}
+
+
 int
 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
 {

mg.c

@@ -47,6 +47,8 @@
 	{ PERL_MAGIC_substr,         "substr(x)" },
 	{ PERL_MAGIC_nonelem,        "nonelem(Y)" },
 	{ PERL_MAGIC_defelem,        "defelem(y)" },
+	{ PERL_MAGIC_hook,           "hook(Z)" },
+	{ PERL_MAGIC_hookelem,       "hookelem(z)" },
 	{ PERL_MAGIC_lvref,          "lvref(\\)" },
 	{ PERL_MAGIC_checkcall,      "checkcall(])" },
 	{ PERL_MAGIC_extvalue,       "extvalue(^)" },

mg_names.inc

@@ -82,6 +82,10 @@
       "/* nonelem 'Y' Array element that does not exist */" },
     { 'y', "want_vtbl_defelem | PERL_MAGIC_VALUE_MAGIC",
       "/* defelem 'y' Shadow \"foreach\" iterator variable / smart parameter vivification */" },
+    { 'Z', "want_vtbl_hook",
+      "/* hook 'Z' %{^HOOK} hash */" },
+    { 'z', "want_vtbl_hookelem",
+      "/* hookelem 'z' %{^HOOK} hash element */" },
     { '\\', "want_vtbl_lvref",
       "/* lvref '\\' Lvalue reference constructor */" },
     { ']', "want_vtbl_checkcall | PERL_MAGIC_VALUE_MAGIC",

mg_raw.h

@@ -55,6 +55,8 @@
 #define PERL_MAGIC_nonelem        'Y' /* Array element that does not exist */
 #define PERL_MAGIC_defelem        'y' /* Shadow "foreach" iterator variable /
                                          smart parameter vivification */
+#define PERL_MAGIC_hook           'Z' /* %{^HOOK} hash */
+#define PERL_MAGIC_hookelem       'z' /* %{^HOOK} hash element */
 #define PERL_MAGIC_lvref          '\\' /* Lvalue reference constructor */
 #define PERL_MAGIC_checkcall      ']' /* Inlining/mutation of call to this CV */
 #define PERL_MAGIC_extvalue       '^' /* Value magic available for use by extensions */
@@ -73,6 +75,8 @@ enum {		/* pass one of these to get_vtbl */
     want_vtbl_envelem,
     want_vtbl_hints,
     want_vtbl_hintselem,
+    want_vtbl_hook,
+    want_vtbl_hookelem,
     want_vtbl_isa,
     want_vtbl_isaelem,
     want_vtbl_lvref,
@@ -111,6 +115,8 @@ EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = {
     "envelem",
     "hints",
     "hintselem",
+    "hook",
+    "hookelem",
     "isa",
     "isaelem",
     "lvref",
@@ -172,6 +178,8 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
   { 0, Perl_magic_setenv, 0, Perl_magic_clearenv, 0, 0, 0, 0 },
   { 0, 0, 0, Perl_magic_clearhints, 0, 0, 0, 0 },
   { 0, Perl_magic_sethint, 0, Perl_magic_clearhint, 0, 0, 0, 0 },
+  { 0, Perl_magic_sethookall, 0, Perl_magic_clearhookall, 0, 0, 0, 0 },
+  { 0, Perl_magic_sethook, 0, Perl_magic_clearhook, 0, 0, 0, 0 },
   { 0, Perl_magic_setisa, 0, Perl_magic_clearisa, 0, 0, 0, 0 },
   { 0, Perl_magic_setisa, 0, 0, 0, 0, 0, 0 },
   { 0, Perl_magic_setlvref, 0, 0, 0, 0, 0, 0 },
@@ -219,6 +227,8 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
 #define PL_vtbl_fm PL_magic_vtables[want_vtbl_fm]
 #define PL_vtbl_hints PL_magic_vtables[want_vtbl_hints]
 #define PL_vtbl_hintselem PL_magic_vtables[want_vtbl_hintselem]
+#define PL_vtbl_hook PL_magic_vtables[want_vtbl_hook]
+#define PL_vtbl_hookelem PL_magic_vtables[want_vtbl_hookelem]
 #define PL_vtbl_isa PL_magic_vtables[want_vtbl_isa]
 #define PL_vtbl_isaelem PL_magic_vtables[want_vtbl_isaelem]
 #define PL_vtbl_lvref PL_magic_vtables[want_vtbl_lvref]