diff options
Diffstat (limited to 't')
32 files changed, 2309 insertions, 2 deletions
@@ -104,7 +104,7 @@ sub _populate_hash { } unless (@ARGV) { - foreach my $dir (qw(base comp cmd run io op uni)) { + foreach my $dir (qw(base comp cmd run io op uni mro)) { _find_tests($dir); } _find_tests("lib") unless $::core; diff --git a/t/mro/basic.t b/t/mro/basic.t new file mode 100644 index 0000000000..303708e1bd --- /dev/null +++ b/t/mro/basic.t @@ -0,0 +1,53 @@ +#!./perl + +use strict; +use warnings; + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More; + +plan tests => 8; + +{ + package MRO_A; + our @ISA = qw//; + package MRO_B; + our @ISA = qw//; + package MRO_C; + our @ISA = qw//; + package MRO_D; + our @ISA = qw/MRO_A MRO_B MRO_C/; + package MRO_E; + our @ISA = qw/MRO_A MRO_B MRO_C/; + package MRO_F; + our @ISA = qw/MRO_D MRO_E/; +} + +is(mro::get_mro('MRO_F'), 'dfs'); +is_deeply(mro::get_linear_isa('MRO_F'), + [qw/MRO_F MRO_D MRO_A MRO_B MRO_C MRO_E/] +); +mro::set_mro('MRO_F', 'c3'); +is(mro::get_mro('MRO_F'), 'c3'); +is_deeply(mro::get_linear_isa('MRO_F'), + [qw/MRO_F MRO_D MRO_E MRO_A MRO_B MRO_C/] +); + +my @isarev = sort { $a cmp $b } mro::get_isarev('MRO_B'); +is_deeply(\@isarev, + [qw/MRO_D MRO_E MRO_F/] +); + +ok(!mro::is_universal('MRO_B')); + +@UNIVERSAL::ISA = qw/MRO_F/; +ok(mro::is_universal('MRO_B')); + +@UNIVERSAL::ISA = (); +ok(mro::is_universal('MRO_B')); diff --git a/t/mro/basic_01_c3.t b/t/mro/basic_01_c3.t new file mode 100644 index 0000000000..95d347967f --- /dev/null +++ b/t/mro/basic_01_c3.t @@ -0,0 +1,53 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 4; + +=pod + +This tests the classic diamond inheritence pattern. + + <A> + / \ +<B> <C> + \ / + <D> + +=cut + +{ + package Diamond_A; + sub hello { 'Diamond_A::hello' } +} +{ + package Diamond_B; + use base 'Diamond_A'; +} +{ + package Diamond_C; + use base 'Diamond_A'; + + sub hello { 'Diamond_C::hello' } +} +{ + package Diamond_D; + use base ('Diamond_B', 'Diamond_C'); + use mro 'c3'; +} + +is_deeply( + mro::get_linear_isa('Diamond_D'), + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], + '... got the right MRO for Diamond_D'); + +is(Diamond_D->hello, 'Diamond_C::hello', '... method resolved itself as expected'); +is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected'); +is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected'); diff --git a/t/mro/basic_01_dfs.t b/t/mro/basic_01_dfs.t new file mode 100644 index 0000000000..11c15a264c --- /dev/null +++ b/t/mro/basic_01_dfs.t @@ -0,0 +1,53 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 4; + +=pod + +This tests the classic diamond inheritence pattern. + + <A> + / \ +<B> <C> + \ / + <D> + +=cut + +{ + package Diamond_A; + sub hello { 'Diamond_A::hello' } +} +{ + package Diamond_B; + use base 'Diamond_A'; +} +{ + package Diamond_C; + use base 'Diamond_A'; + + sub hello { 'Diamond_C::hello' } +} +{ + package Diamond_D; + use base ('Diamond_B', 'Diamond_C'); + use mro 'dfs'; +} + +is_deeply( + mro::get_linear_isa('Diamond_D'), + [ qw(Diamond_D Diamond_B Diamond_A Diamond_C) ], + '... got the right MRO for Diamond_D'); + +is(Diamond_D->hello, 'Diamond_A::hello', '... method resolved itself as expected'); +is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected'); +is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolved itself as expected'); diff --git a/t/mro/basic_02_c3.t b/t/mro/basic_02_c3.t new file mode 100644 index 0000000000..86fbc32f66 --- /dev/null +++ b/t/mro/basic_02_c3.t @@ -0,0 +1,121 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 10; + +=pod + +This example is take from: http://www.python.org/2.3/mro.html + +"My first example" +class O: pass +class F(O): pass +class E(O): pass +class D(O): pass +class C(D,F): pass +class B(D,E): pass +class A(B,C): pass + + + 6 + --- +Level 3 | O | (more general) + / --- \ + / | \ | + / | \ | + / | \ | + --- --- --- | +Level 2 3 | D | 4| E | | F | 5 | + --- --- --- | + \ \ _ / | | + \ / \ _ | | + \ / \ | | + --- --- | +Level 1 1 | B | | C | 2 | + --- --- | + \ / | + \ / \ / + --- +Level 0 0 | A | (more specialized) + --- + +=cut + +{ + package Test::O; + use mro 'c3'; + + package Test::F; + use mro 'c3'; + use base 'Test::O'; + + package Test::E; + use base 'Test::O'; + use mro 'c3'; + + sub C_or_E { 'Test::E' } + + package Test::D; + use mro 'c3'; + use base 'Test::O'; + + sub C_or_D { 'Test::D' } + + package Test::C; + use base ('Test::D', 'Test::F'); + use mro 'c3'; + + sub C_or_D { 'Test::C' } + sub C_or_E { 'Test::C' } + + package Test::B; + use mro 'c3'; + use base ('Test::D', 'Test::E'); + + package Test::A; + use base ('Test::B', 'Test::C'); + use mro 'c3'; +} + +is_deeply( + mro::get_linear_isa('Test::F'), + [ qw(Test::F Test::O) ], + '... got the right MRO for Test::F'); + +is_deeply( + mro::get_linear_isa('Test::E'), + [ qw(Test::E Test::O) ], + '... got the right MRO for Test::E'); + +is_deeply( + mro::get_linear_isa('Test::D'), + [ qw(Test::D Test::O) ], + '... got the right MRO for Test::D'); + +is_deeply( + mro::get_linear_isa('Test::C'), + [ qw(Test::C Test::D Test::F Test::O) ], + '... got the right MRO for Test::C'); + +is_deeply( + mro::get_linear_isa('Test::B'), + [ qw(Test::B Test::D Test::E Test::O) ], + '... got the right MRO for Test::B'); + +is_deeply( + mro::get_linear_isa('Test::A'), + [ qw(Test::A Test::B Test::C Test::D Test::E Test::F Test::O) ], + '... got the right MRO for Test::A'); + +is(Test::A->C_or_D, 'Test::C', '... got the expected method output'); +is(Test::A->can('C_or_D')->(), 'Test::C', '... can got the expected method output'); +is(Test::A->C_or_E, 'Test::C', '... got the expected method output'); +is(Test::A->can('C_or_E')->(), 'Test::C', '... can got the expected method output'); diff --git a/t/mro/basic_02_dfs.t b/t/mro/basic_02_dfs.t new file mode 100644 index 0000000000..bbce6a05a0 --- /dev/null +++ b/t/mro/basic_02_dfs.t @@ -0,0 +1,121 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 10; + +=pod + +This example is take from: http://www.python.org/2.3/mro.html + +"My first example" +class O: pass +class F(O): pass +class E(O): pass +class D(O): pass +class C(D,F): pass +class B(D,E): pass +class A(B,C): pass + + + 6 + --- +Level 3 | O | (more general) + / --- \ + / | \ | + / | \ | + / | \ | + --- --- --- | +Level 2 3 | D | 4| E | | F | 5 | + --- --- --- | + \ \ _ / | | + \ / \ _ | | + \ / \ | | + --- --- | +Level 1 1 | B | | C | 2 | + --- --- | + \ / | + \ / \ / + --- +Level 0 0 | A | (more specialized) + --- + +=cut + +{ + package Test::O; + use mro 'dfs'; + + package Test::F; + use mro 'dfs'; + use base 'Test::O'; + + package Test::E; + use base 'Test::O'; + use mro 'dfs'; + + sub C_or_E { 'Test::E' } + + package Test::D; + use mro 'dfs'; + use base 'Test::O'; + + sub C_or_D { 'Test::D' } + + package Test::C; + use base ('Test::D', 'Test::F'); + use mro 'dfs'; + + sub C_or_D { 'Test::C' } + sub C_or_E { 'Test::C' } + + package Test::B; + use mro 'dfs'; + use base ('Test::D', 'Test::E'); + + package Test::A; + use base ('Test::B', 'Test::C'); + use mro 'dfs'; +} + +is_deeply( + mro::get_linear_isa('Test::F'), + [ qw(Test::F Test::O) ], + '... got the right MRO for Test::F'); + +is_deeply( + mro::get_linear_isa('Test::E'), + [ qw(Test::E Test::O) ], + '... got the right MRO for Test::E'); + +is_deeply( + mro::get_linear_isa('Test::D'), + [ qw(Test::D Test::O) ], + '... got the right MRO for Test::D'); + +is_deeply( + mro::get_linear_isa('Test::C'), + [ qw(Test::C Test::D Test::O Test::F) ], + '... got the right MRO for Test::C'); + +is_deeply( + mro::get_linear_isa('Test::B'), + [ qw(Test::B Test::D Test::O Test::E) ], + '... got the right MRO for Test::B'); + +is_deeply( + mro::get_linear_isa('Test::A'), + [ qw(Test::A Test::B Test::D Test::O Test::E Test::C Test::F) ], + '... got the right MRO for Test::A'); + +is(Test::A->C_or_D, 'Test::D', '... got the expected method output'); +is(Test::A->can('C_or_D')->(), 'Test::D', '... can got the expected method output'); +is(Test::A->C_or_E, 'Test::E', '... got the expected method output'); +is(Test::A->can('C_or_E')->(), 'Test::E', '... can got the expected method output'); diff --git a/t/mro/basic_03_c3.t b/t/mro/basic_03_c3.t new file mode 100644 index 0000000000..08dfea8666 --- /dev/null +++ b/t/mro/basic_03_c3.t @@ -0,0 +1,107 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 4; + +=pod + +This example is take from: http://www.python.org/2.3/mro.html + +"My second example" +class O: pass +class F(O): pass +class E(O): pass +class D(O): pass +class C(D,F): pass +class B(E,D): pass +class A(B,C): pass + + 6 + --- +Level 3 | O | + / --- \ + / | \ + / | \ + / | \ + --- --- --- +Level 2 2 | E | 4 | D | | F | 5 + --- --- --- + \ / \ / + \ / \ / + \ / \ / + --- --- +Level 1 1 | B | | C | 3 + --- --- + \ / + \ / + --- +Level 0 0 | A | + --- + +>>> A.mro() +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>, +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>, +<type 'object'>) + +=cut + +{ + package Test::O; + use mro 'c3'; + + sub O_or_D { 'Test::O' } + sub O_or_F { 'Test::O' } + + package Test::F; + use base 'Test::O'; + use mro 'c3'; + + sub O_or_F { 'Test::F' } + + package Test::E; + use base 'Test::O'; + use mro 'c3'; + + package Test::D; + use base 'Test::O'; + use mro 'c3'; + + sub O_or_D { 'Test::D' } + sub C_or_D { 'Test::D' } + + package Test::C; + use base ('Test::D', 'Test::F'); + use mro 'c3'; + + sub C_or_D { 'Test::C' } + + package Test::B; + use base ('Test::E', 'Test::D'); + use mro 'c3'; + + package Test::A; + use base ('Test::B', 'Test::C'); + use mro 'c3'; +} + +is_deeply( + mro::get_linear_isa('Test::A'), + [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ], + '... got the right MRO for Test::A'); + +is(Test::A->O_or_D, 'Test::D', '... got the right method dispatch'); +is(Test::A->O_or_F, 'Test::F', '... got the right method dispatch'); + +# NOTE: +# this test is particularly interesting because the p5 dispatch +# would actually call Test::D before Test::C and Test::D is a +# subclass of Test::C +is(Test::A->C_or_D, 'Test::C', '... got the right method dispatch'); diff --git a/t/mro/basic_03_dfs.t b/t/mro/basic_03_dfs.t new file mode 100644 index 0000000000..d2af5b2ac9 --- /dev/null +++ b/t/mro/basic_03_dfs.t @@ -0,0 +1,107 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 4; + +=pod + +This example is take from: http://www.python.org/2.3/mro.html + +"My second example" +class O: pass +class F(O): pass +class E(O): pass +class D(O): pass +class C(D,F): pass +class B(E,D): pass +class A(B,C): pass + + 6 + --- +Level 3 | O | + / --- \ + / | \ + / | \ + / | \ + --- --- --- +Level 2 2 | E | 4 | D | | F | 5 + --- --- --- + \ / \ / + \ / \ / + \ / \ / + --- --- +Level 1 1 | B | | C | 3 + --- --- + \ / + \ / + --- +Level 0 0 | A | + --- + +>>> A.mro() +(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>, +<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>, +<type 'object'>) + +=cut + +{ + package Test::O; + use mro 'dfs'; + + sub O_or_D { 'Test::O' } + sub O_or_F { 'Test::O' } + + package Test::F; + use base 'Test::O'; + use mro 'dfs'; + + sub O_or_F { 'Test::F' } + + package Test::E; + use base 'Test::O'; + use mro 'dfs'; + + package Test::D; + use base 'Test::O'; + use mro 'dfs'; + + sub O_or_D { 'Test::D' } + sub C_or_D { 'Test::D' } + + package Test::C; + use base ('Test::D', 'Test::F'); + use mro 'dfs'; + + sub C_or_D { 'Test::C' } + + package Test::B; + use base ('Test::E', 'Test::D'); + use mro 'dfs'; + + package Test::A; + use base ('Test::B', 'Test::C'); + use mro 'dfs'; +} + +is_deeply( + mro::get_linear_isa('Test::A'), + [ qw(Test::A Test::B Test::E Test::O Test::D Test::C Test::F) ], + '... got the right MRO for Test::A'); + +is(Test::A->O_or_D, 'Test::O', '... got the right method dispatch'); +is(Test::A->O_or_F, 'Test::O', '... got the right method dispatch'); + +# NOTE: +# this test is particularly interesting because the p5 dispatch +# would actually call Test::D before Test::C and Test::D is a +# subclass of Test::C +is(Test::A->C_or_D, 'Test::D', '... got the right method dispatch'); diff --git a/t/mro/basic_04_c3.t b/t/mro/basic_04_c3.t new file mode 100644 index 0000000000..f7e92ecfc2 --- /dev/null +++ b/t/mro/basic_04_c3.t @@ -0,0 +1,40 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 1; + +=pod + +From the parrot test t/pmc/object-meths.t + + A B A E + \ / \ / + C D + \ / + \ / + F + +=cut + +{ + package t::lib::A; use mro 'c3'; + package t::lib::B; use mro 'c3'; + package t::lib::E; use mro 'c3'; + package t::lib::C; use mro 'c3'; use base ('t::lib::A', 't::lib::B'); + package t::lib::D; use mro 'c3'; use base ('t::lib::A', 't::lib::E'); + package t::lib::F; use mro 'c3'; use base ('t::lib::C', 't::lib::D'); +} + +is_deeply( + mro::get_linear_isa('t::lib::F'), + [ qw(t::lib::F t::lib::C t::lib::D t::lib::A t::lib::B t::lib::E) ], + '... got the right MRO for t::lib::F'); + diff --git a/t/mro/basic_04_dfs.t b/t/mro/basic_04_dfs.t new file mode 100644 index 0000000000..bb6a352c76 --- /dev/null +++ b/t/mro/basic_04_dfs.t @@ -0,0 +1,40 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 1; + +=pod + +From the parrot test t/pmc/object-meths.t + + A B A E + \ / \ / + C D + \ / + \ / + F + +=cut + +{ + package t::lib::A; use mro 'dfs'; + package t::lib::B; use mro 'dfs'; + package t::lib::E; use mro 'dfs'; + package t::lib::C; use mro 'dfs'; use base ('t::lib::A', 't::lib::B'); + package t::lib::D; use mro 'dfs'; use base ('t::lib::A', 't::lib::E'); + package t::lib::F; use mro 'dfs'; use base ('t::lib::C', 't::lib::D'); +} + +is_deeply( + mro::get_linear_isa('t::lib::F'), + [ qw(t::lib::F t::lib::C t::lib::A t::lib::B t::lib::D t::lib::E) ], + '... got the right MRO for t::lib::F'); + diff --git a/t/mro/basic_05_c3.t b/t/mro/basic_05_c3.t new file mode 100644 index 0000000000..91f2e35eb2 --- /dev/null +++ b/t/mro/basic_05_c3.t @@ -0,0 +1,61 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 2; + +=pod + +This tests a strange bug found by Matt S. Trout +while building DBIx::Class. Thanks Matt!!!! + + <A> + / \ +<C> <B> + \ / + <D> + +=cut + +{ + package Diamond_A; + use mro 'c3'; + + sub foo { 'Diamond_A::foo' } +} +{ + package Diamond_B; + use base 'Diamond_A'; + use mro 'c3'; + + sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo } +} +{ + package Diamond_C; + use mro 'c3'; + use base 'Diamond_A'; + +} +{ + package Diamond_D; + use base ('Diamond_C', 'Diamond_B'); + use mro 'c3'; + + sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo } +} + +is_deeply( + mro::get_linear_isa('Diamond_D'), + [ qw(Diamond_D Diamond_C Diamond_B Diamond_A) ], + '... got the right MRO for Diamond_D'); + +is(Diamond_D->foo, + 'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo', + '... got the right next::method dispatch path'); diff --git a/t/mro/basic_05_dfs.t b/t/mro/basic_05_dfs.t new file mode 100644 index 0000000000..187a640396 --- /dev/null +++ b/t/mro/basic_05_dfs.t @@ -0,0 +1,61 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 2; + +=pod + +This tests a strange bug found by Matt S. Trout +while building DBIx::Class. Thanks Matt!!!! + + <A> + / \ +<C> <B> + \ / + <D> + +=cut + +{ + package Diamond_A; + use mro 'dfs'; + + sub foo { 'Diamond_A::foo' } +} +{ + package Diamond_B; + use base 'Diamond_A'; + use mro 'dfs'; + + sub foo { 'Diamond_B::foo => ' . (shift)->SUPER::foo } +} +{ + package Diamond_C; + use mro 'dfs'; + use base 'Diamond_A'; + +} +{ + package Diamond_D; + use base ('Diamond_C', 'Diamond_B'); + use mro 'dfs'; + + sub foo { 'Diamond_D::foo => ' . (shift)->SUPER::foo } +} + +is_deeply( + mro::get_linear_isa('Diamond_D'), + [ qw(Diamond_D Diamond_C Diamond_A Diamond_B) ], + '... got the right MRO for Diamond_D'); + +is(Diamond_D->foo, + 'Diamond_D::foo => Diamond_A::foo', + '... got the right next::method dispatch path'); diff --git a/t/mro/c3_with_overload.t b/t/mro/c3_with_overload.t new file mode 100644 index 0000000000..88170f3767 --- /dev/null +++ b/t/mro/c3_with_overload.t @@ -0,0 +1,47 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 7; + +{ + package BaseTest; + use strict; + use warnings; + use mro 'c3'; + + package OverloadingTest; + use strict; + use warnings; + use mro 'c3'; + use base 'BaseTest'; + use overload '""' => sub { ref(shift) . " stringified" }, + fallback => 1; + + sub new { bless {} => shift } + + package InheritingFromOverloadedTest; + use strict; + use warnings; + use base 'OverloadingTest'; + use mro 'c3'; +} + +my $x = InheritingFromOverloadedTest->new(); +isa_ok($x, 'InheritingFromOverloadedTest'); + +my $y = OverloadingTest->new(); +isa_ok($y, 'OverloadingTest'); + +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing'); +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing'); + +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly'); + +my $result; +eval { + $result = $x eq 'InheritingFromOverloadedTest stringified' +}; +ok(!$@, '... this should not throw an exception'); +ok($result, '... and we should get the true value'); diff --git a/t/mro/complex_c3.t b/t/mro/complex_c3.t new file mode 100644 index 0000000000..72c9c02181 --- /dev/null +++ b/t/mro/complex_c3.t @@ -0,0 +1,148 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 12; + +=pod + +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879 + + --- --- --- +Level 5 8 | A | 9 | B | A | C | (More General) + --- --- --- V + \ | / | + \ | / | + \ | / | + \ | / | + --- | +Level 4 7 | D | | + --- | + / \ | + / \ | + --- --- | +Level 3 4 | G | 6 | E | | + --- --- | + | | | + | | | + --- --- | +Level 2 3 | H | 5 | F | | + --- --- | + \ / | | + \ / | | + \ | | + / \ | | + / \ | | + --- --- | +Level 1 1 | J | 2 | I | | + --- --- | + \ / | + \ / | + --- v +Level 0 0 | K | (More Specialized) + --- + + +0123456789A +KJIHGFEDABC + +=cut + +{ + package Test::A; use mro 'c3'; + + package Test::B; use mro 'c3'; + + package Test::C; use mro 'c3'; + + package Test::D; use mro 'c3'; + use base qw/Test::A Test::B Test::C/; + + package Test::E; use mro 'c3'; + use base qw/Test::D/; + + package Test::F; use mro 'c3'; + use base qw/Test::E/; + sub testmeth { "wrong" } + + package Test::G; use mro 'c3'; + use base qw/Test::D/; + + package Test::H; use mro 'c3'; + use base qw/Test::G/; + + package Test::I; use mro 'c3'; + use base qw/Test::H Test::F/; + sub testmeth { "right" } + + package Test::J; use mro 'c3'; + use base qw/Test::F/; + + package Test::K; use mro 'c3'; + use base qw/Test::J Test::I/; + sub testmeth { shift->next::method } +} + +is_deeply( + mro::get_linear_isa('Test::A'), + [ qw(Test::A) ], + '... got the right C3 merge order for Test::A'); + +is_deeply( + mro::get_linear_isa('Test::B'), + [ qw(Test::B) ], + '... got the right C3 merge order for Test::B'); + +is_deeply( + mro::get_linear_isa('Test::C'), + [ qw(Test::C) ], + '... got the right C3 merge order for Test::C'); + +is_deeply( + mro::get_linear_isa('Test::D'), + [ qw(Test::D Test::A Test::B Test::C) ], + '... got the right C3 merge order for Test::D'); + +is_deeply( + mro::get_linear_isa('Test::E'), + [ qw(Test::E Test::D Test::A Test::B Test::C) ], + '... got the right C3 merge order for Test::E'); + +is_deeply( + mro::get_linear_isa('Test::F'), + [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ], + '... got the right C3 merge order for Test::F'); + +is_deeply( + mro::get_linear_isa('Test::G'), + [ qw(Test::G Test::D Test::A Test::B Test::C) ], + '... got the right C3 merge order for Test::G'); + +is_deeply( + mro::get_linear_isa('Test::H'), + [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ], + '... got the right C3 merge order for Test::H'); + +is_deeply( + mro::get_linear_isa('Test::I'), + [ qw(Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ], + '... got the right C3 merge order for Test::I'); + +is_deeply( + mro::get_linear_isa('Test::J'), + [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ], + '... got the right C3 merge order for Test::J'); + +is_deeply( + mro::get_linear_isa('Test::K'), + [ qw(Test::K Test::J Test::I Test::H Test::G Test::F Test::E Test::D Test::A Test::B Test::C) ], + '... got the right C3 merge order for Test::K'); + +is(Test::K->testmeth(), "right", 'next::method working ok'); diff --git a/t/mro/complex_dfs.t b/t/mro/complex_dfs.t new file mode 100644 index 0000000000..d864555f91 --- /dev/null +++ b/t/mro/complex_dfs.t @@ -0,0 +1,143 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 11; + +=pod + +This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879 + + --- --- --- +Level 5 8 | A | 9 | B | A | C | (More General) + --- --- --- V + \ | / | + \ | / | + \ | / | + \ | / | + --- | +Level 4 7 | D | | + --- | + / \ | + / \ | + --- --- | +Level 3 4 | G | 6 | E | | + --- --- | + | | | + | | | + --- --- | +Level 2 3 | H | 5 | F | | + --- --- | + \ / | | + \ / | | + \ | | + / \ | | + / \ | | + --- --- | +Level 1 1 | J | 2 | I | | + --- --- | + \ / | + \ / | + --- v +Level 0 0 | K | (More Specialized) + --- + + +0123456789A +KJIHGFEDABC + +=cut + +{ + package Test::A; use mro 'dfs'; + + package Test::B; use mro 'dfs'; + + package Test::C; use mro 'dfs'; + + package Test::D; use mro 'dfs'; + use base qw/Test::A Test::B Test::C/; + + package Test::E; use mro 'dfs'; + use base qw/Test::D/; + + package Test::F; use mro 'dfs'; + use base qw/Test::E/; + + package Test::G; use mro 'dfs'; + use base qw/Test::D/; + + package Test::H; use mro 'dfs'; + use base qw/Test::G/; + + package Test::I; use mro 'dfs'; + use base qw/Test::H Test::F/; + + package Test::J; use mro 'dfs'; + use base qw/Test::F/; + + package Test::K; use mro 'dfs'; + use base qw/Test::J Test::I/; +} + +is_deeply( + mro::get_linear_isa('Test::A'), + [ qw(Test::A) ], + '... got the right DFS merge order for Test::A'); + +is_deeply( + mro::get_linear_isa('Test::B'), + [ qw(Test::B) ], + '... got the right DFS merge order for Test::B'); + +is_deeply( + mro::get_linear_isa('Test::C'), + [ qw(Test::C) ], + '... got the right DFS merge order for Test::C'); + +is_deeply( + mro::get_linear_isa('Test::D'), + [ qw(Test::D Test::A Test::B Test::C) ], + '... got the right DFS merge order for Test::D'); + +is_deeply( + mro::get_linear_isa('Test::E'), + [ qw(Test::E Test::D Test::A Test::B Test::C) ], + '... got the right DFS merge order for Test::E'); + +is_deeply( + mro::get_linear_isa('Test::F'), + [ qw(Test::F Test::E Test::D Test::A Test::B Test::C) ], + '... got the right DFS merge order for Test::F'); + +is_deeply( + mro::get_linear_isa('Test::G'), + [ qw(Test::G Test::D Test::A Test::B Test::C) ], + '... got the right DFS merge order for Test::G'); + +is_deeply( + mro::get_linear_isa('Test::H'), + [ qw(Test::H Test::G Test::D Test::A Test::B Test::C) ], + '... got the right DFS merge order for Test::H'); + +is_deeply( + mro::get_linear_isa('Test::I'), + [ qw(Test::I Test::H Test::G Test::D Test::A Test::B Test::C Test::F Test::E) ], + '... got the right DFS merge order for Test::I'); + +is_deeply( + mro::get_linear_isa('Test::J'), + [ qw(Test::J Test::F Test::E Test::D Test::A Test::B Test::C) ], + '... got the right DFS merge order for Test::J'); + +is_deeply( + mro::get_linear_isa('Test::K'), + [ qw(Test::K Test::J Test::F Test::E Test::D Test::A Test::B Test::C Test::I Test::H Test::G) ], + '... got the right DFS merge order for Test::K'); diff --git a/t/mro/dbic_c3.t b/t/mro/dbic_c3.t new file mode 100644 index 0000000000..a59f334fb4 --- /dev/null +++ b/t/mro/dbic_c3.t @@ -0,0 +1,125 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 1; + +=pod + +This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002: +(No ASCII art this time, this graph is insane) + +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones + +=cut + +{ + package xx::DBIx::Class::Core; use mro 'c3'; + our @ISA = qw/ + xx::DBIx::Class::Serialize::Storable + xx::DBIx::Class::InflateColumn + xx::DBIx::Class::Relationship + xx::DBIx::Class::PK::Auto + xx::DBIx::Class::PK + xx::DBIx::Class::Row + xx::DBIx::Class::ResultSourceProxy::Table + xx::DBIx::Class::AccessorGroup + /; + + package xx::DBIx::Class::InflateColumn; use mro 'c3'; + our @ISA = qw/ xx::DBIx::Class::Row /; + + package xx::DBIx::Class::Row; use mro 'c3'; + our @ISA = qw/ xx::DBIx::Class /; + + package xx::DBIx::Class; use mro 'c3'; + our @ISA = qw/ + xx::DBIx::Class::Componentised + xx::Class::Data::Accessor + /; + + package xx::DBIx::Class::Relationship; use mro 'c3'; + our @ISA = qw/ + xx::DBIx::Class::Relationship::Helpers + xx::DBIx::Class::Relationship::Accessor + xx::DBIx::Class::Relationship::CascadeActions + xx::DBIx::Class::Relationship::ProxyMethods + xx::DBIx::Class::Relationship::Base + xx::DBIx::Class + /; + + package xx::DBIx::Class::Relationship::Helpers; use mro 'c3'; + our @ISA = qw/ + xx::DBIx::Class::Relationship::HasMany + xx::DBIx::Class::Relationship::HasOne + xx::DBIx::Class::Relationship::BelongsTo + xx::DBIx::Class::Relationship::ManyToMany + /; + + package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'c3'; + our @ISA = qw/ xx::DBIx::Class /; + + package xx::DBIx::Class::Relationship::Base; use mro 'c3'; + our @ISA = qw/ xx::DBIx::Class /; + + package xx::DBIx::Class::PK::Auto; use mro 'c3'; + our @ISA = qw/ xx::DBIx::Class /; + + package xx::DBIx::Class::PK; use mro 'c3'; + our @ISA = qw/ xx::DBIx::Class::Row /; + + package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'c3'; + our @ISA = qw/ + xx::DBIx::Class::AccessorGroup + xx::DBIx::Class::ResultSourceProxy + /; + + package xx::DBIx::Class::ResultSourceProxy; use mro 'c3'; + our @ISA = qw/ xx::DBIx::Class /; + + package xx::Class::Data::Accessor; our @ISA = (); use mro 'c3'; + package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'c3'; + package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'c3'; + package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'c3'; + package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'c3'; + package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'c3'; + package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'c3'; + package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'c3'; + package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'c3'; + package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'c3'; +} + +is_deeply( + mro::get_linear_isa('xx::DBIx::Class::Core'), + [qw/ + xx::DBIx::Class::Core + xx::DBIx::Class::Serialize::Storable + xx::DBIx::Class::InflateColumn + xx::DBIx::Class::Relationship + xx::DBIx::Class::Relationship::Helpers + xx::DBIx::Class::Relationship::HasMany + xx::DBIx::Class::Relationship::HasOne + xx::DBIx::Class::Relationship::BelongsTo + xx::DBIx::Class::Relationship::ManyToMany + xx::DBIx::Class::Relationship::Accessor + xx::DBIx::Class::Relationship::CascadeActions + xx::DBIx::Class::Relationship::ProxyMethods + xx::DBIx::Class::Relationship::Base + xx::DBIx::Class::PK::Auto + xx::DBIx::Class::PK + xx::DBIx::Class::Row + xx::DBIx::Class::ResultSourceProxy::Table + xx::DBIx::Class::AccessorGroup + xx::DBIx::Class::ResultSourceProxy + xx::DBIx::Class + xx::DBIx::Class::Componentised + xx::Class::Data::Accessor + /], + '... got the right C3 merge order for xx::DBIx::Class::Core'); diff --git a/t/mro/dbic_dfs.t b/t/mro/dbic_dfs.t new file mode 100644 index 0000000000..f82314718e --- /dev/null +++ b/t/mro/dbic_dfs.t @@ -0,0 +1,125 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 1; + +=pod + +This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002: +(No ASCII art this time, this graph is insane) + +The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones + +=cut + +{ + package xx::DBIx::Class::Core; use mro 'dfs'; + our @ISA = qw/ + xx::DBIx::Class::Serialize::Storable + xx::DBIx::Class::InflateColumn + xx::DBIx::Class::Relationship + xx::DBIx::Class::PK::Auto + xx::DBIx::Class::PK + xx::DBIx::Class::Row + xx::DBIx::Class::ResultSourceProxy::Table + xx::DBIx::Class::AccessorGroup + /; + + package xx::DBIx::Class::InflateColumn; use mro 'dfs'; + our @ISA = qw/ xx::DBIx::Class::Row /; + + package xx::DBIx::Class::Row; use mro 'dfs'; + our @ISA = qw/ xx::DBIx::Class /; + + package xx::DBIx::Class; use mro 'dfs'; + our @ISA = qw/ + xx::DBIx::Class::Componentised + xx::Class::Data::Accessor + /; + + package xx::DBIx::Class::Relationship; use mro 'dfs'; + our @ISA = qw/ + xx::DBIx::Class::Relationship::Helpers + xx::DBIx::Class::Relationship::Accessor + xx::DBIx::Class::Relationship::CascadeActions + xx::DBIx::Class::Relationship::ProxyMethods + xx::DBIx::Class::Relationship::Base + xx::DBIx::Class + /; + + package xx::DBIx::Class::Relationship::Helpers; use mro 'dfs'; + our @ISA = qw/ + xx::DBIx::Class::Relationship::HasMany + xx::DBIx::Class::Relationship::HasOne + xx::DBIx::Class::Relationship::BelongsTo + xx::DBIx::Class::Relationship::ManyToMany + /; + + package xx::DBIx::Class::Relationship::ProxyMethods; use mro 'dfs'; + our @ISA = qw/ xx::DBIx::Class /; + + package xx::DBIx::Class::Relationship::Base; use mro 'dfs'; + our @ISA = qw/ xx::DBIx::Class /; + + package xx::DBIx::Class::PK::Auto; use mro 'dfs'; + our @ISA = qw/ xx::DBIx::Class /; + + package xx::DBIx::Class::PK; use mro 'dfs'; + our @ISA = qw/ xx::DBIx::Class::Row /; + + package xx::DBIx::Class::ResultSourceProxy::Table; use mro 'dfs'; + our @ISA = qw/ + xx::DBIx::Class::AccessorGroup + xx::DBIx::Class::ResultSourceProxy + /; + + package xx::DBIx::Class::ResultSourceProxy; use mro 'dfs'; + our @ISA = qw/ xx::DBIx::Class /; + + package xx::Class::Data::Accessor; our @ISA = (); use mro 'dfs'; + package xx::DBIx::Class::Relationship::HasMany; our @ISA = (); use mro 'dfs'; + package xx::DBIx::Class::Relationship::HasOne; our @ISA = (); use mro 'dfs'; + package xx::DBIx::Class::Relationship::BelongsTo; our @ISA = (); use mro 'dfs'; + package xx::DBIx::Class::Relationship::ManyToMany; our @ISA = (); use mro 'dfs'; + package xx::DBIx::Class::Componentised; our @ISA = (); use mro 'dfs'; + package xx::DBIx::Class::AccessorGroup; our @ISA = (); use mro 'dfs'; + package xx::DBIx::Class::Serialize::Storable; our @ISA = (); use mro 'dfs'; + package xx::DBIx::Class::Relationship::Accessor; our @ISA = (); use mro 'dfs'; + package xx::DBIx::Class::Relationship::CascadeActions; our @ISA = (); use mro 'dfs'; +} + +is_deeply( + mro::get_linear_isa('xx::DBIx::Class::Core'), + [qw/ + xx::DBIx::Class::Core + xx::DBIx::Class::Serialize::Storable + xx::DBIx::Class::InflateColumn + xx::DBIx::Class::Row + xx::DBIx::Class + xx::DBIx::Class::Componentised + xx::Class::Data::Accessor + xx::DBIx::Class::Relationship + xx::DBIx::Class::Relationship::Helpers + xx::DBIx::Class::Relationship::HasMany + xx::DBIx::Class::Relationship::HasOne + xx::DBIx::Class::Relationship::BelongsTo + xx::DBIx::Class::Relationship::ManyToMany + xx::DBIx::Class::Relationship::Accessor + xx::DBIx::Class::Relationship::CascadeActions + xx::DBIx::Class::Relationship::ProxyMethods + xx::DBIx::Class::Relationship::Base + xx::DBIx::Class::PK::Auto + xx::DBIx::Class::PK + xx::DBIx::Class::ResultSourceProxy::Table + xx::DBIx::Class::AccessorGroup + xx::DBIx::Class::ResultSourceProxy + /], + '... got the right DFS merge order for xx::DBIx::Class::Core'); diff --git a/t/mro/inconsistent_c3.t b/t/mro/inconsistent_c3.t new file mode 100644 index 0000000000..07f83c26ba --- /dev/null +++ b/t/mro/inconsistent_c3.t @@ -0,0 +1,47 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 1; + +=pod + +This example is take from: http://www.python.org/2.3/mro.html + +"Serious order disagreement" # From Guido +class O: pass +class X(O): pass +class Y(O): pass +class A(X,Y): pass +class B(Y,X): pass +try: + class Z(A,B): pass #creates Z(A,B) in Python 2.2 +except TypeError: + pass # Z(A,B) cannot be created in Python 2.3 + +=cut + +{ + package X; + + package Y; + + package XY; + our @ISA = ('X', 'Y'); + + package YX; + our @ISA = ('Y', 'X'); + + package Z; + our @ISA = ('XY', 'YX'); +} + +eval { mro::get_linear_isa('Z', 'c3') }; +like($@, qr/^Inconsistent /, '... got the right error with an inconsistent hierarchy'); diff --git a/t/mro/method_caching.t b/t/mro/method_caching.t new file mode 100644 index 0000000000..8013a0a14d --- /dev/null +++ b/t/mro/method_caching.t @@ -0,0 +1,46 @@ +#!./perl + +use strict; +use warnings; +no warnings 'redefine'; # we do a lot of this +no warnings 'prototype'; # we do a lot of this + +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More; + +{ + package MCTest::Base; + sub foo { return $_[1]+1 }; + sub bar { 42 }; + + package MCTest::Derived; + our @ISA = qw/MCTest::Base/; +} + +# These are various ways of re-defining MCTest::Base::foo and checking whether the method is cached when it shouldn't be +my @testsubs = ( + sub { eval 'sub MCTest::Base::foo { return $_[1]+2 }'; is(MCTest::Derived->foo(0), 2); }, + sub { eval 'sub MCTest::Base::foo($) { return $_[1]+3 }'; is(MCTest::Derived->foo(0), 3); }, + sub { eval 'sub MCTest::Base::foo($) { 4 }'; is(MCTest::Derived->foo(0), 4); }, + sub { *MCTest::Base::foo = sub { $_[1]+5 }; is(MCTest::Derived->foo(0), 5); }, + sub { local *MCTest::Base::foo = sub { $_[1]+6 }; is(MCTest::Derived->foo(0), 6); }, + sub { is(MCTest::Derived->foo(0), 5); }, + sub { sub FFF { $_[1]+9 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 9); }, + sub { is(MCTest::Derived->foo(0), 5); }, + sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); }, + sub { *ASDF::asdf = sub { $_[1]+7 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); }, + sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, + sub { sub MCTest::Base::foo($); *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 7); }, + sub { *XYZ = sub { $_[1]+8 }; ${MCTest::Base::}{foo} = \&XYZ; is(MCTest::Derived->foo(0), 8); }, +); + +plan tests => scalar(@testsubs) + 1; + +is(MCTest::Derived->foo(0), 1); +$_->() for (@testsubs); diff --git a/t/mro/next_method.t b/t/mro/next_method.t new file mode 100644 index 0000000000..b0bb789bcf --- /dev/null +++ b/t/mro/next_method.t @@ -0,0 +1,65 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 5; + +=pod + +This tests the classic diamond inheritence pattern. + + <A> + / \ +<B> <C> + \ / + <D> + +=cut + +{ + package Diamond_A; + use mro 'c3'; + sub hello { 'Diamond_A::hello' } + sub foo { 'Diamond_A::foo' } +} +{ + package Diamond_B; + use base 'Diamond_A'; + use mro 'c3'; + sub foo { 'Diamond_B::foo => ' . (shift)->next::method() } +} +{ + package Diamond_C; + use mro 'c3'; + 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'); + use mro 'c3'; + + sub foo { 'Diamond_D::foo => ' . (shift)->next::method() } +} + +is_deeply( + mro::get_linear_isa('Diamond_D'), + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], + '... got the right MRO for Diamond_D'); + +is(Diamond_D->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected'); + +is(Diamond_D->can('hello')->('Diamond_D'), + 'Diamond_C::hello => Diamond_A::hello', + '... can(method) resolved itself as expected'); + +is(UNIVERSAL::can("Diamond_D", 'hello')->('Diamond_D'), + '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/mro/next_method_edge_cases.t b/t/mro/next_method_edge_cases.t new file mode 100644 index 0000000000..496537c137 --- /dev/null +++ b/t/mro/next_method_edge_cases.t @@ -0,0 +1,82 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 11; + +{ + + { + package Foo; + use strict; + use warnings; + use mro 'c3'; + 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; + use mro 'c3'; + 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; + use mro 'c3'; + 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/mro/next_method_in_anon.t b/t/mro/next_method_in_anon.t new file mode 100644 index 0000000000..e135d540dd --- /dev/null +++ b/t/mro/next_method_in_anon.t @@ -0,0 +1,57 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; + +=pod + +This tests the successful handling of a next::method call from within an +anonymous subroutine. + +=cut + +{ + package A; + use mro 'c3'; + + sub foo { + return 'A::foo'; + } + + sub bar { + return 'A::bar'; + } +} + +{ + package B; + use base 'A'; + use mro 'c3'; + + 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/mro/next_method_in_eval.t b/t/mro/next_method_in_eval.t new file mode 100644 index 0000000000..d55ce80ac9 --- /dev/null +++ b/t/mro/next_method_in_eval.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 1; + +=pod + +This tests the use of an eval{} block to wrap a next::method call. + +=cut + +{ + package A; + use mro 'c3'; + + sub foo { + die 'A::foo died'; + return 'A::foo succeeded'; + } +} + +{ + package B; + use base 'A'; + use mro 'c3'; + + 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/mro/next_method_skip.t b/t/mro/next_method_skip.t new file mode 100644 index 0000000000..6bd73d0180 --- /dev/null +++ b/t/mro/next_method_skip.t @@ -0,0 +1,75 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 10; + +=pod + +This tests the classic diamond inheritence pattern. + + <A> + / \ +<B> <C> + \ / + <D> + +=cut + +{ + package Diamond_A; + use mro 'c3'; + sub bar { 'Diamond_A::bar' } + sub baz { 'Diamond_A::baz' } +} +{ + package Diamond_B; + use base 'Diamond_A'; + use mro 'c3'; + sub baz { 'Diamond_B::baz => ' . (shift)->next::method() } +} +{ + package Diamond_C; + use mro 'c3'; + 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'); + use mro 'c3'; + 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_deeply( + mro::get_linear_isa('Diamond_D'), + [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], + '... got the right MRO for Diamond_D'); + +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/mro/next_method_used_with_NEXT.t b/t/mro/next_method_used_with_NEXT.t new file mode 100644 index 0000000000..f7a8c111a1 --- /dev/null +++ b/t/mro/next_method_used_with_NEXT.t @@ -0,0 +1,53 @@ +#!/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; +} + +{ + package Foo; + use strict; + use warnings; + use mro 'c3'; + + sub foo { 'Foo::foo' } + + package Fuz; + use strict; + use warnings; + use mro 'c3'; + use base 'Foo'; + + sub foo { 'Fuz::foo => ' . (shift)->next::method } + + package Bar; + use strict; + use warnings; + use mro 'c3'; + 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/mro/overload_c3.t b/t/mro/overload_c3.t new file mode 100644 index 0000000000..e227dcdbd8 --- /dev/null +++ b/t/mro/overload_c3.t @@ -0,0 +1,54 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 7; + +{ + package BaseTest; + use strict; + use warnings; + use mro 'c3'; + + package OverloadingTest; + use strict; + use warnings; + use mro 'c3'; + use base 'BaseTest'; + use overload '""' => sub { ref(shift) . " stringified" }, + fallback => 1; + + sub new { bless {} => shift } + + package InheritingFromOverloadedTest; + use strict; + use warnings; + use base 'OverloadingTest'; + use mro 'c3'; +} + +my $x = InheritingFromOverloadedTest->new(); +isa_ok($x, 'InheritingFromOverloadedTest'); + +my $y = OverloadingTest->new(); +isa_ok($y, 'OverloadingTest'); + +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing'); +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing'); + +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly'); + +my $result; +eval { + $result = $x eq 'InheritingFromOverloadedTest stringified' +}; +ok(!$@, '... this should not throw an exception'); +ok($result, '... and we should get the true value'); + diff --git a/t/mro/overload_dfs.t b/t/mro/overload_dfs.t new file mode 100644 index 0000000000..98f9a2cb7f --- /dev/null +++ b/t/mro/overload_dfs.t @@ -0,0 +1,54 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 7; + +{ + package BaseTest; + use strict; + use warnings; + use mro 'dfs'; + + package OverloadingTest; + use strict; + use warnings; + use mro 'dfs'; + use base 'BaseTest'; + use overload '""' => sub { ref(shift) . " stringified" }, + fallback => 1; + + sub new { bless {} => shift } + + package InheritingFromOverloadedTest; + use strict; + use warnings; + use base 'OverloadingTest'; + use mro 'dfs'; +} + +my $x = InheritingFromOverloadedTest->new(); +isa_ok($x, 'InheritingFromOverloadedTest'); + +my $y = OverloadingTest->new(); +isa_ok($y, 'OverloadingTest'); + +is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing'); +is("$y", 'OverloadingTest stringified', '... got the right value when stringifing'); + +ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly'); + +my $result; +eval { + $result = $x eq 'InheritingFromOverloadedTest stringified' +}; +ok(!$@, '... this should not throw an exception'); +ok($result, '... and we should get the true value'); + diff --git a/t/mro/recursion_c3.t b/t/mro/recursion_c3.t new file mode 100644 index 0000000000..60b174b1d2 --- /dev/null +++ b/t/mro/recursion_c3.t @@ -0,0 +1,88 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More; +use mro; + +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM}; +plan tests => 8; + +=pod + +These are like the 010_complex_merge_classless test, +but an infinite loop has been made in the heirarchy, +to test that we can fail cleanly instead of going +into an infinite loop + +=cut + +# initial setup, everything sane +{ + package K; + our @ISA = qw/J I/; + package J; + our @ISA = qw/F/; + package I; + our @ISA = qw/H F/; + package H; + our @ISA = qw/G/; + package G; + our @ISA = qw/D/; + package F; + our @ISA = qw/E/; + package E; + our @ISA = qw/D/; + package D; + our @ISA = qw/A B C/; + package C; + our @ISA = qw//; + package B; + our @ISA = qw//; + package A; + our @ISA = qw//; +} + +# A series of 8 abberations that would cause infinite loops, +# each one undoing the work of the previous +my @loopies = ( + sub { @E::ISA = qw/F/ }, + sub { @E::ISA = qw/D/; @C::ISA = qw/F/ }, + sub { @C::ISA = qw//; @A::ISA = qw/K/ }, + sub { @A::ISA = qw//; @J::ISA = qw/F K/ }, + sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ }, + sub { @H::ISA = qw/G/; @B::ISA = qw/B/ }, + sub { @B::ISA = qw//; @K::ISA = qw/K J I/ }, + sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ }, +); + +foreach my $loopy (@loopies) { + eval { + local $SIG{ALRM} = sub { die "ALRMTimeout" }; + alarm(3); + $loopy->(); + mro::get_linear_isa('K', 'c3'); + }; + + if(my $err = $@) { + if($err =~ /ALRMTimeout/) { + ok(0, "Loop terminated by SIGALRM"); + } + elsif($err =~ /Recursive inheritance detected/) { + ok(1, "Graceful exception thrown"); + } + else { + ok(0, "Unrecognized exception: $err"); + } + } + else { + ok(0, "Infinite loop apparently succeeded???"); + } +} diff --git a/t/mro/recursion_dfs.t b/t/mro/recursion_dfs.t new file mode 100644 index 0000000000..a3d610e7f1 --- /dev/null +++ b/t/mro/recursion_dfs.t @@ -0,0 +1,88 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More; +use mro; + +plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM}; +plan tests => 8; + +=pod + +These are like the 010_complex_merge_classless test, +but an infinite loop has been made in the heirarchy, +to test that we can fail cleanly instead of going +into an infinite loop + +=cut + +# initial setup, everything sane +{ + package K; + our @ISA = qw/J I/; + package J; + our @ISA = qw/F/; + package I; + our @ISA = qw/H F/; + package H; + our @ISA = qw/G/; + package G; + our @ISA = qw/D/; + package F; + our @ISA = qw/E/; + package E; + our @ISA = qw/D/; + package D; + our @ISA = qw/A B C/; + package C; + our @ISA = qw//; + package B; + our @ISA = qw//; + package A; + our @ISA = qw//; +} + +# A series of 8 abberations that would cause infinite loops, +# each one undoing the work of the previous +my @loopies = ( + sub { @E::ISA = qw/F/ }, + sub { @E::ISA = qw/D/; @C::ISA = qw/F/ }, + sub { @C::ISA = qw//; @A::ISA = qw/K/ }, + sub { @A::ISA = qw//; @J::ISA = qw/F K/ }, + sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ }, + sub { @H::ISA = qw/G/; @B::ISA = qw/B/ }, + sub { @B::ISA = qw//; @K::ISA = qw/K J I/ }, + sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ }, +); + +foreach my $loopy (@loopies) { + eval { + local $SIG{ALRM} = sub { die "ALRMTimeout" }; + alarm(3); + $loopy->(); + mro::get_linear_isa('K', 'dfs'); + }; + + if(my $err = $@) { + if($err =~ /ALRMTimeout/) { + ok(0, "Loop terminated by SIGALRM"); + } + elsif($err =~ /Recursive inheritance detected/) { + ok(1, "Graceful exception thrown"); + } + else { + ok(0, "Unrecognized exception: $err"); + } + } + else { + ok(0, "Infinite loop apparently succeeded???"); + } +} diff --git a/t/mro/vulcan_c3.t b/t/mro/vulcan_c3.t new file mode 100644 index 0000000000..9ac1c45cd2 --- /dev/null +++ b/t/mro/vulcan_c3.t @@ -0,0 +1,73 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 1; +use mro; + +=pod + +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html> + + Object + ^ + | + LifeForm + ^ ^ + / \ + Sentient BiPedal + ^ ^ + | | + Intelligent Humanoid + ^ ^ + \ / + Vulcan + + define class <sentient> (<life-form>) end class; + define class <bipedal> (<life-form>) end class; + define class <intelligent> (<sentient>) end class; + define class <humanoid> (<bipedal>) end class; + define class <vulcan> (<intelligent>, <humanoid>) end class; + +=cut + +{ + package Object; + use mro 'c3'; + + package LifeForm; + use mro 'c3'; + use base 'Object'; + + package Sentient; + use mro 'c3'; + use base 'LifeForm'; + + package BiPedal; + use mro 'c3'; + use base 'LifeForm'; + + package Intelligent; + use mro 'c3'; + use base 'Sentient'; + + package Humanoid; + use mro 'c3'; + use base 'BiPedal'; + + package Vulcan; + use mro 'c3'; + use base ('Intelligent', 'Humanoid'); +} + +is_deeply( + mro::get_linear_isa('Vulcan'), + [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ], + '... got the right MRO for the Vulcan Dylan Example'); diff --git a/t/mro/vulcan_dfs.t b/t/mro/vulcan_dfs.t new file mode 100644 index 0000000000..4941294233 --- /dev/null +++ b/t/mro/vulcan_dfs.t @@ -0,0 +1,73 @@ +#!./perl + +use strict; +use warnings; +BEGIN { + unless (-d 'blib') { + chdir 't' if -d 't'; + @INC = '../lib'; + } +} + +use Test::More tests => 1; +use mro; + +=pod + +example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html> + + Object + ^ + | + LifeForm + ^ ^ + / \ + Sentient BiPedal + ^ ^ + | | + Intelligent Humanoid + ^ ^ + \ / + Vulcan + + define class <sentient> (<life-form>) end class; + define class <bipedal> (<life-form>) end class; + define class <intelligent> (<sentient>) end class; + define class <humanoid> (<bipedal>) end class; + define class <vulcan> (<intelligent>, <humanoid>) end class; + +=cut + +{ + package Object; + use mro 'dfs'; + + package LifeForm; + use mro 'dfs'; + use base 'Object'; + + package Sentient; + use mro 'dfs'; + use base 'LifeForm'; + + package BiPedal; + use mro 'dfs'; + use base 'LifeForm'; + + package Intelligent; + use mro 'dfs'; + use base 'Sentient'; + + package Humanoid; + use mro 'dfs'; + use base 'BiPedal'; + + package Vulcan; + use mro 'dfs'; + use base ('Intelligent', 'Humanoid'); +} + +is_deeply( + mro::get_linear_isa('Vulcan'), + [ qw(Vulcan Intelligent Sentient LifeForm Object Humanoid BiPedal) ], + '... got the right MRO for the Vulcan Dylan Example'); diff --git a/t/op/magic.t b/t/op/magic.t index 294beb0209..0ce58d3785 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -440,7 +440,10 @@ ok "@+" eq "10 1 6 10"; if (!$Is_VMS) { local @ISA; local %ENV; - eval { push @ISA, __PACKAGE__ }; + # This used to be __PACKAGE__, but that causes recursive + # inheritance, which is detected earlier now and broke + # this test + eval { push @ISA, __FILE__ }; ok( $@ eq '', 'Push a constant on a magic array'); $@ and print "# $@"; eval { %ENV = (PATH => __PACKAGE__) }; |