This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Invalidate method cache on C<local *subname>
[perl5.git] / t / op / method.t
1 #!./perl
2
3 #
4 # test method calls and autoloading.
5 #
6
7 print "1..26\n";
8
9 @A::ISA = 'B';
10 @B::ISA = 'C';
11
12 sub C::d {"C::d"}
13 sub D::d {"D::d"}
14
15 my $cnt = 0;
16 sub test {
17   print "# got `$_[0]', expected `$_[1]'\nnot " unless $_[0] eq $_[1]; 
18   # print "not " unless shift eq shift;
19   print "ok ", ++$cnt, "\n"
20 }
21
22 test( A->d, "C::d");            # Update hash table;
23
24 *B::d = \&D::d;                 # Import now.
25 test (A->d, "D::d");            # Update hash table;
26
27 {
28     local @A::ISA = qw(C);      # Update hash table with split() assignment
29     test (A->d, "C::d");
30     $#A::ISA = -1;
31     test (eval { A->d } || "fail", "fail");
32 }
33 test (A->d, "D::d");
34
35 {
36     local *B::d;
37     eval 'sub B::d {"B::d1"}';  # Import now.
38     test (A->d, "B::d1");       # Update hash table;
39     undef &B::d;
40     test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1);
41 }
42
43 test (A->d, "D::d");            # Back to previous state
44
45 eval 'sub B::d {"B::d2"}';      # Import now.
46 test (A->d, "B::d2");           # Update hash table;
47
48 # What follows is hardly guarantied to work, since the names in scripts
49 # are already linked to "pruned" globs. Say, `undef &B::d' if it were
50 # after `delete $B::{d}; sub B::d {}' would reach an old subroutine.
51
52 undef &B::d;
53 delete $B::{d};
54 test (A->d, "C::d");            # Update hash table;
55
56 eval 'sub B::d {"B::d3"}';      # Import now.
57 test (A->d, "B::d3");           # Update hash table;
58
59 delete $B::{d};
60 *dummy::dummy = sub {};         # Mark as updated
61 test (A->d, "C::d");
62
63 eval 'sub B::d {"B::d4"}';      # Import now.
64 test (A->d, "B::d4");           # Update hash table;
65
66 delete $B::{d};                 # Should work without any help too
67 test (A->d, "C::d");
68
69 {
70     local *C::d;
71     test (eval { A->d } || "nope", "nope");
72 }
73 test (A->d, "C::d");
74
75 *A::x = *A::d;                  # See if cache incorrectly follows synonyms
76 A->d;
77 test (eval { A->x } || "nope", "nope");
78
79 eval <<'EOF';
80 sub C::e;
81 BEGIN { *B::e = \&C::e }        # Shouldn't prevent AUTOLOAD in original pkg
82 sub Y::f;
83 $counter = 0;
84
85 @X::ISA = 'Y';
86 @Y::ISA = 'B';
87
88 sub B::AUTOLOAD {
89   my $c = ++$counter;
90   my $method = $B::AUTOLOAD; 
91   my $msg = "B: In $method, $c";
92   eval "sub $method { \$msg }";
93   goto &$method;
94 }
95 sub C::AUTOLOAD {
96   my $c = ++$counter;
97   my $method = $C::AUTOLOAD; 
98   my $msg = "C: In $method, $c";
99   eval "sub $method { \$msg }";
100   goto &$method;
101 }
102 EOF
103
104 test(A->e(), "C: In C::e, 1");  # We get a correct autoload
105 test(A->e(), "C: In C::e, 1");  # Which sticks
106
107 test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top
108 test(A->ee(), "B: In A::ee, 2"); # Which sticks
109
110 test(Y->f(), "B: In Y::f, 3");  # We vivify a correct method
111 test(Y->f(), "B: In Y::f, 3");  # Which sticks
112
113 # This test is not intended to be reasonable. It is here just to let you
114 # know that you broke some old construction. Feel free to rewrite the test
115 # if your patch breaks it.
116
117 *B::AUTOLOAD = sub {
118   my $c = ++$counter;
119   my $method = $AUTOLOAD; 
120   *$AUTOLOAD = sub { "new B: In $method, $c" };
121   goto &$AUTOLOAD;
122 };
123
124 test(A->eee(), "new B: In A::eee, 4");  # We get a correct $autoload
125 test(A->eee(), "new B: In A::eee, 4");  # Which sticks
126
127 # this test added due to bug discovery
128 test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined");