#
# This script is normally invoked from regen.pl.
-$VERSION = '1.03';
+$VERSION = '1.46';
BEGIN {
- require 'regen/regen_lib.pl';
+ require './regen/regen_lib.pl';
push @INC, './lib';
}
use strict ;
[ 5.017, DEFAULT_ON ],
'experimental::regex_sets' =>
[ 5.017, DEFAULT_ON ],
- 'experimental::lexical_topic' =>
- [ 5.017, DEFAULT_ON ],
'experimental::smartmatch' =>
[ 5.017, DEFAULT_ON ],
'experimental::postderef' =>
[ 5.019, DEFAULT_ON ],
- 'experimental::autoderef' =>
- [ 5.019, DEFAULT_ON ],
'experimental::signatures' =>
[ 5.019, DEFAULT_ON ],
'experimental::win32_perlio' =>
[ 5.021, DEFAULT_ON ],
'experimental::bitwise' =>
[ 5.021, DEFAULT_ON ],
+ 'experimental::declared_refs' =>
+ [ 5.025, DEFAULT_ON ],
+ 'experimental::script_run' =>
+ [ 5.027, DEFAULT_ON ],
+ 'experimental::alpha_assertions' =>
+ [ 5.027, DEFAULT_ON ],
+ 'experimental::private_use' =>
+ [ 5.029, DEFAULT_ON ],
+ 'experimental::uniprop_wildcards' =>
+ [ 5.029, DEFAULT_ON ],
+ 'experimental::vlb' =>
+ [ 5.029, DEFAULT_ON ],
+ 'experimental::isa' =>
+ [ 5.031, DEFAULT_ON ],
}],
'missing' => [ 5.021, DEFAULT_OFF],
'redundant' => [ 5.021, DEFAULT_OFF],
'locale' => [ 5.021, DEFAULT_ON],
+ 'shadow' => [ 5.027, DEFAULT_OFF],
#'default' => [ 5.008, DEFAULT_ON ],
}]};
#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
#define pWARN_STD NULL
-#define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */
-#define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */
+#define pWARN_ALL (STRLEN *) &PL_WARN_ALL /* use warnings 'all' */
+#define pWARN_NONE (STRLEN *) &PL_WARN_NONE /* no warnings 'all' */
#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
(x) == pWARN_NONE)
EOM
walk ($tree) ;
+ for (my $i = $index; $i & 3; $i++) {
+ push @{$list{all}}, $i;
+ }
$index *= 2 ;
$warn_size = int($index / 8) + ($index % 8 != 0) ;
my $k ;
my $last_ver = 0;
+ my @names;
foreach $k (sort { $a <=> $b } keys %ValueToName) {
my ($name, $version) = @{ $ValueToName{$k} };
print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
if $last_ver != $version ;
$name =~ y/:/_/;
- print $warn tab(6, "#define WARN_$name"), " $k\n" ;
+ $name = "WARN_$name";
+ print $warn tab(6, "#define $name"), " $k\n" ;
+ push @names, $name;
$last_ver = $version ;
}
- print $warn "\n" ;
+ print $warn "\n\n/*\n" ;
+
+ print $warn map { "=for apidoc Amnh||$_\n" } @names;
+ print $warn "\n=cut\n*/\n\n" ;
print $warn tab(6, '#define WARNsize'), " $warn_size\n" ;
print $warn tab(6, '#define WARN_ALLstring'), ' "', ('\125' x $warn_size) , "\"\n" ;
print $warn <<'EOM';
-#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
-#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
+#define isLEXWARN_on \
+ cBOOL(PL_curcop && PL_curcop->cop_warnings != pWARN_STD)
+#define isLEXWARN_off \
+ cBOOL(!PL_curcop || PL_curcop->cop_warnings == pWARN_STD)
#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
#define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
#define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
-#define DUP_WARNINGS(p) \
- (specialWARN(p) ? (STRLEN*)(p) \
- : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
- char))
+#define DUP_WARNINGS(p) Perl_dup_warnings(aTHX_ p)
+
+/*
+
+=head1 Warning and Dieing
+
+In all these calls, the C<U32 wI<n>> parameters are warning category
+constants. You can see the ones currently available in
+L<warnings/Category Hierarchy>, just capitalize all letters in the names
+and prefix them by C<WARN_>. So, for example, the category C<void> used in a
+perl program becomes C<WARN_VOID> when used in XS code and passed to one of
+the calls below.
+
+=for apidoc Am|bool|ckWARN|U32 w
+
+Returns a boolean as to whether or not warnings are enabled for the warning
+category C<w>. If the category is by default enabled even if not within the
+scope of S<C<use warnings>>, instead use the L</ckWARN_d> macro.
+
+=for apidoc Am|bool|ckWARN_d|U32 w
+
+Like C<L</ckWARN>>, but for use if and only if the warning category is by
+default enabled even if not within the scope of S<C<use warnings>>.
+
+=for apidoc Am|bool|ckWARN2|U32 w1|U32 w2
+
+Like C<L</ckWARN>>, but takes two warnings categories as input, and returns
+TRUE if either is enabled. If either category is by default enabled even if
+not within the scope of S<C<use warnings>>, instead use the L</ckWARN2_d>
+macro. The categories must be completely independent, one may not be
+subclassed from the other.
+
+=for apidoc Am|bool|ckWARN2_d|U32 w1|U32 w2
+
+Like C<L</ckWARN2>>, but for use if and only if either warning category is by
+default enabled even if not within the scope of S<C<use warnings>>.
+
+=for apidoc Am|bool|ckWARN3|U32 w1|U32 w2|U32 w3
+
+Like C<L</ckWARN2>>, but takes three warnings categories as input, and returns
+TRUE if any is enabled. If any of the categories is by default enabled even
+if not within the scope of S<C<use warnings>>, instead use the L</ckWARN3_d>
+macro. The categories must be completely independent, one may not be
+subclassed from any other.
+
+=for apidoc Am|bool|ckWARN3_d|U32 w1|U32 w2|U32 w3
+
+Like C<L</ckWARN3>>, but for use if and only if any of the warning categories
+is by default enabled even if not within the scope of S<C<use warnings>>.
+
+=for apidoc Am|bool|ckWARN4|U32 w1|U32 w2|U32 w3|U32 w4
+
+Like C<L</ckWARN3>>, but takes four warnings categories as input, and returns
+TRUE if any is enabled. If any of the categories is by default enabled even
+if not within the scope of S<C<use warnings>>, instead use the L</ckWARN4_d>
+macro. The categories must be completely independent, one may not be
+subclassed from any other.
+
+=for apidoc Am|bool|ckWARN4_d|U32 w1|U32 w2|U32 w3|U32 w4
+
+Like C<L</ckWARN4>>, but for use if and only if any of the warning categories
+is by default enabled even if not within the scope of S<C<use warnings>>.
+
+=cut
+
+*/
#define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
#define unpackWARN4(x) (((x) >>24) & 0xFF)
#define ckDEAD(x) \
- ( ! specialWARN(PL_curcop->cop_warnings) && \
- ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
- isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
- isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
- isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
- isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
+ (PL_curcop && \
+ !specialWARN(PL_curcop->cop_warnings) && \
+ (isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
+ (unpackWARN2(x) && \
+ (isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
+ (unpackWARN3(x) && \
+ (isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
+ (unpackWARN4(x) && \
+ isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x)))))))))
/* end of file warnings.h */
EOM
}
while (<DATA>) {
+ last if /^VERSION$/ ;
+ print $pm $_ ;
+}
+
+print $pm qq(our \$VERSION = "$::VERSION";\n);
+
+while (<DATA>) {
last if /^KEYWORDS$/ ;
print $pm $_ ;
}
print $pm "# These are used by various things, including our own tests\n";
print $pm tab(6, 'our $NONE'), '= "', ('\0' x $warn_size) , "\";\n" ;
print $pm tab(6, 'our $DEFAULT'), '= "', mkHex($warn_size, map $_ * 2, @def),
- '", # [', mkRange(@def), "]\n" ;
+ '", # [', mkRange(sort { $a <=> $b } @def), "]\n" ;
print $pm tab(6, 'our $LAST_BIT'), '= ' . "$index ;\n" ;
print $pm tab(6, 'our $BYTES'), '= ' . "$warn_size ;\n" ;
while (<DATA>) {
__END__
package warnings;
-our $VERSION = '1.32';
+VERSION
# Verify that we're called correctly so that warnings will work.
+# Can't use Carp, since Carp uses us!
+# String regexps because constant folding = smaller optree = less memory vs regexp literal
# see also strict.pm.
-unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
- my (undef, $f, $l) = caller;
- die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
-}
+die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(caller)[1,2]
+ if __FILE__ !~ ( '(?x) \b '.__PACKAGE__.' \.pmc? \z' )
+ && __FILE__ =~ ( '(?x) \b (?i:'.__PACKAGE__.') \.pmc? \z' );
KEYWORDS
-our $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
-
sub Croaker
{
require Carp; # this initializes %CarpInternal
Carp::croak(@_);
}
+sub _expand_bits {
+ my $bits = shift;
+ my $want_len = ($LAST_BIT + 7) >> 3;
+ my $len = length($bits);
+ if ($len != $want_len) {
+ if ($bits eq "") {
+ $bits = "\x00" x $want_len;
+ } elsif ($len > $want_len) {
+ substr $bits, $want_len, $len-$want_len, "";
+ } else {
+ my $a = vec($bits, $Offsets{all} >> 1, 2);
+ $a |= $a << 2;
+ $a |= $a << 4;
+ $bits .= chr($a) x ($want_len - $len);
+ }
+ }
+ return $bits;
+}
+
sub _bits {
my $mask = shift ;
my $catmask ;
my $fatal = 0 ;
my $no_fatal = 0 ;
+ $mask = _expand_bits($mask);
foreach my $word ( @_ ) {
if ($word eq 'FATAL') {
$fatal = 1;
elsif ($catmask = $Bits{$word}) {
$mask |= $catmask ;
$mask |= $DeadBits{$word} if $fatal ;
- $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
+ $mask = ~(~$mask | $DeadBits{$word}) if $no_fatal ;
}
else
{ Croaker("Unknown warnings category '$word'")}
{
# called from B::Deparse.pm
push @_, 'all' unless @_ ;
- return _bits(undef, @_) ;
+ return _bits("", @_) ;
}
sub import
my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
- if (vec($mask, $Offsets{'all'}, 1)) {
- $mask |= $Bits{'all'} ;
- $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
- }
-
- # append 'all' when implied (after a lone "FATAL" or "NONFATAL")
- push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' );
+ # append 'all' when implied (empty import list or after a lone
+ # "FATAL" or "NONFATAL")
+ push @_, 'all'
+ if !@_ || (@_==1 && ($_[0] eq 'FATAL' || $_[0] eq 'NONFATAL'));
- # Empty @_ is equivalent to @_ = 'all' ;
- ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
+ ${^WARNING_BITS} = _bits($mask, @_);
}
sub unimport
my $catmask ;
my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
- if (vec($mask, $Offsets{'all'}, 1)) {
- $mask |= $Bits{'all'} ;
- $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
- }
-
# append 'all' when implied (empty import list or after a lone "FATAL")
push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
+ $mask = _expand_bits($mask);
foreach my $word ( @_ ) {
if ($word eq 'FATAL') {
next;
}
elsif ($catmask = $Bits{$word}) {
- $mask &= ~($catmask | $DeadBits{$word} | $All);
+ $mask = ~(~$mask | $catmask | $DeadBits{$word});
}
else
{ Croaker("Unknown warnings category '$word'")}
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 };
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)");
}
$i -= 2 ;
}
+ elsif ($has_level) {
+ $i = 2 + shift;
+ }
else {
$i = _error_loc(); # see where Carp will allocate the error
}
my(@callers_bitmask) = (caller($i))[9] ;
my $callers_bitmask =
@callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
+ length($callers_bitmask) > ($offset >> 3) or $offset = $Offsets{all};
my @results;
foreach my $type (FATAL, NORMAL) {
next unless $wanted & $type;
- push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
- vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
+ push @results, vec($callers_bitmask, $offset + $type - 1, 1);
}
# &enabled and &fatal_enabled
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) {
+ # logic copied from util.c:mess_sv
+ my $stuff = " at " . join " line ", (caller $i)[1,2];
+ $stuff .= sprintf ", <%s> %s %d",
+ *${^LAST_FH}{NAME},
+ ($/ eq "\n" ? "line" : "chunk"), $.
+ 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
for my $name (@names) {
if (! defined $Bits{$name}) {
- $Bits{$name} = _mkMask($LAST_BIT);
- vec($Bits{'all'}, $LAST_BIT, 1) = 1;
- $Offsets{$name} = $LAST_BIT ++;
- foreach my $k (keys %Bits) {
- vec($Bits{$k}, $LAST_BIT, 1) = 0;
+ $Offsets{$name} = $LAST_BIT;
+ $Bits{$name} = _mkMask($LAST_BIT++);
+ $DeadBits{$name} = _mkMask($LAST_BIT++);
+ if (length($Bits{$name}) > length($Bits{all})) {
+ $Bits{all} .= "\x55";
+ $DeadBits{all} .= "\xaa";
}
- $DeadBits{$name} = _mkMask($LAST_BIT);
- vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
}
}
}
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__
+
=head1 NAME
warnings - Perl pragma to control optional warnings
This is the existing flag. If the lexical warnings pragma is B<not>
used in any of you code, or any of the modules that you use, this flag
-will enable warnings everywhere. See L<Backward Compatibility> for
+will enable warnings everywhere. See L</Backward Compatibility> for
details of how this flag interacts with lexical warnings.
=item B<-W>
=head2 Fatal Warnings
X<warning, fatal>
-The presence of the word "FATAL" in the category list will escalate any
-warnings detected from the categories specified in the lexical scope
-into fatal errors.
+The presence of the word "FATAL" in the category list will escalate
+warnings in those categories into fatal errors in that lexical scope.
+
+B<NOTE:> FATAL warnings should be used with care, particularly
+C<< FATAL => 'all' >>.
+
+Libraries using L<warnings::warn|/FUNCTIONS> for custom warning categories
+generally don't expect L<warnings::warn|/FUNCTIONS> to be fatal and can wind up
+in an unexpected state as a result. For XS modules issuing categorized
+warnings, such unanticipated exceptions could also expose memory leak bugs.
+
+Moreover, the Perl interpreter itself has had serious bugs involving
+fatalized warnings. For a summary of resolved and unresolved problems as
+of January 2015, please see
+L<this perl5-porters post|http://www.nntp.perl.org/group/perl.perl5.porters/2015/01/msg225235.html>.
+
+While some developers find fatalizing some warnings to be a useful
+defensive programming technique, using C<< FATAL => 'all' >> to fatalize
+all possible warning categories -- including custom ones -- is particularly
+risky. Therefore, the use of C<< FATAL => 'all' >> is
+L<discouraged|perlpolicy/discouraged>.
-B<NOTE:> Use of FATAL warnings is officially B<discouraged>. Fatalizing
-warnings can, in some circumstances, leave the interpreter in an
-inconsistent internal state. Given the many L<current and historical
-problems with FATAL warnings
-|http://www.nntp.perl.org/group/perl.perl5.porters/2015/01/msg225235.html>
-and the general fragility of this feature, the Perl5 development team
-believes that FATAL warnings should not be used.
+The L<strictures|strictures/VERSION-2> module on CPAN offers one example of
+a warnings subset that the module's authors believe is relatively safe to
+fatalize.
-Moreover, users of FATAL warnings, especially those using
-C<< FATAL => 'all' >> should be fully aware that they are risking future
+B<NOTE:> users of FATAL warnings, especially those using
+C<< FATAL => 'all' >>, should be fully aware that they are risking future
portability of their programs by doing so. Perl makes absolutely no
commitments to not introduce new warnings or warnings categories in the
future; indeed, we explicitly reserve the right to do so. Code that may
and spirit. Use of such features in combination with FATAL warnings is
ENTIRELY AT THE USER'S RISK.
-The following documentation describes the operation of FATAL warnings and
-is provided solely as a reference for use with legacy code.
+The following documentation describes how to use FATAL warnings but the
+perl5 porters strongly recommend that you understand the risks before doing
+so, especially for library code intended for use by others, as there is no
+way for downstream users to change the choice of fatal categories.
In the code below, the use of C<time>, C<length>
and C<join> can all produce a C<"Useless use of xxx in void context">
package MyMod::Abc;
sub open {
- warnings::warnif("deprecated",
- "open is deprecated, use new instead");
+ if (warnings::enabled("deprecated")) {
+ warnings::warn("deprecated",
+ "open is deprecated, use new instead");
+ }
new(@_);
}
=head1 FUNCTIONS
+Note: The functions with names ending in C<_at_level> were added in Perl
+5.28.
+
=over 4
=item use warnings::register
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
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.
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)
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
https://perl5.git.perl.org / perl5.git / blobdiff