10 my $Is_VMS = $^O eq 'VMS';
12 use Carp qw(carp cluck croak confess);
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"
23 { local $SIG{__WARN__} = sub {
24 like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n' };
30 { local $SIG{__WARN__} = sub {
31 like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3' };
39 local $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' };
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' };
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' };
65 # test for caller_info API
66 my $eval = "use Carp; return Carp::caller_info(0);";
67 my %info = eval($eval);
68 is($info{sub_name}, "eval '$eval'", 'caller_info API');
70 # test for '...::CARP_NOT used only once' warning from Carp
74 local $SIG{__WARN__} =
75 sub { if( defined $^S ){ warn $_[0] } else { $warning = $_[0] } }
78 BEGIN { eval { Carp::croak() } }
80 ok !$warning, q/'...::CARP_NOT used only once' warning from Carp/;
82 # Test the location of error messages.
83 like(A::short(), qr/^Error at C/, "Short messages skip carped package");
87 like(A::short(), qr/^Error at B/, "Short messages skip inheritance");
92 like(A::short(), qr/^Error at B/, "Short messages skip inheritance");
98 like(A::short(), qr/^Error at A/, "Inheritance is transitive");
104 like(A::short(), qr/^Error at A/, "Inheritance is transitive");
108 local @C::CARP_NOT = "D";
109 like(A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT");
113 local @D::CARP_NOT = "C";
114 like(A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT");
118 local @D::CARP_NOT = "B";
119 local @B::CARP_NOT = "C";
120 like(A::short(), qr/^Error at A/, "\@CARP_NOT is transitive");
124 local @B::CARP_NOT = "D";
125 local @C::CARP_NOT = "B";
126 like(A::short(), qr/^Error at A/, "\@CARP_NOT is transitive");
131 local @D::CARP_NOT = "B";
132 like(A::short(), qr/^Error at C/, "\@CARP_NOT overrides inheritance");
137 local @D::CARP_NOT = "C";
138 like(A::short(), qr/^Error at B/, "\@CARP_NOT overrides inheritance");
143 local $Carp::Internal{C} = 1;
144 like(A::short(), qr/^Error at B/, "Short doesn't report Internal");
148 local $Carp::Internal{D} = 1;
149 like(A::long(), qr/^Error at C/, "Long doesn't report Internal");
152 # %Carp::CarpInternal
154 local $Carp::CarpInternal{D} = 1;
155 like(A::short(), qr/^Error at B/
156 , "Short doesn't report calls to CarpInternal");
160 local $Carp::CarpInternal{D} = 1;
161 like(A::long(), qr/^Error at C/, "Long doesn't report CarpInternal");
164 # tests for global variables
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+/
175 for my $re (@$aref) {
176 local $Carp::Verbose = $i++;
177 local $SIG{__WARN__} = sub {
178 like $_[0], $re, 'Verbose';
188 my $txt = "Carp::cluck($test_num)";
189 local $Carp::MaxEvalLen = $_;
190 local $SIG{__WARN__} = sub {
191 "@_"=~/'(.+?)(?:\n|')/s;
192 is length($1), length($_?substr($txt,0,$_):substr($txt,0)), 'MaxEvalLen';
194 eval "$txt"; $test_num++;
201 my $arg = 'testtest';
202 local $Carp::MaxArgLen = $_;
203 local $SIG{__WARN__} = sub {
205 is length($1), length($_?substr($arg,0,$_):substr($arg,0)), 'MaxArgLen';
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+/,
221 local $Carp::MaxArgNums = $i++;
222 local $SIG{__WARN__} = sub {
223 like "@_", $_, 'MaxArgNums';
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+$/,
239 local $Carp::CarpLevel = $i++;
240 local $SIG{__WARN__} = sub {
241 like "@_", $_, 'CarpLevel';
250 local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS;
252 # Check that croak() and confess() don't clobber $!
253 runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})',
256 is($?>>8, 42, 'croak() doesn\'t clobber $!');
258 runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
261 is($?>>8, 42, 'confess() doesn\'t clobber $!');
264 # undef used to be incorrectly reported as the string "undef"
267 local $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" };
274 cluck_undef (0, "undef", 2, undef, 4);
276 # check that Carp respects CORE::GLOBAL::caller override after Carp
278 for my $bodge_job (2, 1, 0) {
279 print '# ', ($bodge_job ? 'Not ' : ''), "setting \@DB::args in caller override\n";
280 if ($bodge_job == 1) {
282 print "# required B\n";
285 local *CORE::GLOBAL::caller = sub {
286 local *__ANON__="fakecaller";
287 my @c=CORE::caller(@_);
289 $accum .= "@c[0..3]\n";
290 if (!$bodge_job && CORE::caller() eq 'DB') {
292 return CORE::caller(($_[0]||0)+1);
294 return CORE::caller(($_[0]||0)+1);
297 eval "scalar caller()";
298 like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in eval");
300 my $got = A::long(42);
301 like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in Carp");
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"
308 my $previous_package = $package;
310 like( $got, qr/${package}::long\($warning\) called at $previous_package line 7/, "Correct arguments for $package" );
312 my $arg = $bodge_job ? $warning : 42;
313 like( $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
314 'Correct arguments for A' );
318 no warnings 'redefine';
319 sub CORE::GLOBAL::caller {
322 return CORE::caller($height);
326 my $got = A::long(42);
328 like( $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+!,
329 'Correct arguments for A' );
366 eval{ Carp::croak("Error") };
371 eval{ Carp::confess("Error") };
375 # Put new tests at "new tests go here"