1use warnings; 2no warnings "once"; 3use Config; 4 5use IPC::Open3 1.0103 qw(open3); 6use Test::More tests => 60; 7 8sub 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 19my $Is_VMS = $^O eq 'VMS'; 20 21use Carp qw(carp cluck croak confess); 22 23BEGIN { 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 my $str = Carp::longmess("foo"); 32 is( 33 $str, 34 "foo at t/Carp.t line 31.\n", 35 "we don't overshoot the top stack frame", 36 ); 37} 38 39{ 40 local $SIG{__WARN__} = sub { 41 like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+\.$/, 'ok 2\n'; 42 }; 43 44 carp "ok 2\n"; 45} 46 47{ 48 local $SIG{__WARN__} = sub { 49 like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+\.$/, 'carp 3'; 50 }; 51 52 carp 3; 53} 54 55sub sub_4 { 56 local $SIG{__WARN__} = sub { 57 like $_[0], 58 qr/^(\d+) at.+\b(?i:carp\.t) line \d+\.\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$/, 59 'cluck 4'; 60 }; 61 62 cluck 4; 63} 64 65sub_4; 66 67{ 68 local $SIG{__DIE__} = sub { 69 like $_[0], 70 qr/^(\d+) at.+\b(?i:carp\.t) line \d+\.\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$/, 71 'croak 5'; 72 }; 73 74 eval { croak 5 }; 75} 76 77sub sub_6 { 78 local $SIG{__DIE__} = sub { 79 like $_[0], 80 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+$/, 81 'confess 6'; 82 }; 83 84 eval { confess 6 }; 85} 86 87sub_6; 88 89ok(1); 90 91# test for caller_info API 92my $eval = "use Carp; return Carp::caller_info(0);"; 93my %info = eval($eval); 94is( $info{sub_name}, "eval '$eval'", 'caller_info API' ); 95 96# test for '...::CARP_NOT used only once' warning from Carp 97my $warning; 98eval { do { 99 BEGIN { 100 local $SIG{__WARN__} = sub { 101 if ( defined $^S ) { warn $_[0] } 102 else { $warning = $_[0] } 103 } 104 } 105 106 package Z; 107 108 BEGIN { 109 eval { Carp::croak() }; 110 } 111} }; 112ok !$warning, q/'...::CARP_NOT used only once' warning from Carp/; 113 114# Test the location of error messages. 115like( XA::short(), qr/^Error at XC/, "Short messages skip carped package" ); 116 117{ 118 local @XC::ISA = "XD"; 119 like( XA::short(), qr/^Error at XB/, "Short messages skip inheritance" ); 120} 121 122{ 123 local @XD::ISA = "XC"; 124 like( XA::short(), qr/^Error at XB/, "Short messages skip inheritance" ); 125} 126 127{ 128 local @XD::ISA = "XB"; 129 local @XB::ISA = "XC"; 130 like( XA::short(), qr/^Error at XA/, "Inheritance is transitive" ); 131} 132 133{ 134 local @XB::ISA = "XD"; 135 local @XC::ISA = "XB"; 136 like( XA::short(), qr/^Error at XA/, "Inheritance is transitive" ); 137} 138 139{ 140 local @XC::CARP_NOT = "XD"; 141 like( XA::short(), qr/^Error at XB/, "Short messages see \@CARP_NOT" ); 142} 143 144{ 145 local @XD::CARP_NOT = "XC"; 146 like( XA::short(), qr/^Error at XB/, "Short messages see \@CARP_NOT" ); 147} 148 149{ 150 local @XD::CARP_NOT = "XB"; 151 local @XB::CARP_NOT = "XC"; 152 like( XA::short(), qr/^Error at XA/, "\@CARP_NOT is transitive" ); 153} 154 155{ 156 local @XB::CARP_NOT = "XD"; 157 local @XC::CARP_NOT = "XB"; 158 like( XA::short(), qr/^Error at XA/, "\@CARP_NOT is transitive" ); 159} 160 161{ 162 local @XD::ISA = "XC"; 163 local @XD::CARP_NOT = "XB"; 164 like( XA::short(), qr/^Error at XC/, "\@CARP_NOT overrides inheritance" ); 165} 166 167{ 168 local @XD::ISA = "XB"; 169 local @XD::CARP_NOT = "XC"; 170 like( XA::short(), qr/^Error at XB/, "\@CARP_NOT overrides inheritance" ); 171} 172 173# %Carp::Internal 174{ 175 local $Carp::Internal{XC} = 1; 176 like( XA::short(), qr/^Error at XB/, "Short doesn't report Internal" ); 177} 178 179{ 180 local $Carp::Internal{XD} = 1; 181 like( XA::long(), qr/^Error at XC/, "Long doesn't report Internal" ); 182} 183 184# %Carp::CarpInternal 185{ 186 local $Carp::CarpInternal{XD} = 1; 187 like( 188 XA::short(), qr/^Error at XB/, 189 "Short doesn't report calls to CarpInternal" 190 ); 191} 192 193{ 194 local $Carp::CarpInternal{XD} = 1; 195 like( XA::long(), qr/^Error at XC/, "Long doesn't report CarpInternal" ); 196} 197 198# tests for global variables 199sub x { carp @_ } 200sub w { cluck @_ } 201 202# $Carp::Verbose; 203{ 204 my $aref = [ 205 qr/t at \S*(?i:carp.t) line \d+\./, 206 qr/t at \S*(?i:carp.t) line \d+\.\n\s*main::x\("t"\) called at \S*(?i:carp.t) line \d+/ 207 ]; 208 my $i = 0; 209 210 for my $re (@$aref) { 211 local $Carp::Verbose = $i++; 212 local $SIG{__WARN__} = sub { 213 like $_[0], $re, 'Verbose'; 214 }; 215 216 package Z; 217 main::x('t'); 218 } 219} 220 221# $Carp::MaxEvalLen 222{ 223 my $test_num = 1; 224 for ( 0, 4 ) { 225 my $txt = "Carp::cluck($test_num)"; 226 local $Carp::MaxEvalLen = $_; 227 local $SIG{__WARN__} = sub { 228 "@_" =~ /'(.+?)(?:\n|')/s; 229 is length($1), 230 length( $_ ? substr( $txt, 0, $_ ) : substr( $txt, 0 ) ), 231 'MaxEvalLen'; 232 }; 233 eval "$txt"; 234 $test_num++; 235 } 236} 237 238# $Carp::MaxArgNums 239{ 240 my $i = 0; 241 my $aref = [ 242 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+/, 243 qr/1234 at \S*(?i:carp.t) line \d+\.\n\s*main::w\(1, 2, \.\.\.\) called at \S*(?i:carp.t) line \d+/, 244 ]; 245 246 for (@$aref) { 247 local $Carp::MaxArgNums = $i++; 248 local $SIG{__WARN__} = sub { 249 like "@_", $_, 'MaxArgNums'; 250 }; 251 252 package Z; 253 main::w( 1 .. 4 ); 254 } 255} 256 257# $Carp::CarpLevel 258{ 259 my $i = 0; 260 my $aref = [ 261 qr/1 at \S*(?i:carp.t) line \d+\.\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/, 262 qr/1 at \S*(?i:carp.t) line \d+\.$/, 263 ]; 264 265 for (@$aref) { 266 local $Carp::CarpLevel = $i++; 267 local $SIG{__WARN__} = sub { 268 like "@_", $_, 'CarpLevel'; 269 }; 270 271 package Z; 272 main::w(1); 273 } 274} 275 276SKIP: 277{ 278 skip "IPC::Open3::open3 needs porting", 2 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" 297sub 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 309cluck_undef( 0, "undef", 2, undef, 4 ); 310 311# check that Carp respects CORE::GLOBAL::caller override after Carp 312# has been compiled 313for my $bodge_job ( 2, 1, 0 ) { SKIP: { 314 skip "can't safely detect incomplete caller override on perl $]", 6 315 if $bodge_job && !Carp::CALLER_OVERRIDE_CHECK_OK; 316 print '# ', ( $bodge_job ? 'Not ' : '' ), 317 "setting \@DB::args in caller override\n"; 318 if ( $bodge_job == 1 ) { 319 require B; 320 print "# required B\n"; 321 } 322 my $accum = ''; 323 local *CORE::GLOBAL::caller = sub { 324 local *__ANON__ = "fakecaller"; 325 my @c = CORE::caller(@_); 326 $c[0] ||= 'undef'; 327 $accum .= "@c[0..3]\n"; 328 if ( !$bodge_job && CORE::caller() eq 'DB' ) { 329 330 package DB; 331 return CORE::caller( ( $_[0] || 0 ) + 1 ); 332 } 333 else { 334 return CORE::caller( ( $_[0] || 0 ) + 1 ); 335 } 336 }; 337 eval "scalar caller()"; 338 like( $accum, qr/main::fakecaller/, 339 "test CORE::GLOBAL::caller override in eval" ); 340 $accum = ''; 341 my $got = XA::long(42); 342 like( $accum, qr/main::fakecaller/, 343 "test CORE::GLOBAL::caller override in Carp" ); 344 my $package = 'XA'; 345 my $where = $bodge_job == 1 ? ' in &main::__ANON__' : ''; 346 my $warning 347 = $bodge_job 348 ? "\Q** Incomplete caller override detected$where; \@DB::args were not set **\E" 349 : ''; 350 351 for ( 0 .. 2 ) { 352 my $previous_package = $package; 353 ++$package; 354 like( $got, 355 qr/${package}::long\($warning\) called at $previous_package line \d+/, 356 "Correct arguments for $package" ); 357 } 358 my $arg = $bodge_job ? $warning : 42; 359 like( 360 $got, qr!XA::long\($arg\) called at.+\b(?i:carp\.t) line \d+!, 361 'Correct arguments for XA' 362 ); 363} } 364 365SKIP: { 366 skip "can't safely detect incomplete caller override on perl $]", 1 367 unless Carp::CALLER_OVERRIDE_CHECK_OK; 368 eval q{ 369 no warnings 'redefine'; 370 sub CORE::GLOBAL::caller { 371 my $height = $_[0]; 372 $height++; 373 return CORE::caller($height); 374 } 375 }; 376 377 my $got = XA::long(42); 378 379 like( 380 $got, 381 qr!XA::long\(\Q** Incomplete caller override detected; \E\@DB::args\Q were not set **\E\) called at.+\b(?i:carp\.t) line \d+!, 382 'Correct arguments for XA' 383 ); 384} 385 386# UTF8-flagged strings should not cause Carp to try to load modules (even 387# implicitly via utf8_heavy.pl) after a syntax error [perl #82854]. 388SKIP: 389{ 390 skip "IPC::Open3::open3 needs porting", 1 if $Is_VMS; 391 like( 392 runperl( 393 prog => q< 394 use utf8; use strict; use Carp; 395 BEGIN { $SIG{__DIE__} = sub { Carp::croak qq(aaaaa$_[0]) } } 396 $c 397 >, 398 stderr=>1, 399 ), 400 qr/aaaaa/, 401 'Carp can handle UTF8-flagged strings after a syntax error', 402 ); 403} 404 405# [perl #96672] 406<XD::DATA> for 1..2; 407eval { croak 'heek' }; 408$@ =~ s/\n.*//; # just check first line 409is $@, "heek at ".__FILE__." line ".(__LINE__-2).", <DATA> line 2.\n", 410 'last handle line num is mentioned'; 411 412SKIP: 413{ 414 skip "IPC::Open3::open3 needs porting", 1 if $Is_VMS; 415 like( 416 runperl( 417 prog => q< 418 open FH, q-Makefile.PL-; 419 <FH>; # set PL_last_in_gv 420 BEGIN { *CORE::GLOBAL::die = sub { die Carp::longmess(@_) } }; 421 use Carp; 422 die fumpts; 423 >, 424 ), 425 qr 'fumpts', 426 'Carp::longmess works inside CORE::GLOBAL::die', 427 ); 428} 429 430{ 431 package Foo::No::CARP_NOT; 432 eval { Carp::croak(1) }; 433 ::is_deeply( 434 [ keys %Foo::No::CARP_NOT:: ], 435 [], 436 "Carp doesn't create CARP_NOT or ISA in the caller if they don't exist" 437 ); 438 439 package Foo::No::Autovivify; 440 $CARP_NOT = 1; 441 eval { Carp::croak(1) }; 442 ::ok( 443 !defined *{$Foo::No::Autovivify::{CARP_NOT}}{ARRAY}, 444 "Carp doesn't autovivify the CARP_NOT or ISA arrays if the globs exists but they lack the ARRAY slot" 445 ); 446} 447 448# New tests go here 449 450# line 1 "XA" 451package XA; 452 453sub short { 454 XB::short(); 455} 456 457sub long { 458 XB::long(); 459} 460 461# line 1 "XB" 462package XB; 463 464sub short { 465 XC::short(); 466} 467 468sub long { 469 XC::long(); 470} 471 472# line 1 "XC" 473package XC; 474 475sub short { 476 XD::short(); 477} 478 479sub long { 480 XD::long(); 481} 482 483# line 1 "XD" 484package XD; 485 486sub short { 487 eval { Carp::croak("Error") }; 488 return $@; 489} 490 491sub long { 492 eval { Carp::confess("Error") }; 493 return $@; 494} 495 496# Put new tests at "new tests go here" 497__DATA__ 4981 4992 5003 501