This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid " in Carp.t test programs, due to Win32 shell issues
[perl5.git] / dist / Carp / t / Carp.t
1 use warnings;
2 no warnings "once";
3 use Config;
4
5 use IPC::Open3 1.0103 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 ) { SKIP: {
321     skip "can't safely detect incomplete caller override on perl $]", 6
322         if $bodge_job && !Carp::CALLER_OVERRIDE_CHECK_OK;
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";
328     }
329     my $accum = '';
330     local *CORE::GLOBAL::caller = sub {
331         local *__ANON__ = "fakecaller";
332         my @c = CORE::caller(@_);
333         $c[0] ||= 'undef';
334         $accum .= "@c[0..3]\n";
335         if ( !$bodge_job && CORE::caller() eq 'DB' ) {
336
337             package DB;
338             return CORE::caller( ( $_[0] || 0 ) + 1 );
339         }
340         else {
341             return CORE::caller( ( $_[0] || 0 ) + 1 );
342         }
343     };
344     eval "scalar caller()";
345     like( $accum, qr/main::fakecaller/,
346         "test CORE::GLOBAL::caller override in eval" );
347     $accum = '';
348     my $got = A::long(42);
349     like( $accum, qr/main::fakecaller/,
350         "test CORE::GLOBAL::caller override in Carp" );
351     my $package = 'A';
352     my $where = $bodge_job == 1 ? ' in &main::__ANON__' : '';
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" );
364     }
365     my $arg = $bodge_job ? $warning : 42;
366     like(
367         $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
368         'Correct arguments for A'
369     );
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     };
383
384     my $got = A::long(42);
385
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 }
392
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].
395 like(
396   runperl(
397     prog => q<
398       use utf8; use strict; use Carp;
399       BEGIN { $SIG{__DIE__} = sub { Carp::croak qq(aaaaa$_[0]) } }
400       $c
401     >,
402     stderr=>1,
403   ),
404   qr/aaaaa/,
405   'Carp can handle UTF8-flagged strings after a syntax error',
406 );
407
408 SKIP:
409 {
410     skip("B:: always created when static", 1)
411       if $Config{static_ext} =~ /\bB\b/;
412     is(
413       runperl(
414         prog => q<
415           use Carp;
416           $SIG{__WARN__} = sub{};
417           carp (qq(A duck, but which duck?));
418           print q(ok) unless exists $::{q(B::)};
419         >,
420       ),
421       'ok',
422       'Carp does not autovivify *B::',
423     );
424 }
425
426 # New tests go here
427
428 # line 1 "A"
429 package A;
430
431 sub short {
432     B::short();
433 }
434
435 sub long {
436     B::long();
437 }
438
439 # line 1 "B"
440 package B;
441
442 sub short {
443     C::short();
444 }
445
446 sub long {
447     C::long();
448 }
449
450 # line 1 "C"
451 package C;
452
453 sub short {
454     D::short();
455 }
456
457 sub long {
458     D::long();
459 }
460
461 # line 1 "D"
462 package D;
463
464 sub short {
465     eval { Carp::croak("Error") };
466     return $@;
467 }
468
469 sub long {
470     eval { Carp::confess("Error") };
471     return $@;
472 }
473
474 # Put new tests at "new tests go here"
475 __END__