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