X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9cb6ed42173576c510ef1c29c778425530c66d50..046cc26cf77f76bc63fd4d206fef560054f5d298:/lib/Carp.pm

diff --git a/lib/Carp.pm b/lib/Carp.pm
index 393b126..6148a68 100644
--- a/lib/Carp.pm
+++ b/lib/Carp.pm
@@ -1,21 +1,39 @@
 package Carp;
 
-our $VERSION = '1.08';
-# this file is an utra-lightweight stub. The first time a function is
-# called, Carp::Heavy is loaded, and the real short/longmessmess_jmp
-# subs are installed
+use strict;
+use warnings;
+
+our $VERSION = '1.21';
 
 our $MaxEvalLen = 0;
 our $Verbose    = 0;
 our $CarpLevel  = 0;
-our $MaxArgLen  = 64;   # How much of each argument to print. 0 = all.
-our $MaxArgNums = 8;    # How many arguments to print. 0 = all.
+our $MaxArgLen  = 64;    # How much of each argument to print. 0 = all.
+our $MaxArgNums = 8;     # How many arguments to print. 0 = all.
 
 require Exporter;
-our @ISA = ('Exporter');
-our @EXPORT = qw(confess croak carp);
+our @ISA       = ('Exporter');
+our @EXPORT    = qw(confess croak carp);
 our @EXPORT_OK = qw(cluck verbose longmess shortmess);
-our @EXPORT_FAIL = qw(verbose);	# hook to enable verbose mode
+our @EXPORT_FAIL = qw(verbose);    # hook to enable verbose mode
+
+# 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.
+
+our %CarpInternal;
+our %Internal;
+
+# disable these by default, so they can live w/o require Carp
+$CarpInternal{Carp}++;
+$CarpInternal{warnings}++;
+$Internal{Exporter}++;
+$Internal{'Exporter::Heavy'}++;
 
 # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
 # then the following method will be called by the Exporter which knows
@@ -24,47 +42,336 @@ our @EXPORT_FAIL = qw(verbose);	# hook to enable verbose mode
 
 sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
 
-# fixed hooks for stashes to point to
-sub longmess  { goto &longmess_jmp }
-sub shortmess { goto &shortmess_jmp }
-# these two are replaced when Carp::Heavy is loaded
-sub longmess_jmp  {
-    local($@, $!);
-    eval { require Carp::Heavy };
-    return $@ if $@;
-    goto &longmess_real;
-}
-sub shortmess_jmp  {
-    local($@, $!);
-    eval { require Carp::Heavy };
-    return $@ if $@;
-    goto &shortmess_real;
-}
-
-sub croak   { die  shortmess @_ }
-sub confess { die  longmess  @_ }
+sub _cgc {
+    no strict 'refs';
+    return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
+    return;
+}
+
+sub longmess {
+    # 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 $cgc = _cgc();
+    my $call_pack = $cgc ? $cgc->() : caller();
+    if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
+        return longmess_heavy(@_);
+    }
+    else {
+        local $CarpLevel = $CarpLevel + 1;
+        return longmess_heavy(@_);
+    }
+}
+
+our @CARP_NOT;
+
+sub shortmess {
+    my $cgc = _cgc();
+
+    # Icky backwards compatibility wrapper. :-(
+    local @CARP_NOT = $cgc ? $cgc->() : caller();
+    shortmess_heavy(@_);
+}
+
+sub croak   { die shortmess @_ }
+sub confess { die longmess @_ }
 sub carp    { warn shortmess @_ }
-sub cluck   { warn longmess  @_ }
+sub cluck   { warn longmess @_ }
+
+sub caller_info {
+    my $i = shift(@_) + 1;
+    my %call_info;
+    my $cgc = _cgc();
+    {
+        package DB;
+        @DB::args = \$i;    # A sentinel, which no-one else has the address of
+        @call_info{
+            qw(pack file line sub has_args wantarray evaltext is_require) }
+            = $cgc ? $cgc->($i) : caller($i);
+    }
+
+    unless ( defined $call_info{pack} ) {
+        return ();
+    }
+
+    my $sub_name = Carp::get_subname( \%call_info );
+    if ( $call_info{has_args} ) {
+        my @args;
+        if (   @DB::args == 1
+            && ref $DB::args[0] eq ref \$i
+            && $DB::args[0] == \$i ) {
+            @DB::args = ();    # Don't let anyone see the address of $i
+            local $@;
+            my $where = eval {
+                my $func    = $cgc or return '';
+                my $gv      =
+                    *{
+                        ( $::{"B::"} || return '')       # B stash
+                          ->{svref_2object} || return '' # entry in stash
+                     }{CODE}                             # coderef in entry
+                        ->($func)->GV;
+                my $package = $gv->STASH->NAME;
+                my $subname = $gv->NAME;
+                return unless defined $package && defined $subname;
+
+                # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
+                return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
+                " in &${package}::$subname";
+            } // '';
+            @args
+                = "** Incomplete caller override detected$where; \@DB::args were not set **";
+        }
+        else {
+            @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 ) . ')';
+    }
+    $call_info{sub_name} = $sub_name;
+    return wantarray() ? %call_info : \%call_info;
+}
 
