rpms/perl-Carp
7
0
Fork 0
Code Issues Pull Requests Releases Activity

Replace patched sources with 1.50 CPAN release

Browse Source
This commit is contained in:
Petr Písař 2018-09-10 12:43:15 +02:00
parent 59726b9e5e
commit cea1d7e080
6 changed files with 4 additions and 1019 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -7,3 +7,4 @@
/Carp-1.35.tar.gz
/Carp-1.36.tar.gz
/Carp-1.38.tar.gz
/Carp-1.50.tar.gz

118
Carp-1.38-Upgrade-to-1.40.patch
View File

@ -1,118 +0,0 @@
diff --git a/Changes b/Changes
index b55b49f..dca6a52 100644
--- a/Changes
+++ b/Changes
@@ -1,4 +1,12 @@
+version 1.40; 2016-03-10
+ * Get arg_string.t to compile in perl v5.6
+ * Add information for how to contribute to Carp.
+
+version 1.39; 2016-03-06
+ * bugfix: longmess() should return the error in scalar context
+ (CPANRT#107225)
+
version 1.38; 2015-11-06
* stable release of changes since v1.36
diff --git a/lib/Carp.pm b/lib/Carp.pm
index 9421c74..92f8866 100644
--- a/lib/Carp.pm
+++ b/lib/Carp.pm
@@ -87,7 +87,7 @@ BEGIN {
}
}
-our $VERSION = '1.38';
+our $VERSION = '1.40';
$VERSION =~ tr/_//d;
our $MaxEvalLen = 0;
@@ -445,7 +445,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, @_ );
}
@@ -906,6 +908,12 @@ call die() or warn(), as appropriate.
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.
diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm
index 91a42d1..b05d758 100644
--- a/lib/Carp/Heavy.pm
+++ b/lib/Carp/Heavy.pm
@@ -2,7 +2,7 @@ package Carp::Heavy;
use Carp ();
-our $VERSION = '1.38';
+our $VERSION = '1.40';
$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 a18e3b4..9ecdf88 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 => 65;
+use Test::More tests => 66;
sub runperl {
my(%args) = @_;
@@ -39,6 +39,24 @@ BEGIN {
);
}
+package MyClass;
+
+sub new { return bless +{ field => ['value1', 'SecondVal'] }; }
+
+package main;
+
+{
+ my $err = Carp::longmess(MyClass->new);
+
+ # See:
+ # https://rt.cpan.org/Public/Bug/Display.html?id=107225
+ is_deeply(
+ $err->{field},
+ ['value1', 'SecondVal',],
+ "longmess returns sth meaningful in scalar context when passed a ref.",
+ );
+}
+
{
local $SIG{__WARN__} = sub {
like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+\.$/, 'ok 2\n';
diff --git a/t/arg_string.t b/t/arg_string.t
index 42b43b1..dbd2e6e 100644
--- a/t/arg_string.t
+++ b/t/arg_string.t
@@ -15,7 +15,7 @@ my $e9 = sprintf "%02x", (($] ge 5.007_003)
: ((ord("A") == 193)
? 0x51
: 0xE9));
-my $chr_e9 = chr utf8::unicode_to_native(0xe9);
+my $chr_e9 = chr eval "0x$e9";
my $nl_as_hex = sprintf "%x", ord("\n");
like lm(3), qr/main::lm\(3\)/;

128
Carp-1.40-Upgrade-to-1.42.patch
View File

@ -1,128 +0,0 @@
From 7cdc0cd3cf5f9fd6459daa746db8f647c14ef9fe Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar@redhat.com>
Date: Thu, 11 May 2017 08:43:33 +0200
Subject: [PATCH] Upgrade to 1.42
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Unbundled from perl-5.25.12.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
lib/Carp.pm | 6 +++---
lib/Carp/Heavy.pm | 2 +-
t/Carp.t | 13 ++++++++++++-
t/arg_string.t | 10 +++++++++-
4 files changed, 25 insertions(+), 6 deletions(-)
diff --git a/lib/Carp.pm b/lib/Carp.pm
index 92f8866..05052b9 100644
--- a/lib/Carp.pm
+++ b/lib/Carp.pm
@@ -87,7 +87,7 @@ BEGIN {
}
}
-our $VERSION = '1.40';
+our $VERSION = '1.42';
$VERSION =~ tr/_//d;
our $MaxEvalLen = 0;
@@ -474,7 +474,7 @@ sub ret_backtrace {
eval {
CORE::die;
};
- if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) {
+ if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) {
$mess .= $1;
}
}
@@ -636,7 +636,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()" );
diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm
index b05d758..f9c584a 100644
--- a/lib/Carp/Heavy.pm
+++ b/lib/Carp/Heavy.pm
@@ -2,7 +2,7 @@ package Carp::Heavy;
use Carp ();
-our $VERSION = '1.40';
+our $VERSION = '1.42';
$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 9ecdf88..65daed7 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 => 66;
+use Test::More tests => 67;
sub runperl {
my(%args) = @_;
@@ -442,6 +442,16 @@ $@ =~ s/\n.*//; # just check first line
is $@, "heek at ".__FILE__." line ".(__LINE__-2).", <DATA> line 2.\n",
'last handle line num is mentioned';
+# [cpan #100183]
+{
+ local $/ = \6;
+ <XD::DATA>;
+ eval { croak 'jeek' };
+ $@ =~ s/\n.*//; # just check first line
+ is $@, "jeek at ".__FILE__." line ".(__LINE__-2).", <DATA> chunk 3.\n",
+ 'last handle chunk num is mentioned';
+}
+
SKIP:
{
skip "IPC::Open3::open3 needs porting", 1 if $Is_VMS;
@@ -531,3 +541,4 @@ __DATA__
1
2
3
+abcdefghijklmnopqrstuvwxyz
diff --git a/t/arg_string.t b/t/arg_string.t
index dbd2e6e..dc70f43 100644
--- a/t/arg_string.t
+++ b/t/arg_string.t
@@ -1,6 +1,8 @@
use warnings;
use strict;
+# confirm that stack args are displayed correctly by longmess()
+
use Test::More tests => 32;
use Carp ();
@@ -22,7 +24,13 @@ like lm(3), qr/main::lm\(3\)/;
like lm(substr("3\x{2603}", 0, 1)), qr/main::lm\(3\)/;
like lm(-3), qr/main::lm\(-3\)/;
like lm(-3.5), qr/main::lm\(-3\.5\)/;
-like lm(-3.5e100), qr/main::lm\(-3\.5[eE]\+?100\)/;
+like lm(-3.5e30),
+ qr/main::lm\(
+ (
+ -3500000000000000000000000000000
+ | -3\.5[eE]\+?0?30
+ )
+ \) /x;
like lm(""), qr/main::lm\(""\)/;
like lm("foo"), qr/main::lm\("foo"\)/;
like lm("a\$b\@c\\d\"e"), qr/main::lm\("a\\\$b\\\@c\\\\d\\\"e"\)/;
--
2.9.3

759
Carp-1.42-Upgrade-to-1.50.patch
View File

@ -1,759 +0,0 @@
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

15
perl-Carp.spec
View File

@ -1,18 +1,10 @@
%global cpan_version 1.38
Name: perl-Carp
Version: 1.50
Release: 417%{?dist}
Summary: Alternative warn and die for modules
License: GPL+ or Artistic
URL: https://metacpan.org/release/Carp
Source0: https://cpan.metacpan.org/authors/id/R/RJ/RJBS/Carp-%{cpan_version}.tar.gz
# Unbundled from perl 5.24.0
Patch0: Carp-1.38-Upgrade-to-1.40.patch
# Unbundled from perl 5.25.12
Patch1: Carp-1.40-Upgrade-to-1.42.patch
# Unbundled from perl 5.28.0
Patch2: Carp-1.42-Upgrade-to-1.50.patch
Source0: https://cpan.metacpan.org/authors/id/X/XS/XSAWYERX/Carp-%{version}.tar.gz
BuildArch: noarch
BuildRequires: make
BuildRequires: perl-generators
@ -45,10 +37,7 @@ module was called. There is no guarantee that that is where the error was,
but it is a good educated guess.
%prep
%setup -q -n Carp-%{cpan_version}
%patch0 -p1
%patch1 -p1
%patch2 -p1
%setup -q -n Carp-%{version}
%build
perl Makefile.PL INSTALLDIRS=vendor NO_PACKLIST=1

2
sources
View File

@ -1 +1 @@
93ac4c56312a9db6cef3b502a8169859 Carp-1.38.tar.gz
SHA512 (Carp-1.50.tar.gz) = 624e5fe41492d1d5de840d56a648168f2e6066717efaa20d257b277219ea2cd3b73e5bc2bd46a3e37e060cb3e35b4cccc560bdd169c2e252e861d441e90df4b6