In perl.git, the branch blead has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/c933e4bbba56ec1e52ac51b4617a45d50336021d?hp=da4e040f42421764ef069371d77c008e6b801f45>
- Log -----------------------------------------------------------------
commit c933e4bbba56ec1e52ac51b4617a45d50336021d
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Dec 17 18:00:33 2017 -0800
perldelta for #132468 warnings functions
commit 8841d380660134eefd9d2d5a7cac9909db42af4a
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Dec 17 17:59:33 2017 -0800
perldelta: Alphabetise modules
commit c4583f59133164b3f392c31e9b9573276ec17e74
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Dec 17 17:56:52 2017 -0800
[perl #132468] At _at_level warnings functions
commit e57923a2c4fa758db6d61eb407b8ffb8ac38f5b2
Author: Father Chrysostomos <spr...@cpan.org>
Date: Mon Dec 11 13:38:24 2017 -0800
pp_ctl.c: Add -D output for inward goto
-----------------------------------------------------------------------
Summary of changes:
lib/warnings.pm | 73 ++++++++++++++++++++++++++++++++++++++++++++++---
pod/perldelta.pod | 42 ++++++++++++++++------------
pp_ctl.c | 2 ++
regen/warnings.pl | 73 ++++++++++++++++++++++++++++++++++++++++++++++---
t/lib/warnings/9enabled | 69 ++++++++++++++++++++++++++++++++++++++++++++++
5 files changed, 233 insertions(+), 26 deletions(-)
diff --git a/lib/warnings.pm b/lib/warnings.pm
index c6bbe8c95d..a9a43af959 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -352,6 +352,7 @@ sub unimport
my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE
Regexp)} = ();
+sub LEVEL () { 8 };
sub MESSAGE () { 4 };
sub FATAL () { 2 };
sub NORMAL () { 1 };
@@ -363,8 +364,18 @@ sub __chk
my $isobj = 0 ;
my $wanted = shift;
my $has_message = $wanted & MESSAGE;
-
- unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
+ my $has_level = $wanted & LEVEL ;
+
+ if ($has_level) {
+ if (@_ != ($has_message ? 3 : 2)) {
+ my $sub = (caller 1)[3];
+ my $syntax = $has_message
+ ? "category, level, 'message'"
+ : 'category, level';
+ Croaker("Usage: $sub($syntax)");
+ }
+ }
+ elsif (not @_ == 1 || @_ == ($has_message ? 2 : 0)) {
my $sub = (caller 1)[3];
my $syntax = $has_message ? "[category,] 'message'" : '[category]';
Croaker("Usage: $sub($syntax)");
@@ -402,6 +413,9 @@ sub __chk
}
$i -= 2 ;
}
+ elsif ($has_level) {
+ $i = 2 + shift;
+ }
else {
$i = _error_loc(); # see where Carp will allocate the error
}
@@ -424,9 +438,18 @@ sub __chk
return $results[0] unless $has_message;
# &warnif, and the category is neither enabled as warning nor as fatal
- return if $wanted == (NORMAL | FATAL | MESSAGE)
+ return if ($wanted & (NORMAL | FATAL | MESSAGE))
+ == (NORMAL | FATAL | MESSAGE)
&& !($results[0] || $results[1]);
+ # If we have an explicit level, bypass Carp.
+ if ($has_level and @callers_bitmask) {
+ my $stuff = " at " . join " line ", (caller $i)[1,2];
+ $stuff .= ", <" . *${^LAST_FH}{NAME} . "> line $." if ${^LAST_FH};
+ die "$message$stuff.\n" if $results[0];
+ return warn "$message$stuff.\n";
+ }
+
require Carp;
Carp::croak($message) if $results[0];
# will always get here for &warn. will only get here for &warnif if the
@@ -485,9 +508,29 @@ sub warnif
return __chk(NORMAL | FATAL | MESSAGE, @_);
}
+sub enabled_at_level
+{
+ return __chk(NORMAL | LEVEL, @_);
+}
+
+sub fatal_enabled_at_level
+{
+ return __chk(FATAL | LEVEL, @_);
+}
+
+sub warn_at_level
+{
+ return __chk(FATAL | MESSAGE | LEVEL, @_);
+}
+
+sub warnif_at_level
+{
+ return __chk(NORMAL | FATAL | MESSAGE | LEVEL, @_);
+}
+
# These are not part of any public interface, so we can delete them to save
# space.
-delete @warnings::{qw(NORMAL FATAL MESSAGE)};
+delete @warnings::{qw(NORMAL FATAL MESSAGE LEVEL)};
1;
__END__
@@ -1156,6 +1199,9 @@ warnings::register like this:
=over 4
+Note: The functions with names ending in C<_at_level> were added in Perl
+5.28.
+
=item use warnings::register
Creates a new warnings category with the same name as the package where
@@ -1183,6 +1229,11 @@ Return TRUE if that warnings category is enabled in the
first scope
where the object is used.
Otherwise returns FALSE.
+=item warnings::enabled_at_level($category, $level)
+
+Like C<warnings::enabled>, but $level specifies the exact call frame, 0
+being the immediate caller.
+
=item warnings::fatal_enabled()
Return TRUE if the warnings category with the same name as the current
@@ -1204,6 +1255,11 @@ Return TRUE if that warnings category has been set to
FATAL in the first
scope where the object is used.
Otherwise returns FALSE.
+=item warnings::fatal_enabled_at_level($category, $level)
+
+Like C<warnings::fatal_enabled>, but $level specifies the exact call frame,
+0 being the immediate caller.
+
=item warnings::warn($message)
Print C<$message> to STDERR.
@@ -1230,6 +1286,10 @@ warnings category.
If that warnings category has been set to "FATAL" in the scope where C<$object>
is first used then die. Otherwise return.
+=item warnings::warn_at_level($category, $level, $message)
+
+Like C<warnings::warn>, but $level specifies the exact call frame,
+0 being the immediate caller.
=item warnings::warnif($message)
@@ -1252,6 +1312,11 @@ Equivalent to:
if (warnings::enabled($object))
{ warnings::warn($object, $message) }
+=item warnings::warnif_at_level($category, $level, $message)
+
+Like C<warnings::warnif>, but $level specifies the exact call frame,
+0 being the immediate caller.
+
=item warnings::register_categories(@names)
This registers warning categories for the given names and is primarily for
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 1f68d4c138..0613390377 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -195,10 +195,24 @@ XXX Remove this section if not applicable.
=item *
-L<Locale::Codes> has been upgraded from version 3.54 to 3.55
+L<Data::Dumper> has been upgraded from version 2.167_02 to 2.169.
+Quoting of glob names now obeys the Useqq option [perl #119831].
+Attempts to set an option to C<undef> through a combined getter/setter
+method are no longer mistaken for getter calls [perl #113090].
-B<NOTE>: L<Locale::Codes> is deprecated in core and will be removed
-from Perl 5.30.
+=item *
+
+L<DynaLoader> has been upgraded from version 1.44 to 1.45.
+Its documentation now shows the use of C<__PACKAGE__> and direct object
+syntax [perl #132247].
+
+=item *
+
+L<GDBM_File> has been upgraded from version 1.16 to 1.17.
+Its documentation now explains that C<each> and C<delete> don't mix in
+hashes tied to this module [perl #117449].
+It will now retry opening with an acceptable block size if asking gdbm
+to default the block size failed [perl #119623].
=item *
@@ -209,10 +223,10 @@ in C<BEGIN> blocks. [perl #96538]
=item *
-L<Data::Dumper> has been upgraded from version 2.167_02 to 2.169.
-Quoting of glob names now obeys the Useqq option [perl #119831].
-Attempts to set an option to C<undef> through a combined getter/setter
-method are no longer mistaken for getter calls [perl #113090].
+L<Locale::Codes> has been upgraded from version 3.54 to 3.55
+
+B<NOTE>: L<Locale::Codes> is deprecated in core and will be removed
+from Perl 5.30.
=item *
@@ -224,11 +238,9 @@ core of its job. [perl #110520]
=item *
-L<GDBM_File> has been upgraded from version 1.16 to 1.17.
-Its documentation now explains that C<each> and C<delete> don't mix in
-hashes tied to this module [perl #117449].
-It will now retry opening with an acceptable block size if asking gdbm
-to default the block size failed [perl #119623].
+L<warnings> has been upgraded from version 1.38 to 1.39.
+It now includes new functions with names ending in C<_at_level>, allowing
+callers to specify the exact call frame. [perl #132468]
=item *
@@ -236,12 +248,6 @@ L<XSLoader> has been upgraded from version 0.28 to 0.29.
Its documentation now shows the use of C<__PACKAGE__>, and direct object
syntax for example C<DynaLoader> usage [perl #132247].
-=item *
-
-L<DynaLoader> has been upgraded from version 1.44 to 1.45.
-Its documentation now shows the use of C<__PACKAGE__> and direct object
-syntax [perl #132247].
-
=back
=head2 Removed Modules and Pragmata
diff --git a/pp_ctl.c b/pp_ctl.c
index 88de13605f..a0cb31ccf6 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3057,6 +3057,8 @@ PP(pp_goto)
for (; enterops[ix]; ix++) {
PL_op = enterops[ix];
S_check_op_type(aTHX_ PL_op);
+ DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
+ OP_NAME(PL_op)));
PL_op->op_ppaddr(aTHX);
}
PL_op = oldop;
diff --git a/regen/warnings.pl b/regen/warnings.pl
index b090d4b862..f5d7a89238 100644
--- a/regen/warnings.pl
+++ b/regen/warnings.pl
@@ -670,6 +670,7 @@ sub unimport
my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE
Regexp)} = ();
+sub LEVEL () { 8 };
sub MESSAGE () { 4 };
sub FATAL () { 2 };
sub NORMAL () { 1 };
@@ -681,8 +682,18 @@ sub __chk
my $isobj = 0 ;
my $wanted = shift;
my $has_message = $wanted & MESSAGE;
-
- unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
+ my $has_level = $wanted & LEVEL ;
+
+ if ($has_level) {
+ if (@_ != ($has_message ? 3 : 2)) {
+ my $sub = (caller 1)[3];
+ my $syntax = $has_message
+ ? "category, level, 'message'"
+ : 'category, level';
+ Croaker("Usage: $sub($syntax)");
+ }
+ }
+ elsif (not @_ == 1 || @_ == ($has_message ? 2 : 0)) {
my $sub = (caller 1)[3];
my $syntax = $has_message ? "[category,] 'message'" : '[category]';
Croaker("Usage: $sub($syntax)");
@@ -720,6 +731,9 @@ sub __chk
}
$i -= 2 ;
}
+ elsif ($has_level) {
+ $i = 2 + shift;
+ }
else {
$i = _error_loc(); # see where Carp will allocate the error
}
@@ -742,9 +756,18 @@ sub __chk
return $results[0] unless $has_message;
# &warnif, and the category is neither enabled as warning nor as fatal
- return if $wanted == (NORMAL | FATAL | MESSAGE)
+ return if ($wanted & (NORMAL | FATAL | MESSAGE))
+ == (NORMAL | FATAL | MESSAGE)
&& !($results[0] || $results[1]);
+ # If we have an explicit level, bypass Carp.
+ if ($has_level and @callers_bitmask) {
+ my $stuff = " at " . join " line ", (caller $i)[1,2];
+ $stuff .= ", <" . *${^LAST_FH}{NAME} . "> line $." if ${^LAST_FH};
+ die "$message$stuff.\n" if $results[0];
+ return warn "$message$stuff.\n";
+ }
+
require Carp;
Carp::croak($message) if $results[0];
# will always get here for &warn. will only get here for &warnif if the
@@ -803,9 +826,29 @@ sub warnif
return __chk(NORMAL | FATAL | MESSAGE, @_);
}
+sub enabled_at_level
+{
+ return __chk(NORMAL | LEVEL, @_);
+}
+
+sub fatal_enabled_at_level
+{
+ return __chk(FATAL | LEVEL, @_);
+}
+
+sub warn_at_level
+{
+ return __chk(FATAL | MESSAGE | LEVEL, @_);
+}
+
+sub warnif_at_level
+{
+ return __chk(NORMAL | FATAL | MESSAGE | LEVEL, @_);
+}
+
# These are not part of any public interface, so we can delete them to save
# space.
-delete @warnings::{qw(NORMAL FATAL MESSAGE)};
+delete @warnings::{qw(NORMAL FATAL MESSAGE LEVEL)};
1;
__END__
@@ -1340,6 +1383,9 @@ warnings::register like this:
=over 4
+Note: The functions with names ending in C<_at_level> were added in Perl
+5.28.
+
=item use warnings::register
Creates a new warnings category with the same name as the package where
@@ -1367,6 +1413,11 @@ Return TRUE if that warnings category is enabled in the
first scope
where the object is used.
Otherwise returns FALSE.
+=item warnings::enabled_at_level($category, $level)
+
+Like C<warnings::enabled>, but $level specifies the exact call frame, 0
+being the immediate caller.
+
=item warnings::fatal_enabled()
Return TRUE if the warnings category with the same name as the current
@@ -1388,6 +1439,11 @@ Return TRUE if that warnings category has been set to
FATAL in the first
scope where the object is used.
Otherwise returns FALSE.
+=item warnings::fatal_enabled_at_level($category, $level)
+
+Like C<warnings::fatal_enabled>, but $level specifies the exact call frame,
+0 being the immediate caller.
+
=item warnings::warn($message)
Print C<$message> to STDERR.
@@ -1414,6 +1470,10 @@ warnings category.
If that warnings category has been set to "FATAL" in the scope where C<$object>
is first used then die. Otherwise return.
+=item warnings::warn_at_level($category, $level, $message)
+
+Like C<warnings::warn>, but $level specifies the exact call frame,
+0 being the immediate caller.
=item warnings::warnif($message)
@@ -1436,6 +1496,11 @@ Equivalent to:
if (warnings::enabled($object))
{ warnings::warn($object, $message) }
+=item warnings::warnif_at_level($category, $level, $message)
+
+Like C<warnings::warnif>, but $level specifies the exact call frame,
+0 being the immediate caller.
+
=item warnings::register_categories(@names)
This registers warning categories for the given names and is primarily for
diff --git a/t/lib/warnings/9enabled b/t/lib/warnings/9enabled
index 6d8bd64acf..bbef5e8d41 100644
--- a/t/lib/warnings/9enabled
+++ b/t/lib/warnings/9enabled
@@ -1367,3 +1367,72 @@ My wubble is flanged at - line 24.
My wubble is flanged at - line 25.
My webble is flanged at - line 27.
done
+########
+# NAME _at_level
+select STDERR;
+{ use warnings "utf8"; foo() }
+sub foo { use warnings "syntax"; bar() }
+sub bar {
+ use warnings "unpack";
+ local $\="\n";
+ print "1. ", warnings::enabled_at_level("unpack", 0)||0;
+ print "2. ", warnings::enabled_at_level("unpack", 1)||0;
+ print "3. ", warnings::enabled_at_level("unpack", 2)||0;
+ print "4. ", warnings::enabled_at_level("syntax", 0)||0;
+ print "5. ", warnings::enabled_at_level("syntax", 1)||0;
+ print "6. ", warnings::enabled_at_level("syntax", 2)||0;
+ print "7. ", warnings::enabled_at_level("utf8", 0)||0;
+ print "8. ", warnings::enabled_at_level("utf8", 1)||0;
+ print "9. ", warnings::enabled_at_level("utf8", 2)||0;
+ warnings::warn_at_level ("misc",0,"A mandatory foo warning");
+ warnings::warn_at_level ("misc",1,"A mandatory top-level warning");
+ warnings::warnif_at_level("syntax",0,"A conditional syntax warning");
+ warnings::warnif_at_level("syntax",1,"A conditional syntax warning");
+ warnings::warnif_at_level("utf8",0,"A conditional utf8 warning");
+ warnings::warnif_at_level("utf8",1,"A conditional utf8 warning");
+}
+{ use warnings "syntax"; use warnings FATAL => "utf8"; foo2() }
+sub foo2 {
+ use warnings FATAL => "syntax"; use warnings "utf8"; bar2()
+}
+sub bar2 {
+ $\="\n";
+ print "10. ", warnings::fatal_enabled_at_level("syntax", 0)||0;
+ print "11. ", warnings::fatal_enabled_at_level("syntax", 1)||0;
+ print "12. ", warnings::fatal_enabled_at_level("utf8", 0)||0;
+ print "13. ", warnings::fatal_enabled_at_level("utf8", 1)||0;
+ undef $\;
+ eval { warnings::warn_at_level ("syntax",1,"A fatal warning") };
+ print "Died: $@" if $@;
+ eval { warnings::warnif_at_level("syntax",1,"A fatal syntax warning") };
+ print "Died: $@" if $@;
+ eval { warnings::warnif_at_level("syntax",2,"A syntax warning") };
+ print "Died: $@" if $@;
+ eval { warnings::warnif_at_level("utf8",1,"A utf8 warning") };
+ print "Died: $@" if $@;
+ eval { warnings::warnif_at_level("utf8",2,"A fatal utf8 warning") };
+ print "Died: $@" if $@;
+}
+EXPECT
+1. 0
+2. 0
+3. 0
+4. 1
+5. 0
+6. 0
+7. 0
+8. 1
+9. 0
+A mandatory foo warning at - line 3.
+A mandatory top-level warning at - line 2.
+A conditional syntax warning at - line 3.
+A conditional utf8 warning at - line 2.
+10. 1
+11. 0
+12. 0
+13. 1
+Died: A fatal warning at - line 25.
+Died: A fatal syntax warning at - line 25.
+A syntax warning at - line 23.
+A utf8 warning at - line 25.
+Died: A fatal utf8 warning at - line 23.
--
Perl5 Master Repository
