X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCarp.t;h=2ce5eb4dff92da278a3c38d7e40f96ae02bf095c;hb=e82b93481bc82235f35444c372503cc96abe405b;hp=2ea98d86d7d4e4e1600b4f3be37915189cf9aa77;hpb=b5777b261727bad592dbbe6d1c792d2f010dd753;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/Carp.t b/lib/Carp.t
index 2ea98d8..2ce5eb4 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..9\n";
+plan tests => 21;
+
+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+)$! };
+  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,39 +37,139 @@ 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; 
+    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/;
+
+
+# tests for global variables
+sub x { carp @_ }
+sub w { cluck @_ }
+
+# $Carp::Verbose;
+{   my $aref = [
+        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 $i = 0;
+
+    for my $re (@$aref) {
+        local $Carp::Verbose = $i++;
+        local $SIG{__WARN__} = sub {
+            like $_[0], $re, 'Verbose';
+	};
+        package Z;
+        main::x('t');
+    }
+}
+
+# $Carp::MaxEvalLen
+{   my $test_num = 1;
+    for(0,4) {
+        my $txt = "Carp::cluck($test_num)";
+        local $Carp::MaxEvalLen = $_;
+        local $SIG{__WARN__} = sub {
+	    "@_"=~/'(.+?)(?:\n|')/s;
+            is length($1), length($_?substr($txt,0,$_):substr($txt,0)), 'MaxEvalLen';
+	};
+        eval "$txt"; $test_num++;
+    }
+}
+
+# $Carp::MaxArgLen
+{
+    for(0,4) {
+        my $arg = 'testtest';
+        local $Carp::MaxArgLen = $_;
+        local $SIG{__WARN__} = sub {
+	    "@_"=~/'(.+?)'/;
+	    is length($1), length($_?substr($arg,0,$_):substr($arg,0)), 'MaxArgLen';
+	};
+
+        package Z;
+        main::w($arg);
+    }
+}
+
+# $Carp::MaxArgNums
+{   my $i = 0;
+    my $aref = [
+        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 {
+	    like "@_", $_, 'MaxArgNums';
+	};
+
+        package Z;
+        main::w(1..4);
+    }
+}
+
+# $Carp::CarpLevel
+{   my $i = 0;
+    my $aref = [
+        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 {
+	    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 $!');
+}