From 77efb39417475f92f5120285ddb950d63cd5a321 Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Mon, 19 Dec 2022 18:19:31 +0100 Subject: [PATCH 1/7] t/lib/GH_15109 - rename to t/lib/caller I want to use these modules in other tests, so changing the name makes sense. --- MANIFEST | 8 ++++---- t/lib/GH_15109/Apack.pm | 4 ---- t/lib/GH_15109/Bpack.pm | 4 ---- t/lib/caller/Apack.pm | 4 ++++ t/lib/caller/Bpack.pm | 4 ++++ t/lib/{GH_15109 => caller}/Cpack.pm | 2 +- t/lib/{GH_15109 => caller}/Foo.pm | 0 t/op/caller.t | 6 +++--- 8 files changed, 16 insertions(+), 16 deletions(-) delete mode 100644 t/lib/GH_15109/Apack.pm delete mode 100644 t/lib/GH_15109/Bpack.pm create mode 100644 t/lib/caller/Apack.pm create mode 100644 t/lib/caller/Bpack.pm rename t/lib/{GH_15109 => caller}/Cpack.pm (71%) rename t/lib/{GH_15109 => caller}/Foo.pm (100%) diff --git a/MANIFEST b/MANIFEST index 82a02b667085..b0ee08ae72ef 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5786,6 +5786,10 @@ 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/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 +5829,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 diff --git a/t/lib/GH_15109/Apack.pm b/t/lib/GH_15109/Apack.pm deleted file mode 100644 index fa52ec8b537a..000000000000 --- a/t/lib/GH_15109/Apack.pm +++ /dev/null @@ -1,4 +0,0 @@ -# for use by caller.t for GH #15109 -package Apack; -use Bpack; -1; diff --git a/t/lib/GH_15109/Bpack.pm b/t/lib/GH_15109/Bpack.pm deleted file mode 100644 index f9421c813fc2..000000000000 --- a/t/lib/GH_15109/Bpack.pm +++ /dev/null @@ -1,4 +0,0 @@ -# for use by caller.t for GH #15109 -package Bpack; -use Cpack; -1; diff --git a/t/lib/caller/Apack.pm b/t/lib/caller/Apack.pm new file mode 100644 index 000000000000..597012102fe8 --- /dev/null +++ b/t/lib/caller/Apack.pm @@ -0,0 +1,4 @@ +# for use by caller.t for GH #15109 and other tests +package Apack; +use Bpack; +1; diff --git a/t/lib/caller/Bpack.pm b/t/lib/caller/Bpack.pm new file mode 100644 index 000000000000..db0dca99ff4e --- /dev/null +++ b/t/lib/caller/Bpack.pm @@ -0,0 +1,4 @@ +# for use by caller.t for GH #15109 and other tests +package Bpack; +use Cpack; +1; diff --git a/t/lib/GH_15109/Cpack.pm b/t/lib/caller/Cpack.pm similarity index 71% rename from t/lib/GH_15109/Cpack.pm rename to t/lib/caller/Cpack.pm index 94c409b05ce3..86c422f24e33 100644 --- a/t/lib/GH_15109/Cpack.pm +++ b/t/lib/caller/Cpack.pm @@ -1,4 +1,4 @@ -# for use by caller.t for GH #15109 +# for use by caller.t for GH #15109 and other tests package Cpack; diff --git a/t/lib/GH_15109/Foo.pm b/t/lib/caller/Foo.pm similarity index 100% rename from t/lib/GH_15109/Foo.pm rename to t/lib/caller/Foo.pm diff --git a/t/op/caller.t b/t/op/caller.t index 00bb984dcb19..7ae7fabab176 100644 --- a/t/op/caller.t +++ b/t/op/caller.t @@ -339,14 +339,14 @@ do './op/caller.pl' or die $@; # See that callers within a nested series of 'use's gets the right # filenames. { - local @INC = 'lib/GH_15109/'; + local @INC = 'lib/caller/'; # Apack use's Bpack which use's Cpack which populates @Cpack::caller # with the file:N of all the callers eval 'use Apack; 1'; is($@, "", "GH #15109 - eval"); is (scalar(@Cpack::callers), 10, "GH #15109 - callers count"); - like($Cpack::callers[$_], qr{GH_15109/Bpack.pm:3}, "GH #15109 level $_") for 0..2; - like($Cpack::callers[$_], qr{GH_15109/Apack.pm:3}, "GH #15109 level $_") for 3..5; + like($Cpack::callers[$_], qr{caller/Bpack.pm:3}, "GH #15109 level $_") for 0..2; + like($Cpack::callers[$_], qr{caller/Apack.pm:3}, "GH #15109 level $_") for 3..5; like($Cpack::callers[$_], qr{\(eval \d+\):1}, "GH #15109 level $_") for 6..8; like($Cpack::callers[$_], qr{caller\.t}, "GH #15109 level $_") for 9; From 283e506e6cb4a3efae7adfa3ba89b4999ffe8aa8 Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Fri, 10 Mar 2023 12:13:36 +0100 Subject: [PATCH 2/7] regen/mg_vtable.pl - rename confusing var %sig to %vtable_conf --- regen/mg_vtable.pl | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/regen/mg_vtable.pl b/regen/mg_vtable.pl index 578eabeaea11..e61dc2cce9ef 100644 --- a/regen/mg_vtable.pl +++ b/regen/mg_vtable.pl @@ -215,10 +215,9 @@ BEGIN ); -# %sig +# %vtable_conf # # This hash is mainly concerned with populating the vtable. -# (despite the name it has nothing to do with signals!) # # These have a subtly different "namespace" from the magic types. # @@ -247,9 +246,9 @@ BEGIN # dup # local # For each specified method, add a vtable function pointer -# of the form "Perl_magic_$sig{foo}{get}" etc +# of the form "Perl_magic_$vtable_conf{foo}{get}" etc -my %sig = +my %vtable_conf = ( 'sv' => {get => 'get', set => 'set'}, 'env' => {set => 'set_all_env', clear => 'clear_all_env'}, @@ -455,9 +454,9 @@ BEGIN } -# Process %sig - everything goes to mg_vtable.h +# Process %vtable_conf - everything goes to mg_vtable.h -my @names = sort keys %sig; +my @names = sort keys %vtable_conf; { my $want = join ",\n ", (map {"want_vtbl_$_"} @names), 'magic_vtable_max'; my $names = join qq{",\n "}, @names; @@ -505,7 +504,7 @@ BEGIN my @aliases; while (my $name = shift @names) { - my $data = $sig{$name}; + my $data = $vtable_conf{$name}; push @vtable_names, $name; my @funcs = map { $data->{$_} ? "Perl_magic_$data->{$_}" : 0; From 41bfa2b82ff47c0ad8609cc2a8ac80d5fab0fd07 Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Thu, 16 Mar 2023 18:40:35 +0100 Subject: [PATCH 3/7] sv.h - add SvREFCNT_dec_set_NULL() and also SvREFCNT_dec_ret_NULL() which is used to implement SvREFCNT_dec_set_NULL(). The set_NULL() macro is intended to be used to replace code like this: if (sv) { SvREFCNT_dec_NN(sv); sv = NULL; } The function form just facilitates it, and can be used in situations where returning NULL after decrementing a refcount would be reduce code complexity. --- embed.fnc | 4 ++++ embed.h | 1 + proto.h | 8 ++++++++ sv.h | 23 ++++++++++++++++++++++- sv_inline.h | 12 ++++++++++++ 5 files changed, 47 insertions(+), 1 deletion(-) diff --git a/embed.fnc b/embed.fnc index 176dc27c801e..59956aae7a9d 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3202,6 +3202,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 \ diff --git a/embed.h b/embed.h index 110b092fa2e0..d6feb979d96b 100644 --- a/embed.h +++ b/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) diff --git a/proto.h b/proto.h index 5df8193a974b..eedd5e36a2b2 100644 --- a/proto.h +++ b/proto.h @@ -76,6 +76,10 @@ Perl_Slab_Free(pTHX_ void *op); #define PERL_ARGS_ASSERT_SLAB_FREE \ assert(op) +/* PERL_CALLCONV void +SvREFCNT_dec_set_NULL(pTHX_ SV *sv); */ +#define PERL_ARGS_ASSERT_SVREFCNT_DEC_SET_NULL + PERL_CALLCONV char * Perl__byte_dump_string(pTHX_ const U8 * const start, const STRLEN len, const bool format); #define PERL_ARGS_ASSERT__BYTE_DUMP_STRING \ @@ -9642,6 +9646,10 @@ Perl_SvREFCNT_dec_NN(pTHX_ SV *sv); # define PERL_ARGS_ASSERT_SVREFCNT_DEC_NN \ assert(sv) +PERL_STATIC_INLINE SV * +Perl_SvREFCNT_dec_ret_NULL(pTHX_ SV *sv); +# define PERL_ARGS_ASSERT_SVREFCNT_DEC_RET_NULL + PERL_STATIC_INLINE SV * Perl_SvREFCNT_inc(SV *sv); # define PERL_ARGS_ASSERT_SVREFCNT_INC diff --git a/sv.h b/sv.h index be050f1d1bd2..2cd4ea2593ce 100644 --- a/sv.h +++ b/sv.h @@ -336,13 +336,30 @@ effects and you don't need the return value. C can only be used with expressions without side effects, you don't need the return value, and you know C is not C. -=for apidoc SvREFCNT_dec +=for apidoc SvREFCNT_dec +=for apidoc_item SvREFCNT_dec_set_NULL +=for apidoc_item SvREFCNT_dec_ret_NULL =for apidoc_item SvREFCNT_dec_NN These decrement the reference count of the given SV. C may only be used when C is known to not be C. +The function C is identical to the +C except it returns a NULL C. It is used by +C which is a macro which will, when passed a +non-NULL argument, decrement the reference count of its argument and +then set it to NULL. You can replace code of the following form: + + if (sv) { + SvREFCNT_dec_NN(sv); + sv = NULL; + } + +with + + SvREFCNT_dec_set_NULL(sv); + =for apidoc Am|svtype|SvTYPE|SV* sv Returns the type of the SV. See C>. @@ -375,6 +392,10 @@ perform the upgrade if necessary. See C>. #define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT(MUTABLE_SV(sv))) #define SvREFCNT_dec(sv) Perl_SvREFCNT_dec(aTHX_ MUTABLE_SV(sv)) +#define SvREFCNT_dec_set_NULL(sv) \ + STMT_START { \ + sv = Perl_SvREFCNT_dec_ret_NULL(aTHX_ MUTABLE_SV(sv)); \ + } STMT_END #define SvREFCNT_dec_NN(sv) Perl_SvREFCNT_dec_NN(aTHX_ MUTABLE_SV(sv)) #define SVTYPEMASK 0xff diff --git a/sv_inline.h b/sv_inline.h index 1bb8c2897d3d..3adc130575b1 100644 --- a/sv_inline.h +++ b/sv_inline.h @@ -664,6 +664,7 @@ Perl_SvREFCNT_inc(SV *sv) SvREFCNT(sv)++; return sv; } + PERL_STATIC_INLINE SV * Perl_SvREFCNT_inc_NN(SV *sv) { @@ -672,12 +673,14 @@ Perl_SvREFCNT_inc_NN(SV *sv) SvREFCNT(sv)++; return sv; } + PERL_STATIC_INLINE void Perl_SvREFCNT_inc_void(SV *sv) { if (LIKELY(sv != NULL)) SvREFCNT(sv)++; } + PERL_STATIC_INLINE void Perl_SvREFCNT_dec(pTHX_ SV *sv) { @@ -690,6 +693,15 @@ Perl_SvREFCNT_dec(pTHX_ SV *sv) } } +PERL_STATIC_INLINE SV * +Perl_SvREFCNT_dec_ret_NULL(pTHX_ SV *sv) +{ + PERL_ARGS_ASSERT_SVREFCNT_DEC_RET_NULL; + Perl_SvREFCNT_dec(aTHX_ sv); + return NULL; +} + + PERL_STATIC_INLINE void Perl_SvREFCNT_dec_NN(pTHX_ SV *sv) { From de26a03cecf994eba922a3c27287969437cdd0cc Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Fri, 17 Mar 2023 10:42:30 +0100 Subject: [PATCH 4/7] pod/perldiag.pod - provide full path to issues tracker https://github.com/Perl/perl5/issues shows the list of open issues, whereas https://github.com/Perl/perl5/issues/new/choose is where someone can create a new ticket. --- pod/perldiag.pod | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/pod/perldiag.pod b/pod/perldiag.pod index d774e3537c8d..abe5910c35a5 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -2016,7 +2016,7 @@ called as barewords. Something like this will work: (P) This is either an error in Perl, or, if you're using one, your L. If not the -latter, report the problem to L. +latter, report the problem to L. =item corrupted regexp pointers @@ -5102,7 +5102,7 @@ utility to report; in regex; marked by S<<-- HERE> in m/%s/ (S regexp) You used a regular expression with case-insensitive matching, and there is a bug in Perl in which the built-in regular expression folding rules are not accurate. This may lead to incorrect results. -Please report this as a bug to L. +Please report this as a bug to L. =item Perl_my_%s() not available From 7dceac41b1118feeab9d98550898ccc1938f3e0c Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Fri, 17 Mar 2023 14:02:38 +0100 Subject: [PATCH 5/7] threads-shared - fixup typo in comment --- dist/threads-shared/lib/threads/shared.pm | 4 ++-- dist/threads-shared/shared.xs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/dist/threads-shared/lib/threads/shared.pm b/dist/threads-shared/lib/threads/shared.pm index 0fe94a5b8e83..3c735eb51c5c 100644 --- a/dist/threads-shared/lib/threads/shared.pm +++ b/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 diff --git a/dist/threads-shared/shared.xs b/dist/threads-shared/shared.xs index 45d16c5e31b0..bc516e49c2cc 100644 --- a/dist/threads-shared/shared.xs +++ b/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. From 9961aaca30f44e833d29e1fc613850a42f82d040 Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Thu, 16 Mar 2023 23:54:07 +0100 Subject: [PATCH 6/7] scope.c - add mortal_destructor_sv() and mortal_svfunc_x() The function SAVEDESTRUCTOR_X() (save_destructor_x) can be used to execute a C function at the end of the current psuedo-block. Prior to this patch there was no "mortal" equivalent that would execute at the end of the current statement. We offer a collection of functions which are intended to free SV's at either point in time, but only support callbacks at the end of the current pseudo-block. This patch adds two such functions, "mortal_destructor_sv" which can be used to trigger a perl code reference to execute at the end of the current statement, and "mortal_svfunc_x" which can be used to trigger an SVFUNC_t C function at the end of the current statement. Both functions differ from save_destructor_x() in that instead of supporting a void pointer argument they both require their argument to be some sort of SV pointer. The Perl callback function triggered by "mortal_destructor_sv" may be provided no arguments, a single argument or a list of arguments, depending on the type of argument provided to mortal_destructor_sv(): when the argument is a raw AV (with no SV ref wrapping it), then the contents of the AV are passed in as a list of arguments. When the argument is anything else but NULL, the argument is provided as a single argument, and when it is NULL the perl function is called with no arguments. Both functions are implemented on top of a mortal SV (unseen by the user) which has PERL_MAGIC_destruct magic associated with it, which triggers the destructor behavior when the SV is freed. Both functions are provided with macros to match the normal SAVExx() API, with MORTALDESTRUCTOR_SV() wrapping mortal_destructor_sv() and MORTALSVFUNC_X() wrapping mortal_svfunc_x(). The heart of this logic cribbed from Leon Timmermans' Variable-OnDestruct. See the code at: https://metacpan.org/dist/Variable-OnDestruct/source/lib/Variable/OnDestruct.xs#L6-17 I am very grateful to him for his help on this. Any errors or omissions in this code are my fault, not his. --- MANIFEST | 1 + embed.fnc | 8 ++ embed.h | 3 + ext/XS-APItest/APItest.pm | 2 +- ext/XS-APItest/APItest.xs | 23 +++++ ext/XS-APItest/t/mortal_destructor.t | 30 ++++++ mg_names.inc | 1 + mg_raw.h | 2 + mg_vtable.h | 5 + pod/perldiag.pod | 8 ++ pod/perlguts.pod | 48 +++++++-- proto.h | 15 +++ regen/mg_vtable.pl | 8 ++ scope.c | 139 +++++++++++++++++++++++++++ scope.h | 6 ++ 15 files changed, 292 insertions(+), 7 deletions(-) create mode 100644 ext/XS-APItest/t/mortal_destructor.t diff --git a/MANIFEST b/MANIFEST index b0ee08ae72ef..bb658d2696aa 100644 --- a/MANIFEST +++ b/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 diff --git a/embed.fnc b/embed.fnc index 59956aae7a9d..203a68661d66 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1808,6 +1808,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 \ @@ -1970,7 +1973,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 \ diff --git a/embed.h b/embed.h index d6feb979d96b..b01a23467082 100644 --- a/embed.h +++ b/embed.h @@ -359,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 @@ -961,6 +963,7 @@ # 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) diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 5e8f716a94f9..fb0aa471ca41 100644 --- a/ext/XS-APItest/APItest.pm +++ 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; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index d06e7810f838..bb6eaa12acd0 100644 --- a/ext/XS-APItest/APItest.xs +++ b/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 diff --git a/ext/XS-APItest/t/mortal_destructor.t b/ext/XS-APItest/t/mortal_destructor.t new file mode 100644 index 000000000000..3e113754c4d4 --- /dev/null +++ b/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 diff --git a/mg_names.inc b/mg_names.inc index 5dd0c9ae0ef3..e46c71faf6a6 100644 --- a/mg_names.inc +++ b/mg_names.inc @@ -44,6 +44,7 @@ { PERL_MAGIC_vstring, "vstring(V)" }, { PERL_MAGIC_vec, "vec(v)" }, { PERL_MAGIC_utf8, "utf8(w)" }, + { PERL_MAGIC_destruct, "destruct(X)" }, { PERL_MAGIC_substr, "substr(x)" }, { PERL_MAGIC_nonelem, "nonelem(Y)" }, { PERL_MAGIC_defelem, "defelem(y)" }, diff --git a/mg_raw.h b/mg_raw.h index 73b3f174a79d..24d9643ed149 100644 --- a/mg_raw.h +++ b/mg_raw.h @@ -76,6 +76,8 @@ "/* vec 'v' vec() lvalue */" }, { 'w', "want_vtbl_utf8 | PERL_MAGIC_VALUE_MAGIC", "/* utf8 'w' Cached UTF-8 information */" }, + { 'X', "want_vtbl_destruct | PERL_MAGIC_VALUE_MAGIC", + "/* destruct 'X' destruct callback */" }, { 'x', "want_vtbl_substr | PERL_MAGIC_VALUE_MAGIC", "/* substr 'x' substr() lvalue */" }, { 'Y', "want_vtbl_nonelem | PERL_MAGIC_VALUE_MAGIC", diff --git a/mg_vtable.h b/mg_vtable.h index b005cb7c69cb..bdf8187e55dd 100644 --- a/mg_vtable.h +++ b/mg_vtable.h @@ -51,6 +51,7 @@ #define PERL_MAGIC_vstring 'V' /* SV was vstring literal */ #define PERL_MAGIC_vec 'v' /* vec() lvalue */ #define PERL_MAGIC_utf8 'w' /* Cached UTF-8 information */ +#define PERL_MAGIC_destruct 'X' /* destruct callback */ #define PERL_MAGIC_substr 'x' /* substr() lvalue */ #define PERL_MAGIC_nonelem 'Y' /* Array element that does not exist */ #define PERL_MAGIC_defelem 'y' /* Shadow "foreach" iterator variable / @@ -69,6 +70,7 @@ enum { /* pass one of these to get_vtbl */ want_vtbl_dbline, want_vtbl_debugvar, want_vtbl_defelem, + want_vtbl_destruct, want_vtbl_env, want_vtbl_envelem, want_vtbl_hints, @@ -107,6 +109,7 @@ EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = { "dbline", "debugvar", "defelem", + "destruct", "env", "envelem", "hints", @@ -168,6 +171,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = { { 0, Perl_magic_setdbline, 0, 0, 0, 0, 0, 0 }, { Perl_magic_getdebugvar, Perl_magic_setdebugvar, 0, 0, 0, 0, 0, 0 }, { Perl_magic_getdefelem, Perl_magic_setdefelem, 0, 0, 0, 0, 0, 0 }, + { 0, 0, 0, 0, Perl_magic_freedestruct, 0, 0, 0 }, { 0, Perl_magic_set_all_env, 0, Perl_magic_clear_all_env, 0, 0, 0, 0 }, { 0, Perl_magic_setenv, 0, Perl_magic_clearenv, 0, 0, 0, 0 }, { 0, 0, 0, Perl_magic_clearhints, 0, 0, 0, 0 }, @@ -214,6 +218,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max]; #define PL_vtbl_dbline PL_magic_vtables[want_vtbl_dbline] #define PL_vtbl_debugvar PL_magic_vtables[want_vtbl_debugvar] #define PL_vtbl_defelem PL_magic_vtables[want_vtbl_defelem] +#define PL_vtbl_destruct PL_magic_vtables[want_vtbl_destruct] #define PL_vtbl_env PL_magic_vtables[want_vtbl_env] #define PL_vtbl_envelem PL_magic_vtables[want_vtbl_envelem] #define PL_vtbl_fm PL_magic_vtables[want_vtbl_fm] diff --git a/pod/perldiag.pod b/pod/perldiag.pod index abe5910c35a5..fbeac6651528 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -832,6 +832,14 @@ a C block. You probably meant to use C or C. (F) You called C, but you're not inside a C block. +=item Can't call destructor for 0x%p in global destruction + +(S) This should not happen. Internals code has set up a destructor +using C or C which is firing +during global destruction. Please attempt to reduce the code that triggers +this warning down to a small an example as possible and then report the +problem to L + =item Can't call method "%s" on an undefined value (F) You used the syntax of a method call, but the slot filled by the diff --git a/pod/perlguts.pod b/pod/perlguts.pod index a25438c681a7..9f35597d7a80 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1510,17 +1510,17 @@ will be lost. tables < PERL_MAGIC_backref vtbl_backref For weak ref data @ PERL_MAGIC_arylen_p (none) To move arylen out of XPVAV - B PERL_MAGIC_bm vtbl_regexp Boyer-Moore + B PERL_MAGIC_bm vtbl_regexp Boyer-Moore (fast string search) - c PERL_MAGIC_overload_table vtbl_ovrld Holds overload table + c PERL_MAGIC_overload_table vtbl_ovrld Holds overload table (AMT) on stash - D PERL_MAGIC_regdata vtbl_regdata Regex match position data + D PERL_MAGIC_regdata vtbl_regdata Regex match position data (@+ and @- vars) d PERL_MAGIC_regdatum vtbl_regdatum Regex match position data element E PERL_MAGIC_env vtbl_env %ENV hash e PERL_MAGIC_envelem vtbl_envelem %ENV hash element - f PERL_MAGIC_fm vtbl_regexp Formline + f PERL_MAGIC_fm vtbl_regexp Formline ('compiled' format) g PERL_MAGIC_regex_global vtbl_mglob m//g target H PERL_MAGIC_hints vtbl_hints %^H hash @@ -1548,6 +1548,7 @@ will be lost. V PERL_MAGIC_vstring (none) SV was vstring literal v PERL_MAGIC_vec vtbl_vec vec() lvalue w PERL_MAGIC_utf8 vtbl_utf8 Cached UTF-8 information + X PERL_MAGIC_destruct vtbl_destruct destruct callback x PERL_MAGIC_substr vtbl_substr substr() lvalue Y PERL_MAGIC_nonelem vtbl_nonelem Array element that does not exist @@ -1575,6 +1576,7 @@ will be lost. =for apidoc_item ||PERL_MAGIC_dbline =for apidoc_item ||PERL_MAGIC_debugvar =for apidoc_item ||PERL_MAGIC_defelem +=for apidoc_item ||PERL_MAGIC_destruct =for apidoc_item ||PERL_MAGIC_env =for apidoc_item ||PERL_MAGIC_envelem =for apidoc_item ||PERL_MAGIC_ext @@ -1978,7 +1980,7 @@ this: =item C At the end of I the function C is called with the -only argument C

