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;
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
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
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 */
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);
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);
}
}
}
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);
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__);
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;
--- /dev/null
+#!/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.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=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');
--- /dev/null
+#!/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.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=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');
--- /dev/null
+#!/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 $@;
+ }
+}
--- /dev/null
+#!/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');
+
--- /dev/null
+#!/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{}');
+
+
--- /dev/null
+#!/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');
+
+
--- /dev/null
+#!/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');
projects / gitmo/Class-C3-XS.git / commitdiff