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