. +only argument C

which may be NULL. =for apidoc Ayh||DESTRUCTORFUNC_NOCONTEXT_t =for apidoc Amh||SAVEDESTRUCTOR|DESTRUCTORFUNC_NOCONTEXT_t f|void *p @@ -1986,11 +1988,45 @@ only argument C

. =item C At the end of I the function C is called with the -implicit context argument (if any), and C

. +implicit context argument (if any), and C

which may be NULL. + +Note the I may occur much later than +the the I. You may wish to look at the +C macro instead. =for apidoc Ayh||DESTRUCTORFUNC_t =for apidoc Amh||SAVEDESTRUCTOR_X|DESTRUCTORFUNC_t f|void *p +=item C + +At the end of I the function C is called with +the implicit context argument (if any), and C which may be NULL. + +Be aware that the parameter argument to the destructor function differs +from the related C in that it MUST be either NULL or +an C. + +Note the I may occur much before the +the I. You may wish to look at the +C macro instead. + +=for apidoc Amh||MORTALDESTRUCTOR_X|DESTRUCTORFUNC_t f|SV *sv + +=item C + +At the end of I the Perl function contained in +C is called with the arguments provided (if any) in C. +See the documentation for C for details on +the C parameter is handled. + +Note the I may occur much before the +the I. If you wish to call a perl +function at the end of the current pseudo block you should use the +C API instead, which will require you create a +C wrapper to call the Perl function. + +=for apidoc Amh||MORTALDESTRUCTOR_SV|SV *coderef|SV *args + =item C The current offset on the Perl internal stack (cf. C) is restored diff --git a/proto.h b/proto.h index eedd5e36a2b2..3c69d4eb39a5 100644 --- a/proto.h +++ b/proto.h @@ -2097,6 +2097,12 @@ Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) #define PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P \ assert(sv); assert(mg) +PERL_CALLCONV int +Perl_magic_freedestruct(pTHX_ SV *sv, MAGIC *mg) + __attribute__visibility__("hidden"); +#define PERL_ARGS_ASSERT_MAGIC_FREEDESTRUCT \ + assert(sv); assert(mg) + PERL_CALLCONV int Perl_magic_freemglob(pTHX_ SV *sv, MAGIC *mg) __attribute__visibility__("hidden"); @@ -2488,6 +2494,15 @@ Perl_moreswitches(pTHX_ const char *s); #define PERL_ARGS_ASSERT_MORESWITCHES \ assert(s) +PERL_CALLCONV void +Perl_mortal_destructor_sv(pTHX_ SV *coderef, SV *args); +#define PERL_ARGS_ASSERT_MORTAL_DESTRUCTOR_SV \ + assert(coderef) + +PERL_CALLCONV void +Perl_mortal_svfunc_x(pTHX_ SVFUNC_t f, SV *p); +#define PERL_ARGS_ASSERT_MORTAL_SVFUNC_X + PERL_CALLCONV const struct mro_alg * Perl_mro_get_from_name(pTHX_ SV *name); #define PERL_ARGS_ASSERT_MRO_GET_FROM_NAME \ diff --git a/regen/mg_vtable.pl b/regen/mg_vtable.pl index e61dc2cce9ef..debe6bf06607 100644 --- a/regen/mg_vtable.pl +++ b/regen/mg_vtable.pl @@ -212,6 +212,12 @@ BEGIN vtable => 'debugvar' }, lvref => { char => '\\', vtable => 'lvref', desc => "Lvalue reference constructor" }, + destruct => { + char => "X", + vtable => 'destruct', + desc => "destruct callback", + value_magic => 1, + }, ); @@ -288,6 +294,7 @@ BEGIN 'checkcall' => {copy => 'copycallchecker'}, 'debugvar' => { set => 'setdebugvar', get => 'getdebugvar' }, 'lvref' => {set => 'setlvref'}, + 'destruct' => {free => 'freedestruct'}, ); @@ -428,6 +435,7 @@ BEGIN ($desc, @cont) = $desc =~ /(.{1,$desc_wrap})(?: |\z)/g } } + s/\s+\z// for $desc, @cont; printf $format, $type, $vtbl, $desc; printf $format, '', '', $_ foreach @cont; } diff --git a/scope.c b/scope.c index c434b1e46a42..28c767f1289b 100644 --- a/scope.c +++ b/scope.c @@ -1846,6 +1846,145 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx) #endif /* DEBUGGING */ } +/* +=for apidoc_section $callback +=for apidoc mortal_destructor_sv + +This function arranges for either a Perl code reference, or a C function +reference to be called at the B. + +The C argument determines the type of function that will be +called. If it is C it is assumed to be a reference to a CV and +will arrange for the coderef to be called. If it is not SvROK() then it +is assumed to be a C which is C whose value is a pointer +to a C function of type C created using C. +Either way the C parameter will be provided to the callback as a +parameter, although the rules for doing so differ between the Perl and +C mode. Normally this function is only used directly for the Perl case +and the wrapper C is used for the C function case. + +When operating in Perl callback mode the C parameter may be NULL +in which case the code reference is called with no arguments, otherwise +if it is an AV (SvTYPE(args) == SVt_PVAV) then the contents of the AV +will be used as the arguments to the code reference, and if it is any +other type then the C SV will be provided as a single argument to +the code reference. + +When operating in a C callback mode the C parameter will be passed +directly to the C function as a C pointer. No additional +processing of the argument will be peformed, and it is the callers +responsibility to free the C parameter if necessary. + +Be aware that there is a signficant difference in timing between the +I and the I. If you are looking for a mechanism to trigger a function at the +end of the B you should look at +C instead of this function. + +=for apidoc mortal_svfunc_x + +This function arranges for a C function reference to be called at the +B with the arguments provided. It is a +wrapper around C which ensures that the latter +function is called appropriately. + +Be aware that there is a signficant difference in timing between the +I and the I. If you are looking for a mechanism to trigger a function at the +end of the B you should look at +C instead of this function. + +=for apidoc magic_freedestruct + +This function is called via magic to implement the +C and C functions. It +should not be called directly and has no user servicable parts. + +=cut +*/ + +void +Perl_mortal_destructor_sv(pTHX_ SV *coderef, SV *args) { + PERL_ARGS_ASSERT_MORTAL_DESTRUCTOR_SV; + assert( + (SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV) /* perl coderef */ + || + (SvIOK(coderef) && !SvROK(coderef)) /* C function ref */ + ); + SV *variable = newSV_type_mortal(SVt_IV); + (void)sv_magicext(variable, coderef, PERL_MAGIC_destruct, + &PL_vtbl_destruct, (char *)args, args ? HEf_SVKEY : 0); +} + + +void +Perl_mortal_svfunc_x(pTHX_ SVFUNC_t f, SV *sv) { + PERL_ARGS_ASSERT_MORTAL_SVFUNC_X; + SV *sviv = newSViv(PTR2IV(f)); + mortal_destructor_sv(sviv,sv); +} + + +int +Perl_magic_freedestruct(pTHX_ SV* sv, MAGIC* mg) { + PERL_ARGS_ASSERT_MAGIC_FREEDESTRUCT; + dSP; + union { + SV *sv; + AV *av; + char *pv; + } args_any; + SV *coderef; + + IV nargs = 0; + if (PL_phase == PERL_PHASE_DESTRUCT) { + Perl_warn(aTHX_ "Can't call destructor for 0x%p in global destruction\n", sv); + return 1; + } + + args_any.pv = mg->mg_ptr; + coderef = mg->mg_obj; + + /* Deal with C function destructor */ + if (SvTYPE(coderef) == SVt_IV && !SvROK(coderef)) { + SVFUNC_t f = INT2PTR(SVFUNC_t, SvIV(coderef)); + (f)(aTHX_ args_any.sv); + return 0; + } + + if (args_any.sv) { + if (SvTYPE(args_any.sv) == SVt_PVAV) { + nargs = av_len(args_any.av) + 1; + } else { + nargs = 1; + } + } + PUSHSTACKi(PERLSI_MAGIC); + ENTER_with_name("call_freedestruct"); + SAVETMPS; + EXTEND(SP, nargs); + PUSHMARK(SP); + if (args_any.sv) { + if (SvTYPE(args_any.sv) == SVt_PVAV) { + IV n; + for (n = 0 ; n < nargs ; n++ ) { + SV **argp = av_fetch(args_any.av, n, 0); + if (argp && *argp) + PUSHs(*argp); + } + } else { + PUSHs(args_any.sv); + } + } + PUTBACK; + (void)call_sv(coderef, G_VOID | G_EVAL | G_KEEPERR); + FREETMPS; + LEAVE_with_name("call_freedestruct"); + POPSTACK; + return 0; +} + + /* * ex: set ts=8 sts=4 sw=4 et: */ diff --git a/scope.h b/scope.h index 50ccc15a4e99..ee4e86122480 100644 --- a/scope.h +++ b/scope.h @@ -195,6 +195,12 @@ scope has the given name. C must be a literal string. #define SAVEDESTRUCTOR_X(f,p) \ save_destructor_x((DESTRUCTORFUNC_t)(f), (void*)(p)) +#define MORTALSVFUNC_X(f,sv) \ + mortal_svfunc_x((SVFUNC_t)(f), sv) + +#define MORTALDESTRUCTOR_SV(coderef,args) \ + mortal_destructor_sv(coderef,args) + #define SAVESTACK_POS() \ STMT_START { \ dSS_ADD; \ From d0b1ad153b8a809bf01f7580357a9574c0965ce6 Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Mon, 19 Dec 2022 19:32:03 +0100 Subject: [PATCH 7/7] 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 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 hook is similar to the C hook however except that it is called after the require completes (successfully or not), and its return is ignored always. --- MANIFEST | 12 ++- embed.fnc | 10 ++ embed.h | 4 + embedvar.h | 2 + gv.c | 7 ++ intrpvar.h | 6 +- mg.c | 92 ++++++++++++++++- mg_names.inc | 2 + mg_raw.h | 4 + mg_vtable.h | 10 ++ perl.c | 4 + pod/perldiag.pod | 24 ++++- pod/perlfunc.pod | 64 +++++++++++- pod/perlguts.pod | 4 + pod/perlvar.pod | 65 ++++++++++++ pp_ctl.c | 40 ++++++++ proto.h | 24 +++++ regen/mg_vtable.pl | 11 ++ sv.c | 3 + t/harness | 2 +- t/lib/caller/Bicycle.pm | 3 + t/lib/caller/Cycle.pm | 3 + t/lib/caller/Tricycle.pm | 3 + t/op/glob.t | 2 +- t/op/hook/require.t | 215 +++++++++++++++++++++++++++++++++++++++ 25 files changed, 603 insertions(+), 13 deletions(-) create mode 100644 t/lib/caller/Bicycle.pm create mode 100644 t/lib/caller/Cycle.pm create mode 100644 t/lib/caller/Tricycle.pm create mode 100644 t/op/hook/require.t diff --git a/MANIFEST b/MANIFEST index bb658d2696aa..d19cbf0da697 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5787,10 +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 -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) @@ -6045,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 diff --git a/embed.fnc b/embed.fnc index 203a68661d66..a4c638e29660 100644 --- a/embed.fnc +++ b/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 \ @@ -1889,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 \ diff --git a/embed.h b/embed.h index b01a23467082..1f999f51f514 100644 --- a/embed.h +++ b/embed.h @@ -957,6 +957,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) @@ -992,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) diff --git a/embedvar.h b/embedvar.h index 1ee80949052a..63d28a3a6e3d 100644 --- a/embedvar.h +++ b/embedvar.h @@ -131,6 +131,8 @@ # 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) diff --git a/gv.c b/gv.c index 0fb23995a69c..6b9803b5cd20 100644 --- a/gv.c +++ b/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} */ diff --git a/intrpvar.h b/intrpvar.h index e16dfc493194..eea1d76dd5a6 100644 --- a/intrpvar.h +++ b/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 *) diff --git a/mg.c b/mg.c index 6e911de897df..69a484eb3447 100644 --- a/mg.c +++ b/mg.c @@ -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) { diff --git a/mg_names.inc b/mg_names.inc index e46c71faf6a6..29338448ce46 100644 --- a/mg_names.inc +++ b/mg_names.inc @@ -48,6 +48,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(^)" }, diff --git a/mg_raw.h b/mg_raw.h index 24d9643ed149..971906541294 100644 --- a/mg_raw.h +++ b/mg_raw.h @@ -84,6 +84,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", diff --git a/mg_vtable.h b/mg_vtable.h index bdf8187e55dd..a0273831bf73 100644 --- a/mg_vtable.h +++ b/mg_vtable.h @@ -56,6 +56,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 */ @@ -75,6 +77,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, @@ -114,6 +118,8 @@ EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = { "envelem", "hints", "hintselem", + "hook", + "hookelem", "isa", "isaelem", "lvref", @@ -176,6 +182,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 }, @@ -224,6 +232,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] diff --git a/perl.c b/perl.c index 54afc2c6fb29..13bbaa6db376 100644 --- a/perl.c +++ b/perl.c @@ -932,6 +932,10 @@ perl_destruct(pTHXx) 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) diff --git a/pod/perldiag.pod b/pod/perldiag.pod index fbeac6651528..acd30568a9f5 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -2263,6 +2263,18 @@ the C pragma, is no longer supported as of Perl 5.26.0. Setting it to anything other than C 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 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 for +details. + =item entering effective %s failed (F) While under the C pragma, switching the real and @@ -3961,11 +3973,17 @@ can vary from one line to the next. =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 or C 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 and L. +=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 or C with an empty string an undefined value +which is forbidden. See L and L. + =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{...}>. diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 90f07afbe84d..5a26941e7591 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -7064,7 +7064,69 @@ require executes at all. 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 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 often breaks things. +Nevertheless it can be very helpful to have the ability to perform +actions before and after a C, for instance for trace utilities +like C or to measure time to load and the memory +consumption of the require graph. Because of the difficulties in safely +creating a C wrapper in 5.37.10 we introduced a new mechanism. + +As of 5.37.10, prior to any other actions it performs, C 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 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 statements, unlike C and +C 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, see L|/use Module VERSION LIST> and L. =item reset EXPR diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 9f35597d7a80..e0101d33ad3d 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -1555,6 +1555,8 @@ will be lost. 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 @@ -1584,6 +1586,8 @@ will be lost. =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 diff --git a/pod/perlvar.pod b/pod/perlvar.pod index aebd6a45bd72..25dbd05a9bae 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -779,6 +779,71 @@ and use an C or CORE::GLOBAL::die override instead. See L, L, L, and L 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, 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 B 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 +hook may return a "post-action" coderef which will in turn be executed when +the C 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 hook will be silently ignored. + +C 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 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 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 for an example implementation. + +=item require__after + +The routine indicated by C<${^HOOK}{require__after}> is called by +C B 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 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 hook is called for each required file in FILO +order. In other words if A requires B requires C, then C +will be called first for C, then B and then A. + +=back + =item $BASETIME =item $^T diff --git a/pp_ctl.c b/pp_ctl.c index 4ec141ec69dc..b98c197252a3 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -4233,6 +4233,46 @@ S_require_file(pTHX_ SV *sv) 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) { diff --git a/proto.h b/proto.h index 3c69d4eb39a5..a64f6c6b696f 100644 --- a/proto.h +++ b/proto.h @@ -2057,6 +2057,18 @@ Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) #define PERL_ARGS_ASSERT_MAGIC_CLEARHINTS \ 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"); @@ -2277,6 +2289,18 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) #define PERL_ARGS_ASSERT_MAGIC_SETHINT \ 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"); diff --git a/regen/mg_vtable.pl b/regen/mg_vtable.pl index debe6bf06607..5c8a37c15f31 100644 --- a/regen/mg_vtable.pl +++ b/regen/mg_vtable.pl @@ -168,10 +168,17 @@ BEGIN 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', @@ -262,6 +269,10 @@ BEGIN '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'}, diff --git a/sv.c b/sv.c index 6644a2757f92..4453e52964dc 100644 --- a/sv.c +++ b/sv.c @@ -15894,6 +15894,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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); diff --git a/t/harness b/t/harness index f2c8b39cd7cf..5347f51df3ee 100644 --- a/t/harness +++ b/t/harness @@ -337,7 +337,7 @@ if (@ARGV) { 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}; diff --git a/t/lib/caller/Bicycle.pm b/t/lib/caller/Bicycle.pm new file mode 100644 index 000000000000..083391ef9799 --- /dev/null +++ b/t/lib/caller/Bicycle.pm @@ -0,0 +1,3 @@ +require Tricycle; # part of a cyclic dependency chain + +1; diff --git a/t/lib/caller/Cycle.pm b/t/lib/caller/Cycle.pm new file mode 100644 index 000000000000..67a1ccd971d2 --- /dev/null +++ b/t/lib/caller/Cycle.pm @@ -0,0 +1,3 @@ +require Bicycle; # part of a cyclic dependency chain + +1; diff --git a/t/lib/caller/Tricycle.pm b/t/lib/caller/Tricycle.pm new file mode 100644 index 000000000000..ffc0f72ba514 --- /dev/null +++ b/t/lib/caller/Tricycle.pm @@ -0,0 +1,3 @@ +require Cycle; # part of a cyclic dependency chain + +1; diff --git a/t/op/glob.t b/t/op/glob.t index 01f46a08c009..4a41cc9df6f0 100644 --- a/t/op/glob.t +++ b/t/op/glob.t @@ -20,7 +20,7 @@ elsif ($^O eq 'VMS') { } else { map { $files{$_}++ } ; - 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)); diff --git a/t/op/hook/require.t b/t/op/hook/require.t new file mode 100644 index 000000000000..6957d16975ef --- /dev/null +++ b/t/op/hook/require.t @@ -0,0 +1,215 @@ +#!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)' + ); +}