-1;
-__END__
+# Transform an argument to a function into a string.
+sub format_arg {
+    my $arg = shift;
+    if ( ref($arg) ) {
+        $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
+    }
+    if ( defined($arg) ) {
+        $arg =~ s/'/\\'/g;
+        $arg = str_len_trim( $arg, $MaxArgLen );
+
+        # Quote it?
+        $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/;
+    }                                    # 0-9, not \d, as \d will try to
+    else {                               # load Unicode tables
+        $arg = 'undef';
+    }
+
+    # The following handling of "control chars" is direct from
+    # the original code - it is broken on Unicode though.
+    # Suggestions?
+    utf8::is_utf8($arg)
+        or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
+    return $arg;
+}
 
-=head1 NAME
+# Takes an inheritance cache and a package and returns
+# an anon hash of known inheritances and anon array of
+# inheritances which consequences have not been figured
+# for.
+sub get_status {
+    my $cache = shift;
+    my $pkg   = shift;
+    $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
+    return @{ $cache->{$pkg} };
+}
 
-carp    - warn of errors (from perspective of caller)
+# Takes the info from caller() and figures out the name of
+# the sub/require/eval
+sub get_subname {
+    my $info = shift;
+    if ( defined( $info->{evaltext} ) ) {
+        my $eval = $info->{evaltext};
+        if ( $info->{is_require} ) {
+            return "require $eval";
+        }
+        else {
+            $eval =~ s/([\\\'])/\\$1/g;
+            return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
+        }
+    }
+
+    return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
+}
+
+# Figures out what call (from the point of view of the caller)
+# the long error backtrace should start at.
+sub long_error_loc {
+    my $i;
+    my $lvl = $CarpLevel;
+    {
+        ++$i;
+        my $cgc = _cgc();
+        my $pkg = $cgc ? $cgc->($i) : caller($i);
+        unless ( defined($pkg) ) {
+
+            # This *shouldn't* happen.
+            if (%Internal) {
+                local %Internal;
+                $i = long_error_loc();
+                last;
+            }
+            else {
+
+                # OK, now I am irritated.
+                return 2;
+            }
+        }
+        redo if $CarpInternal{$pkg};
+        redo unless 0 > --$lvl;
+        redo if $Internal{$pkg};
+    }
+    return $i - 1;
+}
+
+sub longmess_heavy {
+    return @_ if ref( $_[0] );    # don't break references as exceptions
+    my $i = long_error_loc();
+    return ret_backtrace( $i, @_ );
+}
+
+# Returns a full stack backtrace starting from where it is
+# told.
+sub ret_backtrace {
+    my ( $i, @error ) = @_;
+    my $mess;
+    my $err = join '', @error;
+    $i++;
 
-cluck   - warn of errors with stack backtrace
-          (not exported by default)
+    my $tid_msg = '';
+    if ( defined &threads::tid ) {
+        my $tid = threads->tid;
+        $tid_msg = " thread $tid" if $tid;
+    }
 
-croak   - die of errors (from perspective of caller)
+    my %i = caller_info($i);
+    $mess = "$err at $i{file} line $i{line}$tid_msg\n";
 
-confess - die of errors with stack backtrace
+    while ( my %i = caller_info( ++$i ) ) {
+        $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
+    }
+
+    return $mess;
+}
+
+sub ret_summary {
+    my ( $i, @error ) = @_;
+    my $err = join '', @error;
+    $i++;
+
+    my $tid_msg = '';
+    if ( defined &threads::tid ) {
+        my $tid = threads->tid;
+        $tid_msg = " thread $tid" if $tid;
+    }
+
+    my %i = caller_info($i);
+    return "$err at $i{file} line $i{line}$tid_msg\n";
+}
+
+sub short_error_loc {
+    # You have to create your (hash)ref out here, rather than defaulting it
+    # inside trusts *on a lexical*, as you want it to persist across calls.
+    # (You can default it on $_[2], but that gets messy)
+    my $cache = {};
+    my $i     = 1;
+    my $lvl   = $CarpLevel;
+    {
+        my $cgc = _cgc();
+        my $called = $cgc ? $cgc->($i) : caller($i);
+        $i++;
+        my $caller = $cgc ? $cgc->($i) : 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 );
+        redo unless 0 > --$lvl;
+    }
+    return $i - 1;
+}
+
+sub shortmess_heavy {
+    return longmess_heavy(@_) if $Verbose;
+    return @_ if ref( $_[0] );    # don't break references as exceptions
+    my $i = short_error_loc();
+    if ($i) {
+        ret_summary( $i, @_ );
+    }
+    else {
+        longmess_heavy(@_);
+    }
+}
+
+# If a string is too long, trims it with ...
+sub str_len_trim {
+    my $str = shift;
+    my $max = shift || 0;
+    if ( 2 < $max and $max < length($str) ) {
+        substr( $str, $max - 3 ) = '...';
+    }
+    return $str;
+}
+
+# Takes two packages and an optional cache.  Says whether the
+# first inherits from the second.
+#
+# Recursive versions of this have to work to avoid certain
+# possible endless loops, and when following long chains of
+# inheritance are less efficient.
+sub trusts {
+    my $child  = shift;
+    my $parent = shift;
+    my $cache  = shift;
+    my ( $known, $partial ) = get_status( $cache, $child );
+
+    # Figure out consequences until we have an answer
+    while ( @$partial and not exists $known->{$parent} ) {
+        my $anc = shift @$partial;
+        next if exists $known->{$anc};
+        $known->{$anc}++;
+        my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
+        my @found = keys %$anc_knows;
+        @$known{@found} = ();
+        push @$partial, @$anc_partial;
+    }
+    return exists $known->{$parent};
+}
+
+# Takes a package and gives a list of those trusted directly
+sub trusts_directly {
+    my $class = shift;
+    no strict 'refs';
+    no warnings 'once';
+    return @{"$class\::CARP_NOT"}
+        ? @{"$class\::CARP_NOT"}
+        : @{"$class\::ISA"};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Carp - alternative warn and die for modules
 
 =head1 SYNOPSIS
 
     use Carp;
+
+    # warn user (from perspective of caller)
+    carp "string trimmed to 80 chars";
+
+    # die of errors (from perspective of caller)
     croak "We're outta here!";
 
+    # die of errors with stack backtrace
+    confess "not implemented";
+
+    # cluck not exported by default
     use Carp qw(cluck);
     cluck "This is how we got here!";
 
@@ -83,7 +390,7 @@ You can also alter the way the output and logic of C<Carp> works, by
 changing some global variables in the C<Carp> namespace. See the
 section on C<GLOBAL VARIABLES> below.
 
-Here is a more complete description of how c<carp> and c<croak> work.
+Here is a more complete description of how C<carp> and C<croak> work.
 What they do is search the call-stack for a function call stack where
 they have not been told that there shouldn't be an error.  If every
 call is marked safe, they give up and give a full stack backtrace
@@ -143,7 +450,7 @@ This feature is enabled by 'importing' the non-existent symbol
 
     perl -MCarp=verbose script.pl
 
-or by including the string C<MCarp=verbose> in the PERL5OPT
+or by including the string C<-MCarp=verbose> in the PERL5OPT
 environment variable.
 
 Alternately, you can set the global variable C<$Carp::Verbose> to true.
@@ -175,19 +482,58 @@ Defaults to C<8>.
 
 =head2 $Carp::Verbose
 
-This variable makes C<carp> and C<cluck> generate stack backtraces
+This variable makes C<carp> and C<croak> generate stack backtraces
 just like C<cluck> and C<confess>.  This is how C<use Carp 'verbose'>
 is implemented internally.
 
 Defaults to C<0>.
 
+=head2 @CARP_NOT
+
+This variable, I<in your package>, says which packages are I<not> to be
+considered as the location of an error. The C<carp()> and C<cluck()>
+functions will skip over callers when reporting where an error occurred.
+
+NB: This variable must be in the package's symbol table, thus:
+
+    # These work
+    our @CARP_NOT; # file scope
+    use vars qw(@CARP_NOT); # package scope
+    @My::Package::CARP_NOT = ... ; # explicit package variable
+
+    # These don't work
+    sub xyz { ... @CARP_NOT = ... } # w/o declarations above
+    my @CARP_NOT; # even at top-level
+
+Example of use:
+
+    package My::Carping::Package;
+    use Carp;
+    our @CARP_NOT;
+    sub bar     { .... or _error('Wrong input') }
+    sub _error  {
+        # temporary control of where'ness, __PACKAGE__ is implicit
+        local @CARP_NOT = qw(My::Friendly::Caller);
+        carp(@_)
+    }
+
+This would make C<Carp> report the error as coming from a caller not
+in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
+
+Also read the L</DESCRIPTION> section above, about how C<Carp> decides
+where the error is reported from.
+
+Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
+
+Overrides C<Carp>'s use of C<@ISA>.
+
 =head2 %Carp::Internal
 
 This says what packages are internal to Perl.  C<Carp> will never
 report an error as being from a line in a package that is internal to
 Perl.  For example:
 
-    $Carp::Internal{ __PACKAGE__ }++;
+    $Carp::Internal{ (__PACKAGE__) }++;
     # time passes...
     sub foo { ... or confess("whatever") };
 
@@ -225,7 +571,7 @@ error is reported from somewhere misleading very high in the call
 stack.
 
 Therefore it is best to avoid C<$Carp::CarpLevel>.  Instead use
-C<@CARP_NOT>, C<%Carp::Internal> and %Carp::CarpInternal>.
+C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
 
 Defaults to C<0>.