#
# This script is normally invoked from regen.pl.
-$VERSION = '1.38';
+$VERSION = '1.46';
BEGIN {
require './regen/regen_lib.pl';
[ 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)
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" ;
#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
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
}
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
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>
=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