develooper Front page | perl.perl5.changes | Postings from November 2010

[perl.git] branch blead, updated. v5.13.7-206-gf6ee7b1

From:
Florian Ragwitz
Date:
November 30, 2010 04:37
Subject:
[perl.git] branch blead, updated. v5.13.7-206-gf6ee7b1
Message ID:
E1PNPSX-00054w-Kp@camel.ams6.corp.booking.com
In perl.git, the branch blead has been updated

<http://perl5.git.perl.org/perl.git/commitdiff/f6ee7b17ee667bcbf2498da72f68d82fe533b6d6?hp=31b05a0f9f5158b8f1340a8e92be562574510792>

- Log -----------------------------------------------------------------
commit f6ee7b17ee667bcbf2498da72f68d82fe533b6d6
Author: Florian Ragwitz <rafl@debian.org>
Date:   Thu Nov 25 02:53:40 2010 +0100

    Update perlguts for sv_unmagicext and mg_findext

M	pod/perlguts.pod

commit 26ab20eec63c596b43c0d540691562ec6b160e7c
Author: Florian Ragwitz <rafl@debian.org>
Date:   Thu Nov 25 02:40:16 2010 +0100

    Add tests for sv_{,un}magicext and mg_findext

M	MANIFEST
M	ext/XS-APItest/APItest.xs
A	ext/XS-APItest/t/magic.t

commit 39de7f53b474076d5a8e28b5b41fddefd29e45d7
Author: Florian Ragwitz <rafl@debian.org>
Date:   Thu Nov 25 02:40:00 2010 +0100

    Add mg_findext

M	embed.fnc
M	embed.h
M	global.sym
M	mg.c
M	proto.h

commit b83794c7d64c56b8d918c51e93d1136d33fa202b
Author: Florian Ragwitz <rafl@debian.org>
Date:   Thu Nov 25 01:06:27 2010 +0100

    Add sv_unmagicext

M	embed.fnc
M	embed.h
M	global.sym
M	proto.h
M	sv.c
-----------------------------------------------------------------------

Summary of changes:
 MANIFEST                  |    1 +
 embed.fnc                 |    2 +
 embed.h                   |    2 +
 ext/XS-APItest/APItest.xs |   30 +++++++++++++++++++++++++++
 ext/XS-APItest/t/magic.t  |   30 +++++++++++++++++++++++++++
 global.sym                |    2 +
 mg.c                      |   45 ++++++++++++++++++++++++++++++++--------
 pod/perlguts.pod          |   33 ++++++++++++++++++++---------
 proto.h                   |    8 +++++++
 sv.c                      |   50 ++++++++++++++++++++++++++++++++------------
 10 files changed, 170 insertions(+), 33 deletions(-)
 create mode 100644 ext/XS-APItest/t/magic.t

diff --git a/MANIFEST b/MANIFEST
index d9281f4..ed16802 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/embed.fnc b/embed.fnc
index fe8f43c..cca7a78 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -727,6 +727,7 @@ Apd	|int	|mg_copy	|NN SV *sv|NN SV *nsv|NULLOK const char *key \
 : Defined in mg.c, used only in scope.c
 pd	|void	|mg_localize	|NN SV* sv|NN SV* nsv|bool setmagic
 ApdR	|MAGIC*	|mg_find	|NULLOK const SV* sv|int type
+ApdR	|MAGIC*	|mg_findext	|NULLOK const SV* sv|int type|NULLOK const MGVTBL *vtbl
 Apd	|int	|mg_free	|NN SV* sv
 Apd	|void	|mg_free_type	|NN SV* sv|int how
 Apd	|int	|mg_get		|NN SV* sv
@@ -1253,6 +1254,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..85ec05c 100644
--- a/embed.h
+++ b/embed.h
@@ -278,6 +278,7 @@
 #define mg_clear(a)		Perl_mg_clear(aTHX_ a)
 #define mg_copy(a,b,c,d)	Perl_mg_copy(aTHX_ a,b,c,d)
 #define mg_find(a,b)		Perl_mg_find(aTHX_ a,b)
+#define mg_findext(a,b,c)	Perl_mg_findext(aTHX_ a,b,c)
 #define mg_free(a)		Perl_mg_free(aTHX_ a)
 #define mg_free_type(a,b)	Perl_mg_free_type(aTHX_ a,b)
 #define mg_get(a)		Perl_mg_get(aTHX_ a)
@@ -595,6 +596,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/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 358159b..325681a 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 0000000..9dfb7c1
--- /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;
diff --git a/global.sym b/global.sym
index 7e8f38b..3831f00 100644
--- a/global.sym
+++ b/global.sym
@@ -311,6 +311,7 @@ Perl_mfree
 Perl_mg_clear
 Perl_mg_copy
 Perl_mg_find
+Perl_mg_findext
 Perl_mg_free
 Perl_mg_free_type
 Perl_mg_get
