diff --git a/MANIFEST b/MANIFEST index 82a02b667085..d19cbf0da697 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 @@ -5786,6 +5787,13 @@ t/io/tell.t See if file seeking works t/io/through.t See if pipe passes data intact t/io/utf8.t See if file seeking works t/japh/abigail.t Obscure tests +t/lib/caller/Apack.pm test Module for caller.t and t/op/hook/require.t +t/lib/caller/Bicycle.pm test Module for t/op/hook/require.t (cyclic) +t/lib/caller/Bpack.pm test Module for caller.t and t/op/hook/require.t +t/lib/caller/Cpack.pm test Module for caller.t and t/op/hook/require.t +t/lib/caller/Cycle.pm test Module for t/op/hook/require.t (cyclic) +t/lib/caller/Foo.pm test Module for caller.t and t/op/hook/require.t +t/lib/caller/Tricycle.pm test Module for t/op/hook/require.t (cyclic) t/lib/CannotParse.pm For test case in op/require_errors.t t/lib/charnames/alias Tests of "use charnames" with aliases. t/lib/Cname.pm Test charnames in regexes (op/pat.t) @@ -5825,10 +5833,6 @@ t/lib/feature/nonesuch Tests for enabling/disabling nonexistent feature t/lib/feature/removed Tests for enabling/disabling removed feature t/lib/feature/say Tests for enabling/disabling say feature t/lib/feature/switch Tests for enabling/disabling switch feature -t/lib/GH_15109/Apack.pm test Module for caller.t -t/lib/GH_15109/Bpack.pm test Module for caller.t -t/lib/GH_15109/Cpack.pm test Module for caller.t -t/lib/GH_15109/Foo.pm test Module for caller.t t/lib/h2ph.h Test header file for h2ph t/lib/h2ph.pht Generated output from h2ph.h by h2ph, for comparison t/lib/locale/latin1 Part of locale.t in Latin 1 @@ -6044,6 +6048,7 @@ t/op/hashassign.t See if hash assignments work t/op/hashwarn.t See if warnings for bad hash assignments work t/op/heredoc.t See if heredoc edge and corner cases work t/op/hexfp.t See if hexadecimal float literals work +t/op/hook/require.t See if require hooks work properly. t/op/inc.t See if inc/dec of integers near 32 bit limit work t/op/inccode.t See if coderefs work in @INC t/op/inccode-tie.t See if tie to @INC works 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. diff --git a/embed.fnc b/embed.fnc index 176dc27c801e..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 \ @@ -1808,6 +1813,9 @@ p |int |magic_existspack \ p |int |magic_freearylen_p \ |NN SV *sv \ |NN MAGIC *mg +dp |int |magic_freedestruct \ + |NN SV *sv \ + |NN MAGIC *mg p |int |magic_freemglob|NN SV *sv \ |NN MAGIC *mg p |int |magic_freeovrld|NN SV *sv \ @@ -1886,6 +1894,11 @@ p |int |magic_setenv |NN SV *sv \ |NN MAGIC *mg dp |int |magic_sethint |NN SV *sv \ |NN MAGIC *mg +p |int |magic_sethook |NULLOK SV *sv \ + |NN MAGIC *mg +p |int |magic_sethookall \ + |NN SV *sv \ + |NN MAGIC *mg p |int |magic_setisa |NN SV *sv \ |NN MAGIC *mg p |int |magic_setlvref |NN SV *sv \ @@ -1970,7 +1983,12 @@ Cop |void * |more_bodies |const svtype sv_type \ |const size_t arena_size Cp |const char *|moreswitches \ |NN const char *s +Adp |void |mortal_destructor_sv \ + |NN SV *coderef \ + |NULLOK SV *args CRTXip |char * |mortal_getenv |NN const char *str +Cdp |void |mortal_svfunc_x|SVFUNC_t f \ + |NULLOK SV *p Adop |const struct mro_alg *|mro_get_from_name \ |NN SV *name Adp |AV * |mro_get_linear_isa \ @@ -3202,6 +3220,10 @@ Adp |SV * |sv_ref |NULLOK SV *dst \ |const int ob AMdip |void |SvREFCNT_dec |NULLOK SV *sv AMdip |void |SvREFCNT_dec_NN|NN SV *sv +Adip |SV * |SvREFCNT_dec_ret_NULL \ + |NULLOK SV *sv +Adm |void |SvREFCNT_dec_set_NULL \ + |NULLOK SV *sv AMTdip |SV * |SvREFCNT_inc |NULLOK SV *sv AMTdip |SV * |SvREFCNT_inc_NN|NN SV *sv AMTdip |void |SvREFCNT_inc_void \ diff --git a/embed.h b/embed.h index 110b092fa2e0..1f999f51f514 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) @@ -358,7 +359,9 @@ # define mg_size(a) Perl_mg_size(aTHX_ a) # define mini_mktime Perl_mini_mktime # define moreswitches(a) Perl_moreswitches(aTHX_ a) +# define mortal_destructor_sv(a,b) Perl_mortal_destructor_sv(aTHX_ a,b) # define mortal_getenv Perl_mortal_getenv +# define mortal_svfunc_x(a,b) Perl_mortal_svfunc_x(aTHX_ a,b) # define mro_get_linear_isa(a) Perl_mro_get_linear_isa(aTHX_ a) # define mro_method_changed_in(a) Perl_mro_method_changed_in(aTHX_ a) # define msbit_pos32 Perl_msbit_pos32 @@ -954,12 +957,15 @@ # define magic_clearenv(a,b) Perl_magic_clearenv(aTHX_ a,b) # define magic_clearhint(a,b) Perl_magic_clearhint(aTHX_ a,b) # define magic_clearhints(a,b) Perl_magic_clearhints(aTHX_ a,b) +# define magic_clearhook(a,b) Perl_magic_clearhook(aTHX_ a,b) +# define magic_clearhookall(a,b) Perl_magic_clearhookall(aTHX_ a,b) # define magic_clearisa(a,b) Perl_magic_clearisa(aTHX_ a,b) # define magic_clearpack(a,b) Perl_magic_clearpack(aTHX_ a,b) # define magic_clearsig(a,b) Perl_magic_clearsig(aTHX_ a,b) # define magic_copycallchecker(a,b,c,d,e) Perl_magic_copycallchecker(aTHX_ a,b,c,d,e) # define magic_existspack(a,b) Perl_magic_existspack(aTHX_ a,b) # define magic_freearylen_p(a,b) Perl_magic_freearylen_p(aTHX_ a,b) +# define magic_freedestruct(a,b) Perl_magic_freedestruct(aTHX_ a,b) # define magic_freemglob(a,b) Perl_magic_freemglob(aTHX_ a,b) # define magic_freeovrld(a,b) Perl_magic_freeovrld(aTHX_ a,b) # define magic_freeutf8(a,b) Perl_magic_freeutf8(aTHX_ a,b) @@ -988,6 +994,8 @@ # define magic_setdefelem(a,b) Perl_magic_setdefelem(aTHX_ a,b) # define magic_setenv(a,b) Perl_magic_setenv(aTHX_ a,b) # define magic_sethint(a,b) Perl_magic_sethint(aTHX_ a,b) +# define magic_sethook(a,b) Perl_magic_sethook(aTHX_ a,b) +# define magic_sethookall(a,b) Perl_magic_sethookall(aTHX_ a,b) # define magic_setisa(a,b) Perl_magic_setisa(aTHX_ a,b) # define magic_setlvref(a,b) Perl_magic_setlvref(aTHX_ a,b) # define magic_setmglob(a,b) Perl_magic_setmglob(aTHX_ a,b) 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/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/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 5dd0c9ae0ef3..29338448ce46 100644 --- a/mg_names.inc +++ b/mg_names.inc @@ -44,9 +44,12 @@ { 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)" }, + { 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 73b3f174a79d..971906541294 100644 --- a/mg_raw.h +++ b/mg_raw.h @@ -76,12 +76,18 @@ "/* 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", "/* 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 b005cb7c69cb..a0273831bf73 100644 --- a/mg_vtable.h +++ b/mg_vtable.h @@ -51,10 +51,13 @@ #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 / 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 */ @@ -69,10 +72,13 @@ 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, want_vtbl_hintselem, + want_vtbl_hook, + want_vtbl_hookelem, want_vtbl_isa, want_vtbl_isaelem, want_vtbl_lvref, @@ -107,10 +113,13 @@ EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = { "dbline", "debugvar", "defelem", + "destruct", "env", "envelem", "hints", "hintselem", + "hook", + "hookelem", "isa", "isaelem", "lvref", @@ -168,10 +177,13 @@ 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 }, { 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 }, @@ -214,11 +226,14 @@ 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] #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 d774e3537c8d..acd30568a9f5 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 @@ -2016,7 +2024,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 @@ -2255,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 @@ -3953,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{...}>. @@ -5102,7 +5128,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 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 a25438c681a7..e0101d33ad3d 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,12 +1548,15 @@ 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 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 @@ -1575,6 +1578,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 @@ -1582,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 @@ -1978,7 +1984,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 +1992,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/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 5df8193a974b..a64f6c6b696f 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 \ @@ -2053,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"); @@ -2093,6 +2109,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"); @@ -2267,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"); @@ -2484,6 +2518,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 \ @@ -9642,6 +9685,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/regen/mg_vtable.pl b/regen/mg_vtable.pl index 578eabeaea11..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', @@ -212,13 +219,18 @@ BEGIN vtable => 'debugvar' }, lvref => { char => '\\', vtable => 'lvref', desc => "Lvalue reference constructor" }, + destruct => { + char => "X", + vtable => 'destruct', + desc => "destruct callback", + value_magic => 1, + }, ); -# %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 +259,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'}, @@ -257,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'}, @@ -289,6 +305,7 @@ BEGIN 'checkcall' => {copy => 'copycallchecker'}, 'debugvar' => { set => 'setdebugvar', get => 'getdebugvar' }, 'lvref' => {set => 'setlvref'}, + 'destruct' => {free => 'freedestruct'}, ); @@ -429,6 +446,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; } @@ -455,9 +473,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 +523,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; 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; \ 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/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) { 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/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/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/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/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/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/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/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; 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)' + ); +}