Commit | Line | Data |
e4783b1c |
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) |