This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Test preamble: unify chdir 't' if -d 't';
[perl5.git] / t / mro / next_edgecases.t
1 #!/usr/bin/perl
2
3 use strict;
4 use warnings;
5
6 BEGIN { chdir 't' if -d 't'; require q(./test.pl); @INC = qw "../lib lib" }
7
8 plan(tests => 12);
9
10 {
11
12     {
13         package Foo;
14         use strict;
15         use warnings;
16         use mro 'c3';
17         sub new { bless {}, $_[0] }
18         sub bar { 'Foo::bar' }
19     }
20
21     # call the submethod in the direct instance
22
23     my $foo = Foo->new();
24     object_ok($foo, 'Foo');
25
26     can_ok($foo, 'bar');
27     is($foo->bar(), 'Foo::bar', '... got the right return value');    
28
29     # fail calling it from a subclass
30
31     {
32         package Bar;
33         use strict;
34         use warnings;
35         use mro 'c3';
36         our @ISA = ('Foo');
37     }  
38     
39     my $bar = Bar->new();
40     object_ok($bar, 'Bar');
41     object_ok($bar, 'Foo');    
42     
43     # test it working with with Sub::Name
44     SKIP: {    
45         eval 'use Sub::Name';
46         skip("Sub::Name is required for this test", 3) if $@;
47     
48         my $m = sub { (shift)->next::method() };
49         Sub::Name::subname('Bar::bar', $m);
50         {
51             no strict 'refs';
52             *{'Bar::bar'} = $m;
53         }
54
55         can_ok($bar, 'bar');
56         my $value = eval { $bar->bar() };
57         ok(!$@, '... calling bar() succeeded') || diag $@;
58         is($value, 'Foo::bar', '... got the right return value too');
59     }
60     
61     # test it failing without Sub::Name
62     {
63         package Baz;
64         use strict;
65         use warnings;
66         use mro 'c3';
67         our @ISA = ('Foo');
68     }      
69     
70     my $baz = Baz->new();
71     object_ok($baz, 'Baz');
72     object_ok($baz, 'Foo');    
73     
74     {
75         my $m = sub { (shift)->next::method() };
76         {
77             no strict 'refs';
78             *{'Baz::bar'} = $m;
79         }
80
81         eval { $baz->bar() };
82         ok($@, '... calling bar() with next::method failed') || diag $@;
83     }
84
85     # Test with non-existing class (used to segfault)
86     {
87         package Qux;
88         use mro;
89         sub foo { No::Such::Class->next::can }
90     }
91
92     eval { Qux->foo() };
93     is($@, '', "->next::can on non-existing package name");
94
95 }