In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/f837477cd1460eda104bacd7f162d25d5254563d?hp=557af69b54d1d713b9c1c375b3485b6ee43970ec>
- Log ----------------------------------------------------------------- commit f837477cd1460eda104bacd7f162d25d5254563d Author: David Mitchell <[email protected]> Date: Tue Oct 19 23:13:07 2010 +0100 Recursive MULTICALL prematurely freed CV See [perl #78070]. Basically, POPSUB/LEAVESUB had a mechanism to decrement the reference count of the CV only at CvDEPTH==1; POP_MULTICALL was decrementing it at all depths. M cop.h M ext/XS-APItest/t/multicall.t commit 9c540340879062c71c21eaf596d6df60630d5bb2 Author: David Mitchell <[email protected]> Date: Tue Oct 19 22:37:37 2010 +0100 add skeleton testing for the MULTICALL macros The macros dMULTICALL, PUSH_MULTICALL, MULTICALL and POP_MULTICALL are completely untested in core apart from incidentally in List-Util. The exercise they get there is probably quite comprehensive, but it's not explicitly testing the macros themselves. Add a hook and new test file to XS::APItest specifically for this purpose. Currently the test file is almost empty. The multicall_each function is shamelessly stolen from List:;Util::first. M MANIFEST M ext/XS-APItest/APItest.xs A ext/XS-APItest/t/multicall.t ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + cop.h | 4 +- ext/XS-APItest/APItest.xs | 39 +++++++++++++++++++++++++++++++++ ext/XS-APItest/t/multicall.t | 49 ++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 91 insertions(+), 2 deletions(-) create mode 100644 ext/XS-APItest/t/multicall.t diff --git a/MANIFEST b/MANIFEST index 0aa5c0f..7f88eb3 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3398,6 +3398,7 @@ ext/XS-APItest/t/keyword_plugin.t test keyword plugin mechanism 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/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 ext/XS-APItest/t/my_exit.t XS::APItest: test my_exit ext/XS-APItest/t/Null.pm Helper for ./blockhooks.t diff --git a/cop.h b/cop.h index 4791c80..8e77ae2 100644 --- a/cop.h +++ b/cop.h @@ -928,8 +928,8 @@ See L<perlcall/Lightweight Callbacks>. #define POP_MULTICALL \ STMT_START { \ - LEAVESUB(multicall_cv); \ - CvDEPTH(multicall_cv)--; \ + if (! --CvDEPTH(multicall_cv)) \ + LEAVESUB(multicall_cv); \ POPBLOCK(cx,PL_curpm); \ POPSTACK; \ CATCH_SET(multicall_oldcatch); \ diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index e39281f..da37281 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -2082,6 +2082,45 @@ rpeep_record () OUTPUT: RETVAL +=pod + +multicall_each: call a sub for each item in the list. Used to test MULTICALL + +=cut + +void +multicall_each(block,...) + SV * block +PROTOTYPE: &@ +CODE: +{ + dMULTICALL; + int index; + GV *gv; + HV *stash; + I32 gimme = G_SCALAR; + SV **args = &PL_stack_base[ax]; + CV *cv; + + if(items <= 1) { + XSRETURN_UNDEF; + } + cv = sv_2cv(block, &stash, &gv, 0); + if (cv == Nullcv) { + croak("multicall_each: not a subroutine reference"); + } + PUSH_MULTICALL(cv); + SAVESPTR(GvSV(PL_defgv)); + + for(index = 1 ; index < items ; index++) { + GvSV(PL_defgv) = args[index]; + MULTICALL; + } + POP_MULTICALL; + XSRETURN_UNDEF; +} + + BOOT: { HV* stash; diff --git a/ext/XS-APItest/t/multicall.t b/ext/XS-APItest/t/multicall.t new file mode 100644 index 0000000..69f7b77 --- /dev/null +++ b/ext/XS-APItest/t/multicall.t @@ -0,0 +1,49 @@ +#!perl -w + +# test the MULTICALL macros +# Note: as of Oct 2010, there are not yet comprehensive tests +# for these macros. + +use warnings; +use strict; + +use Test::More tests => 6; +use XS::APItest; + + +{ + my $sum = 0; + sub add { $sum += $_++ } + + my @a = (1..3); + XS::APItest::multicall_each \&add, @a; + is($sum, 6, "sum okay"); + is($a[0], 2, "a[0] okay"); + is($a[1], 3, "a[1] okay"); + is($a[2], 4, "a[2] okay"); +} + +# [perl #78070] +# multicall using a sub that aleady has CvDEPTH > 1 caused sub +# to be prematurely freed + +{ + my $destroyed = 0; + sub REC::DESTROY { $destroyed = 1 } + + my $closure_var; + { + my $f = sub { + $closure_var; + my $sub = shift; + if (defined $sub) { + XS::APItest::multicall_each \&$sub, 1,2,3; + } + }; + bless $f, 'REC'; + $f->($f); + is($destroyed, 0, "f not yet destroyed"); + } + is($destroyed, 1, "f now destroyed"); + +} -- Perl5 Master Repository
