X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ed504453245a884c3251bdac3ca34c6eb443f5eb..d0d5e94f451e1e9fec149a7b7a2aaa3ee56f6499:/dist/Carp/lib/Carp.pm diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm index fdf6a93..b54ba34 100644 --- a/dist/Carp/lib/Carp.pm +++ b/dist/Carp/lib/Carp.pm @@ -3,34 +3,128 @@ package Carp; { use 5.006; } use strict; use warnings; +BEGIN { + # Very old versions of warnings.pm load Carp. This can go wrong due + # to the circular dependency. If warnings is invoked before Carp, + # then warnings starts by loading Carp, then Carp (above) tries to + # invoke warnings, and gets nothing because warnings is in the process + # of loading and hasn't defined its import method yet. If we were + # only turning on warnings ("use warnings" above) this wouldn't be too + # bad, because Carp would just gets the state of the -w switch and so + # might not get some warnings that it wanted. The real problem is + # that we then want to turn off Unicode warnings, but "no warnings + # 'utf8'" won't be effective if we're in this circular-dependency + # situation. So, if warnings.pm is an affected version, we turn + # off all warnings ourselves by directly setting ${^WARNING_BITS}. + # On unaffected versions, we turn off just Unicode warnings, via + # the proper API. + if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) { + ${^WARNING_BITS} = ""; + } else { + "warnings"->unimport("utf8"); + } +} + +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.26'; +# 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; 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 $RefArgFormatter = undef; # allow caller to format reference arguments require Exporter; our @ISA = ('Exporter'); @@ -70,6 +164,7 @@ sub _cgc { } sub longmess { + local($!, $^E); # Icky backwards compatibility wrapper. :-( # # The story is that the original implementation hard-coded the @@ -90,6 +185,7 @@ sub longmess { our @CARP_NOT; sub shortmess { + local($!, $^E); my $cgc = _cgc(); # Icky backwards compatibility wrapper. :-( @@ -130,25 +226,33 @@ sub caller_info { = $cgc ? $cgc->($i) : caller($i); } - unless ( defined $call_info{pack} ) { + unless ( defined $call_info{file} ) { return (); } 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; @@ -162,12 +266,18 @@ sub caller_info { = "** 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, '...'; + my $overflow; + if ( $MaxArgNums and @args > $MaxArgNums ) + { # More than we want to show? + $#args = $MaxArgNums - 1; + $overflow = 1; + } + + @args = map { Carp::format_arg($_) } @args; + + if ($overflow) { + push @args, '...'; + } } # Push the args onto the subroutine @@ -177,33 +287,129 @@ sub caller_info { 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) ) { - $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. - downgrade($arg, 1); - $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/; + 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 && $isa->( $arg, 'UNIVERSAL' ) && + do { + local $@; + local $in_recurse = 1; + local $SIG{__DIE__} = sub{}; + eval {$arg->can('CARP_TRACE') } + }) + { + return $arg->CARP_TRACE(); + } + elsif (!$in_recurse && + defined($RefArgFormatter) && + do { + local $@; + local $in_recurse = 1; + local $SIG{__DIE__} = sub{}; + eval {$arg = $RefArgFormatter->($arg); 1} + }) + { + return $arg; + } + else + { + # 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"; + } } - else { - $arg = 'undef'; + 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 = "..."; } + 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 @@ -232,6 +438,12 @@ sub get_subname { } } + # this can happen on older perls when the sub (or the stash containing it) + # has been deleted + if ( !defined( $info->{sub} ) ) { + return '__ANON__::__ANON__'; + } + return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub}; } @@ -243,7 +455,8 @@ sub long_error_loc { { ++$i; my $cgc = _cgc(); - my $pkg = $cgc ? $cgc->($i) : caller($i); + my @caller = $cgc ? $cgc->($i) : caller($i); + my $pkg = $caller[0]; unless ( defined($pkg) ) { # This *shouldn't* happen. @@ -252,9 +465,17 @@ sub long_error_loc { $i = long_error_loc(); last; } + elsif (defined $caller[2]) { + # this can happen when the stash has been deleted + # in that case, just assume that it's a reasonable place to + # stop (the file and line data will still be intact in any + # case) - the only issue is that we can't detect if the + # deleted package was internal (so don't do that then) + # -doy + redo unless 0 > --$lvl; + last; + } else { - - # OK, now I am irritated. return 2; } } @@ -266,7 +487,9 @@ sub long_error_loc { } 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, @_ ); } @@ -293,7 +516,7 @@ sub ret_backtrace { eval { CORE::die; }; - if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) { + if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) { $mess .= $1; } } @@ -334,7 +557,20 @@ sub short_error_loc { $i++; my $caller = $cgc ? $cgc->($i) : caller($i); - return 0 unless defined($caller); # What happened? + if (!defined($caller)) { + my @caller = $cgc ? $cgc->($i) : caller($i); + if (@caller) { + # if there's no package but there is other caller info, then + # the package has been deleted - treat this as a valid package + # in this case + redo if defined($called) && $CarpInternal{$called}; + redo unless 0 > --$lvl; + last; + } + else { + return 0; + } + } redo if $Internal{$caller}; redo if $CarpInternal{$caller}; redo if $CarpInternal{$called}; @@ -396,10 +632,16 @@ sub trusts { sub trusts_directly { my $class = shift; no strict 'refs'; - no warnings 'once'; - return @{"$class\::CARP_NOT"} - ? @{"$class\::CARP_NOT"} - : @{"$class\::ISA"}; + my $stash = \%{"$class\::"}; + 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} && ref \$stash->{$var} eq 'GLOB' + && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) { + return @{$stash->{$var}} + } + } + return; } if(!defined($warnings::VERSION) || @@ -437,7 +679,7 @@ Carp - alternative warn and die for modules # 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()" ); @@ -455,6 +697,13 @@ error as being from where your module was called. C returns the contents of this error message. There is no guarantee that that is where the error was, but it is a good educated guess. +C 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 left useful values there. +Of course, C can't guarantee the latter. + You can also alter the way the output and logic of C works, by changing some global variables in the C namespace. See the section on C below. @@ -525,6 +774,41 @@ environment variable. Alternately, you can set the global variable C<$Carp::Verbose> to true. See the C section below. +=head2 Stack Trace formatting + +At each stack level, the subroutine's name is displayed along with +its parameters. For simple scalars, this is sufficient. For complex +data types, such as objects and other references, this can simply +display C<'HASH(0x1ab36d8)'>. + +Carp gives two ways to control this. + +=over 4 + +=item 1. + +For objects, a method, C, will be called, if it exists. If +this method doesn't exist, or it recurses into C, or it otherwise +throws an exception, this is skipped, and Carp moves on to the next option, +otherwise checking stops and the string returned is used. It is recommended +that the object's type is part of the string to make debugging easier. + +=item 2. + +For any type of reference, C<$Carp::RefArgFormatter> is checked (see below). +This variable is expected to be a code reference, and the current parameter +is passed in. If this function doesn't exist (the variable is undef), or +it recurses into C, or it otherwise throws an exception, this is +skipped, and Carp moves on to the next option, otherwise checking stops +and the string returned is used. + +=item 3. + +Otherwise, if neither C nor C<$Carp::RefArgFormatter> is +available, stringify the value ignoring any overloading. + +=back + =head1 GLOBAL VARIABLES =head2 $Carp::MaxEvalLen @@ -545,7 +829,8 @@ 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. +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>. @@ -557,6 +842,17 @@ is implemented internally. Defaults to C<0>. +=head2 $Carp::RefArgFormatter + +This variable sets a general argument formatter to display references. +Plain scalars and objects that implement C will not go through +this formatter. Calling C from within this function is not supported. + +local $Carp::RefArgFormatter = sub { + require Data::Dumper; + Data::Dumper::Dump($_[0]); # not necessarily safe +}; + =head2 @CARP_NOT This variable, I, says which packages are I to be @@ -655,6 +951,12 @@ call die() or warn(), as appropriate. L, L +=head1 CONTRIBUTING + +L is maintained by the perl 5 porters as part of the core perl 5 +version control repository. Please see the L 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. @@ -664,9 +966,9 @@ distribution. =head1 COPYRIGHT -Copyright (C) 1994-2012 Larry Wall +Copyright (C) 1994-2013 Larry Wall -Copyright (C) 2011, 2012 Andrew Main (Zefram) +Copyright (C) 2011, 2012, 2013 Andrew Main (Zefram) =head1 LICENSE