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