t/mro/recursion_dfs.t

   1 #!./perl
   2
   3 use strict;
   4 use warnings;
   5 BEGIN {
   6     unless (-d 'blib') {
   7         chdir 't' if -d 't';
   8         @INC = '../lib';
   9     }
  10 }
  11
  12 use Test::More;
  13 use mro;
  14
  15 plan skip_all => "Your system has no SIGALRM" if !exists $SIG{ALRM};
  16 plan tests => 8;
  17
  18 =pod
  19
  20 These are like the 010_complex_merge_classless test,
  21 but an infinite loop has been made in the heirarchy,
  22 to test that we can fail cleanly instead of going
  23 into an infinite loop
  24
  25 =cut
  26
  27 # initial setup, everything sane
  28 {
  29     package K;
  30     our @ISA = qw/J I/;
  31     package J;
  32     our @ISA = qw/F/;
  33     package I;
  34     our @ISA = qw/H F/;
  35     package H;
  36     our @ISA = qw/G/;
  37     package G;
  38     our @ISA = qw/D/;
  39     package F;
  40     our @ISA = qw/E/;
  41     package E;
  42     our @ISA = qw/D/;
  43     package D;
  44     our @ISA = qw/A B C/;
  45     package C;
  46     our @ISA = qw//;
  47     package B;
  48     our @ISA = qw//;
  49     package A;
  50     our @ISA = qw//;
  51 }
  52
  53 # A series of 8 abberations that would cause infinite loops,
  54 #  each one undoing the work of the previous
  55 my @loopies = (
  56     sub { @E::ISA = qw/F/ },
  57     sub { @E::ISA = qw/D/; @C::ISA = qw/F/ },
  58     sub { @C::ISA = qw//; @A::ISA = qw/K/ },
  59     sub { @A::ISA = qw//; @J::ISA = qw/F K/ },
  60     sub { @J::ISA = qw/F/; @H::ISA = qw/K G/ },
  61     sub { @H::ISA = qw/G/; @B::ISA = qw/B/ },
  62     sub { @B::ISA = qw//; @K::ISA = qw/K J I/ },
  63     sub { @K::ISA = qw/J I/; @D::ISA = qw/A H B C/ },
  64 );
  65
  66 foreach my $loopy (@loopies) {
  67     eval {
  68         local $SIG{ALRM} = sub { die "ALRMTimeout" };
  69         alarm(3);
  70         $loopy->();
  71         mro::get_linear_isa('K', 'dfs');
  72     };
  73
  74     if(my $err = $@) {
  75         if($err =~ /ALRMTimeout/) {
  76             ok(0, "Loop terminated by SIGALRM");
  77         }
  78         elsif($err =~ /Recursive inheritance detected/) {
  79             ok(1, "Graceful exception thrown");
  80         }
  81         else {
  82             ok(0, "Unrecognized exception: $err");
  83         }
  84     }
  85     else {
  86         ok(0, "Infinite loop apparently succeeded???");
  87     }
  88 }