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