From 243826fff8700a7d99f3615334fdffaaf89feef4 Mon Sep 17 00:00:00 2001 From: Jitka Plesnikova Date: Wed, 23 May 2018 14:15:47 +0200 Subject: [PATCH] Upgrade to 1.50 --- Changes | 48 ++++++++++ lib/Carp.pm | 237 +++++++++++++++++++++++++++++++++++++++----------- lib/Carp/Heavy.pm | 2 +- t/Carp.t | 13 ++- t/Carp_overloadless.t | 15 ++++ t/arg_regexp.t | 41 +++------ t/arg_string.t | 9 +- t/broken_can.t | 15 ++++ t/broken_univ_can.t | 24 +++++ t/stack_after_err.t | 69 +++++++++++++++ t/vivify_stash.t | 12 +-- 11 files changed, 397 insertions(+), 88 deletions(-) create mode 100644 t/Carp_overloadless.t create mode 100644 t/broken_can.t create mode 100644 t/broken_univ_can.t create mode 100644 t/stack_after_err.t diff --git a/Changes b/Changes index dca6a52..2b549d9 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,51 @@ +version 1.49 + + * comment only change, document the change from 1.47 better + and create a commit in blead-perl which can be used to + reference this issue from the bug report. + +version 1.48 + + * guard against hand-rolled UNIVERSAL::can() implementations + which throw exceptions when we call $obj->can("(("). + +version 1.47, 1.47_02 + + * Deal with overloading when overload.pm is not use + + * Note 1.47_02 only existed for one commit in blead-perl, + and in fact no 1.47 should ever see the wild. + +version 1.47, 1.47_01 + + * Do not die on trappable stack-not-refcounted bugs while + serializing the stack. + + * Note 1.47_01 only existed for one commit in blead-perl, + and in fact no 1.47 should ever see the wild. + +version 1.46 + + * avoid vivifying UNIVERSAL::isa:: in Carp + +version 1.45 + + * Optimize format_arg when arguments contain many references + +version 1.43 + + * fix problems introduced by the partial EBCDIC support from version + 1.35 + +version 1.42 + + * add some doc clue about what cluck does + + * avoid floating point overflow in test + +version 1.41 + + * add missing " chunk #" phrase to messages version 1.40; 2016-03-10 * Get arg_string.t to compile in perl v5.6 diff --git a/lib/Carp.pm b/lib/Carp.pm index 05052b9..109b7fe 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -87,7 +87,131 @@ BEGIN { } } -our $VERSION = '1.42'; +# 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); + } + ; +} + +sub _univ_mod_loaded { + return 0 unless exists($::{"UNIVERSAL::"}); + for ($::{"UNIVERSAL::"}) { + return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"$_[0]::"}; + for ($$_{"$_[0]::"}) { + return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"VERSION"}; + for ($$_{"VERSION"}) { + return 0 unless ref \$_ eq "GLOB"; + return ${*$_{SCALAR}}; + } + } + } +} + +# _maybe_isa() is usually the UNIVERSAL::isa function. We have to avoid +# the latter if the UNIVERSAL::isa module has been loaded, to avoid infi- +# nite recursion; in that case _maybe_isa simply returns true. +my $isa; +BEGIN { + if (_univ_mod_loaded('isa')) { + *_maybe_isa = sub { 1 } + } + else { + # Since we have already done the check, record $isa for use below + # when defining _StrVal. + *_maybe_isa = $isa = _fetch_sub(UNIVERSAL => "isa"); + } +} + + +# We need an overload::StrVal or equivalent function, but we must avoid +# loading any modules on demand, as Carp is used from __DIE__ handlers and +# may be invoked after a syntax error. +# We can copy recent implementations of overload::StrVal and use +# overloading.pm, which is the fastest implementation, so long as +# overloading is available. If it is not available, we use our own pure- +# Perl StrVal. We never actually use overload::StrVal, for various rea- +# sons described below. +# overload versions are as follows: +# undef-1.00 (up to perl 5.8.0) uses bless (avoid!) +# 1.01-1.17 (perl 5.8.1 to 5.14) uses Scalar::Util +# 1.18+ (perl 5.16+) uses overloading +# The ancient 'bless' implementation (that inspires our pure-Perl version) +# blesses unblessed references and must be avoided. Those using +# Scalar::Util use refaddr, possibly the pure-Perl implementation, which +# has the same blessing bug, and must be avoided. Also, Scalar::Util is +# loaded on demand. Since we avoid the Scalar::Util implementations, we +# end up having to implement our own overloading.pm-based version for perl +# 5.10.1 to 5.14. Since it also works just as well in more recent ver- +# sions, we use it there, too. +BEGIN { + if (eval { require "overloading.pm" }) { + *_StrVal = eval 'sub { no overloading; "$_[0]" }' + } + else { + # Work around the UNIVERSAL::can/isa modules to avoid recursion. + + # _mycan is either UNIVERSAL::can, or, in the presence of an + # override, overload::mycan. + *_mycan = _univ_mod_loaded('can') + ? do { require "overload.pm"; _fetch_sub overload => 'mycan' } + : \&UNIVERSAL::can; + + # _blessed is either UNIVERAL::isa(...), or, in the presence of an + # override, a hideous, but fairly reliable, workaround. + *_blessed = $isa + ? sub { &$isa($_[0], "UNIVERSAL") } + : sub { + my $probe = "UNIVERSAL::Carp_probe_" . rand; + no strict 'refs'; + local *$probe = sub { "unlikely string" }; + local $@; + local $SIG{__DIE__} = sub{}; + (eval { $_[0]->$probe } || '') eq 'unlikely string' + }; + + *_StrVal = sub { + my $pack = ref $_[0]; + # Perl's overload mechanism uses the presence of a special + # "method" named "((" or "()" to signal it is in effect. + # This test seeks to see if it has been set up. "((" post- + # dates overloading.pm, so we can skip it. + return "$_[0]" unless _mycan($pack, "()"); + # Even at this point, the invocant may not be blessed, so + # check for that. + return "$_[0]" if not _blessed($_[0]); + bless $_[0], "Carp"; + my $str = "$_[0]"; + bless $_[0], $pack; + $pack . substr $str, index $str, "="; + } + } +} + + +our $VERSION = '1.50'; $VERSION =~ tr/_//d; our $MaxEvalLen = 0; @@ -203,11 +327,33 @@ 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 + # NOTE this is NOT a complete solution, we cannot 100% guard against + # these bugs. However in many cases Perl *is* capable of detecting + # them and throws an error when it does. Unfortunately serializing + # the arguments on the stack is a perfect way of finding these bugs, + # even when they would not affect normal program flow that did not + # poke around inside the stack. Inside of Carp.pm it makes little + # sense reporting these bugs, as Carp's job is to report the callers + # errors, not the ones it might happen to tickle while doing so. + # See: https://rt.perl.org/Public/Bug/Display.html?id=131046 + # and: https://rt.perl.org/Public/Bug/Display.html?id=52610 + # for more details and discussion. - Yves + 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 ''; @@ -226,7 +372,6 @@ 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? @@ -253,9 +398,10 @@ our $in_recurse; sub format_arg { my $arg = shift; - if ( ref($arg) ) { + if ( my $pack= ref($arg) ) { + # legitimate, let's not leak it. - if (!$in_recurse && + if (!$in_recurse && _maybe_isa( $arg, 'UNIVERSAL' ) && do { local $@; local $in_recurse = 1; @@ -278,8 +424,11 @@ sub format_arg { } else { - my $sub = _fetch_sub(overload => 'StrVal'); - return $sub ? &$sub($arg) : "$arg"; + # Argument may be blessed into a class with overloading, and so + # might have an overloaded stringification. We don't want to + # risk getting the overloaded stringification, so we need to + # use _StrVal, our overload::StrVal()-equivalent. + return _StrVal $arg; } } return "undef" if !defined($arg); @@ -300,32 +449,15 @@ sub format_arg { next; } my $o = ord($c); - - # This code is repeated in Regexp::CARP_TRACE() - if ($] ge 5.007_003) { - substr $arg, $i, 1, sprintf("\\x{%x}", $o) - if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20) - || utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e); - } elsif (ord("A") == 65) { - substr $arg, $i, 1, sprintf("\\x{%x}", $o) - if $o < 0x20 || $o > 0x7e; - } else { # 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. - substr $arg, $i, 1, sprintf("\\x{%x}", $o) - if $o < ord(" ") || ((ord ("^") == 106) - ? $o == 0x5f - : $o == 0xff); - } + 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; + $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg; } downgrade($arg, 1); return "\"".$arg."\"".$suffix; @@ -338,25 +470,12 @@ sub Regexp::CARP_TRACE { 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} - - # This code is repeated in format_arg() - if ($] ge 5.007_003) { - substr $arg, $i, 1, sprintf("\\x{%x}", $o) - if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20) - || utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e); - } elsif (ord("A") == 65) { - substr $arg, $i, 1, sprintf("\\x{%x}", $o) - if $o < 0x20 || $o > 0x7e; - } else { # Early EBCDIC - substr $arg, $i, 1, sprintf("\\x{%x}", $o) - if $o < ord(" ") || ((ord ("^") == 106) - ? $o == 0x5f - : $o == 0xff); - } + 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; + $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg; } downgrade($arg, 1); my $suffix = ""; @@ -452,6 +571,15 @@ sub longmess_heavy { return ret_backtrace( $i, @_ ); } +BEGIN { + if("$]" >= 5.017004) { + # The LAST_FH constant is a reference to the variable. + $Carp::{LAST_FH} = \eval '\${^LAST_FH}'; + } else { + eval '*LAST_FH = sub () { 0 }'; + } +} + # Returns a full stack backtrace starting from where it is # told. sub ret_backtrace { @@ -468,7 +596,16 @@ sub ret_backtrace { my %i = caller_info($i); $mess = "$err at $i{file} line $i{line}$tid_msg"; - if( defined $. ) { + if( $. ) { + # Use ${^LAST_FH} if available. + if (LAST_FH) { + if (${+LAST_FH}) { + $mess .= sprintf ", <%s> %s %d", + *${+LAST_FH}{NAME}, + ($/ eq "\n" ? "line" : "chunk"), $. + } + } + else { local $@ = ''; local $SIG{__DIE__}; eval { @@ -477,6 +614,7 @@ sub ret_backtrace { if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) { $mess .= $1; } + } } $mess .= "\.\n"; @@ -594,7 +732,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}} } } diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm index f9c584a..a9b803c 100644 --- a/lib/Carp/Heavy.pm +++ b/lib/Carp/Heavy.pm @@ -2,7 +2,7 @@ package Carp::Heavy; use Carp (); -our $VERSION = '1.42'; +our $VERSION = '1.50'; $VERSION =~ tr/_//d; # Carp::Heavy was merged into Carp in version 1.12. Any mismatched versions diff --git a/t/Carp.t b/t/Carp.t index 65daed7..b1e399d 100644 --- a/t/Carp.t +++ b/t/Carp.t @@ -3,7 +3,7 @@ no warnings "once"; use Config; use IPC::Open3 1.0103 qw(open3); -use Test::More tests => 67; +use Test::More tests => 68; sub runperl { my(%args) = @_; @@ -488,6 +488,17 @@ SKIP: ); } +{ + package Mpar; + sub f { Carp::croak "tun syn" } + + package Phou; + $Phou::{ISA} = \42; + eval { Mpar::f }; +} +like $@, qr/tun syn/, 'Carp can handle non-glob ISA stash elems'; + + # New tests go here # line 1 "XA" diff --git a/t/Carp_overloadless.t b/t/Carp_overloadless.t new file mode 100644 index 0000000..f4bda04 --- /dev/null +++ b/t/Carp_overloadless.t @@ -0,0 +1,15 @@ +use warnings; +#no warnings 'once'; +use Test::More tests => 1; + +use Carp; + +# test that enabling overload without loading overload.pm does not trigger infinite recursion + +my $p = "OverloadedInXS"; +*{$p."::(("} = sub{}; +*{$p.q!::(""!} = sub { Carp::cluck "" }; +sub { Carp::longmess("longmess:") }->(bless {}, $p); +ok(1); + + diff --git a/t/arg_regexp.t b/t/arg_regexp.t index 1575b29..83e8f03 100644 --- a/t/arg_regexp.t +++ b/t/arg_regexp.t @@ -1,6 +1,8 @@ use warnings; use strict; +# confirm that regexp-typed stack args are displayed correctly by longmess() + use Test::More tests => 42; use Carp (); @@ -16,12 +18,14 @@ my $e9 = sprintf "%02x", (($] ge 5.007_003) : ((ord("A") == 193) ? 0x51 : 0xE9)); -my $chr_e9 = chr eval "0x$e9"; +my $xe9 = "\\x$e9"; +my $chr_e9 = eval "\"$xe9\""; my $nl_as_hex = sprintf "%x", ord("\n"); # On Perl 5.6 we accept some incorrect quoting of Unicode characters, # because upgradedness of regexps isn't preserved by stringification, # so it's impossible to implement the correct behaviour. +# FIXME: the permissive patterns don't account for EBCDIC my $xe9_rx = "$]" < 5.008 ? qr/\\x\{c3\}\\x\{a9\}|\\x\{e9\}/ : qr/\\x\{$e9\}/; my $x666_rx = "$]" < 5.008 ? qr/\\x\{d9\}\\x\{a6\}|\\x\{666\}/ : qr/\\x\{666\}/; my $x2603_rx = "$]" < 5.008 ? qr/\\x\{e2\}\\x\{98\}\\x\{83\}|\\x\{2603\}/ : qr/\\x\{2603\}/; @@ -41,16 +45,10 @@ like lm(qr/\x{666}b/), qr/main::lm\(qr\(\\x\{666\}b\)u?\)/; like lm(rx("\x{666}b")), qr/main::lm\(qr\(${x666_rx}b\)u?\)/; like lm(qr/a\x{666}/), qr/main::lm\(qr\(a\\x\{666\}\)u?\)/; like lm(rx("a\x{666}")), qr/main::lm\(qr\(a${x666_rx}\)u?\)/; -like lm(qr/L${chr_e9}on/), qr/main::lm\(qr\(L\\x\{?${e9}\}?on\)u?\)/; +like lm(qr/L${xe9}on/), qr/main::lm\(qr\(L\\x${e9}on\)u?\)/; like lm(rx("L${chr_e9}on")), qr/main::lm\(qr\(L${xe9_rx}on\)u?\)/; - - -SKIP: { - skip "wide-character-related bug in pre-5.18 perls", 2 if $] lt 5.017_001; - - like lm(qr/L${chr_e9}on \x{2603} !/), qr/main::lm\(qr\(L\\x\{?${e9}\}?on \\x\{2603\} !\)u?\)/; - like lm(rx("L${chr_e9}on \x{2603} !")), qr/main::lm\(qr\(L${xe9_rx}on ${x2603_rx} !\)u?\)/; -} +like lm(qr/L${xe9}on \x{2603} !/), qr/main::lm\(qr\(L\\x${e9}on \\x\{2603\} !\)u?\)/; +like lm(rx("L${chr_e9}on \x{2603} !")), qr/main::lm\(qr\(L${xe9_rx}on ${x2603_rx} !\)u?\)/; $Carp::MaxArgLen = 5; foreach my $arg ("foo bar baz", "foo bar ba", "foo bar b", "foo bar ", "foo bar", "foo ba") { @@ -60,16 +58,10 @@ foreach my $arg ("foo b", "foo ", "foo", "fo", "f", "") { like lm(rx($arg)), qr/main::lm\(qr\(\Q$arg\E\)u?\)/; } like lm(qr/foo.bar$/sm), qr/main::lm\(qr\(fo\)\.\.\.u?ms\)/; - -SKIP: { - skip "wide-character-related bug in pre-5.18 perls", 4 if $] lt 5.017_001; - - like lm(qr/L${chr_e9}on \x{2603} !/), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; - like lm(rx("L${chr_e9}on \x{2603} !")), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; - like lm(qr/L${chr_e9}on\x{2603}/), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; - like lm(rx("L${chr_e9}on\x{2603}")), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; -} - +like lm(qr/L${xe9}on \x{2603} !/), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; +like lm(rx("L${chr_e9}on \x{2603} !")), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; +like lm(qr/L${xe9}on\x{2603}/), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; +like lm(rx("L${chr_e9}on\x{2603}")), qr/main::lm\(qr\(L\\\)\.\.\.u?\)/; like lm(qr/foo\x{2603}/), qr/main::lm\(qr\(fo\)\.\.\.u?\)/; like lm(rx("foo\x{2603}")), qr/main::lm\(qr\(fo\)\.\.\.u?\)/; @@ -77,12 +69,7 @@ $Carp::MaxArgLen = 0; foreach my $arg ("wibble:" x 20, "foo bar baz") { like lm(rx($arg)), qr/main::lm\(qr\(\Q$arg\E\)u?\)/; } - -SKIP: { - skip "wide-character-related bug in pre-5.18 perls", 2 if $] lt 5.017_001; - - like lm(qr/L${chr_e9}on\x{2603}/), qr/main::lm\(qr\(L\\x\{?${e9}\}?on\\x\{2603\}\)u?\)/; - like lm(rx("L${chr_e9}on\x{2603}")), qr/main::lm\(qr\(L${xe9_rx}on${x2603_rx}\)u?\)/; -} +like lm(qr/L${xe9}on\x{2603}/), qr/main::lm\(qr\(L\\x${e9}on\\x\{2603\}\)u?\)/; +like lm(rx("L${chr_e9}on\x{2603}")), qr/main::lm\(qr\(L${xe9_rx}on${x2603_rx}\)u?\)/; 1; diff --git a/t/arg_string.t b/t/arg_string.t index dc70f43..544a4fe 100644 --- a/t/arg_string.t +++ b/t/arg_string.t @@ -1,9 +1,9 @@ use warnings; use strict; -# confirm that stack args are displayed correctly by longmess() +# confirm that string-typed stack args are displayed correctly by longmess() -use Test::More tests => 32; +use Test::More tests => 33; use Carp (); @@ -17,7 +17,8 @@ my $e9 = sprintf "%02x", (($] ge 5.007_003) : ((ord("A") == 193) ? 0x51 : 0xE9)); -my $chr_e9 = chr eval "0x$e9"; +my $xe9 = "\\x$e9"; +my $chr_e9 = eval "\"$xe9\""; my $nl_as_hex = sprintf "%x", ord("\n"); like lm(3), qr/main::lm\(3\)/; @@ -33,9 +34,9 @@ like lm(-3.5e30), \) /x; like lm(""), qr/main::lm\(""\)/; like lm("foo"), qr/main::lm\("foo"\)/; +like lm("a&b"), qr/main::lm\("a&b"\)/; like lm("a\$b\@c\\d\"e"), qr/main::lm\("a\\\$b\\\@c\\\\d\\\"e"\)/; like lm("a\nb"), qr/main::lm\("a\\x\{$nl_as_hex\}b"\)/; - like lm("a\x{666}b"), qr/main::lm\("a\\x\{666\}b"\)/; like lm("\x{666}b"), qr/main::lm\("\\x\{666\}b"\)/; like lm("a\x{666}"), qr/main::lm\("a\\x\{666\}"\)/; diff --git a/t/broken_can.t b/t/broken_can.t new file mode 100644 index 0000000..c32fa19 --- /dev/null +++ b/t/broken_can.t @@ -0,0 +1,15 @@ +use Test::More tests => 1; + +# [perl #132910] + +package Foo; +sub can { die } + +package main; + +use Carp; + +eval { + sub { confess-sins }->(bless[], Foo); +}; +like $@, qr/^-sins at /; diff --git a/t/broken_univ_can.t b/t/broken_univ_can.t new file mode 100644 index 0000000..0ec19d7 --- /dev/null +++ b/t/broken_univ_can.t @@ -0,0 +1,24 @@ +# [perl #132910] +# This mock-up breaks Test::More. Don’t use Test::More. + +sub UNIVERSAL::can { die; } + +# Carp depends on this to detect the override: +BEGIN { $UNIVERSAL::can::VERSION = 0xbaff1ed_bee; } + +use Carp; + +eval { + sub { confess-sins }->(bless[], Foo); +}; +print "1..1\n"; +if ($@ !~ qr/^-sins at /) { + print "not ok 1\n"; + print "# Expected -sins at blah blah blah...\n"; + print "# Instead, we got:\n"; + $@ =~ s/^/# /mg; + print $@; +} +else { + print "ok 1\n"; +} diff --git a/t/stack_after_err.t b/t/stack_after_err.t new file mode 100644 index 0000000..57dbc23 --- /dev/null +++ b/t/stack_after_err.t @@ -0,0 +1,69 @@ +use strict; +use warnings; +use Config; +use IPC::Open3 1.0103 qw(open3); + +BEGIN { + if ($^O eq 'VMS') { + print "1..0 # IPC::Open3 needs porting\n"; + exit; + } +} + +my @tests=( + # Make sure we don’t try to load modules on demand in the presence of over- + # loaded args. If there has been a syntax error, they won’t load. + [ 'Carp does not try to load modules on demand for overloaded args', + "", qr/Looks lark.*o=ARRAY.* CODE/s, + ], + # Run the test also in the presence of + # a) A UNIVERSAL::can module + # b) A UNIVERSAL::isa module + # c) Both + # since they follow slightly different code paths on old pre-5.10.1 perls. + [ 'StrVal fallback in the presence of UNIVERSAL::isa', + 'BEGIN { $UNIVERSAL::isa::VERSION = 1 }', + qr/Looks lark.*o=ARRAY.* CODE/s, + ], + [ 'StrVal fallback in the presence of UNIVERSAL::can', + 'BEGIN { $UNIVERSAL::can::VERSION = 1 }', + qr/Looks lark.*o=ARRAY.* CODE/s, + ], + [ 'StrVal fallback in the presence of UNIVERSAL::can/isa', + 'BEGIN { $UNIVERSAL::can::VERSION = $UNIVERSAL::isa::VERSION = 1 }', + qr/Looks lark.*o=ARRAY.* CODE/s, + ], +); + +my ($test_num)= @ARGV; +if (!$test_num) { + eval sprintf "use Test::More tests => %d; 1", 0+@tests + or die "Failed to use Test::More: $@"; + local $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC); + foreach my $i (1 .. @tests) { + my($w, $r); + my $pid = open3($w, $r, undef, $^X, $0, $i); + close $w; + my $output = do{ local $/; <$r> }; + waitpid($pid, 0); + like($output, $tests[$i-1][2], $tests[$i-1][0]); + } +} else { + eval $tests[$test_num-1][1] . <<'END_OF_TEST_CODE' + no strict; + no warnings; + use Carp; + sub foom { + Carp::confess("Looks lark we got a error: $_[0]") + } + BEGIN { + *{"o::()"} = sub {}; + *{'o::(""'} = sub {"hay"}; + $o::OVERLOAD{dummy}++; # perls before 5.18 need this + *{"CODE::()"} = sub {}; + $SIG{__DIE__} = sub { foom (@_, bless([], o), sub {}) } + } + $a + +END_OF_TEST_CODE + or die $@; +} diff --git a/t/vivify_stash.t b/t/vivify_stash.t index 0ac66d8..744d0d2 100644 --- a/t/vivify_stash.t +++ b/t/vivify_stash.t @@ -1,25 +1,25 @@ BEGIN { print "1..5\n"; } our $has_utf8; BEGIN { $has_utf8 = exists($::{"utf8::"}); } -our $has_overload; BEGIN { $has_overload = exists($::{"overload::"}); } our $has_B; BEGIN { $has_B = exists($::{"B::"}); } +our $has_UNIVERSAL_isa; BEGIN { $has_UNIVERSAL_isa = exists($UNIVERSAL::{"isa::"}); } use Carp; sub { sub { Carp::longmess("x") }->() }->(\1, "\x{2603}", qr/\x{2603}/); -print !(exists($::{"utf8::"}) xor $has_utf8) ? "" : "not ", "ok 1\n"; -print !(exists($::{"overload::"}) xor $has_overload) ? "" : "not ", "ok 2\n"; -print !(exists($::{"B::"}) xor $has_B) ? "" : "not ", "ok 3\n"; +print !(exists($::{"utf8::"}) xor $has_utf8) ? "" : "not ", "ok 1 # used utf8\n"; +print !(exists($::{"B::"}) xor $has_B) ? "" : "not ", "ok 2 # used B\n"; +print !(exists($UNIVERSAL::{"isa::"}) xor $has_UNIVERSAL_isa) ? "" : "not ", "ok 3 # used UNIVERSAL::isa\n"; # Autovivify $::{"overload::"} () = \$::{"overload::"}; () = \$::{"utf8::"}; eval { sub { Carp::longmess() }->(\1) }; -print $@ eq '' ? "ok 4\n" : "not ok 4\n# $@"; +print $@ eq '' ? "ok 4 # longmess check1\n" : "not ok 4 # longmess check1\n# $@"; # overload:: glob without hash undef *{"overload::"}; eval { sub { Carp::longmess() }->(\1) }; -print $@ eq '' ? "ok 5\n" : "not ok 5\n# $@"; +print $@ eq '' ? "ok 5 # longmess check2\n" : "not ok 5 # longmess check2\n# $@"; 1; -- 2.14.3