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, 0 insertions, 1083 deletions

diff --git a/ext/Carp/Makefile.PL b/ext/Carp/Makefile.PL
deleted file mode 100644
index 313f537102..0000000000
--- a/ext/Carp/Makefile.PL
+++ /dev/null
@@ -1,21 +0,0 @@
-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.0104",
-		"Test::More" => 0,
-		"strict" => 0,
-		"warnings" => 0,
-	},
-	LICENSE => "perl",
-	INSTALLDIRS => "$]" < 5.011 ? "perl" : "site",
-);
-
-1;
diff --git a/ext/Carp/lib/Carp.pm b/ext/Carp/lib/Carp.pm
deleted file mode 100644
index 6148a6862f..0000000000
--- a/ext/Carp/lib/Carp.pm
+++ /dev/null
@@ -1,583 +0,0 @@
-package Carp;
-
-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.
-
-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?
-        $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;
-}
-
-# 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.
-
diff --git a/ext/Carp/lib/Carp/Heavy.pm b/ext/Carp/lib/Carp/Heavy.pm
deleted file mode 100644
index 38f95d8a5a..0000000000
--- a/ext/Carp/lib/Carp/Heavy.pm
+++ /dev/null
@@ -1,10 +0,0 @@
-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/ext/Carp/t/Carp.t b/ext/Carp/t/Carp.t
deleted file mode 100644
index 60b33052db..0000000000
--- a/ext/Carp/t/Carp.t
+++ /dev/null
@@ -1,469 +0,0 @@
-use warnings;
-no warnings "once";
-use Config;
-
-use IPC::Open3 1.0104 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__