Add more known sprintf failures.
[p5sagit/p5-mst-13.2.git] / t / op / method.t
1 #!./perl
2
3 #
4 # test method calls and autoloading.
5 #
6
7 BEGIN {
8     chdir 't' if -d 't';
9     @INC = '../lib';
10 }
11
12 print "1..54\n";
13
14 @A::ISA = 'B';
15 @B::ISA = 'C';
16
17 sub C::d {"C::d"}
18 sub D::d {"D::d"}
19
20 my $cnt = 0;
21 sub test {
22   print "# got `$_[0]', expected `$_[1]'\nnot " unless $_[0] eq $_[1]; 
23   # print "not " unless shift eq shift;
24   print "ok ", ++$cnt, "\n"
25 }
26
27 # First, some basic checks of method-calling syntax:
28 $obj = bless [], "Pack";
29 sub Pack::method { shift; join(",", "method", @_) }
30 $mname = "method";
31
32 test(Pack->method("a","b","c"), "method,a,b,c");
33 test(Pack->$mname("a","b","c"), "method,a,b,c");
34 test(method Pack ("a","b","c"), "method,a,b,c");
35 test((method Pack "a","b","c"), "method,a,b,c");
36
37 test(Pack->method(), "method");
38 test(Pack->$mname(), "method");
39 test(method Pack (), "method");
40 test(Pack->method, "method");
41 test(Pack->$mname, "method");
42 test(method Pack, "method");
43
44 test($obj->method("a","b","c"), "method,a,b,c");
45 test($obj->$mname("a","b","c"), "method,a,b,c");
46 test((method $obj ("a","b","c")), "method,a,b,c");
47 test((method $obj "a","b","c"), "method,a,b,c");
48
49 test($obj->method(), "method");
50 test($obj->$mname(), "method");
51 test((method $obj ()), "method");
52 test($obj->method, "method");
53 test($obj->$mname, "method");
54 test(method $obj, "method");
55
56 test( A->d, "C::d");            # Update hash table;
57
58 *B::d = \&D::d;                 # Import now.
59 test (A->d, "D::d");            # Update hash table;
60
61 {
62     local @A::ISA = qw(C);      # Update hash table with split() assignment
63     test (A->d, "C::d");
64     $#A::ISA = -1;
65     test (eval { A->d } || "fail", "fail");
66 }
67 test (A->d, "D::d");
68
69 {
70     local *B::d;
71     eval 'sub B::d {"B::d1"}';  # Import now.
72     test (A->d, "B::d1");       # Update hash table;
73     undef &B::d;
74     test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1);
75 }
76
77 test (A->d, "D::d");            # Back to previous state
78
79 eval 'sub B::d {"B::d2"}';      # Import now.
80 test (A->d, "B::d2");           # Update hash table;
81
82 # What follows is hardly guarantied to work, since the names in scripts
83 # are already linked to "pruned" globs. Say, `undef &B::d' if it were
84 # after `delete $B::{d}; sub B::d {}' would reach an old subroutine.
85
86 undef &B::d;
87 delete $B::{d};
88 test (A->d, "C::d");            # Update hash table;
89
90 eval 'sub B::d {"B::d3"}';      # Import now.
91 test (A->d, "B::d3");           # Update hash table;
92
93 delete $B::{d};
94 *dummy::dummy = sub {};         # Mark as updated
95 test (A->d, "C::d");
96
97 eval 'sub B::d {"B::d4"}';      # Import now.
98 test (A->d, "B::d4");           # Update hash table;
99
100 delete $B::{d};                 # Should work without any help too
101 test (A->d, "C::d");
102
103 {
104     local *C::d;
105     test (eval { A->d } || "nope", "nope");
106 }
107 test (A->d, "C::d");
108
109 *A::x = *A::d;                  # See if cache incorrectly follows synonyms
110 A->d;
111 test (eval { A->x } || "nope", "nope");
112
113 eval <<'EOF';
114 sub C::e;
115 BEGIN { *B::e = \&C::e }        # Shouldn't prevent AUTOLOAD in original pkg
116 sub Y::f;
117 $counter = 0;
118
119 @X::ISA = 'Y';
120 @Y::ISA = 'B';
121
122 sub B::AUTOLOAD {
123   my $c = ++$counter;
124   my $method = $B::AUTOLOAD; 
125   my $msg = "B: In $method, $c";
126   eval "sub $method { \$msg }";
127   goto &$method;
128 }
129 sub C::AUTOLOAD {
130   my $c = ++$counter;
131   my $method = $C::AUTOLOAD; 
132   my $msg = "C: In $method, $c";
133   eval "sub $method { \$msg }";
134   goto &$method;
135 }
136 EOF
137
138 test(A->e(), "C: In C::e, 1");  # We get a correct autoload
139 test(A->e(), "C: In C::e, 1");  # Which sticks
140
141 test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top
142 test(A->ee(), "B: In A::ee, 2"); # Which sticks
143
144 test(Y->f(), "B: In Y::f, 3");  # We vivify a correct method
145 test(Y->f(), "B: In Y::f, 3");  # Which sticks
146
147 # This test is not intended to be reasonable. It is here just to let you
148 # know that you broke some old construction. Feel free to rewrite the test
149 # if your patch breaks it.
150
151 *B::AUTOLOAD = sub {
152   my $c = ++$counter;
153   my $method = $AUTOLOAD; 
154   *$AUTOLOAD = sub { "new B: In $method, $c" };
155   goto &$AUTOLOAD;
156 };
157
158 test(A->eee(), "new B: In A::eee, 4");  # We get a correct $autoload
159 test(A->eee(), "new B: In A::eee, 4");  # Which sticks
160
161 # this test added due to bug discovery
162 test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined");
163
164 # test that failed subroutine calls don't affect method calls
165 {
166     package A1;
167     sub foo { "foo" }
168     package A2;
169     @ISA = 'A1';
170     package main;
171     test(A2->foo(), "foo");
172     test(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1);
173     test(A2->foo(), "foo");
174 }
175
176 {
177     test(do { use Config; eval 'Config->foo()';
178               $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
179     test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()';
180               $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
181 }
182
183 test(do { eval 'E->foo()';
184           $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1);
185 test(do { eval '$e = bless {}, "E"; $e->foo()';
186           $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1);
187
188 # This is actually testing parsing of indirect objects and undefined subs
189 #   print foo("bar") where foo does not exist is not an indirect object.
190 #   print foo "bar"  where foo does not exist is an indirect object.
191 eval { sub AUTOLOAD { "ok ", shift, "\n"; } };
192 print nonsuch(++$cnt);