rpms
/
perl-Carp
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
perl-Carp/Carp-1.42-Upgrade-to-1.50.p...

760 lines
26 KiB
Diff
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

From 243826fff8700a7d99f3615334fdffaaf89feef4 Mon Sep 17 00:00:00 2001
From: Jitka Plesnikova <jplesnik@redhat.com>
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 "<FH> 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 "<My Stringify>" };
+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
Reference in New Issue View Git Blame Copy Permalink