In perl.git, the branch smoke-me/newCONSTSUB has been updated <http://perl5.git.perl.org/perl.git/commitdiff/13e259f2566a0cad6e3d7b149b13e15b20c1768a?hp=afae8808e2be45f9eb45f5551351755194ae1773>
- Log ----------------------------------------------------------------- commit 13e259f2566a0cad6e3d7b149b13e15b20c1768a Author: Nicholas Clark <[email protected]> Date: Mon Aug 13 16:11:35 2012 +0200 Document that newCONSTSUB{,_flags} takes ownership of a reference to the SV. Also note the collusion between op_const_cv() and cv_clone(), whereby the former returns a fresh copy of the SV to the latter, which is then immediately passed to newCONSTSUB. M op.c M pad.c commit 18edd4971ac128be66132e3b220021e7dec6ecba Author: Nicholas Clark <[email protected]> Date: Mon Aug 13 15:11:41 2012 +0200 XS::APItest::newCONSTSUB was not handling SV reference counts correctly. newCONSTSUB() and newCONSTSUB_flags() take ownership of (one reference to) the passed-in SV. As the XS wrapper is passing in a SV taken from the stack, it needs to up the reference count by one in order to avoid later bugs. M ext/XS-APItest/APItest.xs M ext/XS-APItest/t/newCONSTSUB.t commit 91cdc2bcb47045523af958816feb675fbac28451 Author: Nicholas Clark <[email protected]> Date: Mon Aug 13 13:38:03 2012 +0200 Use ALIAS to provide XS::APItest::newCONSTSUB and newCONSTSUB_flags Previously both C routines were wrapped with newCONSTSUB_type, which used a "type" parameter to determine which C code to call. Use an ALIAS to bind the code to two names, and eliminate the "type" parameter. This makes the test code clearer. It's not perfect, as the XS wrapper XS::APItest::newCONSTSUB has a flags parameter whereas the underlying C code does not, but fixing this would require considerably more XS hackery. M ext/XS-APItest/APItest.pm M ext/XS-APItest/APItest.xs M ext/XS-APItest/t/newCONSTSUB.t ----------------------------------------------------------------------- Summary of changes: ext/XS-APItest/APItest.pm | 2 +- ext/XS-APItest/APItest.xs | 11 ++++---- ext/XS-APItest/t/newCONSTSUB.t | 51 ++++++++++++++++++++++++++++++++-------- op.c | 6 ++++- pad.c | 3 ++ 5 files changed, 56 insertions(+), 17 deletions(-) diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 929bf49..a72fb6c 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp; -our $VERSION = '0.41'; +our $VERSION = '0.42'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 1685948..0979aee 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1957,24 +1957,25 @@ call_method(methname, flags, ...) PUSHs(sv_2mortal(newSViv(i))); void -newCONSTSUB_type(stash, name, flags, type, sv) +newCONSTSUB(stash, name, flags, sv) HV* stash SV* name I32 flags - int type SV* sv + ALIAS: + newCONSTSUB_flags = 1 PREINIT: CV* cv; STRLEN len; const char *pv = SvPV(name, len); PPCODE: - switch (type) { + switch (ix) { case 0: - cv = newCONSTSUB(stash, pv, SvOK(sv) ? sv : NULL); + cv = newCONSTSUB(stash, pv, SvOK(sv) ? SvREFCNT_inc(sv) : NULL); break; case 1: cv = newCONSTSUB_flags( - stash, pv, len, flags | SvUTF8(name), SvOK(sv) ? sv : NULL + stash, pv, len, flags | SvUTF8(name), SvOK(sv) ? SvREFCNT_inc(sv) : NULL ); break; } diff --git a/ext/XS-APItest/t/newCONSTSUB.t b/ext/XS-APItest/t/newCONSTSUB.t index afd4426..2df850e 100644 --- a/ext/XS-APItest/t/newCONSTSUB.t +++ b/ext/XS-APItest/t/newCONSTSUB.t @@ -3,7 +3,7 @@ use strict; use utf8; use open qw( :utf8 :std ); -use Test::More tests => 14; +use Test::More tests => 22; use XS::APItest; @@ -13,34 +13,34 @@ use XS::APItest; my $w; local $SIG{__WARN__} = sub { $w .= shift }; sub frimple() { 78 } - newCONSTSUB_type(\%::, "frimple", 0, 1, undef); + newCONSTSUB_flags(\%::, "frimple", 0, undef); like $w, qr/Constant subroutine frimple redefined at /, 'newCONSTSUB constant redefinition warning is unaffected by $^W=0'; undef $w; - newCONSTSUB_type(\%::, "frimple", 0, 1, undef); + newCONSTSUB_flags(\%::, "frimple", 0, undef); is $w, undef, '...unless the const SVs are the same'; eval 'sub frimple() { 78 }'; undef $w; - newCONSTSUB_type(\%::, "frimple", 0, 1, "78"); + newCONSTSUB_flags(\%::, "frimple", 0, "78"); is $w, undef, '...or the const SVs have the same value'; } use warnings; my ($const, $glob) = - XS::APItest::newCONSTSUB_type(\%::, "sanity_check", 0, 0, undef); + XS::APItest::newCONSTSUB(\%::, "sanity_check", 0, undef); ok $const; ok *{$glob}{CODE}; ($const, $glob) = - XS::APItest::newCONSTSUB_type(\%::, "\x{30cb}", 0, 0, undef); + XS::APItest::newCONSTSUB(\%::, "\x{30cb}", 0, undef); ok $const, "newCONSTSUB generates the constant,"; ok *{$glob}{CODE}, "..and the glob,"; ok !$::{"\x{30cb}"}, "...but not the right one"; ($const, $glob) = - XS::APItest::newCONSTSUB_type(\%::, "\x{30cd}", 0, 1, undef); + XS::APItest::newCONSTSUB_flags(\%::, "\x{30cd}", 0, undef); ok $const, "newCONSTSUB_flags generates the constant,"; ok *{$glob}{CODE}, "..and the glob,"; ok $::{"\x{30cd}"}, "...the right one!"; @@ -51,7 +51,7 @@ eval q{ my $w; local $SIG{__WARN__} = sub { $w .= shift }; *foo = sub(){123}; - newCONSTSUB_type(\%::, "foo", 0, 1, undef); + newCONSTSUB_flags(\%::, "foo", 0, undef); is $w, undef, 'newCONSTSUB uses calling scope for redefinition warnings'; } }; @@ -61,11 +61,42 @@ eval q{ *{"foo::\x{100}"} = sub(){return 123}; my $w; local $SIG{__WARN__} = sub { $w .= shift }; - newCONSTSUB_type(\%foo::, "\x{100}", 0, 1, undef); + newCONSTSUB_flags(\%foo::, "\x{100}", 0, undef); like $w, qr/Subroutine \x{100} redefined at /, 'newCONSTSUB redefinition warning + utf8'; undef $w; - newCONSTSUB_type(\%foo::, "\x{100}", 0, 1, 54); + newCONSTSUB_flags(\%foo::, "\x{100}", 0, 54); like $w, qr/Constant subroutine \x{100} redefined at /, 'newCONSTSUB constant redefinition warning + utf8'; } + +# XS::APItest was not handling references correctly here + +package Counter { + our $count = 0; + + sub new { + ++$count; + my $o = bless []; + return $o; + } + + sub DESTROY { + --$count; + } +}; + +foreach (['newCONSTSUB', 'ZZIP'], + ['newCONSTSUB_flags', 'BRRRAPP']) { + my ($using, $name) = @$_; + is($Counter::count, 0, 'No objects exist before we start'); + my $sub = XS::APItest->can($using); + ($const, $glob) = $sub->(\%::, $name, 0, Counter->new()); + is($const, 1, "subroutine generated by $using is CvCONST"); + is($Counter::count, 1, '1 object now exists'); + { + no warnings 'redefine'; + *$glob = sub () {}; + } + is($Counter::count, 0, 'no objects remain'); +} diff --git a/op.c b/op.c index 3aacc83..f3a0018 100644 --- a/op.c +++ b/op.c @@ -6758,7 +6758,8 @@ Perl_cv_const_sv(pTHX_ const CV *const cv) * * We have just cloned an anon prototype that was marked as a const * candidate. Try to grab the current value, and in the case of - * PADSV, ignore it if it has multiple references. Return the value. + * PADSV, ignore it if it has multiple references. In this case we + * return a newly created *copy* of the value. */ SV * @@ -7320,6 +7321,9 @@ eligible for inlining at compile-time. Currently, the only useful value for C<flags> is SVf_UTF8. +The newly created subroutine takes ownership of a reference to the passed in +SV. + Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>, which won't be called if used as a destructor, but will suppress the overhead of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at diff --git a/pad.c b/pad.c index e8f8a43..c672a0e 100644 --- a/pad.c +++ b/pad.c @@ -2079,6 +2079,9 @@ Perl_cv_clone(pTHX_ CV *proto) SV* const const_sv = op_const_sv(CvSTART(cv), cv); if (const_sv) { SvREFCNT_dec(cv); + /* For this calling case, op_const_sv returns a *copy*, which we + donate to newCONSTSUB. Yes, this is ugly, and should be killed. + Need to fix how lib/constant.pm works to eliminate this. */ cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv); } else { -- Perl5 Master Repository
