Rename tied_handle_method() to tied_method(), and make it non-static.
[perl.git] / lib / Carp.t
1 BEGIN {
2         chdir 't' if -d 't';
3         @INC = '../lib';
4         require './test.pl';
5 }
6
7 use warnings;
8 no warnings "once";
9
10 my $Is_VMS = $^O eq 'VMS';
11
12 use Carp qw(carp cluck croak confess);
13
14 BEGIN {
15         plan tests => 56;
16
17         # This test must be run at BEGIN time, because code later in this file
18         # sets CORE::GLOBAL::caller
19         ok !exists $CORE::GLOBAL::{caller},
20           "Loading doesn't create CORE::GLOBAL::caller"
21 }
22
23 { local $SIG{__WARN__} = sub {
24     like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n' };
25
26   carp  "ok 2\n";
27
28 }
29
30 { local $SIG{__WARN__} = sub {
31     like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3' };
32
33   carp 3;
34
35 }
36
37 sub sub_4 {
38
39 local $SIG{__WARN__} = sub {
40     like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$/, 'cluck 4' };
41
42 cluck 4;
43
44 }
45
46 sub_4;
47
48 { local $SIG{__DIE__} = sub {
49     like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$/, 'croak 5' };
50
51   eval { croak 5 };
52 }
53
54 sub sub_6 {
55     local $SIG{__DIE__} = sub {
56         like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+\n\tmain::sub_6\(\) called at.+\b(?i:carp\.t) line \d+$/, 'confess 6' };
57
58     eval { confess 6 };
59 }
60
61 sub_6;
62
63 ok(1);
64
65 # test for caller_info API
66 my $eval = "use Carp; return Carp::caller_info(0);";
67 my %info = eval($eval);
68 is($info{sub_name}, "eval '$eval'", 'caller_info API');
69
70 # test for '...::CARP_NOT used only once' warning from Carp
71 my $warning;
72 eval {
73     BEGIN {
74         local $SIG{__WARN__} =
75             sub { if( defined $^S ){ warn $_[0] } else { $warning = $_[0] } }
76     }
77     package Z;
78     BEGIN { eval { Carp::croak() } }
79 };
80 ok !$warning, q/'...::CARP_NOT used only once' warning from Carp/;
81
82 # Test the location of error messages.
83 like(A::short(), qr/^Error at C/, "Short messages skip carped package");
84
85 {
86     local @C::ISA = "D";
87     like(A::short(), qr/^Error at B/, "Short messages skip inheritance");
88 }
89
90 {
91     local @D::ISA = "C";
92     like(A::short(), qr/^Error at B/, "Short messages skip inheritance");
93 }
94
95 {
96     local @D::ISA = "B";
97     local @B::ISA = "C";
98     like(A::short(), qr/^Error at A/, "Inheritance is transitive");
99 }
100
101 {
102     local @B::ISA = "D";
103     local @C::ISA = "B";
104     like(A::short(), qr/^Error at A/, "Inheritance is transitive");
105 }
106
107 {
108     local @C::CARP_NOT = "D";
109     like(A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT");
110 }
111
112 {
113     local @D::CARP_NOT = "C";
114     like(A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT");
115 }
116
117 {
118     local @D::CARP_NOT = "B";
119     local @B::CARP_NOT = "C";
120     like(A::short(), qr/^Error at A/, "\@CARP_NOT is transitive");
121 }
122
123 {
124     local @B::CARP_NOT = "D";
125     local @C::CARP_NOT = "B";
126     like(A::short(), qr/^Error at A/, "\@CARP_NOT is transitive");
127 }
128
129 {
130     local @D::ISA = "C";
131     local @D::CARP_NOT = "B";
132     like(A::short(), qr/^Error at C/, "\@CARP_NOT overrides inheritance");
133 }
134
135 {
136     local @D::ISA = "B";
137     local @D::CARP_NOT = "C";
138     like(A::short(), qr/^Error at B/, "\@CARP_NOT overrides inheritance");
139 }
140
141 # %Carp::Internal
142 {
143     local $Carp::Internal{C} = 1;
144     like(A::short(), qr/^Error at B/, "Short doesn't report Internal");
145 }
146
147 {
148     local $Carp::Internal{D} = 1;
149     like(A::long(), qr/^Error at C/, "Long doesn't report Internal");
150 }
151
152 # %Carp::CarpInternal
153 {
154     local $Carp::CarpInternal{D} = 1;
155     like(A::short(), qr/^Error at B/
156       , "Short doesn't report calls to CarpInternal");
157 }
158
159 {
160     local $Carp::CarpInternal{D} = 1;
161     like(A::long(), qr/^Error at C/, "Long doesn't report CarpInternal");
162 }
163
164 # tests for global variables
165 sub x { carp @_ }
166 sub w { cluck @_ }
167
168 # $Carp::Verbose;
169 {   my $aref = [
170         qr/t at \S*(?i:carp.t) line \d+/,
171         qr/t at \S*(?i:carp.t) line \d+\n\s*main::x\('t'\) called at \S*(?i:carp.t) line \d+/
172     ];
173     my $i = 0;
174
175     for my $re (@$aref) {
176         local $Carp::Verbose = $i++;
177         local $SIG{__WARN__} = sub {
178             like $_[0], $re, 'Verbose';
179         };
180         package Z;
181         main::x('t');
182     }
183 }
184
185 # $Carp::MaxEvalLen
186 {   my $test_num = 1;
187     for(0,4) {
188         my $txt = "Carp::cluck($test_num)";
189         local $Carp::MaxEvalLen = $_;
190         local $SIG{__WARN__} = sub {
191             "@_"=~/'(.+?)(?:\n|')/s;
192             is length($1), length($_?substr($txt,0,$_):substr($txt,0)), 'MaxEvalLen';
193         };
194         eval "$txt"; $test_num++;
195     }
196 }
197
198 # $Carp::MaxArgLen
199 {
200     for(0,4) {
201         my $arg = 'testtest';
202         local $Carp::MaxArgLen = $_;
203         local $SIG{__WARN__} = sub {
204             "@_"=~/'(.+?)'/;
205             is length($1), length($_?substr($arg,0,$_):substr($arg,0)), 'MaxArgLen';
206         };
207
208         package Z;
209         main::w($arg);
210     }
211 }
212
213 # $Carp::MaxArgNums
214 {   my $i = 0;
215     my $aref = [
216         qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, 3, 4\) called at \S*(?i:carp.t) line \d+/,
217         qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, \.\.\.\) called at \S*(?i:carp.t) line \d+/,
218     ];
219
220     for(@$aref) {
221         local $Carp::MaxArgNums = $i++;
222         local $SIG{__WARN__} = sub {
223             like "@_", $_, 'MaxArgNums';
224         };
225
226         package Z;
227         main::w(1..4);
228     }
229 }
230
231 # $Carp::CarpLevel
232 {   my $i = 0;
233     my $aref = [
234         qr/1 at \S*(?i:carp.t) line \d+\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/,
235         qr/1 at \S*(?i:carp.t) line \d+$/,
236     ];
237
238     for (@$aref) {
239         local $Carp::CarpLevel = $i++;
240         local $SIG{__WARN__} = sub {
241             like "@_", $_, 'CarpLevel';
242         };
243
244         package Z;
245         main::w(1);
246     }
247 }
248
249 {
250     local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS;
251
252     # Check that croak() and confess() don't clobber $!
253     runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})', 
254             stderr => 1);
255
256     is($?>>8, 42, 'croak() doesn\'t clobber $!');
257
258     runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})', 
259             stderr => 1);
260
261     is($?>>8, 42, 'confess() doesn\'t clobber $!');
262 }
263
264 # undef used to be incorrectly reported as the string "undef"
265 sub cluck_undef {
266
267 local $SIG{__WARN__} = sub {
268     like $_[0], qr/^Bang! at.+\b(?i:carp\.t) line \d+\n\tmain::cluck_undef\(0, 'undef', 2, undef, 4\) called at.+\b(?i:carp\.t) line \d+$/, "cluck doesn't quote undef" };
269
270 cluck "Bang!"
271
272 }
273
274 cluck_undef (0, "undef", 2, undef, 4);
275
276 # check that Carp respects CORE::GLOBAL::caller override after Carp
277 # has been compiled
278 for my $bodge_job (2, 1, 0) {
279     print '# ', ($bodge_job ? 'Not ' : ''), "setting \@DB::args in caller override\n";
280     if ($bodge_job == 1) {
281         require B;
282         print "# required B\n";
283     }
284     my $accum = '';
285     local *CORE::GLOBAL::caller = sub {
286         local *__ANON__="fakecaller";
287         my @c=CORE::caller(@_);
288         $c[0] ||= 'undef';
289         $accum .= "@c[0..3]\n";
290         if (!$bodge_job && CORE::caller() eq 'DB') {
291             package DB;
292             return CORE::caller(($_[0]||0)+1);
293         } else {
294             return CORE::caller(($_[0]||0)+1);
295         }
296     };
297     eval "scalar caller()";
298     like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in eval");
299     $accum = '';
300     my $got = A::long(42);
301     like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in Carp");
302     my $package = 'A';
303     my $where = $bodge_job == 1 ? ' in &main::__ANON__' : '';
304     my $warning = $bodge_job ?
305         "\Q** Incomplete caller override detected$where; \@DB::args were not set **\E"
306             : '';
307     for (0..2) {
308         my $previous_package = $package;
309         ++$package;
310         like( $got, qr/${package}::long\($warning\) called at $previous_package line 7/, "Correct arguments for $package" );
311     }
312     my $arg = $bodge_job ? $warning : 42;
313     like( $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
314           'Correct arguments for A' );
315 }
316
317 eval <<'EOT';
318 no warnings 'redefine';
319 sub CORE::GLOBAL::caller {
320     my $height = $_[0];
321     $height++;
322     return CORE::caller($height);
323 }
324 EOT
325
326 my $got = A::long(42);
327
328 like( $got, qr!A::long\(\Q** Incomplete caller override detected; \E\@DB::args\Q were not set **\E\) called at.+\b(?i:carp\.t) line \d+!,
329           'Correct arguments for A' );
330
331 # New tests go here
332
333 # line 1 "A"
334 package A;
335 sub short {
336     B::short();
337 }
338
339 sub long {
340     B::long();
341 }
342
343 # line 1 "B"
344 package B;
345 sub short {
346     C::short();
347 }
348
349 sub long {
350     C::long();
351 }
352
353 # line 1 "C"
354 package C;
355 sub short {
356     D::short();
357 }
358
359 sub long {
360     D::long();
361 }
362
363 # line 1 "D"
364 package D;
365 sub short {
366     eval{ Carp::croak("Error") };
367     return $@;
368 }
369
370 sub long {
371     eval{ Carp::confess("Error") };
372     return $@;
373 }
374
375 # Put new tests at "new tests go here"
376 __END__