From: Brandon L Black Date: Mon, 4 Jun 2007 04:14:24 +0000 (+0000) Subject: fix broken gotos for Catalyst::Plugin::C3, added slightly modified next::method tests... X-Git-Tag: 0.07~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2605e5915fb1dc1d8cd98585f16cb57d1df11c5b;p=gitmo%2FClass-C3-XS.git fix broken gotos for Catalyst::Plugin::C3, added slightly modified next::method tests from Class::C3 --- diff --git a/XS.xs b/XS.xs index 40f535d..f120168 100644 --- a/XS.xs +++ b/XS.xs @@ -266,9 +266,13 @@ __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { return i; } -STATIC SV* -__nextcan(pTHX_ SV* self, I32 throw_nomethod) +XS(XS_Class_C3_XS_nextcan); +XS(XS_Class_C3_XS_nextcan) { + dVAR; dXSARGS; + + SV* self; + I32 throw_nomethod; register I32 cxix; register const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; @@ -288,11 +292,16 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) GV* candidate = NULL; CV* cand_cv = NULL; const char *hvname; - I32 items; + I32 entries; HV* nmcache; HE* cache_entry; SV* cachekey; + self = ST(0); + throw_nomethod = SvIVX(ST(1)); + + SP -= items; + if(sv_isobject(self)) selfstash = SvSTASH(SvRV(self)); else @@ -305,6 +314,7 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); cxix = __dopoptosub_at(cxstack, cxstack_ix); + cxix = __dopoptosub_at(ccstack, cxix - 1); /* This block finds the contextually-enclosing fully-qualified subname, much like looking at (caller($i))[3] until you find a real sub that @@ -376,9 +386,10 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) if(val == &PL_sv_undef) { if(throw_nomethod) Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); - return &PL_sv_undef; + XSRETURN_EMPTY; } - return SvREFCNT_inc(val); + XPUSHs(sv_2mortal(newRV_inc(val))); + XSRETURN(1); } /* beyond here is just for cache misses, so perf isn't as critical */ @@ -389,20 +400,20 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0); linear_svp = AvARRAY(linear_av); - items = AvFILLp(linear_av) + 1; + entries = AvFILLp(linear_av) + 1; - while (items--) { + while (entries--) { SV* const linear_sv = *linear_svp++; assert(linear_sv); if(sv_eq(linear_sv, stashname)) break; } - if(items > 0) { + if(entries > 0) { SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len)); HV* cc3_mro = get_hv("Class::C3::MRO", 0); - while (items--) { + while (entries--) { SV* const linear_sv = *linear_svp++; assert(linear_sv); @@ -448,7 +459,8 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) SvREFCNT_dec(linear_av); SvREFCNT_inc((SV*)cand_cv); hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0); - return (SV*)cand_cv; + XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv))); + XSRETURN(1); } } } @@ -457,7 +469,7 @@ __nextcan(pTHX_ SV* self, I32 throw_nomethod) hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0); if(throw_nomethod) Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); - return &PL_sv_undef; + XSRETURN_EMPTY; } XS(XS_Class_C3_XS_calculateMRO); @@ -602,62 +614,11 @@ XS(XS_Class_C3_XS_calc_mdt) XSRETURN_EMPTY; } -XS(XS_next_can); -XS(XS_next_can) -{ - dVAR; dXSARGS; - - SV* self = ST(0); - SV* methcv = __nextcan(aTHX_ self, 0); - - PERL_UNUSED_VAR(items); - - if(methcv == &PL_sv_undef) { - ST(0) = &PL_sv_undef; - } - else { - ST(0) = sv_2mortal(newRV_inc(methcv)); - } - - XSRETURN(1); -} - -XS(XS_next_method); -XS(XS_next_method) -{ - dMARK; - dAX; - SV* self = ST(0); - SV* methcv = __nextcan(aTHX_ self, 1); - - PL_markstack_ptr++; - call_sv(methcv, GIMME_V); -} - -XS(XS_maybe_next_method); -XS(XS_maybe_next_method) -{ - dMARK; - dAX; - SV* self = ST(0); - SV* methcv = __nextcan(aTHX_ self, 0); - - if(methcv == &PL_sv_undef) { - ST(0) = &PL_sv_undef; - XSRETURN(1); - } - - PL_markstack_ptr++; - call_sv(methcv, GIMME_V); -} - MODULE = Class::C3::XS PACKAGE = Class::C3::XS BOOT: newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__); newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__); newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__); - newXS("next::can", XS_next_can, __FILE__); - newXS("next::method", XS_next_method, __FILE__); - newXS("maybe::next::method", XS_maybe_next_method, __FILE__); + newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__); diff --git a/lib/Class/C3/XS.pm b/lib/Class/C3/XS.pm index 96f31f1..10e41fe 100644 --- a/lib/Class/C3/XS.pm +++ b/lib/Class/C3/XS.pm @@ -47,4 +47,23 @@ it under the same terms as Perl itself. require XSLoader; XSLoader::load('Class::C3::XS', $VERSION); +package # hide me from PAUSE + next; + +sub can { Class::C3::XS::_nextcan($_[0], 0) } + +sub method { + my $method = Class::C3::XS::_nextcan($_[0], 1); + goto &$method; +} + +package # hide me from PAUSE + maybe::next; + +sub method { + my $method = Class::C3::XS::_nextcan($_[0], 0); + goto &$method if defined $method; + return; +} + 1; diff --git a/t/30_next_method.t b/t/30_next_method.t new file mode 100644 index 0000000..c488174 --- /dev/null +++ b/t/30_next_method.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 5; + +BEGIN { use_ok('Class::C3::XS') } + +=pod + +This tests the classic diamond inheritence pattern. + + + / \ + + \ / + + +=cut + +{ + package Diamond_A; + sub hello { 'Diamond_A::hello' } + sub foo { 'Diamond_A::foo' } +} +{ + package Diamond_B; + use base 'Diamond_A'; + sub foo { 'Diamond_B::foo => ' . (shift)->next::method() } +} +{ + package Diamond_C; + use base 'Diamond_A'; + + sub hello { 'Diamond_C::hello => ' . (shift)->next::method() } + sub foo { 'Diamond_C::foo => ' . (shift)->next::method() } +} +{ + package Diamond_D; + use base ('Diamond_B', 'Diamond_C'); + + sub foo { 'Diamond_D::foo => ' . (shift)->next::method() } +} + +is(Diamond_C->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected'); + +is(Diamond_C->can('hello')->('Diamond_C'), + 'Diamond_C::hello => Diamond_A::hello', + '... can(method) resolved itself as expected'); + +is(UNIVERSAL::can("Diamond_C", 'hello')->('Diamond_C'), + 'Diamond_C::hello => Diamond_A::hello', + '... can(method) resolved itself as expected'); + +is(Diamond_D->foo, + 'Diamond_D::foo => Diamond_B::foo => Diamond_C::foo => Diamond_A::foo', + '... method foo resolved itself as expected'); diff --git a/t/31_next_method_skip.t b/t/31_next_method_skip.t new file mode 100644 index 0000000..262eda7 --- /dev/null +++ b/t/31_next_method_skip.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 10; + +BEGIN { use_ok('Class::C3::XS') } + +=pod + +This tests the classic diamond inheritence pattern. + + + / \ + + \ / + + +=cut + +{ + package Diamond_A; + sub bar { 'Diamond_A::bar' } + sub baz { 'Diamond_A::baz' } +} +{ + package Diamond_B; + use base 'Diamond_A'; + sub baz { 'Diamond_B::baz => ' . (shift)->next::method() } +} +{ + package Diamond_C; + use base 'Diamond_A'; + sub foo { 'Diamond_C::foo' } + sub buz { 'Diamond_C::buz' } + + sub woz { 'Diamond_C::woz' } + sub maybe { 'Diamond_C::maybe' } +} +{ + package Diamond_D; + use base ('Diamond_B', 'Diamond_C'); + sub foo { 'Diamond_D::foo => ' . (shift)->next::method() } + sub bar { 'Diamond_D::bar => ' . (shift)->next::method() } + sub buz { 'Diamond_D::buz => ' . (shift)->baz() } + sub fuz { 'Diamond_D::fuz => ' . (shift)->next::method() } + + sub woz { 'Diamond_D::woz can => ' . ((shift)->next::can() ? 1 : 0) } + sub noz { 'Diamond_D::noz can => ' . ((shift)->next::can() ? 1 : 0) } + + sub maybe { 'Diamond_D::maybe => ' . ((shift)->maybe::next::method() || 0) } + sub moybe { 'Diamond_D::moybe => ' . ((shift)->maybe::next::method() || 0) } + +} + +is(Diamond_D->foo, 'Diamond_D::foo => Diamond_C::foo', '... skipped B and went to C correctly'); +is(Diamond_D->bar, 'Diamond_D::bar => Diamond_A::bar', '... skipped B & C and went to A correctly'); +is(Diamond_D->baz, 'Diamond_B::baz => Diamond_A::baz', '... called B method, skipped C and went to A correctly'); +is(Diamond_D->buz, 'Diamond_D::buz => Diamond_B::baz => Diamond_A::baz', '... called D method dispatched to , different method correctly'); +eval { Diamond_D->fuz }; +like($@, qr/^No next::method 'fuz' found for Diamond_D/, '... cannot re-dispatch to a method which is not there'); + +is(Diamond_D->woz, 'Diamond_D::woz can => 1', '... can re-dispatch figured out correctly'); +is(Diamond_D->noz, 'Diamond_D::noz can => 0', '... cannot re-dispatch figured out correctly'); + +is(Diamond_D->maybe, 'Diamond_D::maybe => Diamond_C::maybe', '... redispatched D to C when it exists'); +is(Diamond_D->moybe, 'Diamond_D::moybe => 0', '... quietly failed redispatch from D'); diff --git a/t/32_next_method_edge_cases.t b/t/32_next_method_edge_cases.t new file mode 100644 index 0000000..422f134 --- /dev/null +++ b/t/32_next_method_edge_cases.t @@ -0,0 +1,81 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 12; + +BEGIN { use_ok('Class::C3::XS') } + +{ + + { + package Foo; + use strict; + use warnings; + sub new { bless {}, $_[0] } + sub bar { 'Foo::bar' } + } + + # call the submethod in the direct instance + + my $foo = Foo->new(); + isa_ok($foo, 'Foo'); + + can_ok($foo, 'bar'); + is($foo->bar(), 'Foo::bar', '... got the right return value'); + + # fail calling it from a subclass + + { + package Bar; + use strict; + use warnings; + our @ISA = ('Foo'); + } + + my $bar = Bar->new(); + isa_ok($bar, 'Bar'); + isa_ok($bar, 'Foo'); + + # test it working with with Sub::Name + SKIP: { + eval 'use Sub::Name'; + skip "Sub::Name is required for this test", 3 if $@; + + my $m = sub { (shift)->next::method() }; + Sub::Name::subname('Bar::bar', $m); + { + no strict 'refs'; + *{'Bar::bar'} = $m; + } + + can_ok($bar, 'bar'); + my $value = eval { $bar->bar() }; + ok(!$@, '... calling bar() succedded') || diag $@; + is($value, 'Foo::bar', '... got the right return value too'); + } + + # test it failing without Sub::Name + { + package Baz; + use strict; + use warnings; + our @ISA = ('Foo'); + } + + my $baz = Baz->new(); + isa_ok($baz, 'Baz'); + isa_ok($baz, 'Foo'); + + { + my $m = sub { (shift)->next::method() }; + { + no strict 'refs'; + *{'Baz::bar'} = $m; + } + + eval { $baz->bar() }; + ok($@, '... calling bar() with next::method failed') || diag $@; + } +} diff --git a/t/33_next_method_used_with_NEXT.t b/t/33_next_method_used_with_NEXT.t new file mode 100644 index 0000000..42a3b61 --- /dev/null +++ b/t/33_next_method_used_with_NEXT.t @@ -0,0 +1,52 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +BEGIN { + eval "use NEXT"; + plan skip_all => "NEXT required for this test" if $@; + plan tests => 4; +} + +use Class::C3::XS; + +{ + package Foo; + use strict; + use warnings; + + sub foo { 'Foo::foo' } + + package Fuz; + use strict; + use warnings; + use base 'Foo'; + + sub foo { 'Fuz::foo => ' . (shift)->next::method } + + package Bar; + use strict; + use warnings; + use base 'Foo'; + + sub foo { 'Bar::foo => ' . (shift)->next::method } + + package Baz; + use strict; + use warnings; + require NEXT; # load this as late as possible so we can catch the test skip + + use base 'Bar', 'Fuz'; + + sub foo { 'Baz::foo => ' . (shift)->NEXT::foo } +} + +is(Foo->foo, 'Foo::foo', '... got the right value from Foo->foo'); +is(Fuz->foo, 'Fuz::foo => Foo::foo', '... got the right value from Fuz->foo'); +is(Bar->foo, 'Bar::foo => Foo::foo', '... got the right value from Bar->foo'); + +is(Baz->foo, 'Baz::foo => Bar::foo => Fuz::foo => Foo::foo', '... got the right value using NEXT in a subclass of a C3 class'); + diff --git a/t/34_next_method_in_eval.t b/t/34_next_method_in_eval.t new file mode 100644 index 0000000..8dc9f44 --- /dev/null +++ b/t/34_next_method_in_eval.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; + +BEGIN { use_ok('Class::C3::XS') } + +=pod + +This tests the use of an eval{} block to wrap a next::method call. + +=cut + +{ + package A; + + sub foo { + die 'A::foo died'; + return 'A::foo succeeded'; + } +} + +{ + package B; + use base 'A'; + + sub foo { + eval { + return 'B::foo => ' . (shift)->next::method(); + }; + + if ($@) { + return $@; + } + } +} + +like(B->foo, + qr/^A::foo died/, + 'method resolved inside eval{}'); + + diff --git a/t/35_next_method_in_anon.t b/t/35_next_method_in_anon.t new file mode 100644 index 0000000..aa82f9c --- /dev/null +++ b/t/35_next_method_in_anon.t @@ -0,0 +1,57 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 3; + +BEGIN { use_ok('Class::C3::XS') } + +=pod + +This tests the successful handling of a next::method call from within an +anonymous subroutine. + +=cut + +{ + package A; + + sub foo { + return 'A::foo'; + } + + sub bar { + return 'A::bar'; + } +} + +{ + package B; + use base 'A'; + + sub foo { + my $code = sub { + return 'B::foo => ' . (shift)->next::method(); + }; + return (shift)->$code; + } + + sub bar { + my $code1 = sub { + my $code2 = sub { + return 'B::bar => ' . (shift)->next::method(); + }; + return (shift)->$code2; + }; + return (shift)->$code1; + } +} + +is(B->foo, "B::foo => A::foo", + 'method resolved inside anonymous sub'); + +is(B->bar, "B::bar => A::bar", + 'method resolved inside nested anonymous subs'); + + diff --git a/t/36_next_goto.t b/t/36_next_goto.t new file mode 100644 index 0000000..8766cf5 --- /dev/null +++ b/t/36_next_goto.t @@ -0,0 +1,35 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 5; + +BEGIN { use_ok('Class::C3::XS') } + +{ + package Proxy; + our @ISA = qw//; + sub next_proxy { goto &next::method } + sub maybe_proxy { goto &maybe::next::method } + sub can_proxy { goto &next::can } + + package TBase; + our @ISA = qw//; + sub foo { 42 } + sub bar { 24 } + # baz doesn't exist intentionally + sub quux { 242 } + + package TTop; + our @ISA = qw/TBase/; + sub foo { shift->Proxy::next_proxy() } + sub bar { shift->Proxy::maybe_proxy() } + sub baz { shift->Proxy::maybe_proxy() } + sub quux { shift->Proxy::can_proxy()->() } +} + +is(TTop->foo, 42, 'proxy next::method via goto'); +is(TTop->bar, 24, 'proxy maybe::next::method via goto'); +is(TTop->baz, undef, 'proxy maybe::next::method via goto with no method'); +is(TTop->quux, 242, 'proxy next::can via goto');