Add sv_unmagicext
authorFlorian Ragwitz <rafl@debian.org>
Thu, 25 Nov 2010 00:06:27 +0000 (01:06 +0100)
committerFlorian Ragwitz <rafl@debian.org>
Tue, 30 Nov 2010 11:37:29 +0000 (12:37 +0100)
embed.fnc
embed.h
global.sym
proto.h
sv.c

index fe8f43c..cee3c23 100644 (file)
--- 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 d484a10..b18ba5c 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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)
index 7e8f38b..4aaa59e 100644 (file)
@@ -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 a05f2b9..6469297 100644 (file)
--- 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 aa6b790..c0c2458 100644 (file)
--- 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);
@@ -5381,6 +5373,36 @@ Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
     return 0;
 }
 
+/*
+=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