Commit | Line | Data |
---|---|---|
0e25c5fd | 1 | BEGIN { |
d38ea511 DR |
2 | chdir 't' if -d 't'; |
3 | @INC = '../lib'; | |
4 | require './test.pl'; | |
0e25c5fd JH |
5 | } |
6 | ||
a894cef1 RGS |
7 | use warnings; |
8 | no warnings "once"; | |
9 | ||
4b09a709 MS |
10 | my $Is_VMS = $^O eq 'VMS'; |
11 | ||
0e25c5fd JH |
12 | use Carp qw(carp cluck croak confess); |
13 | ||
7154346b | 14 | BEGIN { |
1a6d5308 | 15 | plan tests => 58; |
0e25c5fd | 16 | |
d38ea511 DR |
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"; | |
7154346b | 21 | } |
0e25c5fd | 22 | |
d38ea511 DR |
23 | { |
24 | local $SIG{__WARN__} = sub { | |
25 | like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n'; | |
26 | }; | |
22dc90ad | 27 | |
d38ea511 | 28 | carp "ok 2\n"; |
ce707141 CB |
29 | } |
30 | ||
d38ea511 DR |
31 | { |
32 | local $SIG{__WARN__} = sub { | |
33 | like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3'; | |
34 | }; | |
ce707141 | 35 | |
d38ea511 | 36 | carp 3; |
ce707141 | 37 | } |
0e25c5fd JH |
38 | |
39 | sub sub_4 { | |
d38ea511 DR |
40 | local $SIG{__WARN__} = sub { |
41 | like $_[0], | |
42 | qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$/, | |
43 | 'cluck 4'; | |
44 | }; | |
0e25c5fd | 45 | |
d38ea511 | 46 | cluck 4; |
0e25c5fd JH |
47 | } |
48 | ||
49 | sub_4; | |
50 | ||
d38ea511 DR |
51 | { |
52 | local $SIG{__DIE__} = sub { | |
53 | like $_[0], | |
54 | qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$/, | |
55 | 'croak 5'; | |
56 | }; | |
0e25c5fd | 57 | |
d38ea511 | 58 | eval { croak 5 }; |
ce707141 | 59 | } |
0e25c5fd JH |
60 | |
61 | sub sub_6 { | |
ce707141 | 62 | local $SIG{__DIE__} = sub { |
d38ea511 DR |
63 | like $_[0], |
64 | 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+$/, | |
65 | 'confess 6'; | |
66 | }; | |
0e25c5fd JH |
67 | |
68 | eval { confess 6 }; | |
69 | } | |
70 | ||
71 | sub_6; | |
72 | ||
ce707141 | 73 | ok(1); |
0e25c5fd | 74 | |
976ea96e | 75 | # test for caller_info API |
ba7a4549 | 76 | my $eval = "use Carp; return Carp::caller_info(0);"; |
976ea96e | 77 | my %info = eval($eval); |
d38ea511 | 78 | is( $info{sub_name}, "eval '$eval'", 'caller_info API' ); |
b5777b26 | 79 | |
ba7a4549 | 80 | # test for '...::CARP_NOT used only once' warning from Carp |
b5777b26 RB |
81 | my $warning; |
82 | eval { | |
83 | BEGIN { | |
d38ea511 DR |
84 | local $SIG{__WARN__} = sub { |
85 | if ( defined $^S ) { warn $_[0] } | |
86 | else { $warning = $_[0] } | |
87 | } | |
b5777b26 | 88 | } |
d38ea511 | 89 | |
22dc90ad | 90 | package Z; |
d38ea511 DR |
91 | |
92 | BEGIN { | |
93 | eval { Carp::croak() }; | |
94 | } | |
b5777b26 | 95 | }; |
ba7a4549 | 96 | ok !$warning, q/'...::CARP_NOT used only once' warning from Carp/; |
22dc90ad | 97 | |
d735c2ef | 98 | # Test the location of error messages. |
d38ea511 | 99 | like( A::short(), qr/^Error at C/, "Short messages skip carped package" ); |
d735c2ef BT |
100 | |
101 | { | |
102 | local @C::ISA = "D"; | |
d38ea511 | 103 | like( A::short(), qr/^Error at B/, "Short messages skip inheritance" ); |
d735c2ef BT |
104 | } |
105 | ||
106 | { | |
107 | local @D::ISA = "C"; | |
d38ea511 | 108 | like( A::short(), qr/^Error at B/, "Short messages skip inheritance" ); |
d735c2ef BT |
109 | } |
110 | ||
111 | { | |
112 | local @D::ISA = "B"; | |
113 | local @B::ISA = "C"; | |
d38ea511 | 114 | like( A::short(), qr/^Error at A/, "Inheritance is transitive" ); |
d735c2ef BT |
115 | } |
116 | ||
117 | { | |
118 | local @B::ISA = "D"; | |
119 | local @C::ISA = "B"; | |
d38ea511 | 120 | like( A::short(), qr/^Error at A/, "Inheritance is transitive" ); |
d735c2ef BT |
121 | } |
122 | ||
123 | { | |
124 | local @C::CARP_NOT = "D"; | |
d38ea511 | 125 | like( A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT" ); |
d735c2ef BT |
126 | } |
127 | ||
128 | { | |
129 | local @D::CARP_NOT = "C"; | |
d38ea511 | 130 | like( A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT" ); |
d735c2ef BT |
131 | } |
132 | ||
133 | { | |
134 | local @D::CARP_NOT = "B"; | |
135 | local @B::CARP_NOT = "C"; | |
d38ea511 | 136 | like( A::short(), qr/^Error at A/, "\@CARP_NOT is transitive" ); |
d735c2ef BT |
137 | } |
138 | ||
139 | { | |
140 | local @B::CARP_NOT = "D"; | |
141 | local @C::CARP_NOT = "B"; | |
d38ea511 | 142 | like( A::short(), qr/^Error at A/, "\@CARP_NOT is transitive" ); |
d735c2ef BT |
143 | } |
144 | ||
145 | { | |
d38ea511 | 146 | local @D::ISA = "C"; |
d735c2ef | 147 | local @D::CARP_NOT = "B"; |
d38ea511 | 148 | like( A::short(), qr/^Error at C/, "\@CARP_NOT overrides inheritance" ); |
d735c2ef BT |
149 | } |
150 | ||
151 | { | |
d38ea511 | 152 | local @D::ISA = "B"; |
d735c2ef | 153 | local @D::CARP_NOT = "C"; |
d38ea511 | 154 | like( A::short(), qr/^Error at B/, "\@CARP_NOT overrides inheritance" ); |
d735c2ef BT |
155 | } |
156 | ||
157 | # %Carp::Internal | |
158 | { | |
159 | local $Carp::Internal{C} = 1; | |
d38ea511 | 160 | like( A::short(), qr/^Error at B/, "Short doesn't report Internal" ); |
d735c2ef BT |
161 | } |
162 | ||
163 | { | |
164 | local $Carp::Internal{D} = 1; | |
d38ea511 | 165 | like( A::long(), qr/^Error at C/, "Long doesn't report Internal" ); |
d735c2ef BT |
166 | } |
167 | ||
168 | # %Carp::CarpInternal | |
169 | { | |
170 | local $Carp::CarpInternal{D} = 1; | |
d38ea511 DR |
171 | like( |
172 | A::short(), qr/^Error at B/, | |
173 | "Short doesn't report calls to CarpInternal" | |
174 | ); | |
d735c2ef BT |
175 | } |
176 | ||
177 | { | |
178 | local $Carp::CarpInternal{D} = 1; | |
d38ea511 | 179 | like( A::long(), qr/^Error at C/, "Long doesn't report CarpInternal" ); |
d735c2ef | 180 | } |
22dc90ad JB |
181 | |
182 | # tests for global variables | |
183 | sub x { carp @_ } | |
184 | sub w { cluck @_ } | |
185 | ||
186 | # $Carp::Verbose; | |
d38ea511 DR |
187 | { |
188 | my $aref = [ | |
ce707141 CB |
189 | qr/t at \S*(?i:carp.t) line \d+/, |
190 | qr/t at \S*(?i:carp.t) line \d+\n\s*main::x\('t'\) called at \S*(?i:carp.t) line \d+/ | |
22dc90ad | 191 | ]; |
ce707141 | 192 | my $i = 0; |
22dc90ad JB |
193 | |
194 | for my $re (@$aref) { | |
195 | local $Carp::Verbose = $i++; | |
196 | local $SIG{__WARN__} = sub { | |
ce707141 | 197 | like $_[0], $re, 'Verbose'; |
d38ea511 DR |
198 | }; |
199 | ||
22dc90ad JB |
200 | package Z; |
201 | main::x('t'); | |
202 | } | |
203 | } | |
204 | ||
205 | # $Carp::MaxEvalLen | |
d38ea511 DR |
206 | { |
207 | my $test_num = 1; | |
208 | for ( 0, 4 ) { | |
22dc90ad JB |
209 | my $txt = "Carp::cluck($test_num)"; |
210 | local $Carp::MaxEvalLen = $_; | |
211 | local $SIG{__WARN__} = sub { | |
d38ea511 DR |
212 | "@_" =~ /'(.+?)(?:\n|')/s; |
213 | is length($1), | |
214 | length( $_ ? substr( $txt, 0, $_ ) : substr( $txt, 0 ) ), | |
215 | 'MaxEvalLen'; | |
216 | }; | |
217 | eval "$txt"; | |
218 | $test_num++; | |
22dc90ad JB |
219 | } |
220 | } | |
221 | ||
222 | # $Carp::MaxArgLen | |
ce707141 | 223 | { |
d38ea511 | 224 | for ( 0, 4 ) { |
22dc90ad JB |
225 | my $arg = 'testtest'; |
226 | local $Carp::MaxArgLen = $_; | |
227 | local $SIG{__WARN__} = sub { | |
d38ea511 DR |
228 | "@_" =~ /'(.+?)'/; |
229 | is length($1), | |
230 | length( $_ ? substr( $arg, 0, $_ ) : substr( $arg, 0 ) ), | |
231 | 'MaxArgLen'; | |
232 | }; | |
22dc90ad JB |
233 | |
234 | package Z; | |
235 | main::w($arg); | |
236 | } | |
237 | } | |
238 | ||
239 | # $Carp::MaxArgNums | |
d38ea511 DR |
240 | { |
241 | my $i = 0; | |
22dc90ad | 242 | my $aref = [ |
ce707141 CB |
243 | 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+/, |
244 | qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, \.\.\.\) called at \S*(?i:carp.t) line \d+/, | |
22dc90ad JB |
245 | ]; |
246 | ||
d38ea511 | 247 | for (@$aref) { |
22dc90ad JB |
248 | local $Carp::MaxArgNums = $i++; |
249 | local $SIG{__WARN__} = sub { | |
d38ea511 DR |
250 | like "@_", $_, 'MaxArgNums'; |
251 | }; | |
22dc90ad JB |
252 | |
253 | package Z; | |
d38ea511 | 254 | main::w( 1 .. 4 ); |
22dc90ad JB |
255 | } |
256 | } | |
257 | ||
258 | # $Carp::CarpLevel | |
d38ea511 DR |
259 | { |
260 | my $i = 0; | |
22dc90ad | 261 | my $aref = [ |
ce707141 CB |
262 | qr/1 at \S*(?i:carp.t) line \d+\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/, |
263 | qr/1 at \S*(?i:carp.t) line \d+$/, | |
22dc90ad JB |
264 | ]; |
265 | ||
266 | for (@$aref) { | |
267 | local $Carp::CarpLevel = $i++; | |
268 | local $SIG{__WARN__} = sub { | |
d38ea511 DR |
269 | like "@_", $_, 'CarpLevel'; |
270 | }; | |
22dc90ad JB |
271 | |
272 | package Z; | |
273 | main::w(1); | |
274 | } | |
275 | } | |
62e1ddac | 276 | |
4b09a709 MS |
277 | { |
278 | local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS; | |
279 | ||
280 | # Check that croak() and confess() don't clobber $! | |
d38ea511 DR |
281 | runperl( |
282 | prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})', | |
283 | stderr => 1 | |
284 | ); | |
4b09a709 | 285 | |
d38ea511 | 286 | is( $? >> 8, 42, 'croak() doesn\'t clobber $!' ); |
4b09a709 | 287 | |
d38ea511 DR |
288 | runperl( |
289 | prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})', | |
290 | stderr => 1 | |
291 | ); | |
4b09a709 | 292 | |
d38ea511 | 293 | is( $? >> 8, 42, 'confess() doesn\'t clobber $!' ); |
4b09a709 | 294 | } |
d735c2ef | 295 | |
9cb6ed42 NC |
296 | # undef used to be incorrectly reported as the string "undef" |
297 | sub cluck_undef { | |
298 | ||
d38ea511 DR |
299 | local $SIG{__WARN__} = sub { |
300 | like $_[0], | |
301 | 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+$/, | |
302 | "cluck doesn't quote undef"; | |
303 | }; | |
9cb6ed42 | 304 | |
d38ea511 | 305 | cluck "Bang!" |
9cb6ed42 NC |
306 | |
307 | } | |
308 | ||
d38ea511 | 309 | cluck_undef( 0, "undef", 2, undef, 4 ); |
9cb6ed42 | 310 | |
248ae9a5 DG |
311 | # check that Carp respects CORE::GLOBAL::caller override after Carp |
312 | # has been compiled | |
d38ea511 DR |
313 | for my $bodge_job ( 2, 1, 0 ) { |
314 | print '# ', ( $bodge_job ? 'Not ' : '' ), | |
315 | "setting \@DB::args in caller override\n"; | |
316 | if ( $bodge_job == 1 ) { | |
317 | require B; | |
318 | print "# required B\n"; | |
bf236c8e | 319 | } |
248ae9a5 | 320 | my $accum = ''; |
a894cef1 | 321 | local *CORE::GLOBAL::caller = sub { |
d38ea511 DR |
322 | local *__ANON__ = "fakecaller"; |
323 | my @c = CORE::caller(@_); | |
a894cef1 RGS |
324 | $c[0] ||= 'undef'; |
325 | $accum .= "@c[0..3]\n"; | |
d38ea511 DR |
326 | if ( !$bodge_job && CORE::caller() eq 'DB' ) { |
327 | ||
eff7e72c | 328 | package DB; |
d38ea511 DR |
329 | return CORE::caller( ( $_[0] || 0 ) + 1 ); |
330 | } | |
331 | else { | |
332 | return CORE::caller( ( $_[0] || 0 ) + 1 ); | |
eff7e72c | 333 | } |
a894cef1 | 334 | }; |
248ae9a5 | 335 | eval "scalar caller()"; |
d38ea511 DR |
336 | like( $accum, qr/main::fakecaller/, |
337 | "test CORE::GLOBAL::caller override in eval" ); | |
248ae9a5 | 338 | $accum = ''; |
eff7e72c | 339 | my $got = A::long(42); |
d38ea511 DR |
340 | like( $accum, qr/main::fakecaller/, |
341 | "test CORE::GLOBAL::caller override in Carp" ); | |
eff7e72c | 342 | my $package = 'A'; |
bf236c8e | 343 | my $where = $bodge_job == 1 ? ' in &main::__ANON__' : ''; |
d38ea511 DR |
344 | my $warning |
345 | = $bodge_job | |
346 | ? "\Q** Incomplete caller override detected$where; \@DB::args were not set **\E" | |
347 | : ''; | |
348 | ||
349 | for ( 0 .. 2 ) { | |
350 | my $previous_package = $package; | |
351 | ++$package; | |
352 | like( $got, | |
353 | qr/${package}::long\($warning\) called at $previous_package line \d+/, | |
354 | "Correct arguments for $package" ); | |
eff7e72c | 355 | } |
bf236c8e | 356 | my $arg = $bodge_job ? $warning : 42; |
d38ea511 DR |
357 | like( |
358 | $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!, | |
359 | 'Correct arguments for A' | |
360 | ); | |
248ae9a5 DG |
361 | } |
362 | ||
bf236c8e NC |
363 | eval <<'EOT'; |
364 | no warnings 'redefine'; | |
365 | sub CORE::GLOBAL::caller { | |
366 | my $height = $_[0]; | |
367 | $height++; | |
368 | return CORE::caller($height); | |
369 | } | |
370 | EOT | |
371 | ||
372 | my $got = A::long(42); | |
373 | ||
d38ea511 DR |
374 | like( |
375 | $got, | |
376 | qr!A::long\(\Q** Incomplete caller override detected; \E\@DB::args\Q were not set **\E\) called at.+\b(?i:carp\.t) line \d+!, | |
377 | 'Correct arguments for A' | |
378 | ); | |
bf236c8e | 379 | |
018c7c82 FC |
380 | # UTF8-flagged strings should not cause Carp to try to load modules (even |
381 | # implicitly via utf8_heavy.pl) after a syntax error [perl #82854]. | |
382 | fresh_perl_like( | |
383 | q< | |
384 | use utf8; use strict; use Carp; | |
385 | BEGIN { $SIG{__DIE__} = sub { Carp::croak "aaaaa$_[0]" } } | |
386 | $c | |
387 | >, | |
388 | qr/aaaaa/, | |
389 | {stderr=>1}, | |
390 | 'Carp can handle UTF8-flagged strings after a syntax error', | |
391 | ); | |
392 | ||
1a6d5308 FC |
393 | fresh_perl_is( |
394 | q< | |
395 | use Carp; | |
396 | $SIG{__WARN__} = sub{}; | |
397 | carp ("A duck, but which duck?"); | |
398 | print "ok" unless exists $::{"B::"}; | |
399 | >, | |
400 | 'ok', | |
401 | {}, | |
402 | 'Carp does not autovivify *B::' | |
403 | ); | |
404 | ||
bf236c8e NC |
405 | # New tests go here |
406 | ||
d735c2ef BT |
407 | # line 1 "A" |
408 | package A; | |
d38ea511 | 409 | |
d735c2ef BT |
410 | sub short { |
411 | B::short(); | |
412 | } | |
413 | ||
414 | sub long { | |
415 | B::long(); | |
416 | } | |
417 | ||
418 | # line 1 "B" | |
419 | package B; | |
d38ea511 | 420 | |
d735c2ef BT |
421 | sub short { |
422 | C::short(); | |
423 | } | |
424 | ||
425 | sub long { | |
426 | C::long(); | |
427 | } | |
428 | ||
429 | # line 1 "C" | |
430 | package C; | |
d38ea511 | 431 | |
d735c2ef BT |
432 | sub short { |
433 | D::short(); | |
434 | } | |
435 | ||
436 | sub long { | |
437 | D::long(); | |
438 | } | |
439 | ||
440 | # line 1 "D" | |
441 | package D; | |
d38ea511 | 442 | |
d735c2ef | 443 | sub short { |
d38ea511 | 444 | eval { Carp::croak("Error") }; |
d735c2ef BT |
445 | return $@; |
446 | } | |
447 | ||
448 | sub long { | |
d38ea511 | 449 | eval { Carp::confess("Error") }; |
d735c2ef BT |
450 | return $@; |
451 | } | |
bf236c8e NC |
452 | |
453 | # Put new tests at "new tests go here" | |
454 | __END__ |