diff options
| -rw-r--r-- | lib/warnings.pm | 73 | ||||
| -rw-r--r-- | regen/warnings.pl | 73 | ||||
| -rw-r--r-- | t/lib/warnings/9enabled | 69 |
3 files changed, 207 insertions, 8 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/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. |