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