@@ -696,6 +697,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/mg.c b/mg.c
index e734d80..39f07f5 100644
--- a/mg.c
+++ b/mg.c
@@ -416,6 +416,26 @@ Perl_mg_clear(pTHX_ SV *sv)
     return 0;
 }
 
+MAGIC*
+S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
+{
+    PERL_UNUSED_CONTEXT;
+
+    assert(flags <= 1);
+
+    if (sv) {
+	MAGIC *mg;
+
+	for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+	    if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
+		return mg;
+	    }
+	}
+    }
+
+    return NULL;
+}
+
 /*
 =for apidoc mg_find
 
@@ -427,15 +447,22 @@ Finds the magic pointer for type matching the SV.  See C<sv_magic>.
 MAGIC*
 Perl_mg_find(pTHX_ const SV *sv, int type)
 {
-    PERL_UNUSED_CONTEXT;
-    if (sv) {
-        MAGIC *mg;
-        for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
-            if (mg->mg_type == type)
-                return mg;
-        }
-    }
-    return NULL;
+    return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
+}
+
+/*
+=for apidoc mg_findext
+
+Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>.  See
+C<sv_magicext>.
+
+=cut
+*/
+
+MAGIC*
+Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
+{
+    return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
 }
 
 /*
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index 8327db2..66bcc8d 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -963,6 +963,12 @@ To remove the magic from an SV, call the function sv_unmagic:
 The C<type> argument should be equal to the C<how> value when the C<SV>
 was initially made magical.
 
+However, note that C<sv_unmagic> removes all magic of a certain C<type> from the
+C<SV>. If you want to remove only certain magic of a C<type> based on the magic
+virtual table, use C<sv_unmagicext> instead:
+
+    int sv_unmagicext(SV *sv, int type, MGVTBL *vtbl);
+
 =head2 Magic Virtual Tables
 
 The C<mg_virtual> field in the C<MAGIC> structure is a pointer to an
@@ -1128,16 +1134,16 @@ objects blessed into the same class as the extension is sufficient.
 For C<PERL_MAGIC_ext> magic, it is usually a good idea to define an
 C<MGVTBL>, even if all its fields will be C<0>, so that individual
 C<MAGIC> pointers can be identified as a particular kind of magic
-using their C<mg_virtual> field.
+using their magic virtual table. C<mg_findext> provides an easy way
+to do that:
 
     STATIC MGVTBL my_vtbl = { 0, 0, 0, 0, 0, 0, 0, 0 };
 
     MAGIC *mg;
-    for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
-        if (mg->mg_type == PERL_MAGIC_ext && mg->mg_virtual == &my_vtbl) {
-            /* this is really ours, not another module's PERL_MAGIC_ext */
-            my_priv_data_t *priv = (my_priv_data_t *)mg->mg_ptr;
-        }
+    if ((mg = mg_findext(sv, PERL_MAGIC_ext, &my_vtbl))) {
+        /* this is really ours, not another module's PERL_MAGIC_ext */
+        my_priv_data_t *priv = (my_priv_data_t *)mg->mg_ptr;
+        ...
     }
 
 Also note that the C<sv_set*()> and C<sv_cat*()> functions described
@@ -1154,11 +1160,18 @@ since their implementation handles 'get' magic.
 
 =head2 Finding Magic
 
-    MAGIC* mg_find(SV*, int type); /* Finds the magic pointer of that type */
+    MAGIC *mg_find(SV *sv, int type); /* Finds the magic pointer of that type */
+
+This routine returns a pointer to a C<MAGIC> structure stored in the SV.
+If the SV does not have that magical feature, C<NULL> is returned. If the
+SV has multiple instances of that magical feature, the first one will be
+returned. C<mg_findext> can be used to find a C<MAGIC> structure of an SV
+based on both it's magic type and it's magic virtual table:
+
+    MAGIC *mg_findext(SV *sv, int type, MGVTBL *vtbl);
 
-This routine returns a pointer to the C<MAGIC> structure stored in the SV.
-If the SV does not have that magical feature, C<NULL> is returned.  Also,
-if the SV is not of type SVt_PVMG, Perl may core dump.
+Also, if the SV passed to C<mg_find> or C<mg_findext> is not of type
+SVt_PVMG, Perl may core dump.
 
     int mg_copy(SV* sv, SV* nsv, const char* key, STRLEN klen);
 
diff --git a/proto.h b/proto.h
index a05f2b9..b44a4ba 100644
--- a/proto.h
+++ b/proto.h
@@ -2208,6 +2208,9 @@ PERL_CALLCONV int	Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 PERL_CALLCONV MAGIC*	Perl_mg_find(pTHX_ const SV* sv, int type)
 			__attribute__warn_unused_result__;
 
+PERL_CALLCONV MAGIC*	Perl_mg_findext(pTHX_ const SV* sv, int type, const MGVTBL *vtbl)
+			__attribute__warn_unused_result__;
+
 PERL_CALLCONV int	Perl_mg_free(pTHX_ SV* sv)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_MG_FREE	\
@@ -4406,6 +4409,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
--- 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

--
Perl5 Master Repository



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About