X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCarp%2FHeavy.pm;h=4355584d20653ed9a10effc8b74dedd7112dcd0e;hb=d735c2efe0b08b05adfb893625476bf4480a2ece;hp=9d3e000aa9de882ad2075c492330d79e19c245ab;hpb=60a2331071c42c5d2731a3f03a19a529f7521acd;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm
index 9d3e000..4355584 100644
--- a/lib/Carp/Heavy.pm
+++ b/lib/Carp/Heavy.pm
@@ -3,16 +3,71 @@ package Carp;
 
 =head1 NAME
 
-Carp heavy machinery - no user serviceable parts inside
+Carp::Heavy - 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;
+# use strict; # not yet
+
+# 'use Carp' just installs some very lightweight stubs; the first time
+# these are called, they require Carp::Heavy which installs the real
+# routines.
+
+# The members of %Internal are packages that are internal to perl.
+# Carp will not report errors from within these packages if it
+# can.  The members of %CarpInternal are internal to Perl's warning
+# system.  Carp will not report errors from within these packages
+# either, and will not report calls *to* these packages for carp and
+# croak.  They replace $CarpLevel, which is deprecated.    The
+# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
+# text and function arguments should be formatted when printed.
+
+# disable these by default, so they can live w/o require Carp
+$CarpInternal{Carp}++;
+$CarpInternal{warnings}++;
+$Internal{Exporter}++;
+$Internal{'Exporter::Heavy'}++;
+
+
+our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose);
+
+# XXX longmess_real and shortmess_real should really be merged into
+# XXX {long|sort}mess_heavy at some point
+
+sub  longmess_real {
+    # Icky backwards compatibility wrapper. :-(
+    #
+    # The story is that the original implementation hard-coded the
+    # number of call levels to go back, so calls to longmess were off
+    # by one.  Other code began calling longmess and expecting this
+    # behaviour, so the replacement has to emulate that behaviour.
+    my $call_pack = caller();
+    if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
+      return longmess_heavy(@_);
+    }
+    else {
+      local $CarpLevel = $CarpLevel + 1;
+      return longmess_heavy(@_);
+    }
+};
+
+sub shortmess_real {
+    # Icky backwards compatibility wrapper. :-(
+    my $call_pack = caller();
+    local @CARP_NOT = caller();
+    shortmess_heavy(@_);
+};
+
+# replace the two hooks added by Carp
+
+# aliasing the whole glob rather than just the CV slot avoids 'redefined'
+# warnings, even in the presence of perl -W (as used by lib/warnings.t !)
+
+*longmess_jmp  = *longmess_real;
+*shortmess_jmp = *shortmess_real;
 
-our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxLenArg, $Verbose);
 
 sub caller_info {
   my $i = shift(@_) + 1;
@@ -28,14 +83,13 @@ 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, '...';
     }
     # Push the args onto the subroutine
-    $sub_name .= '(' . join (',', @args) . ')';
+    $sub_name .= '(' . join (', ', @args) . ')';
   }
   $call_info{sub_name} = $sub_name;
   return wantarray() ? %call_info : \%call_info;
@@ -44,22 +98,22 @@ sub caller_info {
 # Transform an argument to a function into a string.
 sub format_arg {
   my $arg = shift;
-  if (not defined($arg)) {
-    $arg = 'undef';
-  }
-  elsif (ref($arg)) {
+  if (ref($arg)) {
       $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
+  }elsif (not defined($arg)) {
+    $arg = 'undef';
   }
   $arg =~ s/'/\\'/g;
-  $arg = str_len_trim($arg, $MaxLenArg);
+  $arg = str_len_trim($arg, $MaxArgLen);
   
   # Quote it?
   $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
 
   # The following handling of "control chars" is direct from
-  # the original code - I think it is broken on Unicode though.
+  # the original code - it is broken on Unicode though.
   # Suggestions?
-  $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
+  utf8::is_utf8($arg)
+    or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
   return $arg;
 }
 
@@ -78,14 +132,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) . "'";
     }
   }
 
@@ -120,7 +174,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, @_);
 }
@@ -139,24 +193,18 @@ sub ret_backtrace {
     $tid_msg = " thread $tid" if $tid;
   }
 
-  if ($err =~ /\n$/) {
-    $mess = $err;
-  }
-  else {
-    my %i = caller_info($i);
-    $mess = "$err at $i{file} line $i{line}$tid_msg\n";
-  }
+  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 {
   my ($i, @error) = @_;
-  my $mess;
   my $err = join '', @error;
   $i++;
 
@@ -178,8 +226,10 @@ sub short_error_loc {
   {
     my $called = caller($i++);
     my $caller = caller($i);
+
     return 0 unless defined($caller); # What happened?
     redo if $Internal{$caller};
+    redo if $CarpInternal{$caller};
     redo if $CarpInternal{$called};
     redo if trusts($called, $caller, $cache);
     redo if trusts($caller, $called, $cache);
@@ -188,9 +238,10 @@ sub short_error_loc {
   return $i - 1;
 }
 
+
 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, @_);
@@ -237,7 +288,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;