}
}
+sub _fetch_sub { # fetch sub without autovivifying
+ my($pack, $sub) = @_;
+ $pack .= '::';
+ # only works with top-level packages
+ return unless exists($::{$pack});
+ for ($::{$pack}) {
+ return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
+ for ($$_{$sub}) {
+ return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
+ }
+ }
+}
+
+# UTF8_REGEXP_PROBLEM is a compile-time constant indicating whether Carp
+# must avoid applying a regular expression to an upgraded (is_utf8)
+# string. There are multiple problems, on different Perl versions,
+# that require this to be avoided. All versions prior to 5.13.8 will
+# load utf8_heavy.pl for the swash system, even if the regexp doesn't
+# use character classes. Perl 5.6 and Perls [5.11.2, 5.13.11) exhibit
+# specific problems when Carp is being invoked in the aftermath of a
+# syntax error.
BEGIN {
- no strict "refs";
- if(exists($::{"utf8::"}) && exists(*{$::{"utf8::"}}{HASH}->{"is_utf8"}) &&
- defined(*{*{$::{"utf8::"}}{HASH}->{"is_utf8"}}{CODE})) {
- *is_utf8 = \&{"utf8::is_utf8"};
+ if("$]" < 5.013011) {
+ *UTF8_REGEXP_PROBLEM = sub () { 1 };
} else {
- *is_utf8 = sub { 0 };
+ *UTF8_REGEXP_PROBLEM = sub () { 0 };
}
}
+# is_utf8() is essentially the utf8::is_utf8() function, which indicates
+# whether a string is represented in the upgraded form (using UTF-8
+# internally). As utf8::is_utf8() is only available from Perl 5.8
+# onwards, extra effort is required here to make it work on Perl 5.6.
BEGIN {
- no strict "refs";
- if(exists($::{"utf8::"}) && exists(*{$::{"utf8::"}}{HASH}->{"downgrade"}) &&
- defined(*{*{$::{"utf8::"}}{HASH}->{"downgrade"}}{CODE})) {
+ if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) {
+ *is_utf8 = $sub;
+ } else {
+ # black magic for perl 5.6
+ *is_utf8 = sub { unpack("C", "\xaa".$_[0]) != 170 };
+ }
+}
+
+# The downgrade() function defined here is to be used for attempts to
+# downgrade where it is acceptable to fail. It must be called with a
+# second argument that is a true value.
+BEGIN {
+ if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) {
*downgrade = \&{"utf8::downgrade"};
} else {
- *downgrade = sub {};
+ *downgrade = sub {
+ my $r = "";
+ my $l = length($_[0]);
+ for(my $i = 0; $i != $l; $i++) {
+ my $o = ord(substr($_[0], $i, 1));
+ return if $o > 255;
+ $r .= chr($o);
+ }
+ $_[0] = $r;
+ };
}
}
-our $VERSION = '1.32';
+# is_safe_printable_codepoint() indicates whether a character, specified
+# by integer codepoint, is OK to output literally in a trace. Generally
+# this is if it is a printable character in the ancestral character set
+# (ASCII or EBCDIC). This is used on some Perls in situations where a
+# regexp can't be used.
+BEGIN {
+ *is_safe_printable_codepoint =
+ "$]" >= 5.007_003 ?
+ eval(q(sub ($) {
+ my $u = utf8::native_to_unicode($_[0]);
+ $u >= 0x20 && $u <= 0x7e;
+ }))
+ : ord("A") == 65 ?
+ sub ($) { $_[0] >= 0x20 && $_[0] <= 0x7e }
+ :
+ sub ($) {
+ # Early EBCDIC
+ # 3 EBCDIC code pages supported then; all controls but one
+ # are the code points below SPACE. The other one is 0x5F on
+ # POSIX-BC; FF on the other two.
+ # FIXME: there are plenty of unprintable codepoints other
+ # than those that this code and the comment above identifies
+ # as "controls".
+ $_[0] >= ord(" ") && $_[0] <= 0xff &&
+ $_[0] != (ord ("^") == 106 ? 0x5f : 0xff);
+ }
+ ;
+}
+
+our $VERSION = '1.47';
+$VERSION =~ tr/_//d;
our $MaxEvalLen = 0;
our $Verbose = 0;
}
sub longmess {
+ local($!, $^E);
# Icky backwards compatibility wrapper. :-(
#
# The story is that the original implementation hard-coded the
our @CARP_NOT;
sub shortmess {
+ local($!, $^E);
my $cgc = _cgc();
# Icky backwards compatibility wrapper. :-(
my $sub_name = Carp::get_subname( \%call_info );
if ( $call_info{has_args} ) {
- my @args;
- if (CALLER_OVERRIDE_CHECK_OK && @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
+ # guard our serialization of the stack from stack refcounting bugs
+ my @args = map {
+ my $arg;
+ local $@= $@;
+ eval {
+ $arg = $_;
+ 1;
+ } or do {
+ $arg = '** argument not available anymore **';
+ };
+ $arg;
+ } @DB::args;
+ if (CALLER_OVERRIDE_CHECK_OK && @args == 1
+ && ref $args[0] eq ref \$i
+ && $args[0] == \$i ) {
+ @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
+ (_fetch_sub B => 'svref_2object' or return '')
->($func)->GV;
my $package = $gv->STASH->NAME;
my $subname = $gv->NAME;
= "** Incomplete caller override detected$where; \@DB::args were not set **";
}
else {
- @args = @DB::args;
my $overflow;
if ( $MaxArgNums and @args > $MaxArgNums )
{ # More than we want to show?
- $#args = $MaxArgNums;
+ $#args = $MaxArgNums - 1;
$overflow = 1;
}
return wantarray() ? %call_info : \%call_info;
}
+sub _univisa_loaded {
+ return 0 unless exists($::{"UNIVERSAL::"});
+ for ($::{"UNIVERSAL::"}) {
+ return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"isa::"};
+ for ($$_{"isa::"}) {
+ return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"VERSION"};
+ for ($$_{"VERSION"}) {
+ return 0 unless ref \$_ eq "GLOB";
+ return ${*$_{SCALAR}};
+ }
+ }
+ }
+}
+
# Transform an argument to a function into a string.
our $in_recurse;
sub format_arg {
my $arg = shift;
- if ( ref($arg) ) {
+ if ( my $pack= ref($arg) ) {
+
+ # lazy check if the CPAN module UNIVERSAL::isa is used or not
+ # if we use a rogue version of UNIVERSAL this would lead to infinite loop
+ my $isa = _univisa_loaded() ? sub { 1 } : _fetch_sub(UNIVERSAL => "isa");
+
# legitimate, let's not leak it.
- if (!$in_recurse &&
+ if (!$in_recurse && $isa->( $arg, 'UNIVERSAL' ) &&
do {
local $@;
local $in_recurse = 1;
eval {$arg->can('CARP_TRACE') }
})
{
- $arg = $arg->CARP_TRACE();
+ return $arg->CARP_TRACE();
}
elsif (!$in_recurse &&
defined($RefArgFormatter) &&
eval {$arg = $RefArgFormatter->($arg); 1}
})
{
- 1;
+ return $arg;
}
else
{
- $arg = defined(&overload::StrVal) ? overload::StrVal($arg) : "$arg";
+ # this particular bit of magic looking code is responsible for disabling overloads
+ # while we are stringifing arguments, otherwise if an overload calls a Carp sub we
+ # could end up in infinite recursion, which means we will exhaust the C stack and
+ # then segfault. Calling Carp obviously should not trigger an untrappable exception
+ # from Carp itself! - Yves
+ if ($pack->can("((")) {
+ # this eval is required, or fail the overload test
+ # in dist/Carp/t/vivify_stash.t, which is really quite weird.
+ # Even if we never enter this block, the presence of the require
+ # causes the test to fail. This seems like it might be a bug
+ # in require. Needs further investigation - Yves
+ eval "require overload; 1"
+ or return "use overload failed";
+ }
+ my $sub = _fetch_sub(overload => 'StrVal');
+ return $sub ? &$sub($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.
- downgrade($arg, 1);
- $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/;
+ return "undef" if !defined($arg);
+ downgrade($arg, 1);
+ return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
+ $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
+ my $suffix = "";
+ if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
+ substr ( $arg, $MaxArgLen - 3 ) = "";
+ $suffix = "...";
}
- else {
- $arg = 'undef';
+ if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
+ for(my $i = length($arg); $i--; ) {
+ my $c = substr($arg, $i, 1);
+ my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
+ if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
+ substr $arg, $i, 0, "\\";
+ next;
+ }
+ my $o = ord($c);
+ substr $arg, $i, 1, sprintf("\\x{%x}", $o)
+ unless is_safe_printable_codepoint($o);
+ }
+ } else {
+ $arg =~ s/([\"\\\$\@])/\\$1/g;
+ # This is all the ASCII printables spelled-out. It is portable to all
+ # Perl versions and platforms (such as EBCDIC). There are other more
+ # compact ways to do this, but may not work everywhere every version.
+ $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
}
+ downgrade($arg, 1);
+ return "\"".$arg."\"".$suffix;
+}
- # The following handling of "control chars" is direct from
- # the original code - it is broken on Unicode though.
- # Suggestions?
- is_utf8($arg)
- or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
- return $arg;
+sub Regexp::CARP_TRACE {
+ my $arg = "$_[0]";
+ downgrade($arg, 1);
+ if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
+ for(my $i = length($arg); $i--; ) {
+ my $o = ord(substr($arg, $i, 1));
+ my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
+ substr $arg, $i, 1, sprintf("\\x{%x}", $o)
+ unless is_safe_printable_codepoint($o);
+ }
+ } else {
+ # See comment in format_arg() about this same regex.
+ $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
+ }
+ downgrade($arg, 1);
+ my $suffix = "";
+ if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
+ ($suffix, $arg) = ($1, $2);
+ }
+ if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
+ substr ( $arg, $MaxArgLen - 3 ) = "";
+ $suffix = "...".$suffix;
+ }
+ return "qr($arg)$suffix";
}
# Takes an inheritance cache and a package and returns
}
sub longmess_heavy {
- return @_ if ref( $_[0] ); # don't break references as exceptions
+ if ( ref( $_[0] ) ) { # don't break references as exceptions
+ return wantarray ? @_ : $_[0];
+ }
my $i = long_error_loc();
return ret_backtrace( $i, @_ );
}
eval {
CORE::die;
};
- if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) {
+ if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) {
$mess .= $1;
}
}
for my $var (qw/ CARP_NOT ISA /) {
# Don't try using the variable until we know it exists,
# to avoid polluting the caller's namespace.
- if ( $stash->{$var} && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
+ if ( $stash->{$var} && ref \$stash->{$var} eq 'GLOB'
+ && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
return @{$stash->{$var}}
}
}
# cluck, longmess and shortmess not exported by default
use Carp qw(cluck longmess shortmess);
- cluck "This is how we got here!";
+ cluck "This is how we got here!"; # warn with stack backtrace
$long_message = longmess( "message from cluck() or confess()" );
$short_message = shortmess( "message from carp() or croak()" );
contents of this error message. There is no guarantee that that is where the
error was, but it is a good educated guess.
+C<Carp> takes care not to clobber the status variables C<$!> and C<$^E>
+in the course of assembling its error messages. This means that a
+C<$SIG{__DIE__}> or C<$SIG{__WARN__}> handler can capture the error
+information held in those variables, if it is required to augment the
+error message, and if the code calling C<Carp> left useful values there.
+Of course, C<Carp> can't guarantee the latter.
+
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.
skipped, and Carp moves on to the next option, otherwise checking stops
and the string returned is used.
-=item 3
+=item 3.
Otherwise, if neither C<CARP_TRACE> nor C<$Carp::RefArgFormatter> is
available, stringify the value ignoring any overloading.
=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.
+Use a false value to show all arguments to a function call. To suppress all
+arguments, use C<-1> or C<'0 but true'>.
Defaults to C<8>.
L<Carp::Always>,
L<Carp::Clan>
+=head1 CONTRIBUTING
+
+L<Carp> is maintained by the perl 5 porters as part of the core perl 5
+version control repository. Please see the L<perlhack> perldoc for how to
+submit patches and contribute to it.
+
=head1 AUTHOR
The Carp module first appeared in Larry Wall's perl 5.000 distribution.
=head1 COPYRIGHT
-Copyright (C) 1994-2012 Larry Wall
+Copyright (C) 1994-2013 Larry Wall
-Copyright (C) 2011, 2012 Andrew Main (Zefram) <zefram@fysh.org>
+Copyright (C) 2011, 2012, 2013 Andrew Main (Zefram) <zefram@fysh.org>
=head1 LICENSE
https://perl5.git.perl.org / perl5.git / blobdiff