From: Vincent Pit Date: Sat, 24 Jan 2009 16:36:13 +0000 (+0100) Subject: Fix segfaults when using get or uvar magic simultaneously with clear magic X-Git-Tag: v0.28~2 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=03eb870636b3e9f56a04a7a5291752e26f36829e Fix segfaults when using get or uvar magic simultaneously with clear magic --- diff --git a/Magic.xs b/Magic.xs index 44d6c88..73536b8 100644 --- a/Magic.xs +++ b/Magic.xs @@ -89,6 +89,10 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) { # define Newx(v, n, c) New(0, v, n, c) #endif +#ifndef NewOp +# define NewOp(m, var, c, type) Newz(m, var, c, type) +#endif + #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val)) #endif @@ -101,6 +105,10 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) { # define PERL_MAGIC_ext '~' #endif +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + #ifndef MGf_COPY # define MGf_COPY 0 #endif @@ -344,8 +352,11 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) { mg->mg_flags |= MGf_LOCAL; #endif /* MGf_LOCAL */ + if (SvTYPE(sv) < SVt_PVHV) + goto done; + #if VMG_UVAR - if (w->uvar && SvTYPE(sv) >= SVt_PVHV) { + if (w->uvar) { MAGIC *prevmagic; int add_uvar = 1; struct ufuncs uf[2]; @@ -373,15 +384,20 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) { uf[1] = *olduf; vmg_uvar_del(sv, prevmagic, mg, moremagic); } - } + } else if (w->cb_get) + SvGMAGICAL_off(sv); if (add_uvar) { vmg_sv_magicuvar(sv, (const char *) &uf, sizeof(uf)); } } +#else + if (w->cb_get) + SvGMAGICAL_off(sv); #endif /* VMG_UVAR */ +done: return 1; } @@ -636,10 +652,16 @@ STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) { #endif /* MGf_LOCAL */ #if VMG_UVAR +STATIC OP *vmg_pp_resetuvar(pTHX) { + SvRMAGICAL_on(cSVOP_sv); + return NORMAL; +} + STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { struct ufuncs *uf; MAGIC *mg, *umg; SV *key = NULL, *newkey = NULL; + int tied = 0; umg = mg_find(sv, PERL_MAGIC_uvar); /* umg can't be NULL or we wouldn't be there. */ @@ -652,9 +674,17 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { action &= HV_FETCH_ISSTORE | HV_FETCH_ISEXISTS | HV_FETCH_LVALUE | HV_DELETE; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGWIZ *w; - if ((mg->mg_type != PERL_MAGIC_ext) - || (mg->mg_private < SIG_MIN) - || (mg->mg_private > SIG_MAX)) { continue; } + switch (mg->mg_type) { + case PERL_MAGIC_ext: + break; + case PERL_MAGIC_tied: + ++tied; + continue; + default: + continue; + } + if (mg->mg_private < SIG_MIN || mg->mg_private > SIG_MAX) + continue; w = SV2MGWIZ(mg->mg_ptr); switch (w->uvar) { case 0: @@ -681,6 +711,25 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { } } + if (SvRMAGICAL(sv) && !tied) { + /* Temporarily hide the RMAGICAL flag of the hash so it isn't wrongly + * mistaken for a tied hash by the rest of hv_common. It will be reset by + * the op_ppaddr of a new fake op injected between the current and the next + * one. */ + OP *o = PL_op; + if (!o->op_next || o->op_next->op_ppaddr != vmg_pp_resetuvar) { + SVOP *svop; + NewOp(1101, svop, 1, SVOP); + svop->op_type = OP_STUB; + svop->op_ppaddr = vmg_pp_resetuvar; + svop->op_next = o->op_next; + svop->op_flags = 0; + svop->op_sv = sv; + o->op_next = (OP *) svop; + } + SvRMAGICAL_off(sv); + } + return 0; } #endif /* VMG_UVAR */ diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm index 1fea760..a94fbe3 100644 --- a/lib/Variable/Magic.pm +++ b/lib/Variable/Magic.pm @@ -462,8 +462,6 @@ The only way to address this would be to return a reference. If you define a wizard with a C callback and cast it on itself, this destructor won't be called because the wizard will be destroyed first. -Using simultaneously C and C magics on hashes may cause segfaults. - =head1 DEPENDENCIES L 5.7.3. diff --git a/t/32-hash.t b/t/32-hash.t index 8803e35..bf01b3d 100644 --- a/t/32-hash.t +++ b/t/32-hash.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 2 * 20 + 6 + 1; +use Test::More tests => 2 * 21 + 7 + 1; use Variable::Magic qw/cast dispell MGf_COPY VMG_UVAR/; @@ -11,7 +11,7 @@ use lib 't/lib'; use Variable::Magic::TestWatcher; my $wiz = init - [ qw/get set len free copy dup local fetch store exists delete/ ], # clear + [ qw/get set len clear free copy dup local fetch store exists delete/ ], 'hash'; my %n = map { $_ => int rand 1000 } qw/foo bar baz qux/; @@ -20,12 +20,13 @@ my %h = %n; check { cast %h, $wiz } { }, 'cast'; my $s = check { $h{foo} } +{ (fetch => 1) x VMG_UVAR }, - # (copy => 1) x MGf_COPY # if clear magic 'assign element to'; is $s, $n{foo}, 'hash: assign element to correctly'; -$s = check { exists $h{foo} } +{ (exists => 1) x VMG_UVAR }, 'exists'; -ok $s, 'hash: exists correctly'; +for (1 .. 2) { + $s = check { exists $h{foo} } +{ (exists => 1) x VMG_UVAR }, "exists ($_)"; + ok $s, "hash: exists correctly ($_)"; +} my %b; check { %b = %h } { }, 'assign to'; @@ -35,17 +36,16 @@ $s = check { \%h } { }, 'reference'; my @b = check { @h{qw/bar qux/} } +{ (fetch => 2) x VMG_UVAR }, 'slice'; - # (copy => 2) x MGf_COPY # if clear magic is_deeply \@b, [ @n{qw/bar qux/} ], 'hash: slice correctly'; -check { %h = () } { }, 'empty in list context'; # clear => 1 +check { %h = () } { clear => 1 }, 'empty in list context'; check { %h = (a => 1, d => 3); () } - +{ (store => 2, copy => 2) x VMG_UVAR }, # clear => 1 + +{ (store => 2, copy => 2) x VMG_UVAR, clear => 1 }, 'assign from list in void context'; check { %h = map { $_ => 1 } qw/a b d/; } - +{ (exists => 3, store => 3, copy => 3) x VMG_UVAR }, # clear =>1 + +{ (exists => 3, store => 3, copy => 3) x VMG_UVAR, clear => 1 }, 'assign from map in list context'; check { $h{d} = 2; () } +{ (store => 1) x VMG_UVAR }, @@ -69,6 +69,6 @@ check { check { cast %b, $wiz } { }, 'cast 2'; } { free => 1 }, 'scope end'; -check { undef %h } { }, 'undef'; # clear => 1 +check { undef %h } { clear => 1 }, 'undef'; check { dispell %h, $wiz } { }, 'dispell';