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);
   7 set_up_inc('../lib', 'lib');
   8 }
   9
  10 plan(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 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 }