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