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 <[email protected]> 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 <[email protected]> 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 <[email protected]> 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 <[email protected]> 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
