diff options
Diffstat (limited to 'ext')
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 37 | ||||
| -rw-r--r-- | ext/XS-APItest/t/magic.t | 50 |
2 files changed, 87 insertions, 0 deletions
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 00fccb3654..ff7667b24a 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -125,8 +125,19 @@ S_myset_set(pTHX_ SV* sv, MAGIC* mg) return 0; } +static int +S_myset_set_dies(pTHX_ SV* sv, MAGIC* mg) +{ + PERL_UNUSED_ARG(sv); + PERL_UNUSED_ARG(mg); + croak("in S_myset_set_dies"); + return 0; +} + + static MGVTBL vtbl_foo, vtbl_bar; static MGVTBL vtbl_myset = { 0, S_myset_set, 0, 0, 0, 0, 0, 0 }; +static MGVTBL vtbl_myset_dies = { 0, S_myset_set_dies, 0, 0, 0, 0, 0, 0 }; static int S_mycopy_copy(pTHX_ SV *sv, MAGIC* mg, SV *nsv, const char *name, I32 namlen) { @@ -4839,6 +4850,13 @@ test_get_vtbl() # where that magic's job is to increment thingy void +sv_magic_myset_dies(SV *rsv, SV *thingy) +CODE: + sv_magicext(SvRV(rsv), NULL, PERL_MAGIC_ext, &vtbl_myset_dies, + (const char *)thingy, 0); + + +void sv_magic_myset(SV *rsv, SV *thingy) CODE: sv_magicext(SvRV(rsv), NULL, PERL_MAGIC_ext, &vtbl_myset, @@ -4863,6 +4881,25 @@ sv_magic_mycopy_count(SV *rsv) OUTPUT: RETVAL +int +my_av_store(SV *rsv, IV i, SV *sv) + CODE: + if (av_store((AV*)SvRV(rsv), i, sv)) { + SvREFCNT_inc(sv); + RETVAL = 1; + } else { + RETVAL = 0; + } + OUTPUT: + RETVAL + +STRLEN +sv_refcnt(SV *sv) + CODE: + RETVAL = SvREFCNT(sv); + OUTPUT: + RETVAL + MODULE = XS::APItest PACKAGE = XS::APItest diff --git a/ext/XS-APItest/t/magic.t b/ext/XS-APItest/t/magic.t index 165121d3e4..8189523dc1 100644 --- a/ext/XS-APItest/t/magic.t +++ b/ext/XS-APItest/t/magic.t @@ -76,4 +76,54 @@ is $@, "", 'PERL_MAGIC_ext is permitted on read-only things'; is($i, 0, "hash () with set magic"); } +{ + # check if set magic triggered by av_store() via aassign results in + # unreferenced scalars being freed. IOW, results in a double store + # without a corresponding refcount bump. If things work properly this + # should not warn. If there is an issue it will. + my @warn; + local $SIG{__WARN__}= sub { push @warn, $_[0] }; + { + my (@a, $i); + sv_magic_myset_dies(\@a, $i); + eval { + $i = 0; + @a = (1); + }; + } + is(0+@warn, 0, + "If AV set magic dies via aassign it should not warn about double free"); + @warn = (); + { + my (@a, $i, $j); + sv_magic_myset_dies(\@a, $i); + eval { + $j = "blorp"; + my_av_store(\@a,0,$j); + }; + my $base_refcount = 2; # not sure where these come from. + if (\$a[0] == \$j) { + # in this case we expect to have an extra 2 refcounts, + # one from $a[0] and one from $j itself. + is( sv_refcnt($j), $base_refcount + 2, + "\$a[0] is \$j, so refcount(\$j) should be 4"); + } else { + # Note this branch isn't exercised. Whether by design + # or not. I leave it here because it is a possible valid + # outcome. It is marked TODO so if we start going down + # this path we do so knowingly. + diag "av_store has changed behavior - please review this test"; + TODO:{ + local $TODO = "av_store bug stores even if it dies during magic"; + # in this case we expect to have only 1 extra refcount, + # from $j itself. + is( sv_refcnt($j), $base_refcount + 1, + "\$a[0] is not \$j, so refcount(\$j) should be 3"); + } + } + } + is(0+@warn, 0, + "AV set magic that dies via av_store should not warn about double free"); +} + done_testing; |