lib/validate.pl Perl library supporting wholesale file mode validation
lib/vars.pm Declare pseudo-imported global variables
lib/warnings.pm For "use warnings"
+lib/warnings/register.pm For "use warnings::register"
makeaperl.SH perl script that produces a new perl binary
makedef.pl Create symbol export lists for linking
makedepend.SH Precursor to makedepend
package IO::Select;
use strict;
+use warnings::register;
use vars qw($VERSION @ISA);
require Exporter;
-$VERSION = "1.13";
+$VERSION = "1.14";
@ISA = qw(Exporter); # This is only so we can do version checking
sub has_error
{
- require Carp;
- Carp::carp("Call to depreciated method 'has_error', use 'has_exception'")
- if $^W;
+ warnings::warn("Call to depreciated method 'has_error', use 'has_exception'")
+ if warnings::enabled();
goto &has_exception;
}
package Socket;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-$VERSION = "1.71";
+$VERSION = "1.72";
=head1 NAME
=cut
use Carp;
+use warnings::register;
require Exporter;
use XSLoader ();
sub sockaddr_in {
if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die
my($af, $port, @quad) = @_;
- carp "6-ARG sockaddr_in call is deprecated" if $^W;
+ warnings::warn "6-ARG sockaddr_in call is deprecated"
+ if warnings::enabled();
pack_sockaddr_in($port, inet_aton(join('.', @quad)));
} elsif (wantarray) {
croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1;
use 5.005_64;
use strict;
+use warnings::register;
our(@ISA, @EXPORT, $VERSION);
use Carp;
$cnt = 0;
foreach $name (@methods){
if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) {
- carp "function '$name' already defined, overrides struct accessor method"
- if $^W;
+ warnings::warn "function '$name' already defined, overrides struct accessor method"
+ if warnings::enabled();
}
else {
$pre = $pst = $cmt = $sel = '';
# ---
use POSIX qw(strxfrm LC_COLLATE);
+use warnings::register;
require Exporter;
sub new {
my $new = $_[1];
- if ($^W && $] >= 5.003_06) {
+ if (warnings::enabled() && $] >= 5.003_06) {
unless ($please_use_I18N_Collate_even_if_deprecated) {
- warn <<___EOD___;
+ warnings::warn <<___EOD___;
***
WARNING: starting from the Perl version 5.003_06
=cut
use Carp;
+use warnings::register;
sub new {
my $pkg = shift;
sub TIEHANDLE {
my $pkg = shift;
if (defined &{"{$pkg}::new"}) {
- carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing"
- if $^W;
+ warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing"
+ if warnings::enabled();
$pkg->new(@_);
}
else {
=cut
use Carp;
+use warnings::register;
sub new {
my $pkg = shift;
sub TIEHASH {
my $pkg = shift;
if (defined &{"${pkg}::new"}) {
- carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing"
- if $^W;
+ warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing"
+ if warnings::enabled();
$pkg->new(@_);
}
else {
=cut
use Carp;
+use warnings::register;
sub new {
my $pkg = shift;
sub TIESCALAR {
my $pkg = shift;
if (defined &{"{$pkg}::new"}) {
- carp "WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing"
- if $^W;
+ warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing"
+ if warnings::enabled();
$pkg->new(@_);
}
else {
use strict;
use 5.005_64;
+use warnings::register;
our($VERSION, %declared);
-$VERSION = '1.01';
+$VERSION = '1.02';
#=======================================================================
# Maybe the name is tolerable
} elsif ($name =~ /^[A-Za-z_]\w*\z/) {
# Then we'll warn only if you've asked for warnings
- if ($^W) {
- require Carp;
+ if (warnings::enabled()) {
if ($keywords{$name}) {
- Carp::carp("Constant name '$name' is a Perl keyword");
+ warnings::warn("Constant name '$name' is a Perl keyword");
} elsif ($forced_into_main{$name}) {
- Carp::carp("Constant name '$name' is " .
+ warnings::warn("Constant name '$name' is " .
"forced into package main::");
} else {
# Catch-all - what did I miss? If you get this error,
# please let me know what your constant's name was.
# Write to <rootbeer@redcat.com>. Thanks!
- Carp::carp("Constant name '$name' has unknown problems");
+ warnings::warn("Constant name '$name' has unknown problems");
}
}
package syslog;
+use warnings::register;
+
$host = 'localhost' unless $host; # set $syslog'host to change
-if ($] >= 5) {
- warn "You should 'use Sys::Syslog' instead; continuing" # if $^W
+if ($] >= 5 && warnings::enabled()) {
+ warnings::warn "You should 'use Sys::Syslog' instead; continuing";
}
require 'syslog.ph';
# if Carp hasn't been loaded in earlier compile time. :-(
# We'll let those bugs get found on the development track.
require Carp if $] < 5.00450;
+use warnings::register();
sub import {
my $callpack = caller;
} elsif ($sym =~ /^\w+[[{].*[]}]$/) {
require Carp;
Carp::croak("Can't declare individual elements of hash or array");
- } elsif ($^W and length($sym) == 1 and $sym !~ tr/a-zA-Z//) {
- require Carp;
- Carp::carp("No need to declare built-in vars");
+ } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) {
+ warnings::warn("No need to declare built-in vars");
}
}
*{"${callpack}::$sym"} =
use warnings "all";
no warnings "all";
- if (warnings::enabled("void") {
+ use warnings::register;
+ if (warnings::enabled()) {
+ warnings::warn("some warning");
+ }
+
+ if (warnings::enabled("void")) {
warnings::warn("void", "some warning");
}
If no import list is supplied, all possible warnings are either enabled
or disabled.
-Two functions are provided to assist module authors.
+A number of functions are provided to assist module authors.
=over 4
-=item warnings::enabled($category)
+=item use warnings::register
+
+Creates a new warnings category which has the same name as the module
+where the call to the pragma is used.
-Returns TRUE if the warnings category in C<$category> is enabled in the
-calling module. Otherwise returns FALSE.
+=item warnings::enabled([$category])
+Returns TRUE if the warnings category C<$category> is enabled in the
+calling module. Otherwise returns FALSE.
-=item warnings::warn($category, $message)
+If the parameter, C<$category>, isn't supplied, the current package name
+will be used.
+
+=item warnings::warn([$category,] $message)
If the calling module has I<not> set C<$category> to "FATAL", print
C<$message> to STDERR.
If the calling module has set C<$category> to "FATAL", print C<$message>
STDERR then die.
+If the parameter, C<$category>, isn't supplied, the current package name
+will be used.
+
=back
See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
use Carp ;
+%Offsets = (
+ 'all' => 0,
+ 'chmod' => 2,
+ 'closure' => 4,
+ 'exiting' => 6,
+ 'glob' => 8,
+ 'io' => 10,
+ 'closed' => 12,
+ 'exec' => 14,
+ 'newline' => 16,
+ 'pipe' => 18,
+ 'unopened' => 20,
+ 'misc' => 22,
+ 'numeric' => 24,
+ 'once' => 26,
+ 'overflow' => 28,
+ 'pack' => 30,
+ 'portable' => 32,
+ 'recursion' => 34,
+ 'redefine' => 36,
+ 'regexp' => 38,
+ 'severe' => 40,
+ 'debugging' => 42,
+ 'inplace' => 44,
+ 'internal' => 46,
+ 'malloc' => 48,
+ 'signal' => 50,
+ 'substr' => 52,
+ 'syntax' => 54,
+ 'ambiguous' => 56,
+ 'bareword' => 58,
+ 'deprecated' => 60,
+ 'digit' => 62,
+ 'parenthesis' => 64,
+ 'precedence' => 66,
+ 'printf' => 68,
+ 'prototype' => 70,
+ 'qw' => 72,
+ 'reserved' => 74,
+ 'semicolon' => 76,
+ 'taint' => 78,
+ 'umask' => 80,
+ 'uninitialized' => 82,
+ 'unpack' => 84,
+ 'untie' => 86,
+ 'utf8' => 88,
+ 'void' => 90,
+ 'y2k' => 92,
+ );
+
%Bits = (
- 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
- 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
- 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28]
- 'chmod' => "\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [0]
- 'closed' => "\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5]
- 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
- 'debugging' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
- 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
- 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
- 'exec' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
- 'exiting' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
- 'glob' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
- 'inplace' => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21]
- 'internal' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
- 'io' => "\x00\x55\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9]
- 'malloc' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
- 'misc' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
- 'newline' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
- 'numeric' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
- 'once' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
- 'overflow' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
- 'pack' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
- 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
- 'pipe' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
- 'portable' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
- 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
- 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
- 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
- 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
- 'recursion' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
- 'redefine' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
- 'regexp' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
- 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
- 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
- 'severe' => "\x00\x00\x00\x00\x40\x55\x00\x00\x00\x00\x00\x00", # [19..23]
- 'signal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
- 'substr' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
- 'syntax' => "\x00\x00\x00\x00\x00\x00\x50\x55\x55\x05\x00\x00", # [26..37]
- 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
- 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
- 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
- 'unopened' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
- 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
- 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
- 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
- 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
- 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
+ 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
+ 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28]
+ 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
+ 'chmod' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
+ 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
+ 'closure' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+ 'debugging' => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21]
+ 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
+ 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
+ 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
+ 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'inplace' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
+ 'internal' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
+ 'io' => "\x00\x54\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
+ 'malloc' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
+ 'misc' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
+ 'newline' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
+ 'numeric' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
+ 'once' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
+ 'overflow' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
+ 'pack' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
+ 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
+ 'pipe' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
+ 'portable' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
+ 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
+ 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
+ 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
+ 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
+ 'recursion' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
+ 'redefine' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
+ 'regexp' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
+ 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
+ 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
+ 'severe' => "\x00\x00\x00\x00\x00\x55\x01\x00\x00\x00\x00\x00", # [20..24]
+ 'signal' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
+ 'substr' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x40\x55\x55\x15\x00\x00", # [27..38]
+ 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
+ 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
+ 'unopened' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
+ 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
);
%DeadBits = (
- 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
- 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
- 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28]
- 'chmod' => "\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [0]
- 'closed' => "\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5]
- 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
- 'debugging' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
- 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
- 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
- 'exec' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
- 'exiting' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
- 'glob' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
- 'inplace' => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21]
- 'internal' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
- 'io' => "\x00\xaa\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9]
- 'malloc' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
- 'misc' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
- 'newline' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
- 'numeric' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
- 'once' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
- 'overflow' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
- 'pack' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
- 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
- 'pipe' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
- 'portable' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
- 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
- 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
- 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
- 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
- 'recursion' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
- 'redefine' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
- 'regexp' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
- 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
- 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
- 'severe' => "\x00\x00\x00\x00\x80\xaa\x00\x00\x00\x00\x00\x00", # [19..23]
- 'signal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
- 'substr' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
- 'syntax' => "\x00\x00\x00\x00\x00\x00\xa0\xaa\xaa\x0a\x00\x00", # [26..37]
- 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
- 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
- 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
- 'unopened' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
- 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
- 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
- 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
- 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
- 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
+ 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
+ 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28]
+ 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
+ 'chmod' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
+ 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
+ 'closure' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+ 'debugging' => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21]
+ 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
+ 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
+ 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
+ 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'inplace' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
+ 'internal' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
+ 'io' => "\x00\xa8\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
+ 'malloc' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
+ 'misc' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
+ 'newline' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
+ 'numeric' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
+ 'once' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
+ 'overflow' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
+ 'pack' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
+ 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
+ 'pipe' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
+ 'portable' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
+ 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
+ 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
+ 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
+ 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
+ 'recursion' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
+ 'redefine' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
+ 'regexp' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
+ 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
+ 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
+ 'severe' => "\x00\x00\x00\x00\x00\xaa\x02\x00\x00\x00\x00\x00", # [20..24]
+ 'signal' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
+ 'substr' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x80\xaa\xaa\x2a\x00\x00", # [27..38]
+ 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
+ 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
+ 'unopened' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
+ 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
);
-$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
+$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
+$LAST_BIT = 94 ;
+$BYTES = 12 ;
+
+$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
sub bits {
my $mask ;
if ($word eq 'FATAL') {
$fatal = 1;
}
- else {
- if ($catmask = $Bits{$word}) {
- $mask |= $catmask ;
- $mask |= $DeadBits{$word} if $fatal ;
- }
+ elsif ($catmask = $Bits{$word}) {
+ $mask |= $catmask ;
+ $mask |= $DeadBits{$word} if $fatal ;
}
+ else
+ { croak("unknown warnings category '$word'")}
}
return $mask ;
sub unimport {
shift;
- ${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ;
+ my $mask = ${^WARNING_BITS} ;
+ if (vec($mask, $Offsets{'all'}, 1)) {
+ $mask = $Bits{'all'} ;
+ $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
+ }
+ ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
}
sub enabled
{
- # If no parameters, check for any lexical warnings enabled
- # in the users scope.
+ croak("Usage: warnings::enabled([category])")
+ unless @_ == 1 || @_ == 0 ;
+ local $Carp::CarpLevel = 1 ;
+ my $category ;
+ my $offset ;
my $callers_bitmask = (caller(1))[9] ;
- return ($callers_bitmask ne $NONE) if @_ == 0 ;
-
- # otherwise check for the category supplied.
- my $category = shift ;
- return 0
- unless $Bits{$category} ;
return 0 unless defined $callers_bitmask ;
- return 1
- if ($callers_bitmask & $Bits{$category}) ne $NONE ;
-
- return 0 ;
+
+
+ if (@_) {
+ # check the category supplied.
+ $category = shift ;
+ $offset = $Offsets{$category};
+ croak("unknown warnings category '$category'")
+ unless defined $offset;
+ }
+ else {
+ $category = (caller(0))[0] ;
+ $offset = $Offsets{$category};
+ croak("package '$category' not registered for warnings")
+ unless defined $offset ;
+ }
+
+ return vec($callers_bitmask, $offset, 1) ||
+ vec($callers_bitmask, $Offsets{'all'}, 1) ;
}
+
sub warn
{
- croak "Usage: warnings::warn('category', 'message')"
- unless @_ == 2 ;
- my $category = shift ;
- my $message = shift ;
+ croak("Usage: warnings::warn([category,] 'message')")
+ unless @_ == 2 || @_ == 1 ;
local $Carp::CarpLevel = 1 ;
+ my $category ;
+ my $offset ;
my $callers_bitmask = (caller(1))[9] ;
+
+ if (@_ == 2) {
+ $category = shift ;
+ $offset = $Offsets{$category};
+ croak("unknown warnings category '$category'")
+ unless defined $offset ;
+ }
+ else {
+ $category = (caller(0))[0] ;
+ $offset = $Offsets{$category};
+ croak("package '$category' not registered for warnings")
+ unless defined $offset ;
+ }
+
+ my $message = shift ;
croak($message)
- if defined $callers_bitmask &&
- ($callers_bitmask & $DeadBits{$category}) ne $NONE ;
+ if vec($callers_bitmask, $offset+1, 1) ||
+ vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
carp($message) ;
}
--- /dev/null
+package warnings::register ;
+
+require warnings ;
+
+sub mkMask
+{
+ my ($bit) = @_ ;
+ my $mask = "" ;
+
+ vec($mask, $bit, 1) = 1 ;
+ return $mask ;
+}
+
+sub import
+{
+ shift ;
+ my $package = (caller(0))[0] ;
+ if (! defined $warnings::Bits{$package}) {
+ $warnings::Bits{$package} = mkMask($warnings::LAST_BIT) ;
+ vec($warnings::Bits{'all'}, $warnings::LAST_BIT, 1) = 1 ;
+ $warnings::Offsets{$package} = $warnings::LAST_BIT ++ ;
+ foreach my $k (keys %warnings::Bits) {
+ vec($warnings::Bits{$k}, $warnings::LAST_BIT, 1) = 0 ;
+ }
+ $warnings::DeadBits{$package} = mkMask($warnings::LAST_BIT);
+ vec($warnings::DeadBits{'all'}, $warnings::LAST_BIT++, 1) = 1 ;
+ }
+}
+
+1 ;
if (*(mg->mg_ptr+1) == '\0')
sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) {
- if (PL_compiling.cop_warnings == WARN_NONE ||
- PL_compiling.cop_warnings == WARN_STD)
+ if (PL_compiling.cop_warnings == pWARN_NONE ||
+ PL_compiling.cop_warnings == pWARN_STD)
{
sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
}
- else if (PL_compiling.cop_warnings == WARN_ALL) {
+ else if (PL_compiling.cop_warnings == pWARN_ALL) {
sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
}
else {
sv_setsv(sv, PL_compiling.cop_warnings);
}
+ SvPOK_only(sv);
}
else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS"))
sv_setiv(sv, (IV)PL_widesyscalls);
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
if (!SvPOK(sv) && PL_localizing) {
sv_setpvn(sv, WARN_NONEstring, WARNsize);
- PL_compiling.cop_warnings = WARN_NONE;
+ PL_compiling.cop_warnings = pWARN_NONE;
break;
}
- if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize)) {
- PL_compiling.cop_warnings = WARN_ALL;
+ if (isWARN_on(sv, WARN_ALL)) {
+ PL_compiling.cop_warnings = pWARN_ALL;
PL_dowarn |= G_WARN_ONCE ;
}
- else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize))
- PL_compiling.cop_warnings = WARN_NONE;
- else {
- if (specialWARN(PL_compiling.cop_warnings))
- PL_compiling.cop_warnings = newSVsv(sv) ;
- else
- sv_setsv(PL_compiling.cop_warnings, sv);
- if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
- PL_dowarn |= G_WARN_ONCE ;
- }
+ else {
+ int i ;
+ int accumulate = 0 ;
+ int len ;
+ char * ptr = (char*)SvPV(sv, len) ;
+ for (i = 0 ; i < len ; ++i)
+ accumulate += ptr[i] ;
+ if (!accumulate)
+ PL_compiling.cop_warnings = pWARN_NONE;
+ else {
+ if (specialWARN(PL_compiling.cop_warnings))
+ PL_compiling.cop_warnings = newSVsv(sv) ;
+ else
+ sv_setsv(PL_compiling.cop_warnings, sv);
+ if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
+ PL_dowarn |= G_WARN_ONCE ;
+ }
+ }
}
}
else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS"))
return s;
case 'W':
PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
- PL_compiling.cop_warnings = WARN_ALL ;
+ PL_compiling.cop_warnings = pWARN_ALL ;
s++;
return s;
case 'X':
PL_dowarn = G_WARN_ALL_OFF;
- PL_compiling.cop_warnings = WARN_NONE ;
+ PL_compiling.cop_warnings = pWARN_NONE ;
s++;
return s;
case '*':
=head2 Reporting Warnings from a Module
-The C<warnings> pragma provides two functions, namely C<warnings::enabled>
-and C<warnings::warn>, that are useful for module authors. They are
-used when you want to report a module-specific warning, but only when
-the calling module has enabled warnings via the C<warnings> pragma.
+The C<warnings> pragma provides a number of functions that are useful for
+module authors. These are used when you want to report a module-specific
+warning when the calling module has enabled warnings via the C<warnings>
+pragma.
-Consider the module C<abc> below.
+Consider the module C<MyMod::Abc> below.
- package abc;
+ package MyMod::Abc;
- sub open
- {
+ use warnings::register;
+
+ sub open {
+ my $path = shift ;
+ if (warnings::enabled() && $path !~ m#^/#) {
+ warnings::warn("changing relative path to /tmp/");
+ $path = "/tmp/$path" ;
+ }
+ }
+
+ 1 ;
+
+The call to C<warnings::register> will create a new warnings category
+called "MyMod::abc", i.e. the new category name matches the module
+name. The C<open> function in the module will display a warning message
+if it gets given a relative path as a parameter. This warnings will only
+be displayed if the code that uses C<MyMod::Abc> has actually enabled
+them with the C<warnings> pragma like below.
+
+ use MyMod::Abc;
+ use warnings 'MyMod::Abc';
+ ...
+ abc::open("../fred.txt");
+
+It is also possible to test whether the pre-defined warnings categories are
+set in the calling module with the C<warnings::enabled> function. Consider
+this snippet of code:
+
+ package MyMod::Abc;
+
+ sub open {
if (warnings::enabled("deprecated")) {
warnings::warn("deprecated",
- "abc::open is deprecated. Use abc:new") ;
+ "open is deprecated, use new instead") ;
}
new(@_) ;
}
"deprecated" warnings category enabled. Something like this, say.
use warnings 'deprecated';
- use abc;
+ use MyMod::Abc;
...
- abc::open($filename) ;
-
+ MyMod::Abc::open($filename) ;
-If the calling module has escalated the "deprecated" warnings category
-into a fatal error like this:
+The C<warnings::warn> function should be used to actually display the
+warnings message. This is because they can make use of the feature that
+allows warnings to be escalated into fatal errors. So in this case
- use warnings 'FATAL deprecated';
- use abc;
+ use MyMod::Abc;
+ use warnings FATAL => 'MyMod::Abc';
...
- abc::open($filename) ;
+ MyMod::Abc::open('../fred.txt');
-then C<warnings::warn> will detect this and die after displaying the
-warning message.
+the C<warnings::warn> function will detect this and die after
+displaying the warning message.
=head1 TODO
{
SV * mask ;
SV * old_warnings = cx->blk_oldcop->cop_warnings ;
- if (old_warnings == WARN_NONE || old_warnings == WARN_STD)
+ if (old_warnings == pWARN_NONE || old_warnings == pWARN_STD)
mask = newSVpvn(WARN_NONEstring, WARNsize) ;
- else if (old_warnings == WARN_ALL)
+ else if (old_warnings == pWARN_ALL)
mask = newSVpvn(WARN_ALLstring, WARNsize) ;
else
mask = newSVsv(old_warnings);
PL_hints = 0;
SAVESPTR(PL_compiling.cop_warnings);
if (PL_dowarn & G_WARN_ALL_ON)
- PL_compiling.cop_warnings = WARN_ALL ;
+ PL_compiling.cop_warnings = pWARN_ALL ;
else if (PL_dowarn & G_WARN_ALL_OFF)
- PL_compiling.cop_warnings = WARN_NONE ;
+ PL_compiling.cop_warnings = pWARN_NONE ;
else
- PL_compiling.cop_warnings = WARN_STD ;
+ PL_compiling.cop_warnings = pWARN_STD ;
if (filter_sub || filter_child_proc) {
SV *datasv = filter_add(run_user_filter, Nullsv);
use strict;
my $count = 0;
-$^W = 1;
+use warnings;
print "1..4\n";
select(STDERR); $| = 1;
select(STDOUT); $| = 1;
-print "1..21\n";
+print "1..23\n";
use IO::Select 1.09;
$sel->remove($sel->handles);
print "not " unless $sel->count == 0 && !defined($sel->bits);
print "ok 21\n";
+
+# check warnings
+$SIG{__WARN__} = sub {
+ ++ $w
+ if $_[0] =~ /^Call to depreciated method 'has_error', use 'has_exception'/
+ } ;
+$w = 0 ;
+IO::Select::has_error();
+print "not " unless $w == 0 ;
+$w = 0 ;
+print "ok 22\n" ;
+use warnings 'IO::Select' ;
+IO::Select::has_error();
+print "not " unless $w == 1 ;
+$w = 0 ;
+print "ok 23\n" ;
use Socket;
-print "1..6\n";
+print "1..8\n";
if (socket(T,PF_INET,SOCK_STREAM,6)) {
print "ok 1\n";
print "# $!\n";
print "not ok 4\n";
}
+
+# warnings
+$SIG{__WARN__} = sub {
+ ++ $w if $_[0] =~ /^6-ARG sockaddr_in call is deprecated/ ;
+} ;
+$w = 0 ;
+sockaddr_in(1,2,3,4,5,6) ;
+print ($w == 1 ? "not ok 7\n" : "ok 7\n") ;
+use warnings 'Socket' ;
+sockaddr_in(1,2,3,4,5,6) ;
+print ($w == 1 ? "ok 8\n" : "not ok 8\n") ;
print "not " unless close($f);
print "ok 13\n";
unlink("afile");
-
-
# strict behaviour, without any extra references
use warnings 'untie';
-#local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
# strict behaviour, with 1 extra references generating an error
use warnings 'untie';
-#local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
untie %h;
# strict behaviour, with 1 extra references via tied generating an error
use warnings 'untie';
-#local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
# strict behaviour, with 1 extra references which are destroyed
use warnings 'untie';
-#local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$a = 0 ;
# strict behaviour, with extra 1 references via tied which are destroyed
use warnings 'untie';
-#local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
# strict error behaviour, with 2 extra references
use warnings 'untie';
-#local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$b = tied %h ;
# strict behaviour, check scope of strictness.
no warnings 'untie';
-#local $^W = 0 ;
use Tie::Hash ;
$A = tie %H, Tie::StdHash;
$C = $B = tied %H ;
{
use warnings 'untie';
- #local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
######################### We start with some black magic to print on failure.
-BEGIN { $| = 1; print "1..58\n"; }
+BEGIN { $| = 1; print "1..73\n"; }
END {print "not ok 1\n" unless $loaded;}
use constant 1.01;
$loaded = 1;
use constant TRAILING => '12 cats';
{
- my $save_warn;
- local $^W;
- BEGIN { $save_warn = $^W; $^W = 0 }
+ no warnings 'numeric';
test 24, TRAILING == 12;
- BEGIN { $^W = $save_warn }
}
test 25, TRAILING eq '12 cats';
test 57, declared 'Other::IN_OTHER_PACK';
test 58, $constant::declared{'Other::IN_OTHER_PACK'};
+
+@warnings = ();
+eval q{
+{
+ use warnings 'constant';
+ use constant 'BEGIN' => 1 ;
+ use constant 'INIT' => 1 ;
+ use constant 'CHECK' => 1 ;
+ use constant 'END' => 1 ;
+ use constant 'DESTROY' => 1 ;
+ use constant 'AUTOLOAD' => 1 ;
+ use constant 'STDIN' => 1 ;
+ use constant 'STDOUT' => 1 ;
+ use constant 'STDERR' => 1 ;
+ use constant 'ARGV' => 1 ;
+ use constant 'ARGVOUT' => 1 ;
+ use constant 'ENV' => 1 ;
+ use constant 'INC' => 1 ;
+ use constant 'SIG' => 1 ;
+}
+};
+
+test 59, @warnings == 14 ;
+test 60, (shift @warnings) =~ /^Constant name 'BEGIN' is a Perl keyword at/;
+test 61, (shift @warnings) =~ /^Constant name 'INIT' is a Perl keyword at/;
+test 62, (shift @warnings) =~ /^Constant name 'CHECK' is a Perl keyword at/;
+test 63, (shift @warnings) =~ /^Constant name 'END' is a Perl keyword at/;
+test 64, (shift @warnings) =~ /^Constant name 'DESTROY' is a Perl keyword at/;
+test 65, (shift @warnings) =~ /^Constant name 'AUTOLOAD' is a Perl keyword at/;
+test 66, (shift @warnings) =~ /^Constant name 'STDIN' is forced into package main:: a/;
+test 67, (shift @warnings) =~ /^Constant name 'STDOUT' is forced into package main:: at/;
+test 68, (shift @warnings) =~ /^Constant name 'STDERR' is forced into package main:: at/;
+test 69, (shift @warnings) =~ /^Constant name 'ARGV' is forced into package main:: at/;
+test 70, (shift @warnings) =~ /^Constant name 'ARGVOUT' is forced into package main:: at/;
+test 71, (shift @warnings) =~ /^Constant name 'ENV' is forced into package main:: at/;
+test 72, (shift @warnings) =~ /^Constant name 'INC' is forced into package main:: at/;
+test 73, (shift @warnings) =~ /^Constant name 'SIG' is forced into package main:: at/;
+@warnings = ();
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
use strict;
+use warnings;
use vars qw($Test_Num $Total_tests);
my $loaded;
-BEGIN { $| = 1; $^W = 1; $Test_Num = 1 }
+BEGIN { $| = 1; $Test_Num = 1 }
END {print "not ok $Test_Num\n" unless $loaded;}
print "1..$Total_tests\n";
BEGIN { require diagnostics; } # Don't want diagnostics' noise yet.
__END__
-# ignore unknown warning categories
+# check illegal category is caught
use warnings 'this-should-never-be-a-warning-category' ;
EXPECT
+unknown warnings category 'this-should-never-be-a-warning-category' at - line 3
+BEGIN failed--compilation aborted at - line 3.
########
# Check compile time scope of pragma
--FILE-- abc.pm
package abc ;
use warnings "io" ;
-print "ok1\n" if ! warnings::enabled() ;
+print "ok1\n" if ! warnings::enabled('all') ;
print "ok2\n" if ! warnings::enabled("io") ;
1;
--FILE--
--FILE-- abc.pm
package abc ;
no warnings ;
-print "ok1\n" if warnings::enabled() ;
+print "ok1\n" if !warnings::enabled('all') ;
print "ok2\n" if warnings::enabled("syntax") ;
1;
--FILE--
--FILE-- abc.pm
package abc ;
use warnings 'syntax' ;
-print "ok1\n" if warnings::enabled() ;
+print "ok1\n" if warnings::enabled('io') ;
print "ok2\n" if ! warnings::enabled("syntax") ;
1;
--FILE--
--FILE-- abc
no warnings ;
-print "ok1\n" if warnings::enabled() ;
+print "ok1\n" if !warnings::enabled('all') ;
print "ok2\n" if warnings::enabled("syntax") ;
1;
--FILE--
--FILE-- abc
use warnings 'syntax' ;
-print "ok1\n" if warnings::enabled ;
+print "ok1\n" if ! warnings::enabled('all') ;
print "ok2\n" if ! warnings::enabled("syntax") ;
print "ok3\n" if warnings::enabled("io") ;
1;
package abc ;
no warnings ;
sub check {
- print "ok1\n" if warnings::enabled ;
+ print "ok1\n" if !warnings::enabled('all') ;
print "ok2\n" if warnings::enabled("syntax") ;
}
1;
package abc ;
use warnings 'io' ;
sub check {
- print "ok1\n" if warnings::enabled ;
- print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok1\n" if ! warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
print "ok3\n" if ! warnings::enabled("io") ;
}
1;
package abc ;
no warnings ;
sub check {
- print "ok1\n" if warnings::enabled ;
+ print "ok1\n" if !warnings::enabled('all') ;
print "ok2\n" if warnings::enabled("syntax") ;
}
1;
package abc ;
use warnings 'io' ;
sub check {
- print "ok1\n" if warnings::enabled ;
- print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok1\n" if ! warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
print "ok3\n" if ! warnings::enabled("io") ;
}
1;
--FILE-- abc.pm
package abc ;
use warnings "io" ;
-print "ok1\n" if ! warnings::enabled() ;
+print "ok1\n" if ! warnings::enabled('all') ;
print "ok2\n" if ! warnings::enabled("io") ;
1;
--FILE-- def.pm
--FILE-- abc.pm
package abc ;
no warnings ;
-print "ok1\n" if warnings::enabled() ;
+print "ok1\n" if ! warnings::enabled('all') ;
print "ok2\n" if warnings::enabled("syntax") ;
print "ok3\n" if !warnings::enabled("io") ;
1;
--FILE-- def.pm
use warnings 'syntax' ;
-print "ok4\n" if warnings::enabled() ;
+print "ok4\n" if !warnings::enabled('all') ;
print "ok5\n" if warnings::enabled("io") ;
use abc ;
1;
package abc ;
no warnings ;
sub check {
- print "ok1\n" if warnings::enabled ;
+ print "ok1\n" if !warnings::enabled('all') ;
print "ok2\n" if warnings::enabled("syntax") ;
}
1;
package abc ;
use warnings 'io' ;
sub check {
- print "ok1\n" if warnings::enabled ;
- print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok1\n" if ! warnings::enabled('all') ;
+ print "ok2\n" if warnings::enabled("syntax") ;
print "ok3\n" if ! warnings::enabled("io") ;
}
1;
package abc ;
no warnings ;
sub check {
- print "ok1\n" if warnings::enabled ;
+ print "ok1\n" if !warnings::enabled('all') ;
print "ok2\n" if warnings::enabled("syntax") ;
}
1;
package abc ;
use warnings 'io' ;
sub check {
- print "ok1\n" if warnings::enabled ;
+ print "ok1\n" if !warnings::enabled('all') ;
print "ok2\n" if warnings::enabled("syntax") ;
print "ok3\n" if warnings::enabled("io") ;
}
package abc ;
use warnings 'io' ;
sub check {
- print "ok1\n" if warnings::enabled ;
+ print "ok1\n" if ! warnings::enabled('all') ;
print "ok2\n" if warnings::enabled("syntax") ;
print "ok3\n" if ! warnings::enabled("io") ;
}
package abc ;
use warnings 'io' ;
sub check {
- print "ok1\n" if ! warnings::enabled ;
+ print "ok1\n" if ! warnings::enabled('all') ;
}
1;
--FILE--
package abc ;
use warnings 'misc' ;
sub check {
- print "ok1\n" if warnings::enabled ;
+ print "ok1\n" if ! warnings::enabled('all') ;
print "ok2\n" if warnings::enabled("syntax") ;
print "ok3\n" if warnings::enabled("io") ;
print "ok4\n" if ! warnings::enabled("misc") ;
use warnings ;
eval { warnings::warn() } ;
print $@ ;
-eval { warnings::warn("fred") } ;
+eval { warnings::warn("fred", "joe") } ;
print $@ ;
EXPECT
-Usage: warnings::warn('category', 'message') at - line 4
-Usage: warnings::warn('category', 'message') at - line 6
+Usage: warnings::warn([category,] 'message') at - line 4
+unknown warnings category 'fred' at - line 6
+ require 0 called at - line 6
########
--FILE-- abc.pm
EXPECT
[[hello at - line 3
]]
+########
+-W
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+print "ok1\n" if warnings::enabled("io") ;
+print "ok2\n" if warnings::enabled("all") ;
+1;
+--FILE--
+no warnings;
+use abc ;
+EXPECT
+ok1
+ok2
+########
+-X
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+print "ok1\n" if !warnings::enabled("io") ;
+print "ok2\n" if !warnings::enabled("all") ;
+1;
+--FILE--
+use warnings;
+use abc ;
+EXPECT
+ok1
+ok2
+########
+
+--FILE-- abc.pm
+package abc ;
+no warnings ;
+sub check {
+ print "ok\n" if ! warnings::enabled() ;
+}
+1;
+--FILE--
+use warnings 'syntax' ;
+use abc ;
+abc::check() ;
+EXPECT
+package 'abc' not registered for warnings at - line 3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'io' ;
+use warnings::register ;
+sub check {
+ print "ok1\n" if warnings::enabled ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if !warnings::enabled("io") ;
+}
+1;
+--FILE--
+use warnings 'syntax' ;
+use abc ;
+use warnings 'abc' ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'io' ;
+use warnings::register ;
+sub check {
+ print "ok1\n" if !warnings::enabled ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if !warnings::enabled("io") ;
+}
+1;
+--FILE--
+use warnings 'syntax' ;
+use abc ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+no warnings ;
+use warnings::register ;
+sub check {
+ print "ok1\n" if warnings::enabled ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+}
+1;
+--FILE--
+use warnings 'syntax' ;
+use abc ;
+use warnings 'abc' ;
+eval { abc::check() ; };
+print $@ ;
+EXPECT
+ok1
+ok2
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'io' ;
+use warnings::register ;
+sub check {
+ print "ok1\n" if !warnings::enabled ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if !warnings::enabled("io") ;
+}
+1;
+--FILE--
+use warnings 'syntax' ;
+use abc ;
+eval { abc::check() ; } ;
+print $@ ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'io' ;
+use warnings::register ;
+sub check {
+ print "ok1\n" if warnings::enabled ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if !warnings::enabled("io") ;
+}
+1;
+--FILE--
+use warnings 'syntax' ;
+use abc ;
+use warnings 'abc' ;
+sub fred { abc::check() }
+fred() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'io' ;
+use warnings::register ;
+sub check {
+ print "ok1\n" if ! warnings::enabled ;
+}
+1;
+--FILE--
+use warnings 'syntax' ;
+use abc ;
+sub fred { no warnings ; abc::check() }
+fred() ;
+EXPECT
+ok1
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'misc' ;
+use warnings::register;
+sub check {
+ print "ok1\n" if warnings::enabled ;
+ print "ok2\n" if warnings::enabled("syntax") ;
+ print "ok3\n" if warnings::enabled("io") ;
+ print "ok4\n" if ! warnings::enabled("misc") ;
+}
+1;
+--FILE--
+use warnings 'syntax' ;
+use abc ;
+use warnings 'abc' ;
+sub fred { use warnings 'io' ; abc::check() }
+fred() ;
+EXPECT
+ok1
+ok2
+ok3
+ok4
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings 'misc' ;
+use warnings::register;
+sub check { warnings::warn("hello") }
+1;
+--FILE--
+use abc;
+use warnings "abc" ;
+abc::check() ;
+EXPECT
+hello at - line 3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings::register;
+sub check { warnings::warn("hello") }
+1;
+--FILE--
+use abc;
+abc::check() ;
+EXPECT
+hello at - line 2
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings::register ;
+sub check { warnings::warn("hello") }
+1;
+--FILE--
+use abc;
+use warnings qw( FATAL deprecated ) ;
+eval { abc::check() ; } ;
+print "[[$@]]\n";
+EXPECT
+hello at - line 3
+[[]]
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings::register ;
+sub check { warnings::warn("hello") }
+1;
+--FILE--
+use abc;
+use warnings qw( FATAL abc ) ;
+eval { abc::check() ; } ;
+print "[[$@]]\n";
+EXPECT
+[[hello at - line 3
+]]
+########
+-W
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+use warnings::register ;
+sub check {
+ print "ok1\n" if warnings::enabled() ;
+ print "ok2\n" if warnings::enabled("io") ;
+ print "ok3\n" if warnings::enabled("all") ;
+}
+1;
+--FILE--
+no warnings;
+use abc ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+-X
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+use warnings::register ;
+sub check {
+ print "ok1\n" if !warnings::enabled() ;
+ print "ok2\n" if !warnings::enabled("io") ;
+ print "ok3\n" if !warnings::enabled("all") ;
+}
+1;
+--FILE--
+no warnings;
+use abc ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+use warnings::register ;
+sub check {
+ print "ok1\n" if warnings::enabled() ;
+ print "ok2\n" if warnings::enabled("io") ;
+ print "ok3\n" if warnings::enabled("all") ;
+}
+1;
+--FILE--
+use warnings 'all';
+use abc ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+use warnings::register ;
+sub check {
+ print "ok1\n" if !warnings::enabled() ;
+ print "ok2\n" if !warnings::enabled("io") ;
+ print "ok3\n" if !warnings::enabled("all") ;
+}
+1;
+--FILE--
+use abc ;
+no warnings ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+use warnings::register ;
+sub check {
+ print "ok1\n" if !warnings::enabled() ;
+ print "ok2\n" if !warnings::enabled("io") ;
+ print "ok3\n" if !warnings::enabled("all") ;
+}
+1;
+--FILE--
+use abc ;
+use warnings 'abc';
+no warnings ;
+abc::check() ;
+EXPECT
+ok1
+ok2
+ok3
+########
+
+--FILE-- abc.pm
+package abc ;
+use warnings "io" ;
+use warnings::register ;
+sub check {
+ print "abc self" . (warnings::enabled() ? "" : " not") . " enabled\n" ;
+ print "abc def" . (warnings::enabled('def') ? "" : " not") . " enabled\n" ;
+ print "abc all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ;
+}
+1;
+--FILE-- def.pm
+package def ;
+use warnings "io" ;
+use warnings::register ;
+sub check {
+ print "def self" . (warnings::enabled() ? "" : " not") . " enabled\n" ;
+ print "def abc" . (warnings::enabled('abc') ? "" : " not") . " enabled\n" ;
+ print "def all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ;
+}
+1;
+--FILE--
+use abc ;
+use def ;
+use warnings 'abc';
+abc::check() ;
+def::check() ;
+no warnings 'abc' ;
+use warnings 'def' ;
+abc::check() ;
+def::check() ;
+use warnings 'abc' ;
+use warnings 'def' ;
+abc::check() ;
+def::check() ;
+no warnings 'abc' ;
+no warnings 'def' ;
+abc::check() ;
+def::check() ;
+use warnings;
+abc::check() ;
+def::check() ;
+no warnings 'abc' ;
+abc::check() ;
+def::check() ;
+EXPECT
+abc self enabled
+abc def not enabled
+abc all not enabled
+def self not enabled
+def abc enabled
+def all not enabled
+abc self not enabled
+abc def enabled
+abc all not enabled
+def self enabled
+def abc not enabled
+def all not enabled
+abc self enabled
+abc def enabled
+abc all not enabled
+def self enabled
+def abc enabled
+def all not enabled
+abc self not enabled
+abc def not enabled
+abc all not enabled
+def self not enabled
+def abc not enabled
+def all not enabled
+abc self enabled
+abc def enabled
+abc all enabled
+def self enabled
+def abc enabled
+def all enabled
+abc self not enabled
+abc def enabled
+abc all not enabled
+def self enabled
+def abc not enabled
+def all not enabled
#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
-#define WARN_STD Nullsv
-#define WARN_ALL (Nullsv+1) /* use warnings 'all' */
-#define WARN_NONE (Nullsv+2) /* no warnings 'all' */
+#define pWARN_STD Nullsv
+#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
+#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
-#define specialWARN(x) ((x) == WARN_STD || (x) == WARN_ALL || \
- (x) == WARN_NONE)
+#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
+ (x) == pWARN_NONE)
#define ckDEAD(x) \
( ! specialWARN(PL_curcop->cop_warnings) && \
IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
#define ckWARN(x) \
- ( (PL_curcop->cop_warnings != WARN_STD && \
- PL_curcop->cop_warnings != WARN_NONE && \
- (PL_curcop->cop_warnings == WARN_ALL || \
+ ( (PL_curcop->cop_warnings != pWARN_STD && \
+ PL_curcop->cop_warnings != pWARN_NONE && \
+ (PL_curcop->cop_warnings == pWARN_ALL || \
IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \
- || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
+ || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) )
#define ckWARN2(x,y) \
- ( (PL_curcop->cop_warnings != WARN_STD && \
- PL_curcop->cop_warnings != WARN_NONE && \
- (PL_curcop->cop_warnings == WARN_ALL || \
+ ( (PL_curcop->cop_warnings != pWARN_STD && \
+ PL_curcop->cop_warnings != pWARN_NONE && \
+ (PL_curcop->cop_warnings == pWARN_ALL || \
IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \
IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \
- || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
+ || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) )
#define ckWARN_d(x) \
- (PL_curcop->cop_warnings == WARN_STD || \
- PL_curcop->cop_warnings == WARN_ALL || \
- (PL_curcop->cop_warnings != WARN_NONE && \
+ (PL_curcop->cop_warnings == pWARN_STD || \
+ PL_curcop->cop_warnings == pWARN_ALL || \
+ (PL_curcop->cop_warnings != pWARN_NONE && \
IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )
#define ckWARN2_d(x,y) \
- (PL_curcop->cop_warnings == WARN_STD || \
- PL_curcop->cop_warnings == WARN_ALL || \
- (PL_curcop->cop_warnings != WARN_NONE && \
+ (PL_curcop->cop_warnings == pWARN_STD || \
+ PL_curcop->cop_warnings == pWARN_ALL || \
+ (PL_curcop->cop_warnings != pWARN_NONE && \
(IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \
IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) )
-#define isLEXWARN_on (PL_curcop->cop_warnings != WARN_STD)
-#define isLEXWARN_off (PL_curcop->cop_warnings == WARN_STD)
+#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
+#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
-#define WARN_CHMOD 0
-#define WARN_CLOSURE 1
-#define WARN_EXITING 2
-#define WARN_GLOB 3
-#define WARN_IO 4
-#define WARN_CLOSED 5
-#define WARN_EXEC 6
-#define WARN_NEWLINE 7
-#define WARN_PIPE 8
-#define WARN_UNOPENED 9
-#define WARN_MISC 10
-#define WARN_NUMERIC 11
-#define WARN_ONCE 12
-#define WARN_OVERFLOW 13
-#define WARN_PACK 14
-#define WARN_PORTABLE 15
-#define WARN_RECURSION 16
-#define WARN_REDEFINE 17
-#define WARN_REGEXP 18
-#define WARN_SEVERE 19
-#define WARN_DEBUGGING 20
-#define WARN_INPLACE 21
-#define WARN_INTERNAL 22
-#define WARN_MALLOC 23
-#define WARN_SIGNAL 24
-#define WARN_SUBSTR 25
-#define WARN_SYNTAX 26
-#define WARN_AMBIGUOUS 27
-#define WARN_BAREWORD 28
-#define WARN_DEPRECATED 29
-#define WARN_DIGIT 30
-#define WARN_PARENTHESIS 31
-#define WARN_PRECEDENCE 32
-#define WARN_PRINTF 33
-#define WARN_PROTOTYPE 34
-#define WARN_QW 35
-#define WARN_RESERVED 36
-#define WARN_SEMICOLON 37
-#define WARN_TAINT 38
-#define WARN_UMASK 39
-#define WARN_UNINITIALIZED 40
-#define WARN_UNPACK 41
-#define WARN_UNTIE 42
-#define WARN_UTF8 43
-#define WARN_VOID 44
-#define WARN_Y2K 45
+#define WARN_ALL 0
+#define WARN_CHMOD 1
+#define WARN_CLOSURE 2
+#define WARN_EXITING 3
+#define WARN_GLOB 4
+#define WARN_IO 5
+#define WARN_CLOSED 6
+#define WARN_EXEC 7
+#define WARN_NEWLINE 8
+#define WARN_PIPE 9
+#define WARN_UNOPENED 10
+#define WARN_MISC 11
+#define WARN_NUMERIC 12
+#define WARN_ONCE 13
+#define WARN_OVERFLOW 14
+#define WARN_PACK 15
+#define WARN_PORTABLE 16
+#define WARN_RECURSION 17
+#define WARN_REDEFINE 18
+#define WARN_REGEXP 19
+#define WARN_SEVERE 20
+#define WARN_DEBUGGING 21
+#define WARN_INPLACE 22
+#define WARN_INTERNAL 23
+#define WARN_MALLOC 24
+#define WARN_SIGNAL 25
+#define WARN_SUBSTR 26
+#define WARN_SYNTAX 27
+#define WARN_AMBIGUOUS 28
+#define WARN_BAREWORD 29
+#define WARN_DEPRECATED 30
+#define WARN_DIGIT 31
+#define WARN_PARENTHESIS 32
+#define WARN_PRECEDENCE 33
+#define WARN_PRINTF 34
+#define WARN_PROTOTYPE 35
+#define WARN_QW 36
+#define WARN_RESERVED 37
+#define WARN_SEMICOLON 38
+#define WARN_TAINT 39
+#define WARN_UMASK 40
+#define WARN_UNINITIALIZED 41
+#define WARN_UNPACK 42
+#define WARN_UNTIE 43
+#define WARN_UTF8 44
+#define WARN_VOID 45
+#define WARN_Y2K 46
#define WARNsize 12
#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125"
sub DEFAULT_OFF () { 2 }
my $tree = {
+
+'all' => {
'io' => { 'pipe' => DEFAULT_OFF,
'unopened' => DEFAULT_OFF,
'closed' => DEFAULT_OFF,
'pack' => DEFAULT_OFF,
'unpack' => DEFAULT_OFF,
#'default' => DEFAULT_ON,
- } ;
+ }
+} ;
###########################################################################
my %list ;
my %Value ;
-my $index = 0 ;
+my $index ;
sub walk
{
if (@ARGV && $ARGV[0] eq "tree")
{
- print " all -+\n" ;
+ #print " all -+\n" ;
printTree($tree, " ", 4) ;
exit ;
}
#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
-#define WARN_STD Nullsv
-#define WARN_ALL (Nullsv+1) /* use warnings 'all' */
-#define WARN_NONE (Nullsv+2) /* no warnings 'all' */
+#define pWARN_STD Nullsv
+#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
+#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
-#define specialWARN(x) ((x) == WARN_STD || (x) == WARN_ALL || \
- (x) == WARN_NONE)
+#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
+ (x) == pWARN_NONE)
#define ckDEAD(x) \
( ! specialWARN(PL_curcop->cop_warnings) && \
IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
#define ckWARN(x) \
- ( (PL_curcop->cop_warnings != WARN_STD && \
- PL_curcop->cop_warnings != WARN_NONE && \
- (PL_curcop->cop_warnings == WARN_ALL || \
+ ( (PL_curcop->cop_warnings != pWARN_STD && \
+ PL_curcop->cop_warnings != pWARN_NONE && \
+ (PL_curcop->cop_warnings == pWARN_ALL || \
IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \
- || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
+ || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) )
#define ckWARN2(x,y) \
- ( (PL_curcop->cop_warnings != WARN_STD && \
- PL_curcop->cop_warnings != WARN_NONE && \
- (PL_curcop->cop_warnings == WARN_ALL || \
+ ( (PL_curcop->cop_warnings != pWARN_STD && \
+ PL_curcop->cop_warnings != pWARN_NONE && \
+ (PL_curcop->cop_warnings == pWARN_ALL || \
IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \
IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \
- || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
+ || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) )
#define ckWARN_d(x) \
- (PL_curcop->cop_warnings == WARN_STD || \
- PL_curcop->cop_warnings == WARN_ALL || \
- (PL_curcop->cop_warnings != WARN_NONE && \
+ (PL_curcop->cop_warnings == pWARN_STD || \
+ PL_curcop->cop_warnings == pWARN_ALL || \
+ (PL_curcop->cop_warnings != pWARN_NONE && \
IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )
#define ckWARN2_d(x,y) \
- (PL_curcop->cop_warnings == WARN_STD || \
- PL_curcop->cop_warnings == WARN_ALL || \
- (PL_curcop->cop_warnings != WARN_NONE && \
+ (PL_curcop->cop_warnings == pWARN_STD || \
+ PL_curcop->cop_warnings == pWARN_ALL || \
+ (PL_curcop->cop_warnings != pWARN_NONE && \
(IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \
IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) )
-#define isLEXWARN_on (PL_curcop->cop_warnings != WARN_STD)
-#define isLEXWARN_off (PL_curcop->cop_warnings == WARN_STD)
+#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
+#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
EOM
+my $offset = 0 ;
+
+$index = $offset ;
+#@{ $list{"all"} } = walk ($tree) ;
+walk ($tree) ;
-$index = 0 ;
-@{ $list{"all"} } = walk ($tree) ;
$index *= 2 ;
my $warn_size = int($index / 8) + ($index % 8 != 0) ;
print PM $_ ;
}
-$list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
+#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
+
+#my %Keys = map {lc $Value{$_}, $_} keys %Value ;
+
+print PM "%Offsets = (\n" ;
+foreach my $k (sort { $a <=> $b } keys %Value) {
+ my $v = lc $Value{$k} ;
+ $k *= 2 ;
+ print PM tab(4, " '$v'"), "=> $k,\n" ;
+}
+
+print PM " );\n\n" ;
+
print PM "%Bits = (\n" ;
foreach $k (sort keys %list) {
}
print PM " );\n\n" ;
-print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
+print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
+print PM '$LAST_BIT = ' . "$index ;\n" ;
+print PM '$BYTES = ' . "$warn_size ;\n" ;
while (<DATA>) {
print PM $_ ;
}
use warnings "all";
no warnings "all";
- if (warnings::enabled("void") {
+ use warnings::register;
+ if (warnings::enabled()) {
+ warnings::warn("some warning");
+ }
+
+ if (warnings::enabled("void")) {
warnings::warn("void", "some warning");
}
If no import list is supplied, all possible warnings are either enabled
or disabled.
-Two functions are provided to assist module authors.
+A number of functions are provided to assist module authors.
=over 4
-=item warnings::enabled($category)
+=item use warnings::register
+
+Creates a new warnings category which has the same name as the module
+where the call to the pragma is used.
+
+=item warnings::enabled([$category])
-Returns TRUE if the warnings category in C<$category> is enabled in the
-calling module. Otherwise returns FALSE.
+Returns TRUE if the warnings category C<$category> is enabled in the
+calling module. Otherwise returns FALSE.
+If the parameter, C<$category>, isn't supplied, the current package name
+will be used.
-=item warnings::warn($category, $message)
+=item warnings::warn([$category,] $message)
If the calling module has I<not> set C<$category> to "FATAL", print
C<$message> to STDERR.
If the calling module has set C<$category> to "FATAL", print C<$message>
STDERR then die.
+If the parameter, C<$category>, isn't supplied, the current package name
+will be used.
+
=back
See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
KEYWORDS
+$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
+
sub bits {
my $mask ;
my $catmask ;
if ($word eq 'FATAL') {
$fatal = 1;
}
- else {
- if ($catmask = $Bits{$word}) {
- $mask |= $catmask ;
- $mask |= $DeadBits{$word} if $fatal ;
- }
+ elsif ($catmask = $Bits{$word}) {
+ $mask |= $catmask ;
+ $mask |= $DeadBits{$word} if $fatal ;
}
+ else
+ { croak("unknown warnings category '$word'")}
}
return $mask ;
sub unimport {
shift;
- ${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ;
+ my $mask = ${^WARNING_BITS} ;
+ if (vec($mask, $Offsets{'all'}, 1)) {
+ $mask = $Bits{'all'} ;
+ $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
+ }
+ ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
}
sub enabled
{
- # If no parameters, check for any lexical warnings enabled
- # in the users scope.
+ croak("Usage: warnings::enabled([category])")
+ unless @_ == 1 || @_ == 0 ;
+ local $Carp::CarpLevel = 1 ;
+ my $category ;
+ my $offset ;
my $callers_bitmask = (caller(1))[9] ;
- return ($callers_bitmask ne $NONE) if @_ == 0 ;
-
- # otherwise check for the category supplied.
- my $category = shift ;
- return 0
- unless $Bits{$category} ;
return 0 unless defined $callers_bitmask ;
- return 1
- if ($callers_bitmask & $Bits{$category}) ne $NONE ;
-
- return 0 ;
+
+
+ if (@_) {
+ # check the category supplied.
+ $category = shift ;
+ $offset = $Offsets{$category};
+ croak("unknown warnings category '$category'")
+ unless defined $offset;
+ }
+ else {
+ $category = (caller(0))[0] ;
+ $offset = $Offsets{$category};
+ croak("package '$category' not registered for warnings")
+ unless defined $offset ;
+ }
+
+ return vec($callers_bitmask, $offset, 1) ||
+ vec($callers_bitmask, $Offsets{'all'}, 1) ;
}
+
sub warn
{
- croak "Usage: warnings::warn('category', 'message')"
- unless @_ == 2 ;
- my $category = shift ;
- my $message = shift ;
+ croak("Usage: warnings::warn([category,] 'message')")
+ unless @_ == 2 || @_ == 1 ;
local $Carp::CarpLevel = 1 ;
+ my $category ;
+ my $offset ;
my $callers_bitmask = (caller(1))[9] ;
+
+ if (@_ == 2) {
+ $category = shift ;
+ $offset = $Offsets{$category};
+ croak("unknown warnings category '$category'")
+ unless defined $offset ;
+ }
+ else {
+ $category = (caller(0))[0] ;
+ $offset = $Offsets{$category};
+ croak("package '$category' not registered for warnings")
+ unless defined $offset ;
+ }
+
+ my $message = shift ;
croak($message)
- if defined $callers_bitmask &&
- ($callers_bitmask & $DeadBits{$category}) ne $NONE ;
+ if vec($callers_bitmask, $offset+1, 1) ||
+ vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
carp($message) ;
}
projects / p5sagit/p5-mst-13.2.git / commitdiff