Add sv_unmagicext

5 files changed, 44 insertions, 14 deletions

diff --git a/embed.fnc b/embed.fnc
index fe8f43caa4..cee3c23bfb 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1253,6 +1253,7 @@ Amdb	|void	|sv_setsv	|NN SV *dstr|NULLOK SV *sstr
 Amdb	|void	|sv_taint	|NN SV* sv
 ApdR	|bool	|sv_tainted	|NN SV *const sv
 Apd	|int	|sv_unmagic	|NN SV *const sv|const int type
+Apd	|int	|sv_unmagicext	|NN SV *const sv|const int type|NULLOK MGVTBL *vtbl
 Apdmb	|void	|sv_unref	|NN SV* sv
 Apd	|void	|sv_unref_flags	|NN SV *const ref|const U32 flags
 Apd	|void	|sv_untaint	|NN SV *const sv
diff --git a/embed.h b/embed.h
index d484a10820..b18ba5cf14 100644
--- a/embed.h
+++ b/embed.h
@@ -595,6 +595,7 @@
 #define sv_true(a)		Perl_sv_true(aTHX_ a)
 #define sv_uni_display(a,b,c,d)	Perl_sv_uni_display(aTHX_ a,b,c,d)
 #define sv_unmagic(a,b)		Perl_sv_unmagic(aTHX_ a,b)
+#define sv_unmagicext(a,b,c)	Perl_sv_unmagicext(aTHX_ a,b,c)
 #define sv_unref_flags(a,b)	Perl_sv_unref_flags(aTHX_ a,b)
 #define sv_untaint(a)		Perl_sv_untaint(aTHX_ a)
 #define sv_upgrade(a,b)		Perl_sv_upgrade(aTHX_ a,b)
diff --git a/global.sym b/global.sym
index 7e8f38b4f3..4aaa59ea40 100644
--- a/global.sym
+++ b/global.sym
@@ -696,6 +696,7 @@ Perl_sv_tainted
 Perl_sv_true
 Perl_sv_uni_display
 Perl_sv_unmagic
+Perl_sv_unmagicext
 Perl_sv_unref
 Perl_sv_unref_flags
 Perl_sv_untaint
diff --git a/proto.h b/proto.h
index a05f2b9d79..6469297e58 100644
--- a/proto.h
+++ b/proto.h
@@ -4406,6 +4406,11 @@ PERL_CALLCONV int	Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
 #define PERL_ARGS_ASSERT_SV_UNMAGIC	\
 	assert(sv)
 
+PERL_CALLCONV int	Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_UNMAGICEXT	\
+	assert(sv)
+
 /* PERL_CALLCONV void	Perl_sv_unref(pTHX_ SV* sv)
 			__attribute__nonnull__(pTHX_1); */
 #define PERL_ARGS_ASSERT_SV_UNREF	\
diff --git a/sv.c b/sv.c
index aa6b7908f7..c0c2458191 100644
--- a/sv.c
+++ b/sv.c
@@ -5330,31 +5330,23 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
     }
 }
 
-/*
-=for apidoc sv_unmagic
-
-Removes all magic of type C<type> from an SV.
-
-=cut
-*/
-
 int
-Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
+S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
 {
     MAGIC* mg;
     MAGIC** mgp;
 
-    PERL_ARGS_ASSERT_SV_UNMAGIC;
+    assert(flags <= 1);
 
     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
 	return 0;
     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
     for (mg = *mgp; mg; mg = *mgp) {
-	if (mg->mg_type == type) {
-            const MGVTBL* const vtbl = mg->mg_virtual;
+	const MGVTBL* const virt = mg->mg_virtual;
+	if (mg->mg_type == type && (!flags || virt == vtbl)) {
 	    *mgp = mg->mg_moremagic;
-	    if (vtbl && vtbl->svt_free)
-		vtbl->svt_free(aTHX_ sv, mg);
+	    if (virt && virt->svt_free)
+		virt->svt_free(aTHX_ sv, mg);
 	    if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
 		if (mg->mg_len > 0)
 		    Safefree(mg->mg_ptr);
@@ -5382,6 +5374,36 @@ Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
 }
 
 /*
+=for apidoc sv_unmagic
+
+Removes all magic of type C<type> from an SV.
+
+=cut
+*/
+
+int
+Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
+{
+    PERL_ARGS_ASSERT_SV_UNMAGIC;
+    return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
+}
+
+/*
+=for apidoc sv_unmagicext
+
+Removes all magic of type C<type> with the specified C<vtbl> from an SV.
+
+=cut
+*/
+
+int
+Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
+{
+    PERL_ARGS_ASSERT_SV_UNMAGICEXT;
+    return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
+}
+
+/*
 =for apidoc sv_rvweaken
 
 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the