X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4b09a709cacc8926b531523da1d1511f3a87dcb2..b88df9907a8d7b4fae1100629cc85633a901355e:/lib/Carp.t

diff --git a/lib/Carp.t b/lib/Carp.t
index 2ce5eb4..c24760b 100644
--- a/lib/Carp.t
+++ b/lib/Carp.t
@@ -8,7 +8,7 @@ my $Is_VMS = $^O eq 'VMS';
 
 use Carp qw(carp cluck croak confess);
 
-plan tests => 21;
+plan tests => 37;
 
 ok 1;
 
@@ -72,6 +72,87 @@ eval {
 };
 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 @_ }
@@ -158,7 +239,6 @@ sub w { cluck @_ }
     }
 }
 
-
 {
     local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS;
 
@@ -173,3 +253,57 @@ sub w { cluck @_ }
 
     is($?>>8, 42, 'confess() doesn\'t clobber $!');
 }
+
+# undef used to be incorrectly reported as the string "undef"
+sub cluck_undef {
+
+local $SIG{__WARN__} = sub {
+    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" };
+
+cluck "Bang!"
+
+}
+
+cluck_undef (0, "undef", 2, undef, 4);
+
+# 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 $@;
+}