a Test::Harness tweak to make the test lines show up prettier

[p5sagit/p5-mst-13.2.git] / lib / Carp / Heavy.pm

diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm
index 36bdcd4..c3d3c26 100644 (file)
--- a/lib/Carp/Heavy.pm
+++ b/lib/Carp/Heavy.pm
@@ -1,8 +1,18 @@
+# Carp::Heavy uses some variables in common with Carp.
 package Carp;
 
-our $MaxEvalLen;
-our $MaxLenArg;
-our $Verbose;
+=head1 NAME
+
+Carp heavy machinery - no user serviceable parts inside
+
+=cut
+
+# use strict; # not yet
+
+# On one line so MakeMaker will see it.
+use Carp;  our $VERSION = $Carp::VERSION;
+
+our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose);
 
 sub caller_info {
   my $i = shift(@_) + 1;
@@ -18,8 +28,7 @@ sub caller_info {
 
   my $sub_name = Carp::get_subname(\%call_info);
   if ($call_info{has_args}) {
-    # Reuse the @args array to avoid warnings. :-)
-    local @args = map {Carp::format_arg($_)} @args;
+    my @args = map {Carp::format_arg($_)} @DB::args;
     if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
       $#args = $MaxArgNums;
       push @args, '...';
@@ -38,10 +47,10 @@ sub format_arg {
     $arg = 'undef';
   }
   elsif (ref($arg)) {
-    $arg .= ''; # Make it a string;
+      $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
   }
   $arg =~ s/'/\\'/g;
-  $arg = str_len_trim($arg, $MaxLenArg);
+  $arg = str_len_trim($arg, $MaxArgLen);
   
   # Quote it?
   $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
@@ -49,7 +58,7 @@ sub format_arg {
   # The following handling of "control chars" is direct from
   # the original code - I think it is broken on Unicode though.
   # Suggestions?
-  $arg =~ s/([[:cntrl:]]|[[^:ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
+  $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
   return $arg;
 }
 
@@ -68,14 +77,14 @@ sub get_status {
 # the sub/require/eval
 sub get_subname {
   my $info = shift;
-  if (defined($info->{eval})) {
-    my $eval = $info->{eval};
+  if (defined($info->{evaltext})) {
+    my $eval = $info->{evaltext};
     if ($info->{is_require}) {
       return "require $eval";
     }
     else {
       $eval =~ s/([\\\'])/\\$1/g;
-      return str_len_trim($eval, $MaxEvalLen);
+      return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
     }
   }
 
@@ -110,7 +119,7 @@ sub long_error_loc {
 
 
 sub longmess_heavy {
-  return @_ if ref($_[0]); # WHAT IS THIS FOR???
+  return @_ if ref($_[0]); # don't break references as exceptions
   my $i = long_error_loc();
   return ret_backtrace($i, @_);
 }
@@ -129,19 +138,19 @@ sub ret_backtrace {
     $tid_msg = " thread $tid" if $tid;
   }
 
-  if ($err =~ /\n$/) {
+  { if ($err =~ /\n$/) {       # extra block to localise $1 etc
     $mess = $err;
   }
   else {
     my %i = caller_info($i);
     $mess = "$err at $i{file} line $i{line}$tid_msg\n";
-  }
+  }}
 
   while (my %i = caller_info(++$i)) {
       $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
   }
   
-  return $mess || $err;
+  return $mess;
 }
 
 sub ret_summary {
@@ -180,7 +189,7 @@ sub short_error_loc {
 
 sub shortmess_heavy {
   return longmess_heavy(@_) if $Verbose;
-  return @_ if ref($_[0]); # WHAT IS THIS FOR???
+  return @_ if ref($_[0]); # don't break references as exceptions
   my $i = short_error_loc();
   if ($i) {
     ret_summary($i, @_);
@@ -227,7 +236,11 @@ sub trusts {
 # Takes a package and gives a list of those trusted directly
 sub trusts_directly {
     my $class = shift;
-    return @{"$class\::ISA"};
+    no strict 'refs';
+    no warnings 'once'; 
+    return @{"$class\::CARP_NOT"}
+      ? @{"$class\::CARP_NOT"}
+      : @{"$class\::ISA"};
 }
 
 1;