In perl.git, the branch blead has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/a0da1e165c011c775b9f39a37ab6d3dd6a1c0969?hp=f88ca576baabd4517ec5766efa11b1e1fc8109af>
- Log -----------------------------------------------------------------
commit a0da1e165c011c775b9f39a37ab6d3dd6a1c0969
Author: Father Chrysostomos <spr...@cpan.org>
Date: Mon Feb 26 09:23:28 2018 -0800
warnings.pm: _at_level functions and chunky handles
The _at_level functions, which have to bypass Carp, were not
reporting non-line-based filehandles correctly. The perl core
does:
..., <fh> chunk 7.
if $/ is not "\n". warnings.pm should do the same. It was using
‘line’.
commit 5c8d1071aaf72214e66b1a224890384ab6ca5153
Author: Father Chrysostomos <spr...@cpan.org>
Date: Mon Feb 26 01:23:53 2018 -0800
Carp: Avoid run-time mods; StrVal workarounds
Carp needs to avoid loading modules while reporting errors, because
it may be invoked via $SIG{__DIE__} after a syntax error, when BEGIN
blocks are forbidden.
Before this commit (as of v5.27.8-360-gc99363a) it was doing just that
for reference arguments within stack traces.
That means we either need to load overload.pm at start-up so that
overload::StrVal is already available, or avoid overload::StrVal
altogether.
It turns out that various versions of overload::StrVal have
their own problems that prevent Carp from using them (out-
lined in the comments added to Carp.pm and also described at
<https://rt.perl.org/Ticket/Display.html?id=132902#txn-1535564>).
So we now follow two approaches: If overloading.pm is available, use
that; otherwise, use a hideous workaround inspired by ancient imple-
entations of overload::StrVal and Scalar::Util::blessed, while avoid-
ing the bugs in those old versions.
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
dist/Carp/lib/Carp.pm | 91 ++++++++++++++++++++++++++++++++-----------
dist/Carp/t/stack_after_err.t | 73 ++++++++++++++++++++++++++++++++++
dist/Carp/t/vivify_stash.t | 12 +++---
lib/warnings.pm | 5 ++-
regen/warnings.pl | 5 ++-
t/lib/warnings/9enabled | 19 +++++++++
7 files changed, 175 insertions(+), 31 deletions(-)
create mode 100644 dist/Carp/t/stack_after_err.t
diff --git a/MANIFEST b/MANIFEST
index acc1bcba7f..b054110b65 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2975,6 +2975,7 @@ dist/Carp/t/errno.t See if Carp preserves
$! and $^E
dist/Carp/t/heavy.t See if Carp::Heavy works
dist/Carp/t/heavy_mismatch.t See if Carp::Heavy catches version
mismatch
dist/Carp/t/rt52610_crash.t Test that we can gracefully handle
serializing the stack with stack-refcounting bugs
+dist/Carp/t/stack_after_err.t Test stack traces after syntax errors
dist/Carp/t/stash_deletion.t See if Carp handles stash deletion
dist/Carp/t/swash.t See if Carp avoids breaking swash loading
dist/Carp/t/vivify_gv.t See if Carp leaves utf8:: stuff alone
diff --git a/dist/Carp/lib/Carp.pm b/dist/Carp/lib/Carp.pm
index d5443ba676..10509d4339 100644
--- a/dist/Carp/lib/Carp.pm
+++ b/dist/Carp/lib/Carp.pm
@@ -130,12 +130,71 @@ sub _univ_mod_loaded {
}
}
-# _mycan is either UNIVERSAL::can, or, in the presence of an override,
-# overload::mycan.
+# 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 {
- *_mycan = _univ_mod_loaded('can')
- ? do { require "overload.pm"; _fetch_sub overload => 'mycan' }
- : \&UNIVERSAL::can
+ 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 = _univ_mod_loaded('isa')
+ ? 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'
+ }
+ : do {
+ my $isa = _fetch_sub(qw/UNIVERSAL isa/);
+ sub { &$isa($_[0], "UNIVERSAL") }
+ };
+
+ *_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, "=";
+ }
+ }
}
@@ -358,23 +417,11 @@ sub format_arg {
}
else
{
- # 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.
- 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,
- # so we need to use overload::StrVal() below. But it's
- # possible that the overload module hasn't been loaded:
- # overload methods can be installed without it. So load
- # the module here. The bareword form of require is here
- # eschewed to avoid this compile-time effect of vivifying
- # the target module's stash.
- require "overload.pm";
- }
- 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);
diff --git a/dist/Carp/t/stack_after_err.t b/dist/Carp/t/stack_after_err.t
new file mode 100644
index 0000000000..8bf5be965a
--- /dev/null
+++ b/dist/Carp/t/stack_after_err.t
@@ -0,0 +1,73 @@
+use Config;
+use IPC::Open3 1.0103 qw(open3);
+use Test::More tests => 4;
+
+sub runperl {
+ my(%args) = @_;
+ my($w, $r);
+
+ local $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC);
+
+ my $pid = open3($w, $r, undef, $^X, "-e", $args{prog});
+ close $w;
+ my $output = "";
+ while(<$r>) { $output .= $_; }
+ waitpid($pid, 0);
+ return $output;
+}
+
+
+# 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.
+like(
+ runperl(
+ prog => q<
+ 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 +
+ >,
+ ),
+ qr 'Looks lark.*o=ARRAY.* CODE's,
+ 'Carp does not try to load modules on demand for overloaded args',
+);
+
+# 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.
+my $prog = q<
+ 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 +
+>;
+for (
+ ["UNIVERSAL::isa", 'BEGIN { $UNIVERSAL::isa::VERSION = 1 }'],
+ ["UNIVERSAL::can", 'BEGIN { $UNIVERSAL::can::VERSION = 1 }'],
+ ["UNIVERSAL::can/isa", 'BEGIN { $UNIVERSAL::can::VERSION =
+ $UNIVERSAL::isa::VERSION = 1 }'],
+) {
+ my ($tn, $preamble) = @$_;
+ like(runperl( prog => "$preamble$prog" ),
+ qr 'Looks lark.*o=ARRAY.* CODE's,
+ "StrVal fallback in the presence of $tn",
+ )
+}
diff --git a/dist/Carp/t/vivify_stash.t b/dist/Carp/t/vivify_stash.t
index 46e0b637e9..744d0d2584 100644
--- a/dist/Carp/t/vivify_stash.t
+++ b/dist/Carp/t/vivify_stash.t
@@ -1,7 +1,6 @@
-BEGIN { print "1..6\n"; }
+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::"}); }
@@ -9,19 +8,18 @@ use Carp;
sub { sub { Carp::longmess("x") }->() }->(\1, "\x{2603}", qr/\x{2603}/);
print !(exists($::{"utf8::"}) xor $has_utf8) ? "" : "not ", "ok 1 # used
utf8\n";
-print !(exists($::{"overload::"}) xor $has_overload) ? "" : "not ", "ok 2 #
used overload\n";
-print !(exists($::{"B::"}) xor $has_B) ? "" : "not ", "ok 3 # used B\n";
-print !(exists($UNIVERSAL::{"isa::"}) xor $has_UNIVERSAL_isa) ? "" : "not ",
"ok 4 # used UNIVERSAL::isa\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 5 # longmess check1\n" : "not ok 5 # longmess check1\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 6 # longmess check2\n" : "not ok 6 # longmess check2\n#
$@";
+print $@ eq '' ? "ok 5 # longmess check2\n" : "not ok 5 # longmess check2\n#
$@";
1;
diff --git a/lib/warnings.pm b/lib/warnings.pm
index f0e2a7fcdd..af23f909b7 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -450,8 +450,11 @@ sub __chk
# If we have an explicit level, bypass Carp.
if ($has_level and @callers_bitmask) {
+ # logic copied from util.c:mess_sv
my $stuff = " at " . join " line ", (caller $i)[1,2];
- $stuff .= ", <" . *${^LAST_FH}{NAME} . "> line $." if $. && ${^LAST_FH};
+ $stuff .= ", <" . *${^LAST_FH}{NAME} . "> "
+ . ($/ eq "\n" ? "line" : "chunk") . " $."
+ if $. && ${^LAST_FH};
die "$message$stuff.\n" if $results[0];
return warn "$message$stuff.\n";
}
diff --git a/regen/warnings.pl b/regen/warnings.pl
index a9bd467269..abc10d2949 100644
--- a/regen/warnings.pl
+++ b/regen/warnings.pl
@@ -766,8 +766,11 @@ sub __chk
# If we have an explicit level, bypass Carp.
if ($has_level and @callers_bitmask) {
+ # logic copied from util.c:mess_sv
my $stuff = " at " . join " line ", (caller $i)[1,2];
- $stuff .= ", <" . *${^LAST_FH}{NAME} . "> line $." if $. && ${^LAST_FH};
+ $stuff .= ", <" . *${^LAST_FH}{NAME} . "> "
+ . ($/ eq "\n" ? "line" : "chunk") . " $."
+ if $. && ${^LAST_FH};
die "$message$stuff.\n" if $results[0];
return warn "$message$stuff.\n";
}
diff --git a/t/lib/warnings/9enabled b/t/lib/warnings/9enabled
index 7a9acd4bb8..3e0bcba7e4 100644
--- a/t/lib/warnings/9enabled
+++ b/t/lib/warnings/9enabled
@@ -1454,3 +1454,22 @@ bimp;
EXPECT
Foo warning at - line 13, <FH> line 2.
Bar warning at - line 13.
+########
+# NAME _at_level with chunky filehandle
+use warnings;
+# Create temp file for testing handles.
+open oUt, ">tmp" or die $!;
+print oUt "foo7bar7";
+close oUt;
+sub bimp {
+ open FH, "tmp";
+ $/ = 7;
+ <FH>; <FH>;
+ warnings::warn_at_level("syntax", 0, "Foo warning");
+ close FH;
+ warnings::warn_at_level("syntax", 0, "Bar warning");
+};
+bimp;
+EXPECT
+Foo warning at - line 14, <FH> chunk 2.
+Bar warning at - line 14.
--
Perl5 Master Repository
