lib/NEXT/test.pl

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