t/lib/next.t

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