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
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 use Config;
10
11 my $Is_VMS = $^O eq 'VMS';
12
13 use Carp qw(carp cluck croak confess);
14
15 BEGIN {
16     plan tests => 58;
17
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";
22 }
23
24 {
25     local $SIG{__WARN__} = sub {
26         like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n';
27     };
28
29     carp "ok 2\n";
30 }
31
32 {
33     local $SIG{__WARN__} = sub {
34         like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3';
35     };
36
37     carp 3;
38 }
39
40 sub sub_4 {
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     };
46
47     cluck 4;
48 }
49
50 sub_4;
51
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     };
58
59     eval { croak 5 };
60 }
61
62 sub sub_6 {
63     local $SIG{__DIE__} = sub {
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     };
68
69     eval { confess 6 };
70 }
71
72 sub_6;
73
74 ok(1);
75
76 # test for caller_info API
77 my $eval = "use Carp; return Carp::caller_info(0);";
78 my %info = eval($eval);
79 is( $info{sub_name}, "eval '$eval'", 'caller_info API' );
80
81 # test for '...::CARP_NOT used only once' warning from Carp
82 my $warning;
83 eval {
84     BEGIN {
85         local $SIG{__WARN__} = sub {
86             if   ( defined $^S ) { warn $_[0] }
87             else                 { $warning = $_[0] }
88             }
89     }
90
91     package Z;
92
93     BEGIN {
94         eval { Carp::croak() };
95     }
96 };
97 ok !$warning, q/'...::CARP_NOT used only once' warning from Carp/;
98
99 # Test the location of error messages.
100 like( A::short(), qr/^Error at C/, "Short messages skip carped package" );
101
102 {
103     local @C::ISA = "D";
104     like( A::short(), qr/^Error at B/, "Short messages skip inheritance" );
105 }
106
107 {
108     local @D::ISA = "C";
109     like( A::short(), qr/^Error at B/, "Short messages skip inheritance" );
110 }
111
112 {
113     local @D::ISA = "B";
114     local @B::ISA = "C";
115     like( A::short(), qr/^Error at A/, "Inheritance is transitive" );
116 }
117
118 {
119     local @B::ISA = "D";
120     local @C::ISA = "B";
121     like( A::short(), qr/^Error at A/, "Inheritance is transitive" );
122 }
123
124 {
125     local @C::CARP_NOT = "D";
126     like( A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT" );
127 }
128
129 {
130     local @D::CARP_NOT = "C";
131     like( A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT" );
132 }
133
134 {
135     local @D::CARP_NOT = "B";
136     local @B::CARP_NOT = "C";
137     like( A::short(), qr/^Error at A/, "\@CARP_NOT is transitive" );
138 }
139
140 {
141     local @B::CARP_NOT = "D";
142     local @C::CARP_NOT = "B";
143     like( A::short(), qr/^Error at A/, "\@CARP_NOT is transitive" );
144 }
145
146 {
147     local @D::ISA      = "C";
148     local @D::CARP_NOT = "B";
149     like( A::short(), qr/^Error at C/, "\@CARP_NOT overrides inheritance" );
150 }
151
152 {
153     local @D::ISA      = "B";
154     local @D::CARP_NOT = "C";
155     like( A::short(), qr/^Error at B/, "\@CARP_NOT overrides inheritance" );
156 }
157
158 # %Carp::Internal
159 {
160     local $Carp::Internal{C} = 1;
161     like( A::short(), qr/^Error at B/, "Short doesn't report Internal" );
162 }
163
164 {
165     local $Carp::Internal{D} = 1;
166     like( A::long(), qr/^Error at C/, "Long doesn't report Internal" );
167 }
168
169 # %Carp::CarpInternal
170 {
171     local $Carp::CarpInternal{D} = 1;
172     like(
173         A::short(), qr/^Error at B/,
174         "Short doesn't report calls to CarpInternal"
175     );
176 }
177
178 {
179     local $Carp::CarpInternal{D} = 1;
180     like( A::long(), qr/^Error at C/, "Long doesn't report CarpInternal" );
181 }
182
183 # tests for global variables
184 sub x { carp @_ }
185 sub w { cluck @_ }
186
187 # $Carp::Verbose;
188 {
189     my $aref = [
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+/
192     ];
193     my $i = 0;
194
195     for my $re (@$aref) {
196         local $Carp::Verbose = $i++;
197         local $SIG{__WARN__} = sub {
198             like $_[0], $re, 'Verbose';
199         };
200
201         package Z;
202         main::x('t');
203     }
204 }
205
206 # $Carp::MaxEvalLen
207 {
208     my $test_num = 1;
209     for ( 0, 4 ) {
210         my $txt = "Carp::cluck($test_num)";
211         local $Carp::MaxEvalLen = $_;
212         local $SIG{__WARN__} = sub {
213             "@_" =~ /'(.+?)(?:\n|')/s;
214             is length($1),
215                 length( $_ ? substr( $txt, 0, $_ ) : substr( $txt, 0 ) ),
216                 'MaxEvalLen';
217         };
218         eval "$txt";
219         $test_num++;
220     }
221 }
222
223 # $Carp::MaxArgLen
224 {
225     for ( 0, 4 ) {
226         my $arg = 'testtest';
227         local $Carp::MaxArgLen = $_;
228         local $SIG{__WARN__} = sub {
229             "@_" =~ /'(.+?)'/;
230             is length($1),
231                 length( $_ ? substr( $arg, 0, $_ ) : substr( $arg, 0 ) ),
232                 'MaxArgLen';
233         };
234
235         package Z;
236         main::w($arg);
237     }
238 }
239
240 # $Carp::MaxArgNums
241 {
242     my $i    = 0;
243     my $aref = [
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+/,
246     ];
247
248     for (@$aref) {
249         local $Carp::MaxArgNums = $i++;
250         local $SIG{__WARN__} = sub {
251             like "@_", $_, 'MaxArgNums';
252         };
253
254         package Z;
255         main::w( 1 .. 4 );
256     }
257 }
258
259 # $Carp::CarpLevel
260 {
261     my $i    = 0;
262     my $aref = [
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+$/,
265     ];
266
267     for (@$aref) {
268         local $Carp::CarpLevel = $i++;
269         local $SIG{__WARN__} = sub {
270             like "@_", $_, 'CarpLevel';
271         };
272
273         package Z;
274         main::w(1);
275     }
276 }
277
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 $!
282     runperl(
283         prog   => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})',
284         stderr => 1
285     );
286
287     is( $? >> 8, 42, 'croak() doesn\'t clobber $!' );
288
289     runperl(
290         prog   => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
291         stderr => 1
292     );
293
294     is( $? >> 8, 42, 'confess() doesn\'t clobber $!' );
295 }
296
297 # undef used to be incorrectly reported as the string "undef"
298 sub cluck_undef {
299
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     };
305
306     cluck "Bang!"
307
308 }
309
310 cluck_undef( 0, "undef", 2, undef, 4 );
311
312 # check that Carp respects CORE::GLOBAL::caller override after Carp
313 # has been compiled
314 for 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";
320     }
321     my $accum = '';
322     local *CORE::GLOBAL::caller = sub {
323         local *__ANON__ = "fakecaller";
324         my @c = CORE::caller(@_);
325         $c[0] ||= 'undef';
326         $accum .= "@c[0..3]\n";
327         if ( !$bodge_job && CORE::caller() eq 'DB' ) {
328
329             package DB;
330             return CORE::caller( ( $_[0] || 0 ) + 1 );
331         }
332         else {
333             return CORE::caller( ( $_[0] || 0 ) + 1 );
334         }
335     };
336     eval "scalar caller()";
337     like( $accum, qr/main::fakecaller/,
338         "test CORE::GLOBAL::caller override in eval" );
339     $accum = '';
340     my $got = A::long(42);
341     like( $accum, qr/main::fakecaller/,
342         "test CORE::GLOBAL::caller override in Carp" );
343     my $package = 'A';
344     my $where = $bodge_job == 1 ? ' in &main::__ANON__' : '';
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" );
356     }
357     my $arg = $bodge_job ? $warning : 42;
358     like(
359         $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
360         'Correct arguments for A'
361     );
362 }
363
364 eval <<'EOT';
365 no warnings 'redefine';
366 sub CORE::GLOBAL::caller {
367     my $height = $_[0];
368     $height++;
369     return CORE::caller($height);
370 }
371 EOT
372
373 my $got = A::long(42);
374
375 like(
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 );
380
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].
383 fresh_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
394 SKIP:
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   }
411
412 # New tests go here
413
414 # line 1 "A"
415 package A;
416
417 sub short {
418     B::short();
419 }
420
421 sub long {
422     B::long();
423 }
424
425 # line 1 "B"
426 package B;
427
428 sub short {
429     C::short();
430 }
431
432 sub long {
433     C::long();
434 }
435
436 # line 1 "C"
437 package C;
438
439 sub short {
440     D::short();
441 }
442
443 sub long {
444     D::long();
445 }
446
447 # line 1 "D"
448 package D;
449
450 sub short {
451     eval { Carp::croak("Error") };
452     return $@;
453 }
454
455 sub long {
456     eval { Carp::confess("Error") };
457     return $@;
458 }
459
460 # Put new tests at "new tests go here"
461 __END__