Add tests for sv_{,un}magicext and mg_findext

3 files changed, 61 insertions, 0 deletions

diff --git a/MANIFEST b/MANIFEST
index d9281f462a..ed168026fe 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3440,6 +3440,7 @@ ext/XS-APItest/t/labelconst.t	test recursive descent label parsing
 ext/XS-APItest/t/loopblock.t	test recursive descent block parsing
 ext/XS-APItest/t/looprest.t	test recursive descent statement-sequence parsing
 ext/XS-APItest/t/magic_chain.t	test low-level MAGIC chain handling
+ext/XS-APItest/t/magic.t	test attaching, finding, and removing magic
 ext/XS-APItest/t/Markers.pm	Helper for ./blockhooks.t
 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/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 358159bb7d..325681ab5a 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -30,6 +30,8 @@ typedef struct {
 
 START_MY_CXT
 
+MGVTBL vtbl_foo, vtbl_bar;
+
 /* indirect functions to test the [pa]MY_CXT macros */
 
 int
@@ -2639,3 +2641,31 @@ BOOT:
     CV *asscv = get_cv("XS::APItest::postinc", 0);
     cv_set_call_checker(asscv, THX_ck_entersub_postinc, (SV*)asscv);
 }
+
+MODULE = XS::APItest		PACKAGE = XS::APItest::Magic
+
+PROTOTYPES: DISABLE
+
+void
+sv_magic_foo(SV *sv, SV *thingy)
+ALIAS:
+    sv_magic_bar = 1
+CODE:
+    sv_magicext(SvRV(sv), NULL, PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo, (const char *)thingy, 0);
+
+SV *
+mg_find_foo(SV *sv)
+ALIAS:
+    mg_find_bar = 1
+CODE:
+    MAGIC *mg = mg_findext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
+    RETVAL = mg ? SvREFCNT_inc((SV *)mg->mg_ptr) : &PL_sv_undef;
+OUTPUT:
+    RETVAL
+
+void
+sv_unmagic_foo(SV *sv)
+ALIAS:
+    sv_unmagic_bar = 1
+CODE:
+    sv_unmagicext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
diff --git a/ext/XS-APItest/t/magic.t b/ext/XS-APItest/t/magic.t
new file mode 100644
index 0000000000..9dfb7c1b79
--- /dev/null
+++ b/ext/XS-APItest/t/magic.t
@@ -0,0 +1,30 @@
+use strict;
+use warnings;
+use Test::More;
+
+use XS::APItest;
+
+my $sv = bless {}, 'Moo';
+my $foo = 'affe';
+my $bar = 'tiger';
+
+ok !mg_find_foo($sv), 'no foo magic yet';
+ok !mg_find_bar($sv), 'no bar magic yet';
+
+sv_magic_foo($sv, $foo);
+is mg_find_foo($sv), $foo, 'foo magic attached';
+ok !mg_find_bar($sv), '... but still no bar magic';
+
+sv_magic_bar($sv, $bar);
+is mg_find_foo($sv), $foo, 'foo magic still attached';
+is mg_find_bar($sv), $bar, '... and bar magic is there too';
+
+sv_unmagic_foo($sv);
+ok !mg_find_foo($sv), 'foo magic removed';
+is mg_find_bar($sv), $bar, '... but bar magic is still there';
+
+sv_unmagic_bar($sv);
+ok !mg_find_foo($sv), 'foo magic still removed';
+ok !mg_find_bar($sv), '... and bar magic is removed too';
+
+done_testing;