summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/Carp.pm396
-rw-r--r--lib/Carp.t259
2 files changed, 359 insertions, 296 deletions
diff --git a/lib/Carp.pm b/lib/Carp.pm
index a1d743f31d..d85a94085d 100644
--- a/lib/Carp.pm
+++ b/lib/Carp.pm
@@ -8,14 +8,14 @@ our $VERSION = '1.19';
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
@@ -57,97 +57,107 @@ sub longmess {
# 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(@_);
+ if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
+ return longmess_heavy(@_);
}
else {
- local $CarpLevel = $CarpLevel + 1;
- return longmess_heavy(@_);
+ 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 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::svref_2object($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;
+ 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);
}
- if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
- $#args = $MaxArgNums;
- push @args, '...';
+
+ 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::svref_2object($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 ) . ')';
}
- # Push the args onto the subroutine
- $sub_name .= '(' . join (', ', @args) . ')';
- }
- $call_info{sub_name} = $sub_name;
- return wantarray() ? %call_info : \%call_info;
+ $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 =~ /^-?[\d.]+\z/;
- } else {
- $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;
+ 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 =~ /^-?[\d.]+\z/;
+ }
+ else {
+ $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
@@ -156,149 +166,148 @@ sub format_arg {
# for.
sub get_status {
my $cache = shift;
- my $pkg = shift;
- $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
- return @{$cache->{$pkg}};
+ 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) . "'";
+ 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};
+ 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;
- }
+ 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};
}
- redo if $CarpInternal{$pkg};
- redo unless 0 > --$lvl;
- redo if $Internal{$pkg};
- }
- return $i - 1;
+ 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, @_);
+ 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;
+ 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";
-}
+ 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;
+ }
-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;
+ 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(@_);
- }
+ 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;
+ 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
@@ -308,16 +317,17 @@ sub str_len_trim {
# possible endless loops, and when following long chains of
# inheritance are less efficient.
sub trusts {
- my $child = shift;
+ my $child = shift;
my $parent = shift;
- my $cache = shift;
- my ($known, $partial) = get_status($cache, $child);
+ 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}) {
+ 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 ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
my @found = keys %$anc_knows;
@$known{@found} = ();
push @$partial, @$anc_partial;
@@ -329,10 +339,10 @@ sub trusts {
sub trusts_directly {
my $class = shift;
no strict 'refs';
- no warnings 'once';
+ no warnings 'once';
return @{"$class\::CARP_NOT"}
- ? @{"$class\::CARP_NOT"}
- : @{"$class\::ISA"};
+ ? @{"$class\::CARP_NOT"}
+ : @{"$class\::ISA"};
}
1;
diff --git a/lib/Carp.t b/lib/Carp.t
index ffbb22226d..9a785f52d0 100644
--- a/lib/Carp.t
+++ b/lib/Carp.t
@@ -1,7 +1,7 @@
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
- require './test.pl';
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
}
use warnings;
@@ -12,48 +12,58 @@ my $Is_VMS = $^O eq 'VMS';
use Carp qw(carp cluck croak confess);
BEGIN {
- plan tests => 56;
+ plan tests => 56;
- # 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"
+ # 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/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;
+{
+ 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';
+ };
-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;
-
+ 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' };
+{
+ 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 };
+ 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' };
+ 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 };
}
@@ -65,100 +75,108 @@ 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');
+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] } }
+ local $SIG{__WARN__} = sub {
+ if ( defined $^S ) { warn $_[0] }
+ else { $warning = $_[0] }
+ }
}
+
package Z;
- BEGIN { eval { Carp::croak() } }
+
+ 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");
+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");
+ 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");
+ 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");
+ 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");
+ 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");
+ 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");
+ 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");
+ 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");
+ like( A::short(), qr/^Error at A/, "\@CARP_NOT is transitive" );
}
{
- local @D::ISA = "C";
+ local @D::ISA = "C";
local @D::CARP_NOT = "B";
- like(A::short(), qr/^Error at C/, "\@CARP_NOT overrides inheritance");
+ like( A::short(), qr/^Error at C/, "\@CARP_NOT overrides inheritance" );
}
{
- local @D::ISA = "B";
+ local @D::ISA = "B";
local @D::CARP_NOT = "C";
- like(A::short(), qr/^Error at B/, "\@CARP_NOT overrides inheritance");
+ 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");
+ 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");
+ 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");
+ 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");
+ like( A::long(), qr/^Error at C/, "Long doesn't report CarpInternal" );
}
# tests for global variables
@@ -166,7 +184,8 @@ sub x { carp @_ }
sub w { cluck @_ }
# $Carp::Verbose;
-{ my $aref = [
+{
+ 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+/
];
@@ -176,34 +195,41 @@ sub w { cluck @_ }
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 $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++;
+ "@_" =~ /'(.+?)(?:\n|')/s;
+ is length($1),
+ length( $_ ? substr( $txt, 0, $_ ) : substr( $txt, 0 ) ),
+ 'MaxEvalLen';
+ };
+ eval "$txt";
+ $test_num++;
}
}
# $Carp::MaxArgLen
{
- for(0,4) {
+ for ( 0, 4 ) {
my $arg = 'testtest';
local $Carp::MaxArgLen = $_;
local $SIG{__WARN__} = sub {
- "@_"=~/'(.+?)'/;
- is length($1), length($_?substr($arg,0,$_):substr($arg,0)), 'MaxArgLen';
- };
+ "@_" =~ /'(.+?)'/;
+ is length($1),
+ length( $_ ? substr( $arg, 0, $_ ) : substr( $arg, 0 ) ),
+ 'MaxArgLen';
+ };
package Z;
main::w($arg);
@@ -211,25 +237,27 @@ sub w { cluck @_ }
}
# $Carp::MaxArgNums
-{ my $i = 0;
+{
+ 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) {
+ for (@$aref) {
local $Carp::MaxArgNums = $i++;
local $SIG{__WARN__} = sub {
- like "@_", $_, 'MaxArgNums';
- };
+ like "@_", $_, 'MaxArgNums';
+ };
package Z;
- main::w(1..4);
+ main::w( 1 .. 4 );
}
}
# $Carp::CarpLevel
-{ my $i = 0;
+{
+ 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+$/,
@@ -238,8 +266,8 @@ sub w { cluck @_ }
for (@$aref) {
local $Carp::CarpLevel = $i++;
local $SIG{__WARN__} = sub {
- like "@_", $_, 'CarpLevel';
- };
+ like "@_", $_, 'CarpLevel';
+ };
package Z;
main::w(1);
@@ -250,68 +278,86 @@ sub w { cluck @_ }
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);
+ runperl(
+ prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})',
+ stderr => 1
+ );
- is($?>>8, 42, 'croak() doesn\'t clobber $!');
+ is( $? >> 8, 42, 'croak() doesn\'t clobber $!' );
- runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
- stderr => 1);
+ runperl(
+ prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
+ stderr => 1
+ );
- is($?>>8, 42, 'confess() doesn\'t clobber $!');
+ 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" };
+ 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 "Bang!"
}
-cluck_undef (0, "undef", 2, undef, 4);
+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";
+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(@_);
+ local *__ANON__ = "fakecaller";
+ my @c = CORE::caller(@_);
$c[0] ||= 'undef';
$accum .= "@c[0..3]\n";
- if (!$bodge_job && CORE::caller() eq 'DB') {
+ if ( !$bodge_job && CORE::caller() eq 'DB' ) {
+
package DB;
- return CORE::caller(($_[0]||0)+1);
- } else {
- return CORE::caller(($_[0]||0)+1);
+ 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");
+ 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");
+ 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 $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' );
+ like(
+ $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
+ 'Correct arguments for A'
+ );
}
eval <<'EOT';
@@ -325,13 +371,17 @@ 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' );
+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'
+);
# New tests go here
# line 1 "A"
package A;
+
sub short {
B::short();
}
@@ -342,6 +392,7 @@ sub long {
# line 1 "B"
package B;
+
sub short {
C::short();
}
@@ -352,6 +403,7 @@ sub long {
# line 1 "C"
package C;
+
sub short {
D::short();
}
@@ -362,13 +414,14 @@ sub long {
# line 1 "D"
package D;
+
sub short {
- eval{ Carp::croak("Error") };
+ eval { Carp::croak("Error") };
return $@;
}
sub long {
- eval{ Carp::confess("Error") };
+ eval { Carp::confess("Error") };
return $@;
}
View Lorry Controller Status