dual-life Carp

Make Carp portable to older Perl versions:
* check minimum Perl version (5.6) at load time
* use || instead of //
* attempt downgrading to avoid loading Unicode tables when that might fail
* check whether utf8::is_utf8() exists before calling it
* lower IPC::Open3 version requirement in Carp tests

4 files changed, 1111 insertions, 0 deletions

diff --git a/dist/Carp/Makefile.PL b/dist/Carp/Makefile.PL
new file mode 100644
index 0000000000..42207a2b4b
--- /dev/null
+++ b/dist/Carp/Makefile.PL
@@ -0,0 +1,21 @@
+use warnings;
+use strict;
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+	NAME => "Carp",
+	VERSION_FROM => "lib/Carp.pm",
+	ABSTRACT_FROM => "lib/Carp.pm",
+	PREREQ_PM => {
+		"Exporter" => 0,
+		"IPC::Open3" => "1.0103",
+		"Test::More" => 0,
+		"strict" => 0,
+		"warnings" => 0,
+	},
+	LICENSE => "perl",
+	INSTALLDIRS => "$]" < 5.011 ? "perl" : "site",
+);
+
+1;
diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm
new file mode 100644
index 0000000000..52edcd8535
--- /dev/null
+++ b/dist/Carp/lib/Carp.pm
@@ -0,0 +1,611 @@
+package Carp;
+
+{ use 5.006; }
+use strict;
+use warnings;
+
+our $VERSION = '1.22';
+
+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.
+
+require Exporter;
+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
+
+# 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
+# to do this thanks to @EXPORT_FAIL, above.  $_[1] will contain the word
+# 'verbose'.
+
+sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
+
+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 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;
+}
+
+# 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?
+        # Downgrade, and use [0-9] rather than \d, to avoid loading
+        # Unicode tables, which would be liable to fail if we're
+        # processing a syntax error.
+        utf8::downgrade($arg, 1) if "$]" >= 5.008;
+        $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/;
+    }
+    else {
+        $arg = 'undef';
+    }
+
+    # The following handling of "control chars" is direct from
+    # the original code - it is broken on Unicode though.
+    # Suggestions?
+    no strict "refs";
+    defined(*{"utf8::is_utf8"}{CODE}) && utf8::is_utf8($arg)
+        or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
+    return $arg;
+}
+
+# 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} };
+}
+
+# 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++;
+
+    my $tid_msg = '';
+    if ( defined &threads::tid ) {
+        my $tid = threads->tid;
+        $tid_msg = " thread $tid" if $tid;
+    }
+
+    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;
+}
+
+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!";
+
+=head1 DESCRIPTION
+
+The Carp routines are useful in your own modules because
+they act like die() or warn(), but with a message which is more
+likely to be useful to a user of your module.  In the case of
+cluck, confess, and longmess that context is a summary of every
+call in the call-stack.  For a shorter message you can use C<carp>
+or C<croak> which report the error as being from where your module
+was called.  There is no guarantee that that is where the error
+was, but it is a good educated guess.
+
+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.
+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
+instead.  In other words they presume that the first likely looking
+potential suspect is guilty.  Their rules for telling whether
+a call shouldn't generate errors work as follows:
+
+=over 4
+
+=item 1.
+
+Any call from a package to itself is safe.
+
+=item 2.
+
+Packages claim that there won't be errors on calls to or from
+packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
+(if that array is empty) C<@ISA>.  The ability to override what
+@ISA says is new in 5.8.
+
+=item 3.
+
+The trust in item 2 is transitive.  If A trusts B, and B
+trusts C, then A trusts C.  So if you do not override C<@ISA>
+with C<@CARP_NOT>, then this trust relationship is identical to,
+"inherits from".
+
+=item 4.
+
+Any call from an internal Perl module is safe.  (Nothing keeps
+user modules from marking themselves as internal to Perl, but
+this practice is discouraged.)
+
+=item 5.
+
+Any call to Perl's warning system (eg Carp itself) is safe.
+(This rule is what keeps it from reporting the error at the
+point where you call C<carp> or C<croak>.)
+
+=item 6.
+
+C<$Carp::CarpLevel> can be set to skip a fixed number of additional
+call levels.  Using this is not recommended because it is very
+difficult to get it to behave correctly.
+
+=back
+
+=head2 Forcing a Stack Trace
+
+As a debugging aid, you can force Carp to treat a croak as a confess
+and a carp as a cluck across I<all> modules. In other words, force a
+detailed stack trace to be given.  This can be very helpful when trying
+to understand why, or from where, a warning or error is being generated.
+
+This feature is enabled by 'importing' the non-existent symbol
+'verbose'. You would typically enable it by saying
+
+    perl -MCarp=verbose script.pl
+
+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.
+See the C<GLOBAL VARIABLES> section below.
+
+=head1 GLOBAL VARIABLES
+
+=head2 $Carp::MaxEvalLen
+
+This variable determines how many characters of a string-eval are to
+be shown in the output. Use a value of C<0> to show all text.
+
+Defaults to C<0>.
+
+=head2 $Carp::MaxArgLen
+
+This variable determines how many characters of each argument to a
+function to print. Use a value of C<0> to show the full length of the
+argument.
+
+Defaults to C<64>.
+
+=head2 $Carp::MaxArgNums
+
+This variable determines how many arguments to each function to show.
+Use a value of C<0> to show all arguments to a function call.
+
+Defaults to C<8>.
+
+=head2 $Carp::Verbose
+
+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__) }++;
+    # time passes...
+    sub foo { ... or confess("whatever") };
+
+would give a full stack backtrace starting from the first caller
+outside of __PACKAGE__.  (Unless that package was also internal to
+Perl.)
+
+=head2 %Carp::CarpInternal
+
+This says which packages are internal to Perl's warning system.  For
+generating a full stack backtrace this is the same as being internal
+to Perl, the stack backtrace will not start inside packages that are
+listed in C<%Carp::CarpInternal>.  But it is slightly different for
+the summary message generated by C<carp> or C<croak>.  There errors
+will not be reported on any lines that are calling packages in
+C<%Carp::CarpInternal>.
+
+For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
+Therefore the full stack backtrace from C<confess> will not start
+inside of C<Carp>, and the short message from calling C<croak> is
+not placed on the line where C<croak> was called.
+
+=head2 $Carp::CarpLevel
+
+This variable determines how many additional call frames are to be
+skipped that would not otherwise be when reporting where an error
+occurred on a call to one of C<Carp>'s functions.  It is fairly easy
+to count these call frames on calls that generate a full stack
+backtrace.  However it is much harder to do this accounting for calls
+that generate a short message.  Usually people skip too many call
+frames.  If they are lucky they skip enough that C<Carp> goes all of
+the way through the call stack, realizes that something is wrong, and
+then generates a full stack backtrace.  If they are unlucky then the
+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 C<%Carp::CarpInternal>.
+
+Defaults to C<0>.
+
+=head1 BUGS
+
+The Carp routines don't handle exception objects currently.
+If called with a first argument that is a reference, they simply
+call die() or warn(), as appropriate.
+
+=head1 SEE ALSO
+
+L<Carp::Always>,
+L<Carp::Clan>
+
+=head1 AUTHOR
+
+The Carp module first appeared in Larry Wall's perl 5.000 distribution.
+Since then it has been modified by several of the perl 5 porters.
+Andrew Main (Zefram) <zefram@fysh.org> divested Carp into an independent
+distribution.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1994-2011 Larry Wall
+
+Copyright (C) 2011 Andrew Main (Zefram) <zefram@fysh.org>
+
+=head1 LICENSE
+
+This module is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
diff --git a/dist/Carp/lib/Carp/Heavy.pm b/dist/Carp/lib/Carp/Heavy.pm
new file mode 100644
index 0000000000..38f95d8a5a
--- /dev/null
+++ b/dist/Carp/lib/Carp/Heavy.pm
@@ -0,0 +1,10 @@
+package Carp;
+
+# On one line so MakeMaker will see it.
+use Carp;  our $VERSION = $Carp::VERSION;
+
+1;
+
+# Most of the machinery of Carp used to be there.
+# It has been moved in Carp.pm now, but this placeholder remains for
+# the benefit of modules that like to preload Carp::Heavy directly.
diff --git a/dist/Carp/t/Carp.t b/dist/Carp/t/Carp.t
new file mode 100644
index 0000000000..9dd5a125fd
--- /dev/null
+++ b/dist/Carp/t/Carp.t
@@ -0,0 +1,469 @@
+use warnings;
+no warnings "once";
+use Config;
+
+use IPC::Open3 1.0103 qw(open3);
+use Test::More tests => 58;
+
+sub runperl {
+    my(%args) = @_;
+    my($w, $r);
+    my $pid = open3($w, $r, undef, $^X, "-e", $args{prog});
+    close $w;
+    my $output = "";
+    while(<$r>) { $output .= $_; }
+    waitpid($pid, 0);
+    return $output;
+}
+
+my $Is_VMS = $^O eq 'VMS';
+
+use Carp qw(carp cluck croak confess);
+
+BEGIN {
+    # This test must be run at BEGIN time, because code later in this file
+    # sets CORE::GLOBAL::caller
+    ok !exists $CORE::GLOBAL::{caller},
+        "Loading doesn't create CORE::GLOBAL::caller";
+}
+
+{
+    local $SIG{__WARN__} = sub {
+        like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n';
+    };
+
+    carp "ok 2\n";
+}
+
+{
+    local $SIG{__WARN__} = sub {
+        like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3';
+    };
+
+    carp 3;
+}
+
+sub sub_4 {
+    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;
+}
+
+sub_4;
+
+{
+    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 };
+}
+
+sub sub_6 {
+    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;
+
+ok(1);
+
+# test for caller_info API
+my $eval = "use Carp; return Carp::caller_info(0);";
+my %info = eval($eval);
+is( $info{sub_name}, "eval '$eval'", 'caller_info API' );
+
+# test for '...::CARP_NOT used only once' warning from Carp
+my $warning;
+eval {
+    BEGIN {
+        local $SIG{__WARN__} = sub {
+            if   ( defined $^S ) { warn $_[0] }
+            else                 { $warning = $_[0] }
+            }
+    }
+
+    package Z;
+
+    BEGIN {
+        eval { Carp::croak() };
+    }
+};
+ok !$warning, q/'...::CARP_NOT used only once' warning from Carp/;
+
+# 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 @_ }
+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 $!' );
+}
+
+# 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 );
+
+# check that Carp respects CORE::GLOBAL::caller override after Carp
+# has been compiled
+for my $bodge_job ( 2, 1, 0 ) {
+    print '# ', ( $bodge_job ? 'Not ' : '' ),
+        "setting \@DB::args in caller override\n";
+    if ( $bodge_job == 1 ) {
+        require B;
+        print "# required B\n";
+    }
+    my $accum = '';
+    local *CORE::GLOBAL::caller = sub {
+        local *__ANON__ = "fakecaller";
+        my @c = CORE::caller(@_);
+        $c[0] ||= 'undef';
+        $accum .= "@c[0..3]\n";
+        if ( !$bodge_job && CORE::caller() eq 'DB' ) {
+
+            package DB;
+            return CORE::caller( ( $_[0] || 0 ) + 1 );
+        }
+        else {
+            return CORE::caller( ( $_[0] || 0 ) + 1 );
+        }
+    };
+    eval "scalar caller()";
+    like( $accum, qr/main::fakecaller/,
+        "test CORE::GLOBAL::caller override in eval" );
+    $accum = '';
+    my $got = A::long(42);
+    like( $accum, qr/main::fakecaller/,
+        "test CORE::GLOBAL::caller override in Carp" );
+    my $package = 'A';
+    my $where = $bodge_job == 1 ? ' in &main::__ANON__' : '';
+    my $warning
+        = $bodge_job
+        ? "\Q** Incomplete caller override detected$where; \@DB::args were not set **\E"
+        : '';
+
+    for ( 0 .. 2 ) {
+        my $previous_package = $package;
+        ++$package;
+        like( $got,
+            qr/${package}::long\($warning\) called at $previous_package line \d+/,
+            "Correct arguments for $package" );
+    }
+    my $arg = $bodge_job ? $warning : 42;
+    like(
+        $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
+        'Correct arguments for A'
+    );
+}
+
+eval <<'EOT';
+no warnings 'redefine';
+sub CORE::GLOBAL::caller {
+    my $height = $_[0];
+    $height++;
+    return CORE::caller($height);
+}
+EOT
+
+my $got = A::long(42);
+
+like(
+    $got,
+    qr!A::long\(\Q** Incomplete caller override detected; \E\@DB::args\Q were not set **\E\) called at.+\b(?i:carp\.t) line \d+!,
+    'Correct arguments for A'
+);
+
+# UTF8-flagged strings should not cause Carp to try to load modules (even
+# implicitly via utf8_heavy.pl) after a syntax error [perl #82854].
+like(
+  runperl(
+    prog => q<
+      use utf8; use strict; use Carp;
+      BEGIN { $SIG{__DIE__} = sub { Carp::croak "aaaaa$_[0]" } }
+      $c
+    >,
+    stderr=>1,
+  ),
+  qr/aaaaa/,
+  'Carp can handle UTF8-flagged strings after a syntax error',
+);
+
+SKIP:
+{
+    skip("B:: always created when static", 1)
+      if $Config{static_ext} =~ /\bB\b/;
+    is(
+      runperl(
+	prog => q<
+	  use Carp;
+	  $SIG{__WARN__} = sub{};
+	  carp ("A duck, but which duck?");
+	  print "ok" unless exists $::{"B::"};
+	>,
+      ),
+      'ok',
+      'Carp does not autovivify *B::',
+    );
+}
+
+# New tests go here
+
+# 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 $@;
+}
+
+# Put new tests at "new tests go here"
+__END__