Commit bd7d7e1682 for perl
commit bd7d7e1682867c2aadefb0b3d5354d230b3f2abf
Author: Paul Evans <leonerd@leonerd.org.uk>
Date: Wed Oct 28 14:53:19 2026 +0000
Create magicv2 shape for subroutines; MGv2s_CODE
Adds a new kind of magicv2 functions structure shape, identified by
`.shape = MGv2s_CODE`. This is intended to be applied to subroutines
(i.e. SVt_PVCV), and will have trigger functions relating to various
points in the lifetime of compiling, managing, and running a subroutine.
The trigger function `clone_cv` fills the same role as `copy` magic on
(legacy) v1 magic when applied at the same time.
The `pre_newcv` and `post_newcv` trigger functions allow magic code to
interrupt and alter the way a subroutine is compiled, by adjusting its
optree or the resulting new CV. These are only meaningful to apply to
`PL_compcv`; when applied to anything else they won't get an opportunity
to run.
diff --git a/MANIFEST b/MANIFEST
index 437da2f8d8..04333d701e 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5248,6 +5248,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/magicv2.t XS::APItest: tests for Magic-v2 related APIs
+ext/XS-APItest/t/magicv2-code.t XS::APItest: tests for Magic-v2 related APIs on CODE magic
ext/XS-APItest/t/magicv2-threads.t XS::APItest: tests for Magic-v2 related APIs across multiple threads
ext/XS-APItest/t/magicv2-value.t XS::APItest: tests for Magic-v2 related APIs on SCALARVALUE magic
ext/XS-APItest/t/Markers.pm Helper for ./blockhooks.t
diff --git a/dump.c b/dump.c
index 07f1edb07d..2534c4d4d0 100644
--- a/dump.c
+++ b/dump.c
@@ -2025,6 +2025,7 @@ Perl_do_magicv2_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I
case MGv2s_SCALARVAR: shapename = "SCALARVAR"; break;
case MGv2s_ARRAYVAR: shapename = "ARRAYVAR"; break;
case MGv2s_HASHVAR: shapename = "HASHVAR"; break;
+ case MGv2s_CODE: shapename = "CODE"; break;
case MGv2s_SCALARVALUE:
shapename = "SCALARVALUE"; break;
}
@@ -2067,6 +2068,19 @@ Perl_do_magicv2_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I
dump_indent(level, file, " CLEAR\n");
break;
}
+
+ case MGv2s_CODE:
+ {
+ const struct CodeMagicFunctions *funcs = MgCODEFUNCS(mg);
+ if (funcs->pre_newcv)
+ dump_indent(level, file, " PRE_NEWCV\n");
+ if (funcs->post_newcv)
+ dump_indent(level, file, " POST_NEWCV\n");
+ if (funcs->clone_cv)
+ dump_indent(level, file, " CLONE_CV\n");
+ break;
+ }
+
case MGv2s_SCALARVALUE:
{
const struct ScalarValueMagicFunctions *funcs = MgSCALARVALUEFUNCS(mg);
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index 9003ad7ad1..0d9a894691 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.52';
+our $VERSION = '1.53';
require XSLoader;
diff --git a/ext/XS-APItest/APItest_magicv2.inc b/ext/XS-APItest/APItest_magicv2.inc
index 629e82ef4a..502fab8af1 100644
--- a/ext/XS-APItest/APItest_magicv2.inc
+++ b/ext/XS-APItest/APItest_magicv2.inc
@@ -45,6 +45,58 @@ magicfunc_inc_on_clone_clone(pTHX_ SV *nsv, MAGIC *nmg, SV *osv, MAGIC *omg, CLO
sv_inc(auxsv);
}
+static OP *
+magicfunc_log_pre_newcv(pTHX_ SV *cv, OP *o, MAGIC *mg)
+{
+ SV *var = get_sv("main::MG_LOG", GV_ADD);
+
+ if (!SvOK(var))
+ sv_setpvs(var, "");
+ else
+ sv_catpvs(var, ",");
+ sv_catpvf(var, "pre_newcv(<%" SVf ">:cv=%s)",
+ SVfARG(MgAUXSV(mg)), cv == (SV *)PL_compcv ? "PL_compcv" : "?");
+
+ return o;
+}
+
+static MAGIC *
+magicfunc_log_post_newcv(pTHX_ SV *cv, SV *compcv, MAGIC *compmg)
+{
+ PERL_UNUSED_ARG(cv);
+
+ SV *var = get_sv("main::MG_LOG", GV_ADD);
+
+ if (!SvOK(var))
+ sv_setpvs(var, "");
+ else
+ sv_catpvs(var, ",");
+ sv_catpvf(var, "post_newcv(<%" SVf ">:compcv=%s)",
+ SVfARG(MgAUXSV(compmg)), compcv == (SV *)PL_compcv ? "PL_compcv" : "?");
+
+ return NULL;
+}
+
+static OP *
+magicfunc_add_one_to_expr(pTHX_ SV *cv, OP *o, MAGIC *mg)
+{
+ PERL_UNUSED_ARG(cv);
+ PERL_UNUSED_ARG(mg);
+
+ return newBINOP(OP_ADD, 0, o,
+ newSVOP(OP_CONST, 0, newSViv(1)));
+}
+
+static MAGIC *
+magicfunc_copy_clone(pTHX_ SV *nsv, SV *sv, MAGIC *mg)
+{
+ MAGIC *nmg = magicv2_copy(nsv, sv, mg);
+
+ MgAUXSV_set(nmg, newSVpvs("this-is-clone"));
+
+ return nmg;
+}
+
static const struct MagicFunctions magicfuncs_empty = {
.ver = 2,
.shape = MGv2s_BASE,
@@ -147,6 +199,31 @@ static const struct ArrayVarMagicFunctions magicfuncs_inc_after_clear_hash = {
.clear = &magicfunc_inc,
};
+static const struct CodeMagicFunctions magicfuncs_log_on_newcv = {
+ .ver = 2,
+ .shape = MGv2s_CODE,
+ .debug_name = "XS::APItest/log_on_newcv",
+
+ .pre_newcv = &magicfunc_log_pre_newcv,
+ .post_newcv = &magicfunc_log_post_newcv,
+};
+
+static const struct CodeMagicFunctions magicfuncs_add_one_to_expr = {
+ .ver = 2,
+ .shape = MGv2s_CODE,
+ .debug_name = "XS::APItest/add_one_to_expr",
+
+ .pre_newcv = &magicfunc_add_one_to_expr,
+};
+
+static const struct CodeMagicFunctions magicfuncs_copy_clonecv = {
+ .ver = 2,
+ .shape = MGv2s_CODE,
+ .debug_name = "XS::APItest/copy_clonecv",
+
+ .clone_cv = &magicfunc_copy_clone,
+};
+
/* we can't make this one `static` because -Wc++-compat gets upset if we do */
extern const struct ScalarValueMagicFunctions magicfuncs_value;
@@ -192,6 +269,9 @@ static const struct {
{"inc_after_set", (struct MagicFunctions *)&magicfuncs_inc_after_set},
{"inc_after_clear_arr", (struct MagicFunctions *)&magicfuncs_inc_after_clear_arr},
{"inc_after_clear_hash", (struct MagicFunctions *)&magicfuncs_inc_after_clear_hash},
+ {"log_on_newcv", (struct MagicFunctions *)&magicfuncs_log_on_newcv},
+ {"add_one_to_expr", (struct MagicFunctions *)&magicfuncs_add_one_to_expr},
+ {"copy_clonecv", (struct MagicFunctions *)&magicfuncs_copy_clonecv},
{"value", (struct MagicFunctions *)&magicfuncs_value},
{NULL, NULL},
};
diff --git a/ext/XS-APItest/APItest_magicv2.xs b/ext/XS-APItest/APItest_magicv2.xs
index 4c85727432..a6ae1a2df9 100644
--- a/ext/XS-APItest/APItest_magicv2.xs
+++ b/ext/XS-APItest/APItest_magicv2.xs
@@ -23,6 +23,13 @@ sv_magicv2_add(SV *sv, SV *magicname, SV *auxsvref, U16 priv = 0)
user->y = 456;
}
+SV *
+PL_compcv()
+ CODE:
+ RETVAL = newRV_inc((SV *)PL_compcv);
+ OUTPUT:
+ RETVAL
+
bool
sv_magicv2_exists(SV *sv, SV *magicname)
CODE:
@@ -40,6 +47,7 @@ sv_magicv2_exists_by_auxsv(SV *sv, SV *auxsvref)
SV *
MgAUXSV(SV *sv, SV *magicname)
// args different than the C macros
+ PROTOTYPE: \[$@%]$
ALIAS:
MgAUXSV = 0
MgPRIV = 2
@@ -47,7 +55,7 @@ MgAUXSV(SV *sv, SV *magicname)
MgKEYSV = 4
CODE:
{
- MAGIC *mg = sv_magicv2_find_by_funcs(sv, S_magicfuncs_by_name(aTHX_ magicname));
+ MAGIC *mg = sv_magicv2_find_by_funcs(SvRV(sv), S_magicfuncs_by_name(aTHX_ magicname));
if(!mg)
XSRETURN_UNDEF;
@@ -242,3 +250,19 @@ void
sv_magicv2_remove(SV *sv, SV *magicname)
CODE:
sv_magicv2_remove_by_funcs(sv, S_magicfuncs_by_name(aTHX_ magicname));
+
+SV *
+find_lexical_protosub(SV *name)
+ CODE:
+ PADOFFSET padix = pad_findmy_sv(name, 0);
+ if (padix == NOT_IN_PAD)
+ croak("Did not find %" SVf " in the pad", SVfARG(name));
+
+ PADNAME *pn = PadnamelistARRAY(PL_comppad_name)[padix];
+ CV *protocv = PadnamePROTOCV(pn);
+ if (!protocv)
+ croak("Lexical sub %" SVf " does not have a protocv", SVfARG(name));
+
+ RETVAL = newRV_inc((SV *)protocv);
+ OUTPUT:
+ RETVAL
diff --git a/ext/XS-APItest/t/magicv2-code.t b/ext/XS-APItest/t/magicv2-code.t
new file mode 100644
index 0000000000..610e4d92f4
--- /dev/null
+++ b/ext/XS-APItest/t/magicv2-code.t
@@ -0,0 +1,56 @@
+use strict;
+use warnings;
+use Test::More;
+
+use XS::APItest;
+
+# Code magics with 'pre_newcv' / 'post_newcv' function
+{
+ # pre/post_newcv are invoked during compiletime so we have to use a BEGIN
+ # block to apply this magic early enough
+ our $MG_LOG;
+
+ sub testfunc {
+ BEGIN {
+ sv_magicv2_add(&{PL_compcv()}, 'log_on_newcv', \"A");
+ sv_magicv2_add(&{PL_compcv()}, 'log_on_newcv', \"B");
+ }
+ }
+
+ is $MG_LOG, join( ",", qw(
+ pre_newcv(<A>:cv=PL_compcv)
+ pre_newcv(<B>:cv=PL_compcv)
+ post_newcv(<B>:compcv=PL_compcv)
+ post_newcv(<A>:compcv=PL_compcv) ) ),
+ 'magic triggers invoked in correct order';
+}
+
+# Code magic 'pre_newcv' can alter optree
+{#
+ sub ten {
+ BEGIN {
+ sv_magicv2_add(&{PL_compcv()}, 'add_one_to_expr', undef);
+ }
+ 9;
+ }
+
+ is ten(), 10,
+ 'magic pre_newcv trigger can alter optree';
+}
+
+# Code magics with 'clone_cv' function
+{
+ my sub lexsub { }
+ BEGIN {
+ ## arranging to get code magic on a protosub early enough that we
+ ## get to run the clone_cv operation at all is nontrivial.
+ sv_magicv2_add(&{ find_lexical_protosub('&lexsub') },
+ copy_clonecv => \"this-is-protosub");
+ }
+
+ my $cv = \&lexsub;
+ is ${ MgAUXSV(&{$cv}, 'copy_clonecv') }, "this-is-clone",
+ 'MgAUXSV is copied by clone_cv and incremented';
+}
+
+done_testing;
diff --git a/mg.c b/mg.c
index e14506db59..b440deab54 100644
--- a/mg.c
+++ b/mg.c
@@ -332,6 +332,70 @@ clears the hash, such as C<undef %hash>.
=back
+=for apidoc Axy||struct CodeMagicFunctions
+
+This structure extends the basic C<struct MagicFunctions> by adding the
+following fields to store more trigger functions. It may only be applied
+to subroutines - i.e. those whose type is C<SVt_PVCV>.
+
+ struct CodeMagicFunctions {
+ ...
+
+ OP *(*pre_newcv)(pTHX_ SV *cv, OP *o, MAGIC *mg);
+ MAGIC *(*post_newcv)(pTHX_ SV *cv, SV *compcv, MAGIC *compmg);
+
+ MAGIC *(*clone_cv)(pTHX_ SV *ncv, SV *protocv,
+ MAGIC *protomg);
+ };
+
+For this structure, the C<shape> field takes the value C<MGv2s_CODE>.
+
+=over 4
+
+=item C<pre_newcv> trigger function
+
+An optional pointer to a function to be invoked as part of the L</newATTRSUB>
+or L</newMYSUB> API functions, when finishing the steps of compiling a new
+subroutine. To take effect, this magic has to be applied to C<PL_compcv>.
+
+This trigger function is passed a pointer to the optree representing the body
+of the function, and may inspect or alter it. The return value from the
+trigger function is then captured by the newly-created CV.
+
+In the case that C<PL_compcv> has multiple magic attachments that provide this
+trigger function, they are invoked in I<reverse> order - that is, the most
+recently applied magic is the first to get an opportunity to inspect the
+optree. Its result is then passed to the previous one, and so on, with the
+newly-created CV capturing the result of the final trigger function to be
+invoked, which is the one from the oldest-applied magic.
+
+=item C<post_newcv> trigger function
+
+An optional pointer to a function to be invoked as part of the L</newATTRSUB>
+or L</newMYSUB> API functions, when finishing the steps of compiling a new
+subroutine. To take effect, this magic has to be applied to C<PL_compcv>.
+
+This trigger function is invoked after the new CV has been created, and is
+passed a pointer to it, as well as the C<PL_compcv>. It can adjust or make
+use of the new CV; perhaps by copying its own magic there. As this trigger
+function has the same argument shape and return type as the C<localize_mg>
+trigger, it has the same ability to use L</magicv2_copy> or variants; or
+wrapping those in your own trigger function to perform additional steps.
+
+=item C<clone_cv> trigger function
+
+An optional pointer to a function to be invoked as part of the L</cv_clone>
+API function. It is passed a pointer to the new CV that was created as part
+of the clone operation, as well as the original protosub and the magic that
+invoked it.
+
+As this trigger function has the same argument shape and return type as the
+C<localize_mg> trigger, the same notes apply to this with regard to using
+L</magicv2_copy> or its variants; or wrapping those in your own trigger
+function to perform additional steps.
+
+=back
+
=for apidoc Axy||struct ScalarValueMagicFunctions
This structure extends the basic C<struct MagicFunctions> by adding the
@@ -481,6 +545,7 @@ Perl_mg_magical(SV *sv)
if (MgIsV2(mg)) {
switch (MgFUNCS(mg)->shape) {
case MGv2s_BASE:
+ case MGv2s_CODE:
break;
case MGv2s_SCALARVAR:
@@ -908,19 +973,41 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
MAGIC* mg;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- const MGVTBL* const vtbl = mg->mg_virtual;
- if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
- count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
+ if (MgIsV2(mg)) {
+ switch (MgFUNCS(mg)->shape) {
+ case MGv2s_BASE:
+ case MGv2s_SCALARVAR:
+ case MGv2s_ARRAYVAR:
+ case MGv2s_HASHVAR:
+ case MGv2s_SCALARVALUE:
+ /* nothing to do */
+ break;
+
+ case MGv2s_CODE:
+ {
+ /* This is a 'clone_cv' operation */
+ const struct CodeMagicFunctions *funcs = MgCODEFUNCS(mg);
+ if (funcs->clone_cv)
+ (*funcs->clone_cv)(aTHX_ nsv, sv, mg);
+ break;
+ }
+ }
}
else {
- const char type = mg->mg_type;
- if (isUPPER(type) && type != PERL_MAGIC_uvar) {
- sv_magic(nsv,
- (type == PERL_MAGIC_tied)
- ? SvTIED_obj(sv, mg)
- : mg->mg_obj,
- toLOWER(type), key, klen);
- count++;
+ const MGVTBL* const vtbl = mg->mg_virtual;
+ if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
+ count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
+ }
+ else {
+ const char type = mg->mg_type;
+ if (isUPPER(type) && type != PERL_MAGIC_uvar) {
+ sv_magic(nsv,
+ (type == PERL_MAGIC_tied)
+ ? SvTIED_obj(sv, mg)
+ : mg->mg_obj,
+ toLOWER(type), key, klen);
+ count++;
+ }
}
}
}
@@ -956,6 +1043,7 @@ Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
if (MgIsV2(mg)) {
switch(MgFUNCS(mg)->shape) {
case MGv2s_BASE:
+ case MGv2s_CODE:
case MGv2s_SCALARVALUE:
/* does not support localisation */
break;
diff --git a/mg.h b/mg.h
index 9987dfeead..ea20a8e95f 100644
--- a/mg.h
+++ b/mg.h
@@ -116,6 +116,7 @@ enum MagicShape {
MGv2s_SCALARVAR,
MGv2s_ARRAYVAR,
MGv2s_HASHVAR,
+ MGv2s_CODE,
MGv2s_SCALARVALUE,
};
@@ -226,6 +227,30 @@ magic structure is compatible.
#define MgHASHVARFUNCS(mg) MGv2_ASSERT_AND_CAST_FUNCS_(mg, MGv2s_HASHVAR, const struct HashVarMagicFunctions *)
+struct CodeMagicFunctions {
+ _PERL_MAGICFUNCTIONS_COMMON_FIELDS;
+ /* TODO: Add various trigger functions for lifetimes of the CV, including
+ * around its compiletime, and callchecker
+ */
+
+ OP *(*pre_newcv)(pTHX_ SV *cv, OP *o, MAGIC *mg);
+ MAGIC *(*post_newcv)(pTHX_ SV *cv, SV *compcv, MAGIC *compmg);
+
+ MAGIC *(*clone_cv)(pTHX_ SV *ncv, SV *protocv, MAGIC *protomg);
+};
+
+/*
+=for apidoc Am|const struct CodeMagicFunctions *|MgCODEFUNCS|MAGIC *mg
+Returns a pointer to the magic functions structure of the given Magic v2
+instance, cast to a type of C<const struct CodeMagicFunctions>. On debugging
+perls this will additionally assert that the I<shape> field of the magic
+structure is compatible.
+
+=cut
+*/
+
+#define MgCODEFUNCS(mg) MGv2_ASSERT_AND_CAST_FUNCS_(mg, MGv2s_CODE, const struct CodeMagicFunctions *)
+
#define MGv2f_SCALARVALUE_AUTOPROPAGATE (1<<18)
struct ScalarValueMagicFunctions {
diff --git a/op.c b/op.c
index c4ec8a97be..ababd13e3e 100644
--- a/op.c
+++ b/op.c
@@ -11490,6 +11490,51 @@ S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
return;
}
+#define run_codemagics_pre_newcv(cv, block) S_run_codemagics_pre_newcv(aTHX_ cv, block)
+static OP *
+S_run_codemagics_pre_newcv(pTHX_ SV *cv, OP *block)
+{
+ /* We want to run `pre_newcv` triggers in the reverse order from
+ * mg_moremagic iteration order. We'll capture MAGICs into a temporary
+ * AV so we can iterate it backwards.
+ */
+
+ AV *codemagics = NULL;
+
+ for (MAGIC *mg = SvMAGIC(cv); mg; mg = mg->mg_moremagic) {
+ if (MgIsV2(mg) &&
+ MgFUNCS(mg)->shape == MGv2s_CODE &&
+ MgCODEFUNCS(mg)->pre_newcv)
+ av_create_and_push(&codemagics, newSVuv(PTR2UV(mg)));
+ }
+
+ if (!codemagics)
+ return block;
+
+ sv_2mortal((SV *)codemagics);
+
+ UV n_magics = av_count(codemagics);
+ SV **svp = AvARRAY(codemagics);
+ for (UV i = n_magics; i > 0; i--) {
+ MAGIC *mg = INT2PTR(MAGIC *, SvUV(svp[i-1]));
+ block = (*MgCODEFUNCS(mg)->pre_newcv)(aTHX_ (SV *)cv, block, mg);
+ }
+
+ return block;
+}
+
+#define run_codemagics_post_newcv(newcv, compcv) S_run_codemagics_post_newcv(aTHX_ newcv, compcv)
+static void
+S_run_codemagics_post_newcv(pTHX_ SV *newcv, SV *compcv)
+{
+ for (MAGIC *mg = SvMAGIC(compcv); mg; mg = mg->mg_moremagic) {
+ if (MgIsV2(mg) &&
+ MgFUNCS(mg)->shape == MGv2s_CODE &&
+ MgCODEFUNCS(mg)->post_newcv)
+ (void)(*MgCODEFUNCS(mg)->post_newcv)(aTHX_ newcv, compcv, mg);
+ }
+}
+
/*
=for apidoc newMYSUB
@@ -11601,6 +11646,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
if (block) {
if (CvIsMETHOD(PL_compcv))
block = class_wrap_method_body(block);
+ if (SvMAGIC(PL_compcv))
+ block = run_codemagics_pre_newcv((SV *)PL_compcv, block);
/* This makes sub {}; work as expected. */
if (block->op_type == OP_STUB) {
const line_t l = PL_parser->copline;
@@ -11849,6 +11896,9 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
}
}
+ if (PL_compcv && SvMAGIC((SV *)PL_compcv))
+ run_codemagics_post_newcv((SV *)cv, (SV *)PL_compcv);
+
done:
if (PL_parser)
PL_parser->copline = NOLINE;
@@ -12153,8 +12203,13 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
if (block) {
assert(PL_parser);
+ /* TODO(leonerd):
+ * This suggests that class_wrap_method_body might want to just be some CODE magic */
if (CvIsMETHOD(PL_compcv))
block = class_wrap_method_body(block);
+ if (SvMAGIC((SV *)PL_compcv))
+ block = run_codemagics_pre_newcv((SV *)PL_compcv, block);
+
/* This makes sub {}; work as expected. */
if (block->op_type == OP_STUB) {
const line_t l = PL_parser->copline;
@@ -12425,6 +12480,10 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
}
assert(cv);
+
+ if (PL_compcv && SvMAGIC((SV *)PL_compcv))
+ run_codemagics_post_newcv((SV *)cv, (SV *)PL_compcv);
+
if (block && has_name) {
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV * const tmpstr = cv_name(cv,NULL,0);
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index b24b8bb99b..5bca15ac88 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -423,6 +423,15 @@ well.
=over 4
+=item * CODE magic for Magic v2
+
+A new sub-type of magic has been added, designed to be applied to subroutines
+(i.e. SVs having the type C<SVt_PVCV>). This magic sub-type has various
+trigger functions relating to compile-time or runtime management of the
+subroutine to which it is attached.
+
+For more details, see L<perlapi/"struct CodeMagicFunctions">.
+
=item * save_scalar_flags
Added a new function analogous to C<save_aelem_flags> and C<save_helem_flags>, to have more control over saving scalars.
diff --git a/sv.c b/sv.c
index 754617b79e..8a508a3f7d 100644
--- a/sv.c
+++ b/sv.c
@@ -6729,6 +6729,11 @@ Perl_sv_magicv2_add(pTHX_ SV *sv, const struct MagicFunctions *funcs, U32 flags,
goto bad_shape;
break;
+ case MGv2s_CODE:
+ if (svt != SVt_PVCV)
+ goto bad_shape;
+ break;
+
case MGv2s_SCALARVALUE:
if (svt > SVt_PVMG && svt != SVt_PVLV && svt != SVt_REGEXP)
goto bad_shape;