Commit | Line | Data |
e4783b1c |
1 | #! /usr/local/bin/perl -w |
2 | |
55a1c97c |
3 | BEGIN { print "1..25\n"; } |
e4783b1c |
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 ); |
55a1c97c |
15 | sub B::AUTOLOAD { return ( 9, $_[0]->NEXT::AUTOLOAD() ) |
16 | if $AUTOLOAD =~ /.*(missing_method|secondary)/ } |
e4783b1c |
17 | sub B::DESTROY { $_[0]->NEXT::DESTROY() } |
18 | |
19 | package C; |
55a1c97c |
20 | sub C::DESTROY { print "ok 23\n"; $_[0]->NEXT::DESTROY() } |
e4783b1c |
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() ) } |
55a1c97c |
26 | sub D::DESTROY { print "ok 22\n"; $_[0]->NEXT::DESTROY() } |
e4783b1c |
27 | sub D::oops { $_[0]->NEXT::method() } |
55a1c97c |
28 | sub D::secondary { return ( 17, 18, map { $_+10 } $_[0]->NEXT::secondary() ) } |
e4783b1c |
29 | |
30 | package E; |
31 | @E::ISA = qw( F G ); |
32 | sub E::method { return ( 4, $_[0]->NEXT::method(), $_[0]->NEXT::method() ) } |
55a1c97c |
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() } |
e4783b1c |
36 | |
37 | package F; |
38 | sub F::method { return ( 5 ) } |
55a1c97c |
39 | sub F::AUTOLOAD { return ( 11 ) if $AUTOLOAD =~ /.*(missing_method|secondary)/ } |
40 | sub F::DESTROY { print "ok 25\n" } |
e4783b1c |
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) |
55a1c97c |
71 | |
72 | eval { |
73 | local *C::AUTOLOAD = sub { $_[0]->NEXT::method() }; |
74 | *C::AUTOLOAD = *C::AUTOLOAD; |
75 | eval { $obj->missing_method(); } && print "not "; |
e4783b1c |
76 | }; |
e4783b1c |
77 | print "ok 13\n"; |
78 | |
79 | # NAMED METHOD CAN'T REDISPATCH TO AUTOLOAD'ED METHOD (ok 14) |
55a1c97c |
80 | eval { |
81 | *C::method = sub{ $_[0]->NEXT::AUTOLOAD() }; |
82 | *C::method = *C::method; |
83 | eval { $obj->method(); } && print "not "; |
e4783b1c |
84 | }; |
e4783b1c |
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 | |
55a1c97c |
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) |