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)
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
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 \
|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 \
# 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_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)
# define PL_hash_rand_bits_enabled (vTHX->Ihash_rand_bits_enabled)
# define PL_HasMultiCharFold (vTHX->IHasMultiCharFold)
# define PL_hintgv (vTHX->Ihintgv)
+# define PL_hook__require__after (vTHX->Ihook__require__after)
+# define PL_hook__require__before (vTHX->Ihook__require__before)
# define PL_hv_fetch_ent_mh (vTHX->Ihv_fetch_ent_mh)
# define PL_in_clean_all (vTHX->Iin_clean_all)
# define PL_in_clean_objs (vTHX->Iin_clean_objs)
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} */
=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 */
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 *)
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));
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);
}
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)
{
PERL_ARGS_ASSERT_MAGIC_SETISA;
{ 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(^)" },
"/* 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",
#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 */
want_vtbl_envelem,
want_vtbl_hints,
want_vtbl_hintselem,
+ want_vtbl_hook,
+ want_vtbl_hookelem,
want_vtbl_isa,
want_vtbl_isaelem,
want_vtbl_lvref,
"envelem",
"hints",
"hintselem",
+ "hook",
+ "hookelem",
"isa",
"isaelem",
"lvref",
{ 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 },
#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]
PL_warnhook = NULL;
SvREFCNT_dec(PL_diehook);
PL_diehook = NULL;
+ SvREFCNT_dec(PL_hook__require__before);
+ PL_hook__require__before = NULL;
+ SvREFCNT_dec(PL_hook__require__after);
+ PL_hook__require__after = NULL;
/* call exit list functions */
while (PL_exitlistlen-- > 0)
Setting it to anything other than C<undef> is a fatal error as of Perl
5.28.
+=item ${^HOOK}{%s} may only be a CODE reference or undef
+
+(F) You attempted to assign something other than undef or a CODE ref to
+C<%{^HOOK}>. Hooks may only be CODE refs. See L<perlvar/%{^HOOK}> for
+details.
+
+=item Attempt to set unknown hook '%s' in %{^HOOK}
+
+(F) You attempted to assign something other than undef or a CODE ref to
+C<%{^HOOK}>. Hooks may only be CODE refs. See L<perlvar/%{^HOOK}> for
+details.
+
=item entering effective %s failed
(F) While under the C<use filetest> pragma, switching the real and
=item Missing or undefined argument to %s
-(F) You tried to call require or do with no argument or with an undefined
-value as an argument. Require expects either a package name or a
-file-specification as an argument; do expects a filename. See
+(F) You tried to call C<require> or C<do> with no argument or with an
+undefined value as an argument. Require expects either a package name or
+a file-specification as an argument; do expects a filename. See
L<perlfunc/require EXPR> and L<perlfunc/do EXPR>.
+=item Missing or undefined argument to %s via %{^HOOK}{require__before}
+
+(F) A C<%{^HOOK}{require__before}> hook rewrote the name of the file being
+compiled with C<require> or C<do> with an empty string an undefined value
+which is forbidden. See L<perlvar/%{^HOOK}> and L<perlfunc/require EXPR>.
+
=item Missing right brace on \%c{} in regex; marked by S<<-- HERE> in m/%s/
(F) Missing right brace in C<\x{...}>, C<\p{...}>, C<\P{...}>, or C<\N{...}>.
As of 5.37.7 C<@INC> values of undef will be silently ignored.
-For a yet-more-powerful import facility, see
+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 the memory
+consumption of the require graph. Because of the difficulties in safely
+creating a C<require()> wrapper in 5.37.10 we introduced a new mechanism.
+
+As of 5.37.10, prior to any other actions it performs, C<require> will
+check if C<${^HOOK}{require__before}> contains a coderef, and if it does
+it will be called with the filename form of the item being loaded. The hook
+may modify C<$_[0]> to load a different filename, or it may throw a fatal
+exception to cause the require to fail, which will be treated as though the
+required code itself had thrown an exception.
+
+The C<${^HOOK}{require__before}> hook may return a code reference, in
+which case the code reference will be executed (in an eval with the
+filname as a parameter) after the require completes. It will be executed
+regardless of how the compilation completed, and even if the require
+throws a fatal exception. The function may 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<${^HOOK}{require__before}>
+handlers should always take this into account.
+
+ {
+ use Scalar::Util qw(reftype);
+ my $old_hook = ${^HOOK}{require__before};
+ local ${^HOOK}{require__before} = 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 ref($old_hook_ret)
+ && reftype($old_hook_ret) eq "CODE";
+ 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<${^HOOK}{require__before}> 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.
+
+There is a similar hook that fires after require completes,
+C<${^HOOK}{require__after}>, which will be called after each require statement
+completes, either via an exception or successfully. It will be called with
+the filename of the most recently executed require statement. It is executed
+in an eval, and will not in any way affect execution.
+
+For a yet-more-powerful import facility built around C<require>, see
L<C<use>|/use Module VERSION LIST> and L<perlmod>.
=item reset EXPR
y PERL_MAGIC_defelem vtbl_defelem Shadow "foreach" iterator
variable / smart parameter
vivification
+ Z PERL_MAGIC_hook vtbl_hook %{^HOOK} hash
+ z PERL_MAGIC_hookelem vtbl_hookelem %{^HOOK} hash element
\ PERL_MAGIC_lvref vtbl_lvref Lvalue reference
constructor
] PERL_MAGIC_checkcall vtbl_checkcall Inlining/mutation of call
=for apidoc_item ||PERL_MAGIC_fm
=for apidoc_item ||PERL_MAGIC_hints
=for apidoc_item ||PERL_MAGIC_hintselem
+=for apidoc_item ||PERL_MAGIC_hook
+=for apidoc_item ||PERL_MAGIC_hookelem
=for apidoc_item ||PERL_MAGIC_isa
=for apidoc_item ||PERL_MAGIC_isaelem
=for apidoc_item ||PERL_MAGIC_lvref
See L<perlfunc/die>, L<perlfunc/warn>, L<perlfunc/eval>, and
L<warnings> for additional information.
+=item %{^HOOK}
+X<%{^HOOK}>
+
+This hash contains coderefs which are called when various perl keywords
+which are hard or impossible to wrap are called. The keys of this hash
+are named after the keyword that is being hooked, followed by two
+underbars and then a phase term; either "before" or "after".
+
+Perl will throw an error if you attempt modify a key which is not
+documented to exist, or if you attempt to store anything other than a
+code reference or undef in the hash. If you wish to use an object to
+implement a hook you can use currying to embed the object into an
+anonymous code reference.
+
+Currently there is only one keyword which can be hooked, C<require>, but
+it is expected that in future releases there will be additional keywords
+with hook support.
+
+=over 4
+
+=item require__before
+
+The routine indicated by C<${^HOOK}{require__before}> is called by
+C<require> B<before> it checks C<%INC>, looks up C<@INC>, calls INC
+hooks, 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 alter this filename to change what file is loaded. If
+the hook dies during execution then it will block the require from executing.
+
+In order to make it easy to perform an action with shared state both
+before and after the require keyword was executed the C<require__before>
+hook may return a "post-action" coderef which will in turn be executed when
+the C<require> completes. This coderef will be executed regardless as to
+whether the require completed succesfully or threw an exception. It will
+be called with the filename that was required. You can check %INC to
+determine if the require was successful. Any other return from the
+C<require__before> hook will be silently ignored.
+
+C<require__before> hooks are called in FIFO order, and if the hook
+returns a code reference those code references will be called in FILO
+order. In other words if A requires B requires C, then
+C<require__before> will be called first for A, then B and then C, and
+the post-action code reference will executed first for C, then B and
+then finally A.
+
+Well behaved code should ensure that when setting up a
+C<require__before> hook that any prior installed hook will be called,
+and that their return value, if a code reference, will be called as
+well. See L<perlfunc/require> for an example implementation.
+
+=item require__after
+
+The routine indicated by C<${^HOOK}{require__after}> is called by
+C<require> B<after> the require completes. It is called with a single
+argument, the filename for the item being required (package names are
+converted to paths). It is executed when the C<require> completes,
+either via exception or via completion of the require statement, and you
+can check C<%INC> to determine if the require was successful.
+
+The C<require__after> hook is called for each required file in FILO
+order. In other words if A requires B requires C, then C<require__after>
+will be called first for C, then B and then A.
+
+=back
+
=item $BASETIME
=item $^T
if (!(name && len > 0 && *name))
DIE(aTHX_ "Missing or undefined argument to %s", op_name);
+ if (
+ PL_hook__require__before
+ && SvROK(PL_hook__require__before)
+ && SvTYPE(SvRV(PL_hook__require__before)) == SVt_PVCV
+ ) {
+ SV* name_sv = sv_mortalcopy(sv);
+ SV *post_hook__require__before_sv = NULL;
+
+ 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_hook__require__before, G_SCALAR);
+ SPAGAIN;
+ if (count && SvOK(*SP) && SvROK(*SP) && SvTYPE(SvRV(*SP)) == SVt_PVCV)
+ post_hook__require__before_sv = SvREFCNT_inc_simple_NN(*SP);
+ if (!sv_streq(name_sv,sv)) {
+ /* they modified the name argument, so do some sleight of hand */
+ name = SvPV_nomg_const(name_sv, len);
+ if (!(name && len > 0 && *name))
+ DIE(aTHX_ "Missing or undefined argument to %s via %%{^HOOK}{require__before}",
+ op_name);
+ sv = SvREFCNT_inc_simple_NN(name_sv);
+ }
+ FREETMPS;
+ LEAVE_with_name("call_PRE_REQUIRE");
+ if (post_hook__require__before_sv) {
+ MORTALDESTRUCTOR_SV(post_hook__require__before_sv, newSVsv(sv));
+ }
+ }
+ if (
+ PL_hook__require__after
+ && SvROK(PL_hook__require__after)
+ && SvTYPE(SvRV(PL_hook__require__after)) == SVt_PVCV
+ ) {
+ MORTALDESTRUCTOR_SV(PL_hook__require__after, newSVsv(sv));
+ }
+
#ifndef VMS
/* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
if (op_is_require) {
assert(sv); assert(mg)
PERL_CALLCONV int
+Perl_magic_clearhook(pTHX_ SV *sv, MAGIC *mg)
+ __attribute__visibility__("hidden");
+#define PERL_ARGS_ASSERT_MAGIC_CLEARHOOK \
+ assert(mg)
+
+PERL_CALLCONV int
+Perl_magic_clearhookall(pTHX_ SV *sv, MAGIC *mg)
+ __attribute__visibility__("hidden");
+#define PERL_ARGS_ASSERT_MAGIC_CLEARHOOKALL \
+ assert(mg)
+
+PERL_CALLCONV int
Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
__attribute__visibility__("hidden");
#define PERL_ARGS_ASSERT_MAGIC_CLEARISA \
assert(sv); assert(mg)
PERL_CALLCONV int
+Perl_magic_sethook(pTHX_ SV *sv, MAGIC *mg)
+ __attribute__visibility__("hidden");
+#define PERL_ARGS_ASSERT_MAGIC_SETHOOK \
+ assert(mg)
+
+PERL_CALLCONV int
+Perl_magic_sethookall(pTHX_ SV *sv, MAGIC *mg)
+ __attribute__visibility__("hidden");
+#define PERL_ARGS_ASSERT_MAGIC_SETHOOKALL \
+ assert(sv); assert(mg)
+
+PERL_CALLCONV int
Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
__attribute__visibility__("hidden");
#define PERL_ARGS_ASSERT_MAGIC_SETISA \
desc => 'Tied scalar or handle' },
qr => { char => 'r', vtable => 'regexp', value_magic => 1,
readonly_acceptable => 1, desc => 'Precompiled qr// regex' },
+
+ hook => { char => 'Z',
+ vtable => 'hook', desc => '%{^HOOK} hash' },
+ hookelem => { char => 'z',
+ vtable => 'hookelem', desc => '%{^HOOK} hash element' },
+
sig => { char => 'S', vtable => 'sig',
desc => '%SIG hash' },
sigelem => { char => 's', vtable => 'sigelem',
desc => '%SIG hash element' },
+
taint => { char => 't', vtable => 'taint', value_magic => 1,
desc => 'Taintedness' },
uvar => { char => 'U', vtable => 'uvar',
'sig' => { set => 'setsigall' },
'sigelem' => {get => 'getsig', set => 'setsig', clear => 'clearsig',
cond => '#ifndef PERL_MICRO'},
+
+ 'hook' => { set => 'sethookall', clear => 'clearhookall' },
+ 'hookelem' => {set => 'sethook', clear => 'clearhook'},
+
'pack' => {len => 'sizepack', clear => 'wipepack'},
'packelem' => {get => 'getpack', set => 'setpack', clear => 'clearpack'},
'dbline' => {set => 'setdbline'},
PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
+ PL_hook__require__before = sv_dup_inc(proto_perl->Ihook__require__before, param);
+ PL_hook__require__after = sv_dup_inc(proto_perl->Ihook__require__after, param);
+
/* switches */
PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
PL_inplace = SAVEPV(proto_perl->Iinplace);
my $which = $ENV{PERL_TEST_HARNESS_ASAP} ? \@last : \@next;
push @$which, qw(comp run cmd);
- push @$which, qw(io re opbasic op uni mro lib class porting perf test_pl);
+ push @$which, qw(io re opbasic op op/hook uni mro lib class porting perf test_pl);
push @$which, 'japh' if $torture;
push @$which, 'win32' if $^O eq 'MSWin32';
push @$which, 'benchmark' if $ENV{PERL_BENCHMARK};
--- /dev/null
+require Tricycle; # part of a cyclic dependency chain
+
+1;
--- /dev/null
+require Bicycle; # part of a cyclic dependency chain
+
+1;
--- /dev/null
+require Cycle; # part of a cyclic dependency chain
+
+1;
}
else {
map { $files{$_}++ } <op/*>;
- map { delete $files{$_} } split /\n/, `ls op/* | cat`;
+ map { delete $files{"op/$_"} } split /\n/, `ls op/ | cat`;
}
ok( !(keys(%files)),'leftover op/* files' ) or diag(join(' ',sort keys %files));
--- /dev/null
+#!perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ require './test.pl';
+ set_up_inc( qw(../lib) );
+}
+
+use strict;
+use warnings;
+
+plan(tests => 14);
+
+{
+ fresh_perl_like(
+ '${^HOOK}{require__before} = "x";',
+ qr!\$\{\^HOOK\}\{require__before\} may only be a CODE reference or undef!,
+ { },
+ '%{^HOOK} forbids non code refs (string)');
+}
+{
+ fresh_perl_like(
+ '${^HOOK}{require__before} = [];',
+ qr!\$\{\^HOOK\}\{require__before\} may only be a CODE reference or undef!,
+ { },
+ '%{^HOOK} forbids non code refs (array)');
+}
+{
+ fresh_perl_like(
+ '${^HOOK}{require__before} = sub { die "Not allowed to load $_[0]" }; require Frobnitz;',
+ qr!Not allowed to load Frobnitz\.pm!,
+ { },
+ '${^HOOK}{require__before} exceptions stop require');
+}
+{
+ fresh_perl_is(
+ 'use lib "./lib/caller"; '.
+ '${^HOOK}{require__before} = '.
+ ' 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
+ { },
+ '${^HOOK}{require__before} with post action works as expected with t/lib/caller/Apack');
+}
+{
+ fresh_perl_is(
+ 'use lib "./lib/caller"; '.
+ '${^HOOK}{require__before} = '.
+ ' sub { $_[0] = "Apack.pm" if $_[0] eq "Cycle.pm";'.
+ ' my ($name) = @_; warn "before $name"; ' .
+ ' return sub { warn "after $name" } }; ' .
+ 'require Cycle;',
+ <<'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
+ { },
+ '${^HOOK}{require__before} with filename rewrite works as expected (Cycle.pm -> Apack.pm)');
+}
+{
+ fresh_perl_is(
+ 'use lib "./lib/caller"; '.
+ '${^HOOK}{require__before} = '.
+ ' sub { my ($name) = @_; my $n = ++$::counter; warn "before $name ($n)"; ' .
+ ' return sub { warn "after $name ($n)" } }; ' .
+ 'require Cycle;',
+ <<'EOF_WANT',
+before Cycle.pm (1) at - line 1.
+before Bicycle.pm (2) at - line 1.
+before Tricycle.pm (3) at - line 1.
+before Cycle.pm (4) at - line 1.
+after Cycle.pm (4) at - line 1.
+after Tricycle.pm (3) at - line 1.
+after Bicycle.pm (2) at - line 1.
+after Cycle.pm (1) at - line 1.
+EOF_WANT
+ { },
+ '${^HOOK}{require__before} with post action with state work as expected with t/lib/caller/Cycle');
+}
+{
+ fresh_perl_is(
+ 'use lib "./lib/caller"; my @seen;'.
+ '${^HOOK}{require__before} = '.
+ ' sub { die "Cycle detected: @seen $_[0]\n" if grep $_ eq $_[0], @seen; push @seen,$_[0]; ' .
+ ' return sub { pop @seen } }; ' .
+ 'require Cycle;',
+ <<'EOF_WANT',
+Cycle detected: Cycle.pm Bicycle.pm Tricycle.pm Cycle.pm
+Compilation failed in require at lib/caller/Bicycle.pm line 1.
+Compilation failed in require at lib/caller/Cycle.pm line 1.
+Compilation failed in require at - line 1.
+EOF_WANT
+ { },
+ '${^HOOK}{require__before} with post action with state work as expected with t/lib/caller/Cycle');
+}
+{
+ fresh_perl_is(
+ 'use lib "./lib/caller"; '.
+ '${^HOOK}{require__before} = '.
+ ' sub { my ($before_name) = @_; warn "before $before_name"; ' .
+ ' return sub { my ($after_name) = @_; warn "after $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
+ { },
+ '${^HOOK}{require__before} with post action and name arg works as expected');
+}
+{
+ fresh_perl_is(
+ 'use lib "./lib/caller"; '.
+ '${^HOOK}{require__before} = '.
+ ' sub { my ($name) = @_; warn "before $name" };' .
+ 'require Apack;',
+ <<'EOF_WANT',
+before Apack.pm at - line 1.
+before Bpack.pm at - line 1.
+before Cpack.pm at - line 1.
+EOF_WANT
+ { },
+ '${^HOOK}{require__before} with no post action works as expected with t/lib/caller/Apack');
+}
+{
+ fresh_perl_is(
+ 'use lib "./lib/caller"; '.
+ '${^HOOK}{require__after} = '.
+ ' sub { my ($name) = @_; warn "after $name" };' .
+ 'require Apack;',
+ <<'EOF_WANT',
+after Cpack.pm at - line 1.
+after Bpack.pm at - line 1.
+after Apack.pm at - line 1.
+EOF_WANT
+ { },
+ '${^HOOK}{require__after} works as expected with t/lib/caller/Apack');
+}
+{
+ fresh_perl_is(
+ 'use lib "./lib/caller"; '.
+ '%{^HOOK} = ( require__before => sub { print "before: $_[0]\n" },
+ require__after => sub { print "after: $_[0]\n" } );
+ { local %{^HOOK}; require Apack; }
+ print "done\n";',
+ "done\n",
+ { },
+ 'local %{^HOOK} works to clear hooks.'
+ );
+}
+{
+ fresh_perl_is(
+ 'use lib "./lib/caller"; '.
+ '%{^HOOK} = ( require__before => sub { print "before: $_[0]\n" },
+ require__after => sub { print "after: $_[0]\n" } );
+ { local %{^HOOK}; require Cycle; }
+ require Apack;',
+ <<'EOF_WANT',
+before: Apack.pm
+before: Bpack.pm
+before: Cpack.pm
+after: Cpack.pm
+after: Bpack.pm
+after: Apack.pm
+EOF_WANT
+ { },
+ 'local %{^HOOK} works to clear and restore hooks.'
+ );
+}
+{
+ fresh_perl_is(
+ 'use lib "./lib/caller"; '.
+ '%{^HOOK} = ( require__before => sub { print "before: $_[0]\n" } );
+ %{^HOOK} = ( require__after => sub { print "after: $_[0]\n" } );
+ require Apack;',
+ <<'EOF_WANT',
+after: Cpack.pm
+after: Bpack.pm
+after: Apack.pm
+EOF_WANT
+ { },
+ '%{^HOOK} = (...); works as expected (part 1)'
+ );
+}
+
+{
+ fresh_perl_is(
+ 'use lib "./lib/caller"; '.
+ '%{^HOOK} = ( require__after => sub { print "after: $_[0]\n" } );
+ %{^HOOK} = ( require__before => sub { print "before: $_[0]\n" } );
+ require Apack;',
+ <<'EOF_WANT',
+before: Apack.pm
+before: Bpack.pm
+before: Cpack.pm
+EOF_WANT
+ { },
+ '%{^HOOK} = (...); works as expected (part 2)'
+ );
+}
https://perl5.git.perl.org / perl5.git / commitdiff