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