In perl.git, the branch blead has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/4efd247d4c712a390e5c79db522ef527f439ad6b?hp=cb3fd6ac9362413a80d297fb7708846bd904102b>
- Log -----------------------------------------------------------------
commit 4efd247d4c712a390e5c79db522ef527f439ad6b
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Feb 25 18:19:54 2018 -0800
[perl #132910] Carp: Avoid ->can
If a module has its own ‘can’ (or even UNIVERSAL::can) implementation,
it may impede Carp’s use of ->can to detect overloading. Instead,
use UNIVERSAL::can directly, or, in the presence of an override,
use overload::mycan. Don’t use overload::Overloaded, since old
versions of overload call ->can.
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 2 ++
dist/Carp/lib/Carp.pm | 50 +++++++++++++++++++++++++------------------
dist/Carp/t/broken_can.t | 15 +++++++++++++
dist/Carp/t/broken_univ_can.t | 24 +++++++++++++++++++++
4 files changed, 70 insertions(+), 21 deletions(-)
create mode 100644 dist/Carp/t/broken_can.t
create mode 100644 dist/Carp/t/broken_univ_can.t
diff --git a/MANIFEST b/MANIFEST
index 4794817c5f..acc1bcba7f 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2966,6 +2966,8 @@ dist/Carp/t/arg_regexp.t See if Carp formats
regexp args OK in stack traces
dist/Carp/t/arg_string.t See if Carp formats string args OK in
stack traces
dist/Carp/t/baduni.t See if Carp handles non-char Unicode
dist/Carp/t/baduni_warnings.t See if Carp handles non-char Unicode
when loaded via warnings.pm
+dist/Carp/t/broken_can.t Test Carp with bad can implementations
+dist/Carp/t/broken_univ_can.t Test Carp with bad UNIVERSAL::can
dist/Carp/t/Carp.t See if Carp works
dist/Carp/t/Carp_overload.t See if Carp handles overloads
dist/Carp/t/Carp_overloadless.t See if Carp handles overloads
that dont use overload.pm
diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm
index 1aa16c9d24..d5443ba676 100644
--- a/dist/Carp/lib/Carp.pm
+++ b/dist/Carp/lib/Carp.pm
@@ -116,6 +116,29 @@ BEGIN {
;
}
+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}};
+ }
+ }
+ }
+}
+
+# _mycan is either UNIVERSAL::can, or, in the presence of an override,
+# overload::mycan.
+BEGIN {
+ *_mycan = _univ_mod_loaded('can')
+ ? do { require "overload.pm"; _fetch_sub overload => 'mycan' }
+ : \&UNIVERSAL::can
+}
+
+
our $VERSION = '1.49';
$VERSION =~ tr/_//d;
@@ -298,20 +321,6 @@ 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 {
@@ -321,7 +330,9 @@ sub format_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");
+ my $isa = _univ_mod_loaded('isa')
+ ? sub { 1 }
+ : _fetch_sub(UNIVERSAL => "isa");
# legitimate, let's not leak it.
if (!$in_recurse && $isa->( $arg, 'UNIVERSAL' ) &&
@@ -347,13 +358,10 @@ sub format_arg {
}
else
{
- # overload uses the presence of a special "method" name "((" to
signal
+ # overload 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.
- # In theory we should be able to use 'can' without the $in_recurse
guard,
- # but this breaks modules that call overloads or croak during
can(), for
- # instance Class::Std v0.013, so if we end up here twice, we will
just
- # load overload outright.
- if ($in_recurse || do{ local $in_recurse = 1; $pack->can("((") ||
$pack->can("()") }) {
+ if (_mycan($pack, "((") || _mycan($pack, "()")) {
# Argument is blessed into a class with overloading, and
# so might have an overloaded stringification. We don't
# want to risk getting the overloaded stringification,
diff --git a/dist/Carp/t/broken_can.t b/dist/Carp/t/broken_can.t
new file mode 100644
index 0000000000..c32fa1909d
--- /dev/null
+++ b/dist/Carp/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/dist/Carp/t/broken_univ_can.t b/dist/Carp/t/broken_univ_can.t
new file mode 100644
index 0000000000..0ec19d7aa3
--- /dev/null
+++ b/dist/Carp/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";
+}
--
Perl5 Master Repository
