X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCarp.t;h=63e15654d1c4a3c214bcb16406ae52c6b8597ec5;hb=c7e68384b26a4c916827142ae090582b63face0c;hp=8b9bef98c7b0374f4fc4a531ab77574793c15d34;hpb=22dc90ad47bfa790b556c07d444ffa5b2626a4bf;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Carp.t b/lib/Carp.t index 8b9bef9..63e1565 100644 --- a/lib/Carp.t +++ b/lib/Carp.t @@ -1,31 +1,35 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require './test.pl'; } +my $Is_VMS = $^O eq 'VMS'; + use Carp qw(carp cluck croak confess); -print "1..19\n"; +plan tests => 36; + +ok 1; -print "ok 1\n"; +{ local $SIG{__WARN__} = sub { + like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n' }; -$SIG{__WARN__} = sub { - print "ok $1\n" - if $_[0] =~ m!ok (\d+)\n at.+\b(?i:carp\.t) line \d+$! }; + carp "ok 2\n"; -carp "ok 2\n"; +} -$SIG{__WARN__} = sub { - print "ok $1\n" - if $_[0] =~ m!(\d+) at.+\b(?i:carp\.t) line \d+$! }; +{ local $SIG{__WARN__} = sub { + like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3' }; -carp 3; + carp 3; + +} sub sub_4 { -$SIG{__WARN__} = sub { - print "ok $1\n" - if $_[0] =~ m!^(\d+) at.+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$! }; +local $SIG{__WARN__} = sub { + 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' }; cluck 4; @@ -33,43 +37,122 @@ cluck 4; sub_4; -$SIG{__DIE__} = sub { - print "ok $1\n" - if $_[0] =~ m!^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$! }; +{ local $SIG{__DIE__} = sub { + 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' }; -eval { croak 5 }; + eval { croak 5 }; +} sub sub_6 { - $SIG{__DIE__} = sub { - print "ok $1\n" - if $_[0] =~ m!^(\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+$! }; + local $SIG{__DIE__} = sub { + 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' }; eval { confess 6 }; } sub_6; -print "ok 7\n"; +ok(1); # test for caller_info API my $eval = "use Carp::Heavy; return Carp::caller_info(0);"; my %info = eval($eval); -print "not " if ($info{sub_name} ne "eval '$eval'"); -print "ok 8\n"; +is($info{sub_name}, "eval '$eval'", 'caller_info API'); # test for '...::CARP_NOT used only once' warning from Carp::Heavy my $warning; eval { BEGIN { $^W = 1; - $SIG{__WARN__} = + local $SIG{__WARN__} = sub { if( defined $^S ){ warn $_[0] } else { $warning = $_[0] } } } package Z; BEGIN { eval { Carp::croak() } } }; -print $warning ? "not ok 9\n#$warning" : "ok 9\n"; +ok !$warning, q/'...::CARP_NOT used only once' warning from Carp::Heavy/; + +# Test the location of error messages. +like(A::short(), qr/^Error at C/, "Short messages skip carped package"); + +{ + local @C::ISA = "D"; + like(A::short(), qr/^Error at B/, "Short messages skip inheritance"); +} + +{ + local @D::ISA = "C"; + like(A::short(), qr/^Error at B/, "Short messages skip inheritance"); +} + +{ + local @D::ISA = "B"; + local @B::ISA = "C"; + like(A::short(), qr/^Error at A/, "Inheritance is transitive"); +} + +{ + local @B::ISA = "D"; + local @C::ISA = "B"; + like(A::short(), qr/^Error at A/, "Inheritance is transitive"); +} + +{ + local @C::CARP_NOT = "D"; + like(A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT"); +} + +{ + local @D::CARP_NOT = "C"; + like(A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT"); +} + +{ + local @D::CARP_NOT = "B"; + local @B::CARP_NOT = "C"; + like(A::short(), qr/^Error at A/, "\@CARP_NOT is transitive"); +} + +{ + local @B::CARP_NOT = "D"; + local @C::CARP_NOT = "B"; + like(A::short(), qr/^Error at A/, "\@CARP_NOT is transitive"); +} + +{ + local @D::ISA = "C"; + local @D::CARP_NOT = "B"; + like(A::short(), qr/^Error at C/, "\@CARP_NOT overrides inheritance"); +} + +{ + local @D::ISA = "B"; + local @D::CARP_NOT = "C"; + like(A::short(), qr/^Error at B/, "\@CARP_NOT overrides inheritance"); +} + +# %Carp::Internal +{ + local $Carp::Internal{C} = 1; + like(A::short(), qr/^Error at B/, "Short doesn't report Internal"); +} + +{ + local $Carp::Internal{D} = 1; + like(A::long(), qr/^Error at C/, "Long doesn't report Internal"); +} +# %Carp::CarpInternal +{ + local $Carp::CarpInternal{D} = 1; + like(A::short(), qr/^Error at B/ + , "Short doesn't report calls to CarpInternal"); +} + +{ + local $Carp::CarpInternal{D} = 1; + like(A::long(), qr/^Error at C/, "Long doesn't report CarpInternal"); +} # tests for global variables sub x { carp @_ } @@ -77,16 +160,15 @@ sub w { cluck @_ } # $Carp::Verbose; { my $aref = [ - qr/t at \S*Carp.t line \d+/, - qr/t at \S*Carp.t line \d+\n\s*main::x\('t'\) called at \S*Carp.t line \d+/ + qr/t at \S*(?i:carp.t) line \d+/, + qr/t at \S*(?i:carp.t) line \d+\n\s*main::x\('t'\) called at \S*(?i:carp.t) line \d+/ ]; - my $test_num = 10; my $i = 0; + my $i = 0; for my $re (@$aref) { local $Carp::Verbose = $i++; local $SIG{__WARN__} = sub { - print "not " unless $_[0] =~ $re; - print "ok ".$test_num++." - Verbose\n"; + like $_[0], $re, 'Verbose'; }; package Z; main::x('t'); @@ -94,28 +176,26 @@ sub w { cluck @_ } } # $Carp::MaxEvalLen -{ my $test_num = 12; +{ my $test_num = 1; for(0,4) { my $txt = "Carp::cluck($test_num)"; local $Carp::MaxEvalLen = $_; local $SIG{__WARN__} = sub { "@_"=~/'(.+?)(?:\n|')/s; - print "not " unless length $1 eq length $_?substr($txt,0,$_):substr($txt,0); - print "ok $test_num - MaxEvalLen\n"; + is length($1), length($_?substr($txt,0,$_):substr($txt,0)), 'MaxEvalLen'; }; eval "$txt"; $test_num++; } } # $Carp::MaxArgLen -{ my $test_num = 14; +{ for(0,4) { my $arg = 'testtest'; local $Carp::MaxArgLen = $_; local $SIG{__WARN__} = sub { "@_"=~/'(.+?)'/; - print "not " unless length $1 eq length $_?substr($arg,0,$_):substr($arg,0); - print "ok ".$test_num++." - MaxArgLen\n"; + is length($1), length($_?substr($arg,0,$_):substr($arg,0)), 'MaxArgLen'; }; package Z; @@ -124,17 +204,16 @@ sub w { cluck @_ } } # $Carp::MaxArgNums -{ my $test_num = 16; my $i = 0; +{ my $i = 0; my $aref = [ - qr/1234 at \S*Carp.t line \d+\n\s*main::w\(1, 2, 3, 4\) called at \S*Carp.t line \d+/, - qr/1234 at \S*Carp.t line \d+\n\s*main::w\(1, 2, \.\.\.\) called at \S*Carp.t line \d+/, + 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+/, + qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, \.\.\.\) called at \S*(?i:carp.t) line \d+/, ]; for(@$aref) { local $Carp::MaxArgNums = $i++; local $SIG{__WARN__} = sub { - print "not " unless "@_"=~$_; - print "ok ".$test_num++." - MaxArgNums\n"; + like "@_", $_, 'MaxArgNums'; }; package Z; @@ -143,20 +222,76 @@ sub w { cluck @_ } } # $Carp::CarpLevel -{ my $test_num = 18; my $i = 0; +{ my $i = 0; my $aref = [ - qr/1 at \S*Carp.t line \d+\n\s*main::w\(1\) called at \S*Carp.t line \d+/, - qr/1 at \S*Carp.t line \d+$/, + qr/1 at \S*(?i:carp.t) line \d+\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/, + qr/1 at \S*(?i:carp.t) line \d+$/, ]; for (@$aref) { local $Carp::CarpLevel = $i++; local $SIG{__WARN__} = sub { - print "not " unless "@_"=~$_; - print "ok ".$test_num++." - CarpLevel\n"; + like "@_", $_, 'CarpLevel'; }; package Z; main::w(1); } } + +{ + local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS; + + # Check that croak() and confess() don't clobber $! + runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})', + stderr => 1); + + is($?>>8, 42, 'croak() doesn\'t clobber $!'); + + runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})', + stderr => 1); + + is($?>>8, 42, 'confess() doesn\'t clobber $!'); +} + +# line 1 "A" +package A; +sub short { + B::short(); +} + +sub long { + B::long(); +} + +# line 1 "B" +package B; +sub short { + C::short(); +} + +sub long { + C::long(); +} + +# line 1 "C" +package C; +sub short { + D::short(); +} + +sub long { + D::long(); +} + +# line 1 "D" +package D; +sub short { + eval{ Carp::croak("Error") }; + return $@; +} + +sub long { + eval{ Carp::confess("Error") }; + return $@; +}