final touches for lexical warnings (from Paul Marquess)

p4raw-id: //depot/perl@5702

diff --git a/MANIFEST b/MANIFEST
index f8ea07a..f097747 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -939,6 +939,7 @@ lib/utf8_heavy.pl                           Support routines for utf8 pragma
 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

diff --git a/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm
index 1d8cda6..df92b04 100644 (file)
--- a/ext/IO/lib/IO/Select.pm
+++ b/ext/IO/lib/IO/Select.pm
@@ -7,10 +7,11 @@
 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
 
@@ -129,9 +130,8 @@ sub has_exception
 
 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;
 }
 

diff --git a/ext/Socket/Socket.pm b/ext/Socket/Socket.pm
index f83cb18..02f098d 100644 (file)
--- a/ext/Socket/Socket.pm
+++ b/ext/Socket/Socket.pm
@@ -1,7 +1,7 @@
 package Socket;
 
 our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-$VERSION = "1.71";
+$VERSION = "1.72";
 
 =head1 NAME
 
@@ -160,6 +160,7 @@ have AF_UNIX in the right place.
 =cut
 
 use Carp;
+use warnings::register;
 
 require Exporter;
 use XSLoader ();
@@ -302,7 +303,8 @@ BEGIN {
 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;

diff --git a/lib/Class/Struct.pm b/lib/Class/Struct.pm
index b4f2117..63eddac 100644 (file)
--- a/lib/Class/Struct.pm
+++ b/lib/Class/Struct.pm
@@ -5,6 +5,7 @@ package Class::Struct;
 use 5.005_64;
 
 use strict;
+use warnings::register;
 our(@ISA, @EXPORT, $VERSION);
 
 use Carp;
@@ -167,8 +168,8 @@ sub struct {
     $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 = '';

diff --git a/lib/I18N/Collate.pm b/lib/I18N/Collate.pm
index 580ca39..64a03a2 100644 (file)
--- a/lib/I18N/Collate.pm
+++ b/lib/I18N/Collate.pm
@@ -108,6 +108,7 @@ European character set.
 # ---
 
 use POSIX qw(strxfrm LC_COLLATE);
+use warnings::register;
 
 require Exporter;
 
@@ -123,9 +124,9 @@ cmp         collate_cmp
 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

diff --git a/lib/Tie/Handle.pm b/lib/Tie/Handle.pm
index cbac735..588ecea 100644 (file)
--- a/lib/Tie/Handle.pm
+++ b/lib/Tie/Handle.pm
@@ -108,6 +108,7 @@ The L<perltie> section contains an example of tying handles.
 =cut
 
 use Carp;
+use warnings::register;
 
 sub new {
     my $pkg = shift;
@@ -119,8 +120,8 @@ sub new {
 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 {

diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm
index 928b798..c6ec3d4 100644 (file)
--- a/lib/Tie/Hash.pm
+++ b/lib/Tie/Hash.pm
@@ -102,6 +102,7 @@ good working examples.
 =cut
 
 use Carp;
+use warnings::register;
 
 sub new {
     my $pkg = shift;
@@ -113,8 +114,8 @@ sub new {
 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 {

diff --git a/lib/Tie/Scalar.pm b/lib/Tie/Scalar.pm
index 1e2caee..0c67590 100644 (file)
--- a/lib/Tie/Scalar.pm
+++ b/lib/Tie/Scalar.pm
@@ -79,6 +79,7 @@ process IDs with priority.
 =cut
 
 use Carp;
+use warnings::register;
 
 sub new {
     my $pkg = shift;
@@ -90,8 +91,8 @@ sub new {
 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 {

diff --git a/lib/constant.pm b/lib/constant.pm
index b4fcd42..72ad793 100644 (file)
--- a/lib/constant.pm
+++ b/lib/constant.pm
@@ -2,9 +2,10 @@ package constant;
 
 use strict;
 use 5.005_64;
+use warnings::register;
 
 our($VERSION, %declared);
-$VERSION = '1.01';
+$VERSION = '1.02';
 
 #=======================================================================
 
@@ -51,18 +52,17 @@ sub import {
     # 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");
            }
        }
 

diff --git a/lib/syslog.pl b/lib/syslog.pl
index 9e03399..70c439b 100644 (file)
--- a/lib/syslog.pl
+++ b/lib/syslog.pl
@@ -29,10 +29,12 @@
 
 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';

diff --git a/lib/vars.pm b/lib/vars.pm
index 6ae5373..bde0b2a 100644 (file)
--- a/lib/vars.pm
+++ b/lib/vars.pm
@@ -8,6 +8,7 @@ require 5.002;
 # 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;
@@ -22,9 +23,8 @@ sub import {
            } 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"} =

diff --git a/lib/warnings.pm b/lib/warnings.pm
index 11fd5b0..11558d5 100644 (file)
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -17,7 +17,12 @@ warnings - Perl pragma to control optional warnings
     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");
     }
 
@@ -26,23 +31,33 @@ warnings - Perl pragma to control optional warnings
 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>.
@@ -51,107 +66,161 @@ 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 ;
@@ -161,12 +230,12 @@ sub bits {
        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 ;
@@ -179,38 +248,70 @@ sub import {
 
 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) ;
 }
 

diff --git a/lib/warnings/register.pm b/lib/warnings/register.pm
new file mode 100644 (file)
index 0000000..da6be97
--- /dev/null
+++ b/lib/warnings/register.pm
@@ -0,0 +1,30 @@
+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 ;

diff --git a/mg.c b/mg.c
index 96d268b..8bdb2ee 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -565,17 +565,18 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        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);
@@ -1715,23 +1716,31 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
            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"))

diff --git a/perl.c b/perl.c
index 3569e93..e517451 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -2233,12 +2233,12 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
        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 '*':

diff --git a/pod/perllexwarn.pod b/pod/perllexwarn.pod
index af1a910..cee1687 100644 (file)
--- a/pod/perllexwarn.pod
+++ b/pod/perllexwarn.pod
@@ -339,20 +339,49 @@ fatal error.
 
 =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(@_) ;
     }
@@ -366,21 +395,21 @@ display a warning message whenever the calling module has (at least) the
 "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
 

diff --git a/pp_ctl.c b/pp_ctl.c
index 4917b02..cee753a 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1562,9 +1562,9 @@ PP(pp_caller)
     {
        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);
@@ -3167,11 +3167,11 @@ PP(pp_require)
     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);

diff --git a/t/lib/filepath.t b/t/lib/filepath.t
index 40e6e21..5628d0c 100755 (executable)
--- a/t/lib/filepath.t
+++ b/t/lib/filepath.t
@@ -9,7 +9,7 @@ use File::Path;
 use strict;
 
 my $count = 0;
-$^W = 1;
+use warnings;
 
 print "1..4\n";
 

diff --git a/t/lib/io_sel.t b/t/lib/io_sel.t
index e0d7a45..85e14ab 100755 (executable)
--- a/t/lib/io_sel.t
+++ b/t/lib/io_sel.t
@@ -10,7 +10,7 @@ BEGIN {
 select(STDERR); $| = 1;
 select(STDOUT); $| = 1;
 
-print "1..21\n";
+print "1..23\n";
 
 use IO::Select 1.09;
 
@@ -114,3 +114,19 @@ print "ok 20\n";
 $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" ;

diff --git a/t/lib/socket.t b/t/lib/socket.t
index 8f945ac..d5e1848 100755 (executable)
--- a/t/lib/socket.t
+++ b/t/lib/socket.t
@@ -13,7 +13,7 @@ BEGIN {
        
 use Socket;
 
-print "1..6\n";
+print "1..8\n";
 
 if (socket(T,PF_INET,SOCK_STREAM,6)) {
   print "ok 1\n";
@@ -74,3 +74,14 @@ else {
        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") ;

diff --git a/t/lib/tie-stdhandle.t b/t/lib/tie-stdhandle.t
index cb8303d..cf3a183 100755 (executable)
--- a/t/lib/tie-stdhandle.t
+++ b/t/lib/tie-stdhandle.t
@@ -45,5 +45,3 @@ print "ok 12\n";
 print "not " unless close($f);
 print "ok 13\n";
 unlink("afile");     
-
-

diff --git a/t/op/tie.t b/t/op/tie.t
index 105b1d6..9543420 100755 (executable)
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -78,7 +78,6 @@ EXPECT
 
 # strict behaviour, without any extra references
 use warnings 'untie';
-#local $^W = 1 ;
 use Tie::Hash ;
 tie %h, Tie::StdHash;
 untie %h;
@@ -87,7 +86,6 @@ EXPECT
 
 # 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;
@@ -97,7 +95,6 @@ untie attempted while 1 inner references still exist
 
 # 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;
@@ -108,7 +105,6 @@ untie attempted while 1 inner references still exist
 
 # 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 ;
@@ -118,7 +114,6 @@ EXPECT
 
 # 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;
@@ -129,7 +124,6 @@ EXPECT
 
 # strict error behaviour, with 2 extra references 
 use warnings 'untie';
-#local $^W = 1 ;
 use Tie::Hash ;
 $a = tie %h, Tie::StdHash;
 $b = tied %h ;
@@ -140,13 +134,11 @@ untie attempted while 2 inner references still exist
 
 # 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;

diff --git a/t/pragma/constant.t b/t/pragma/constant.t
index 5904a4f..443bcf6 100755 (executable)
--- a/t/pragma/constant.t
+++ b/t/pragma/constant.t
@@ -14,7 +14,7 @@ END { print @warnings }
 
 ######################### 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;
@@ -96,11 +96,8 @@ test 23, length(MESS) == 8;
 
 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';
 
@@ -194,3 +191,41 @@ test 52, !$constant::declared{'main::PIE'};
 
 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 = ();

diff --git a/t/pragma/diagnostics.t b/t/pragma/diagnostics.t
index 8c9a152..15cd6b5 100755 (executable)
--- a/t/pragma/diagnostics.t
+++ b/t/pragma/diagnostics.t
@@ -11,11 +11,12 @@ BEGIN {
 # 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.

diff --git a/t/pragma/warn/2use b/t/pragma/warn/2use
index 396f201..60a60c3 100644 (file)
--- a/t/pragma/warn/2use
+++ b/t/pragma/warn/2use
@@ -5,9 +5,11 @@ TODO
 
 __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

diff --git a/t/pragma/warn/9enabled b/t/pragma/warn/9enabled
index 1ecf24a..7facf99 100755 (executable)
--- a/t/pragma/warn/9enabled
+++ b/t/pragma/warn/9enabled
@@ -5,7 +5,7 @@ __END__
 --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-- 
@@ -19,7 +19,7 @@ ok2
 --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-- 
@@ -33,7 +33,7 @@ ok2
 --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-- 
@@ -46,7 +46,7 @@ ok2
 
 --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-- 
@@ -59,7 +59,7 @@ ok2
 
 --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;
@@ -76,7 +76,7 @@ ok3
 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;
@@ -93,8 +93,8 @@ ok2
 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;
@@ -112,7 +112,7 @@ ok3
 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;
@@ -129,8 +129,8 @@ ok2
 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;
@@ -147,7 +147,7 @@ ok3
 --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
@@ -165,13 +165,13 @@ ok2
 --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;
@@ -190,7 +190,7 @@ ok5
 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;
@@ -208,8 +208,8 @@ ok2
 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;
@@ -228,7 +228,7 @@ ok3
 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;
@@ -246,7 +246,7 @@ ok2
 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") ;
 }
@@ -269,7 +269,7 @@ ok2
 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") ;
 }
@@ -289,7 +289,7 @@ ok3
 package abc ;
 use warnings 'io' ;
 sub check {
-  print "ok1\n" if  ! warnings::enabled ;
+  print "ok1\n" if  ! warnings::enabled('all') ;
 }
 1;
 --FILE-- 
@@ -305,7 +305,7 @@ ok1
 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") ;
@@ -327,11 +327,12 @@ ok4
 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
@@ -388,3 +389,431 @@ print "[[$@]]\n";
 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

diff --git a/warnings.h b/warnings.h
index 31942e1..a2bcaeb 100644 (file)
--- a/warnings.h
+++ b/warnings.h
@@ -16,97 +16,98 @@
 #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"

diff --git a/warnings.pl b/warnings.pl
index 0952305..61602d5 100644 (file)
--- a/warnings.pl
+++ b/warnings.pl
@@ -9,6 +9,8 @@ sub DEFAULT_ON  () { 1 }
 sub DEFAULT_OFF () { 2 }
 
 my $tree = {
+
+'all' => {
                'io'            => {    'pipe'          => DEFAULT_OFF,
                                        'unopened'      => DEFAULT_OFF,
                                        'closed'        => DEFAULT_OFF,
@@ -56,7 +58,8 @@ my $tree = {
                'pack'          => DEFAULT_OFF,
                'unpack'        => DEFAULT_OFF,
                 #'default'     => DEFAULT_ON,
-       } ;
+       }
+} ;
 
 
 ###########################################################################
@@ -70,7 +73,7 @@ sub tab {
 
 my %list ;
 my %Value ;
-my $index = 0 ;
+my $index ;
 
 sub walk
 {
@@ -161,7 +164,7 @@ sub mkHex
 
 if (@ARGV && $ARGV[0] eq "tree")
 {
-    print "  all -+\n" ;
+    #print "  all -+\n" ;
     printTree($tree, "   ", 4) ;
     exit ;
 }
@@ -190,56 +193,59 @@ print WARN <<'EOM' ;
 #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) ;
@@ -268,7 +274,19 @@ while (<DATA>) {
     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) {
 
@@ -296,7 +314,9 @@ 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 $_ ;
 }
@@ -323,7 +343,12 @@ warnings - Perl pragma to control optional warnings
     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");
     }
 
@@ -332,23 +357,33 @@ warnings - Perl pragma to control optional warnings
 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>.
@@ -359,6 +394,8 @@ use Carp ;
 
 KEYWORDS
 
+$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
+
 sub bits {
     my $mask ;
     my $catmask ;
@@ -367,12 +404,12 @@ sub bits {
        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 ;
@@ -385,38 +422,70 @@ sub import {
 
 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) ;
 }