warn if ++ or -- are unable to change the value because it's beyond

[perl5.git] / lib / Carp.t

diff --git a/lib/Carp.t b/lib/Carp.t
index 47f83c9..c24760b 100644 (file)
--- a/lib/Carp.t
+++ b/lib/Carp.t
@@ -4,9 +4,11 @@ BEGIN {
        require './test.pl';
 }
 
+my $Is_VMS = $^O eq 'VMS';
+
 use Carp qw(carp cluck croak confess);
 
-plan tests => 19;
+plan tests => 37;
 
 ok 1;
 
@@ -70,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 @_ }
@@ -155,3 +238,72 @@ sub w { cluck @_ }
         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 $!');
+}
+
+# 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 $@;
+}