xref: /openbsd/gnu/usr.bin/perl/t/mro/next_edgecases.t (revision 264ca280) 
1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6BEGIN { chdir 't'; require q(./test.pl); @INC = qw "../lib lib" }
7
8plan(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}
96