lib/NEXT/t/next.t

   1 BEGIN {
   2     if ($ENV{PERL_CORE}) {
   3         chdir('t') if -d 't';
   4         @INC = qw(../lib);
   5     }
   6 }
   7
   8 BEGIN { print "1..26\n"; }
   9
  10 use NEXT;
  11
  12 print "ok 1\n";
  13
  14 package A;
  15 sub A::method   { return ( 3, $_[0]->NEXT::method() ) }
  16 sub A::DESTROY  { $_[0]->NEXT::DESTROY() }
  17 sub A::evaled   { eval { $_[0]->NEXT::evaled(); return 'evaled' } }
  18
  19 package B;
  20 use base qw( A );
  21 sub B::AUTOLOAD { return ( 9, $_[0]->NEXT::AUTOLOAD() )
  22                         if $AUTOLOAD =~ /.*(missing_method|secondary)/ }
  23 sub B::DESTROY  { $_[0]->NEXT::DESTROY() }
  24
  25 package C;
  26 sub C::DESTROY  { print "ok 24\n"; $_[0]->NEXT::DESTROY() }
  27
  28 package D;
  29 @D::ISA = qw( B C E );
  30 sub D::method   { return ( 2, $_[0]->NEXT::method() ) }
  31 sub D::AUTOLOAD { return ( 8, $_[0]->NEXT::AUTOLOAD() ) }
  32 sub D::DESTROY  { print "ok 23\n"; $_[0]->NEXT::DESTROY() }
  33 sub D::oops     { $_[0]->NEXT::method() }
  34 sub D::secondary { return ( 17, 18, map { $_+10 } $_[0]->NEXT::secondary() ) }
  35
  36 package E;
  37 @E::ISA = qw( F G );
  38 sub E::method   { return ( 4,  $_[0]->NEXT::method(), $_[0]->NEXT::method() ) }
  39 sub E::AUTOLOAD { return ( 10, $_[0]->NEXT::AUTOLOAD() )
  40                         if $AUTOLOAD =~ /.*(missing_method|secondary)/ }
  41 sub E::DESTROY  { print "ok 25\n"; $_[0]->NEXT::DESTROY() }
  42
  43 package F;
  44 sub F::method   { return ( 5  ) }
  45 sub F::AUTOLOAD { return ( 11 ) if $AUTOLOAD =~ /.*(missing_method|secondary)/ }
  46 sub F::DESTROY  { print "ok 26\n" }
  47
  48 package G;
  49 sub G::method   { return ( 6 ) }
  50 sub G::AUTOLOAD { print "not "; return }
  51 sub G::DESTROY  { print "not ok 22"; return }
  52
  53 package main;
  54
  55 my $obj = bless {}, "D";
  56
  57 my @vals;
  58
  59 # TEST NORMAL REDISPATCH (ok 2..6)
  60 @vals = $obj->method();
  61 print map "ok $_\n", @vals;
  62
  63 # RETEST NORMAL REDISPATCH SHOULD BE THE SAME (ok 7)
  64 @vals = $obj->method();
  65 print "not " unless join("", @vals) == "23456";
  66 print "ok 7\n";
  67
  68 # TEST AUTOLOAD REDISPATCH (ok 8..11)
  69 @vals = $obj->missing_method();
  70 print map "ok $_\n", @vals;
  71
  72 # NAMED METHOD CAN'T REDISPATCH TO NAMED METHOD OF DIFFERENT NAME (ok 12)
  73 eval { $obj->oops() } && print "not ";
  74 print "ok 12\n";
  75
  76 # AUTOLOAD'ED METHOD CAN'T REDISPATCH TO NAMED METHOD (ok 13)
  77
  78 eval {
  79         local *C::AUTOLOAD = sub { $_[0]->NEXT::method() };
  80         *C::AUTOLOAD = *C::AUTOLOAD;
  81         eval { $obj->missing_method(); } && print "not ";
  82 };
  83 print "ok 13\n";
  84
  85 # NAMED METHOD CAN'T REDISPATCH TO AUTOLOAD'ED METHOD (ok 14)
  86 eval {
  87         *C::method = sub{ $_[0]->NEXT::AUTOLOAD() };
  88         *C::method = *C::method;
  89         eval { $obj->method(); } && print "not ";
  90 };
  91 print "ok 14\n";
  92
  93 # BASE CLASS METHODS ONLY REDISPATCHED WITHIN HIERARCHY (ok 15..16)
  94 my $ob2 = bless {}, "B";
  95 @val = $ob2->method();
  96 print "not " unless @val==1 && $val[0]==3;
  97 print "ok 15\n";
  98
  99 @val = $ob2->missing_method();
 100 print "not " unless @val==1 && $val[0]==9;
 101 print "ok 16\n";
 102
 103 # TEST SECONDARY AUTOLOAD REDISPATCH (ok 17..21)
 104 @vals = $obj->secondary();
 105 print map "ok $_\n", @vals;
 106
 107 # TEST HANDLING OF NEXT:: INSIDE EVAL (22)
 108 eval {
 109         $obj->evaled;
 110         $@ && print "not ";
 111 };
 112 print "ok 22\n";
 113
 114 # CAN REDISPATCH DESTRUCTORS (ok 23..26)