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