From: Vincent Pit Date: Sun, 5 Aug 2012 20:39:43 +0000 (+0200) Subject: Don't crash if dispell is called in a clear, free or uvar callback X-Git-Tag: v0.51~8 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=4de8639a5eb25d672b6248bd80e433abd0a267e2;p=perl%2Fmodules%2FVariable-Magic.git Don't crash if dispell is called in a clear, free or uvar callback --- diff --git a/Magic.xs b/Magic.xs index 94d816f..e45baea 100644 --- a/Magic.xs +++ b/Magic.xs @@ -401,7 +401,9 @@ STATIC const char vmg_argstorefailed[] = "Error while storing arguments"; #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION typedef struct { - HV *b__op_stashes[OPc_MAX]; + HV *b__op_stashes[OPc_MAX]; + I32 depth; + MAGIC *freed_tokens; } my_cxt_t; START_MY_CXT @@ -767,11 +769,12 @@ typedef struct { STATIC void vmg_mg_del(pTHX_ SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremagic) { #define vmg_mg_del(S, P, M, N) vmg_mg_del(aTHX_ (S), (P), (M), (N)) + dMY_CXT; + if (prevmagic) prevmagic->mg_moremagic = moremagic; else SvMAGIC_set(sv, moremagic); - mg->mg_moremagic = NULL; /* Destroy private data */ #if VMG_UVAR @@ -779,15 +782,42 @@ STATIC void vmg_mg_del(pTHX_ SV *sv, MAGIC *prevmagic, MAGIC *mg, MAGIC *moremag Safefree(mg->mg_ptr); } else { #endif /* VMG_UVAR */ - if (mg->mg_obj != sv) + if (mg->mg_obj != sv) { SvREFCNT_dec(mg->mg_obj); + mg->mg_obj = NULL; + } /* Unreference the wizard */ SvREFCNT_dec((SV *) mg->mg_ptr); + mg->mg_ptr = NULL; #if VMG_UVAR } #endif /* VMG_UVAR */ - Safefree(mg); + if (MY_CXT.depth) { + mg->mg_moremagic = MY_CXT.freed_tokens; + MY_CXT.freed_tokens = mg; + } else { + mg->mg_moremagic = NULL; + Safefree(mg); + } +} + +STATIC int vmg_magic_chain_free(pTHX_ MAGIC *mg, MAGIC *skip) { +#define vmg_magic_chain_free(M, S) vmg_magic_chain_free(aTHX_ (M), (S)) + int skipped = 0; + + while (mg) { + MAGIC *moremagic = mg->mg_moremagic; + + if (mg == skip) + ++skipped; + else + Safefree(mg); + + mg = moremagic; + } + + return skipped; } STATIC UV vmg_cast(pTHX_ SV *sv, const vmg_wizard *w, const SV *wiz, SV **args, I32 items) { @@ -1026,12 +1056,77 @@ STATIC SV *vmg_op_info(pTHX_ unsigned int opinfo) { #define VMG_CB_CALL_ARGS_MASK 15 #define VMG_CB_CALL_ARGS_SHIFT 4 -#define VMG_CB_CALL_OPINFO (VMG_OP_INFO_NAME|VMG_OP_INFO_OBJECT) +#define VMG_CB_CALL_OPINFO (VMG_OP_INFO_NAME|VMG_OP_INFO_OBJECT) /* 1|2 */ +#define VMG_CB_CALL_GUARD 4 + +STATIC int vmg_dispell_guard_oncroak(pTHX_ void *ud) { + dMY_CXT; + + MY_CXT.depth--; + + /* If we're at the upmost magic call and we're about to die, we can just free + * the tokens right now, since we will jump past the problematic part of our + * caller. */ + if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) { + vmg_magic_chain_free(MY_CXT.freed_tokens, NULL); + MY_CXT.freed_tokens = NULL; + } + + return 1; +} + +STATIC int vmg_dispell_guard_free(pTHX_ SV *sv, MAGIC *mg) { + vmg_magic_chain_free((MAGIC *) mg->mg_ptr, NULL); + + return 0; +} + +#if VMG_THREADSAFE + +STATIC int vmg_dispell_guard_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *params) { + /* The freed magic tokens aren't cloned by perl because it cannot reach them + * (they have been detached from their parent SV when they were enqueued). + * Hence there's nothing to purge in the new thread. */ + mg->mg_ptr = NULL; + + return 0; +} + +#endif /* VMG_THREADSAFE */ + +STATIC MGVTBL vmg_dispell_guard_vtbl = { + NULL, /* get */ + NULL, /* set */ + NULL, /* len */ + NULL, /* clear */ + vmg_dispell_guard_free, /* free */ + NULL, /* copy */ +#if VMG_THREADSAFE + vmg_dispell_guard_dup, /* dup */ +#else + NULL, /* dup */ +#endif +#if MGf_LOCAL + NULL, /* local */ +#endif /* MGf_LOCAL */ +}; + +STATIC SV *vmg_dispell_guard_new(pTHX_ MAGIC *root) { +#define vmg_dispell_guard_new(R) vmg_dispell_guard_new(aTHX_ (R)) + SV *guard; + + guard = sv_newmortal(); + sv_magicext(guard, NULL, PERL_MAGIC_ext, &vmg_dispell_guard_vtbl, + (char *) root, 0); + + return guard; +} STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) { va_list ap; int ret = 0; unsigned int i, args, opinfo; + MAGIC **chain = NULL; SV *svr; dSP; @@ -1056,7 +1151,16 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) { XPUSHs(vmg_op_info(opinfo)); PUTBACK; - vmg_call_sv(cb, G_SCALAR, 0, NULL); + if (flags & VMG_CB_CALL_GUARD) { + dMY_CXT; + MY_CXT.depth++; + vmg_call_sv(cb, G_SCALAR, vmg_dispell_guard_oncroak, NULL); + MY_CXT.depth--; + if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) + chain = &MY_CXT.freed_tokens; + } else { + vmg_call_sv(cb, G_SCALAR, 0, NULL); + } SPAGAIN; svr = POPs; @@ -1067,6 +1171,11 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) { FREETMPS; LEAVE; + if (chain) { + vmg_dispell_guard_new(*chain); + *chain = NULL; + } + return ret; } @@ -1180,8 +1289,13 @@ STATIC U32 vmg_svt_len_noop(pTHX_ SV *sv, MAGIC *mg) { STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) { const vmg_wizard *w = vmg_wizard_from_mg_nocheck(mg); + unsigned int flags = w->opinfo; + +#if !VMG_HAS_PERL(5, 12, 0) + flags |= VMG_CB_CALL_GUARD; +#endif - return vmg_cb_call1(w->cb_clear, w->opinfo, sv, mg->mg_obj); + return vmg_cb_call1(w->cb_clear, flags, sv, mg->mg_obj); } #define vmg_svt_clear_noop vmg_svt_default_noop @@ -1201,6 +1315,8 @@ STATIC int vmg_svt_free_cleanup(pTHX_ void *ud) { } SvREFCNT_dec(sv); + vmg_dispell_guard_oncroak(aTHX_ ud); + /* After that, propagate the error upwards. */ return 1; } @@ -1240,7 +1356,18 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) { XPUSHs(vmg_op_info(w->opinfo)); PUTBACK; - vmg_call_sv(w->cb_free, G_SCALAR, vmg_svt_free_cleanup, sv); + { + dMY_CXT; + MY_CXT.depth++; + vmg_call_sv(w->cb_free, G_SCALAR, vmg_svt_free_cleanup, sv); + MY_CXT.depth--; + if (MY_CXT.depth == 0 && MY_CXT.freed_tokens) { + /* Free all the tokens in the chain but the current one (if it's present). + * It will be taken care of by our caller, Perl_mg_free(). */ + vmg_magic_chain_free(MY_CXT.freed_tokens, mg); + MY_CXT.freed_tokens = NULL; + } + } SPAGAIN; svr = POPs; @@ -1320,6 +1447,7 @@ STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) { /* ... uvar magic .......................................................... */ #if VMG_UVAR + STATIC OP *vmg_pp_resetuvar(pTHX) { SvRMAGICAL_on(cSVOP_sv); return NORMAL; @@ -1327,7 +1455,7 @@ STATIC OP *vmg_pp_resetuvar(pTHX) { STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { vmg_uvar_ud *ud; - MAGIC *mg, *umg; + MAGIC *mg, *umg, *moremagic; SV *key = NULL, *newkey = NULL; int tied = 0; @@ -1341,9 +1469,13 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { if (ud->old_uf.uf_set) ud->old_uf.uf_set(aTHX_ action, sv); - for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { + for (mg = SvMAGIC(sv); mg; mg = moremagic) { const vmg_wizard *w; + /* mg may be freed later by the uvar call, so we need to fetch the next + * token before reaching that fateful point. */ + moremagic = mg->mg_moremagic; + switch (mg->mg_type) { case PERL_MAGIC_ext: break; @@ -1370,21 +1502,25 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS|HV_FETCH_LVALUE|HV_DELETE)) { case 0: if (w->cb_fetch) - vmg_cb_call2(w->cb_fetch, w->opinfo, sv, mg->mg_obj, key); + vmg_cb_call2(w->cb_fetch, w->opinfo | VMG_CB_CALL_GUARD, sv, + mg->mg_obj, key); break; case HV_FETCH_ISSTORE: case HV_FETCH_LVALUE: case (HV_FETCH_ISSTORE|HV_FETCH_LVALUE): if (w->cb_store) - vmg_cb_call2(w->cb_store, w->opinfo, sv, mg->mg_obj, key); + vmg_cb_call2(w->cb_store, w->opinfo | VMG_CB_CALL_GUARD, sv, + mg->mg_obj, key); break; case HV_FETCH_ISEXISTS: if (w->cb_exists) - vmg_cb_call2(w->cb_exists, w->opinfo, sv, mg->mg_obj, key); + vmg_cb_call2(w->cb_exists, w->opinfo | VMG_CB_CALL_GUARD, sv, + mg->mg_obj, key); break; case HV_DELETE: if (w->cb_delete) - vmg_cb_call2(w->cb_delete, w->opinfo, sv, mg->mg_obj, key); + vmg_cb_call2(w->cb_delete, w->opinfo | VMG_CB_CALL_GUARD, sv, + mg->mg_obj, key); break; } } @@ -1410,6 +1546,7 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) { return 0; } + #endif /* VMG_UVAR */ /* --- Macros for the XS section ------------------------------------------- */ @@ -1469,6 +1606,8 @@ BOOT: MY_CXT_INIT; for (c = OPc_NULL; c < OPc_MAX; ++c) MY_CXT.b__op_stashes[c] = NULL; + MY_CXT.depth = 0; + MY_CXT.freed_tokens = NULL; #if VMG_THREADSAFE MUTEX_INIT(&vmg_vtable_refcount_mutex); MUTEX_INIT(&vmg_op_name_init_mutex); @@ -1506,6 +1645,7 @@ CLONE(...) PROTOTYPE: DISABLE PREINIT: U32 had_b__op_stash = 0; + I32 old_depth; int c; PPCODE: { @@ -1514,6 +1654,7 @@ PPCODE: if (MY_CXT.b__op_stashes[c]) had_b__op_stash |= (((U32) 1) << c); } + old_depth = MY_CXT.depth; } { MY_CXT_CLONE; @@ -1521,6 +1662,8 @@ PPCODE: MY_CXT.b__op_stashes[c] = (had_b__op_stash & (((U32) 1) << c)) ? gv_stashpv(vmg_opclassnames[c], 1) : NULL; } + MY_CXT.depth = old_depth; + MY_CXT.freed_tokens = NULL; } XSRETURN(0); diff --git a/t/15-self.t b/t/15-self.t index 1491dfe..a205ea5 100644 --- a/t/15-self.t +++ b/t/15-self.t @@ -3,9 +3,14 @@ use strict; use warnings; -use Test::More tests => 17; +use Test::More; -use Variable::Magic qw; +my $tests; +BEGIN { $tests = 17 } + +plan tests => $tests; + +use Variable::Magic qw; use lib 't/lib'; use Variable::Magic::TestGlobalDestruction; @@ -52,6 +57,135 @@ my $c = 0; ok($res, 're-re-cast on self is valid'); } +{ + my %testcases; + + BEGIN { + my %magics = do { + my @magics = qw; + push @magics, 'local' if MGf_LOCAL; + push @magics, qw if VMG_UVAR; + map { $_ => 1 } @magics; + }; + + %testcases = ( + SCALAR => { + id => 1, + ctor => sub { my $val = 123; \$val }, + tests => [ + get => [ sub { my $val = ${$_[0]} } => 123 ], + set => [ sub { ${$_[0]} = 456; $_[0] } => \456 ], + free => [ ], + ], + }, + ARRAY => { + id => 2, + ctor => sub { [ 0 .. 2 ] }, + tests => [ + len => [ sub { my $len = @{$_[0]} } => 3 ], + clear => [ sub { @{$_[0]} = (); $_[0] } => [ ] ], + free => [ ], + ], + }, + HASH => { + id => 3, + ctor => sub { +{ foo => 'bar' } }, + tests => [ + clear => [ sub { %{$_[0]} = (); $_[0] } => +{ } ], + free => [ ], + fetch => [ sub { my $val = $_[0]->{foo} } => 'bar' ], + store => [ sub { $_[0]->{foo} = 'baz'; $_[0] } => { foo => 'baz' } ], + exists => [ sub { my $res = exists $_[0]->{foo} } => 1 ], + delete => [ sub { my $val = delete $_[0]->{foo} } => 'bar' ], + ], + }, + ); + + my $count; + + for my $testcases (map $_->{tests}, values %testcases) { + my $i = 0; + while ($i < $#$testcases) { + if ($magics{$testcases->[$i]}) { + $i += 2; + ++$count; + } else { + splice @$testcases, $i, 2; + } + } + } + + $tests += $count * 2 * 2 * 3; + } + + my @types = sort { $testcases{$a}->{id} <=> $testcases{$b}->{id} } + keys %testcases; + + my $other_wiz = wizard data => sub { 'abc' }; + + for my $type (@types) { + my $ctor = $testcases{$type}->{ctor}; + + my @testcases = @{$testcases{$type}->{tests}}; + while (@testcases >= 2) { + my ($magic, $test) = splice @testcases, 0, 2; + + for my $dispell (0, 1) { + for my $die (0, 1) { + my $desc = $dispell ? 'dispell' : 'cast'; + $desc .= " a $type from a $magic callback"; + $desc .= ' and dieing' if $die; + + my $wiz; + my $code = $dispell + ? sub { &dispell($_[0], $wiz); die 'oops' if $die; return } + : sub { &cast($_[0], $other_wiz); die 'oops' if $die; return }; + $wiz = wizard( + data => sub { 'xyz' }, + $magic => $code, + ); + + my ($var, $res, $err); + if ($magic eq 'free') { + eval { + my $v = $ctor->(); + &cast($v, $wiz); + }; + $err = $@; + } else { + $var = $ctor->(); + &cast($var, $wiz); + $res = eval { + $test->[0]->($var); + }; + $err = $@; + } + + if ($die) { + SKIP: { + skip 'error not propagated' => 1 if $magic eq 'free'; + like $err, qr/^oops at/, "$desc: correct error"; + } + is $res, undef, "$desc: returned undef"; + } else { + is $err, '', "$desc: no error"; + is_deeply $res, $test->[1], "$desc: returned value"; + } + if (not defined $var) { + pass "$desc: meaningless"; + } elsif ($dispell) { + my $data = &getdata($var, $wiz); + is $data, undef, "$desc: correctly dispelled"; + } else { + my $data = &getdata($var, $other_wiz); + is $data, 'abc', "$desc: correctly cast"; + } + } + } + } + } +} + eval q[ use lib 't/lib'; BEGIN { require Variable::Magic::TestDestroyRequired; }