X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d5dcec3a2d59e371062ff5b9430ca9be9eaf3b66..d0d5e94f451e1e9fec149a7b7a2aaa3ee56f6499:/dist/Carp/lib/Carp.pm diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm index 6ed248f..b54ba34 100644 --- a/dist/Carp/lib/Carp.pm +++ b/dist/Carp/lib/Carp.pm @@ -25,27 +25,99 @@ BEGIN { } } +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; @@ -92,6 +164,7 @@ sub _cgc { } sub longmess { + local($!, $^E); # Icky backwards compatibility wrapper. :-( # # The story is that the original implementation hard-coded the @@ -112,6 +185,7 @@ sub longmess { our @CARP_NOT; sub shortmess { + local($!, $^E); my $cgc = _cgc(); # Icky backwards compatibility wrapper. :-( @@ -158,19 +232,27 @@ sub caller_info { 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; @@ -184,11 +266,10 @@ sub caller_info { = "** 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; } @@ -206,14 +287,33 @@ 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) ) { + 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; @@ -221,7 +321,7 @@ sub format_arg { eval {$arg->can('CARP_TRACE') } }) { - $arg = $arg->CARP_TRACE(); + return $arg->CARP_TRACE(); } elsif (!$in_recurse && defined($RefArgFormatter) && @@ -232,34 +332,84 @@ sub format_arg { 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 @@ -337,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, @_ ); } @@ -364,7 +516,7 @@ sub ret_backtrace { eval { CORE::die; }; - if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) { + if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) { $mess .= $1; } } @@ -484,7 +636,8 @@ sub trusts_directly { 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}} } } @@ -526,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()" ); @@ -544,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. @@ -642,7 +802,7 @@ 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 +=item 3. Otherwise, if neither C nor C<$Carp::RefArgFormatter> is available, stringify the value ignoring any overloading. @@ -669,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>. @@ -790,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. @@ -799,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