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 }