pp_ctl.c - add support for a __REQUIRE__

Hook is called before anything else happens inside of a require,
and may return a callback which will be called after everything else
is done.

Author: demerphq

MANIFEST

@@ -6008,6 +6008,7 @@ t/op/repeat.t			See if x operator works
 t/op/require_37033.t		See if require always closes rsfp
 t/op/require_errors.t		See if errors from require are reported correctly
 t/op/require_gh20577.t		Make sure updating %INC from an INC hook doesnt break @INC
+t/op/require_hook.t		See if require hooks work properly.
 t/op/require_override.t		See if require handles no argument properly
 t/op/reset.t			See if reset operator works
 t/op/reverse.t			See if reverse operator works

intrpvar.h

@@ -492,6 +492,7 @@ PERLVAR(I, origfilename, char *)
 PERLVARI(I, xsubfilename, const char *, NULL)
 PERLVAR(I, diehook,	SV *)
 PERLVAR(I, warnhook,	SV *)
+PERLVARI(I, requirehook, SV *,NULL)
 
 /* switches */
 PERLVAR(I, patchlevel,	SV *)

mg.c

@@ -1670,15 +1670,20 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
     if (*s == '_') {
         if (memEQs(s, len, "__DIE__"))
             svp = &PL_diehook;
-        else if (memEQs(s, len, "__WARN__")
+        else if (memEQs(s, len, "__REQUIRE__")) {
+            if (sv && SvOK(sv) && (!SvROK(sv) || SvTYPE(SvRV(sv))!= SVt_PVCV))
+                croak("$SIG{__REQUIRE__} may only be a CODE reference or undef");
+            svp = &PL_requirehook;
+        } else if (memEQs(s, len, "__WARN__")
                  && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
             /* Merge the existing behaviours, which are as follows:
                magic_setsig, we always set svp to &PL_warnhook
                (hence we always change the warnings handler)
                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));
@@ -1750,8 +1755,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);

perl.c

@@ -938,6 +938,10 @@ perl_destruct(pTHXx)
     PL_warnhook = NULL;
     SvREFCNT_dec(PL_diehook);
     PL_diehook = NULL;
+    if (PL_requirehook) {
+        SvREFCNT_dec(PL_requirehook);
+        PL_requirehook = NULL;
+    }
 
     /* call exit list functions */
     while (PL_exitlistlen-- > 0)

pod/perldiag.pod

@@ -2162,6 +2162,12 @@ the C<encoding> pragma, is no longer supported as of Perl 5.26.0.
 Setting it to anything other than C<undef> is a fatal error as of Perl
 5.28.
 
+=item $SIG{__REQUIRE__} may only be a CODE reference or undef
+
+(F) You attempted to assign something other than undef or a CODE ref to
+C<$SIG{__REQUIRE__}>, require hooks only allow CODE refs.
+See L<perlfunc/require> for more details.
+
 =item entering effective %s failed
 
 (F) While under the C<use filetest> pragma, switching the real and

pod/perlfunc.pod

@@ -6969,6 +6969,55 @@ require executes at all.
 
 As of 5.37.7 C<@INC> values of undef will be silently ignored.
 
+The function C<require()> is difficult to wrap properly. Many modules consult
+the stack to find information about their caller, and injecting a new stack
+frame by wrapping C<require()> often breaks things. Nevertheless it can be
+very helpful to have the ability to perform actions before and after a
+C<require>, for instance for trace utilities like C<Devel::TraceUse> or to
+measure time to load and memory consumption of the require graph. Because of
+the difficulties in safely creating a C<require()> wrapper in 5.37.7 we
+introduced a new mechanism.
+
+As of 5.37.7, prior to any other actions it performs, C<require> will check if
+C<$SIG{__REQUIRE__}> contains a coderef, and if it does it will be called with
+the filename form of the item being loaded. This function call is informative
+only, and will not affect the require process except by throwing a fatal
+exception, which will be treated as though the required code itself had thrown
+an exception. However the function may return a code reference, which will be
+executed in an eval with no arguments after the require completes, regardless
+of how the compilation completed even if the require throws a fatal exception.
+The function must consult C<%INC> to determine if the require failed or not.
+For instance the following code will print some diagnostics before and after
+every C<require> statement. The example also includes logic to chain the
+signal, so that multiple signals can cooperate. Well behaved
+C<$SIG{__REQUIRE__}> handlers should always take this into account.
+
+    {
+        my $old_hook = $SIG{__REQUIRE__};
+        local $SIG{__REQUIRE__} = sub {
+            my ($name) = @_;
+            my $old_hook_ret;
+            $old_hook_ret = $old_hook->($name) if $old_hook;
+            warn "Requiring: $name\n";
+            return sub {
+                $old_hook_ret->() if $old_hook_ret;
+                warn sprintf "Finished requiring %s: %s\n",
+                        $name, $INC{$name} ? "loaded" :"failed";
+            };
+        };
+        require Whatever;
+    }
+
+This hook executes for ALL C<require> statements, unlike C<INC> and C<INCDIR>
+hooks, which are only executed for relative file names, and it executes first
+before any other special behaviour inside of require. Note that the initial hook
+in C<$SIG{__REQUIRE__}> is *not* executed inside of an eval, and throwing an
+exception will stop further processing, but the after hook it may return is
+executed inside of an eval, and any exceptions it throws will be silently ignored.
+This is because it executes inside of the scope cleanup logic that is triggered
+after the require completes, and an exception at this time would not stop the
+module from being loaded, etc.
+
 For a yet-more-powerful import facility, see
 L<C<use>|/use Module VERSION LIST> and L<perlmod>.
 

pod/perlvar.pod

@@ -779,6 +779,13 @@ and use an C<END{}> or CORE::GLOBAL::die override instead.
 See L<perlfunc/die>, L<perlfunc/warn>, L<perlfunc/eval>, and
 L<warnings> for additional information.
 
+The routine indicated by C<$SIG{__REQUIRE__}> is called by C<require>
+before it looks up C<@INC>, or compiles any code. It is called
+with a single argument, the filename for the item being required (package
+names are converted to paths). It may return a coderef which will be
+executed when the C<require> completes, either via exception or via
+completion of the require statement.
+
 =item $BASETIME
 
 =item $^T

pp_ctl.c

@@ -4089,6 +4089,19 @@ S_require_version(pTHX_ SV *sv)
     RETPUSHYES;
 }
 
+static void
+S_call_post_require_hook(pTHX_ SV *hook_sv) {
+    dSP;
+    sv_2mortal(hook_sv);
+    ENTER_with_name("call_POST_REQUIRE");
+    SAVETMPS;
+    PUSHMARK(SP);
+    int count = call_sv(hook_sv, G_VOID);
+    FREETMPS;
+    LEAVE_with_name("call_POST_REQUIRE");
+}
+
+
 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
  * The first form will have already been converted at compile time to
  * the second form */
@@ -4243,6 +4256,27 @@ S_require_file(pTHX_ SV *sv)
 
     PERL_DTRACE_PROBE_FILE_LOADING(unixname);
 
+    SV *after_requirehook_sv = NULL;
+    if (PL_requirehook && SvROK(PL_requirehook) && SvTYPE(SvRV(PL_requirehook)) == SVt_PVCV) {
+        SV* name_sv = sv_mortalcopy(sv);
+
+        ENTER_with_name("call_PRE_REQUIRE");
+        SAVETMPS;
+        EXTEND(SP, 1);
+        PUSHMARK(SP);
+        PUSHs(name_sv); /* always use the object for method calls */
+        PUTBACK;
+        int count = call_sv(PL_requirehook, G_SCALAR);
+        SPAGAIN;
+        if (count && SvOK(*SP) && SvROK(*SP) && SvTYPE(SvRV(*SP)) == SVt_PVCV)
+            after_requirehook_sv = SvREFCNT_inc(*SP);
+        FREETMPS;
+        LEAVE_with_name("call_PRE_REQUIRE");
+        if (after_requirehook_sv)
+            SAVEDESTRUCTOR_X(S_call_post_require_hook, after_requirehook_sv);
+    }
+
+
     /* Try to locate and open a file, possibly using @INC  */
 
     /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load

sv.c

@@ -15811,6 +15811,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_xsubfilename	= proto_perl->Ixsubfilename;
     PL_diehook		= sv_dup_inc(proto_perl->Idiehook, param);
     PL_warnhook		= sv_dup_inc(proto_perl->Iwarnhook, param);
+    PL_requirehook      = sv_dup_inc(proto_perl->Irequirehook, param);
 
     /* switches */
     PL_patchlevel	= sv_dup_inc(proto_perl->Ipatchlevel, param);

t/op/require_hook.t

@@ -0,0 +1,54 @@
+#!perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    require './test.pl';
+    set_up_inc( qw(../lib) );
+}
+
+use strict;
+use warnings;
+
+plan(tests => 4);
+
+# Dedupe @INC. In a future patch we /may/ refuse to process items
+# more than once and deduping here will prevent the tests from failing
+# should we make that change.
+my %seen; @INC = grep {!$seen{$_}++} @INC;
+{
+    # as of 5.37.7
+    fresh_perl_like(
+        '$SIG{__REQUIRE__} = "x";',
+        qr!\$SIG\{__REQUIRE__\} may only be a CODE reference or undef!,
+        { }, '$SIG{__REQUIRE__} forbids non code refs (string)');
+}
+{
+    # as of 5.37.7
+    fresh_perl_like(
+        '$SIG{__REQUIRE__} = [];',
+        qr!\$SIG\{__REQUIRE__\} may only be a CODE reference or undef!,
+        { }, '$SIG{__REQUIRE__} forbids non code refs (array ref)');
+}
+{
+    # as of 5.37.7
+    fresh_perl_like(
+        '$SIG{__REQUIRE__} = sub { die "Not allowed to load $_[0]" }; require Frobnitz;',
+        qr!Not allowed to load Frobnitz\.pm!,
+        { }, '$SIG{__REQUIRE__} exceptions stop require');
+}
+{
+    # as of 5.37.7
+    fresh_perl_is(
+        'use lib "./lib/caller"; '.
+        '$SIG{__REQUIRE__} = sub { my ($name)= @_; warn "before $name"; '.
+        'return sub { warn "after $name" } }; require Apack;',
+        <<'EOF_WANT',
+before Apack.pm at - line 1.
+before Bpack.pm at - line 1.
+before Cpack.pm at - line 1.
+after Cpack.pm at - line 1.
+after Bpack.pm at - line 1.
+after Apack.pm at - line 1.
+EOF_WANT
+        { }, '$SIG{__REQUIRE__} works as expected with t/lib/caller/Apack');
+}