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