This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
lexical warnings update, ability to inspect bitmask in calling
authorGurusamy Sarathy <gsar@cpan.org>
Sun, 20 Feb 2000 22:58:09 +0000 (22:58 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Sun, 20 Feb 2000 22:58:09 +0000 (22:58 +0000)
scope, among other things (from Paul Marquess)

p4raw-id: //depot/perl@5170

26 files changed:
MANIFEST
lib/warnings.pm
malloc.c
mg.c
op.c
pod/perldiag.pod
pod/perlfunc.pod
pod/perllexwarn.pod
pp.c
pp_ctl.c
pp_hot.c
regcomp.c
regexec.c
sv.c
t/op/substr.t
t/pragma/warn/op
t/pragma/warn/pp
t/pragma/warn/pp_ctl
t/pragma/warn/pp_hot
t/pragma/warn/regcomp
t/pragma/warn/regexec
t/pragma/warn/sv
t/pragma/warn/toke
toke.c
warnings.h
warnings.pl

index 2ea10b0..1d8e59c 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1445,6 +1445,7 @@ t/pragma/warn/5nolint     Tests for -X switch
 t/pragma/warn/6default Tests default warnings
 t/pragma/warn/7fatal   Tests fatal warnings
 t/pragma/warn/8signal  Tests warnings + __WARN__ and __DIE__
+t/pragma/warn/9enabled Tests warnings
 t/pragma/warn/av       Tests for av.c for warnings.t
 t/pragma/warn/doio     Tests for doio.c for warnings.t
 t/pragma/warn/doop     Tests for doop.c for warnings.t
index b952295..11fd5b0 100644 (file)
@@ -17,98 +17,141 @@ warnings - Perl pragma to control optional warnings
     use warnings "all";
     no warnings "all";
 
+    if (warnings::enabled("void") {
+        warnings::warn("void", "some warning");
+    }
+
 =head1 DESCRIPTION
 
 If no import list is supplied, all possible warnings are either enabled
 or disabled.
 
-See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
+Two functions are provided to assist module authors.
+
+=over 4
+
+=item warnings::enabled($category)
+
+Returns TRUE if the warnings category in C<$category> is enabled in the
+calling module. Otherwise returns FALSE.
+
+
+=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.
+
+=back
+
+See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
 
 =cut
 
 use Carp ;
 
 %Bits = (
-    'all'              => "\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..35]
-    'ambiguous'                => "\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [16]
-    'bareword'         => "\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [17]
-    'closed'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
-    'closure'          => "\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [27]
-    'debugging'                => "\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [12]
-    'deprecated'       => "\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [18]
-    'digit'            => "\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [19]
-    'exec'             => "\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
-    'inplace'          => "\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [13]
-    'internal'         => "\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [14]
-    'io'               => "\x55\x05\x00\x00\x00\x00\x00\x00\x00", # [0..5]
-    'misc'             => "\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [6]
-    'newline'          => "\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
-    'numeric'          => "\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [7]
-    'octal'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [20]
-    'once'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [8]
-    'overflow'         => "\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [28]
-    'parenthesis'      => "\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [21]
-    'pipe'             => "\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [4]
-    'portable'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [29]
-    'printf'           => "\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [22]
-    'recursion'                => "\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [9]
-    'redefine'         => "\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [10]
-    'reserved'         => "\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [23]
-    'semicolon'                => "\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [24]
-    'severe'           => "\x00\x00\x40\x15\x00\x00\x00\x00\x00", # [11..14]
-    'signal'           => "\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [30]
-    'substr'           => "\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [31]
-    'syntax'           => "\x00\x00\x00\x40\x55\x55\x01\x00\x00", # [15..24]
-    'taint'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [32]
-    'uninitialized'    => "\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [25]
-    'unopened'         => "\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [5]
-    'unsafe'           => "\x00\x00\x00\x00\x00\x00\x50\x55\x15", # [26..34]
-    'untie'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [33]
-    'utf8'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [34]
-    'void'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [35]
+    '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]
   );
 
 %DeadBits = (
-    'all'              => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..35]
-    'ambiguous'                => "\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [16]
-    'bareword'         => "\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [17]
-    'closed'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
-    'closure'          => "\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [27]
-    'debugging'                => "\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [12]
-    'deprecated'       => "\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [18]
-    'digit'            => "\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [19]
-    'exec'             => "\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
-    'inplace'          => "\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [13]
-    'internal'         => "\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [14]
-    'io'               => "\xaa\x0a\x00\x00\x00\x00\x00\x00\x00", # [0..5]
-    'misc'             => "\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [6]
-    'newline'          => "\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
-    'numeric'          => "\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [7]
-    'octal'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [20]
-    'once'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [8]
-    'overflow'         => "\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [28]
-    'parenthesis'      => "\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [21]
-    'pipe'             => "\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [4]
-    'portable'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [29]
-    'printf'           => "\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [22]
-    'recursion'                => "\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [9]
-    'redefine'         => "\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [10]
-    'reserved'         => "\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [23]
-    'semicolon'                => "\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [24]
-    'severe'           => "\x00\x00\x80\x2a\x00\x00\x00\x00\x00", # [11..14]
-    'signal'           => "\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [30]
-    'substr'           => "\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [31]
-    'syntax'           => "\x00\x00\x00\x80\xaa\xaa\x02\x00\x00", # [15..24]
-    'taint'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [32]
-    'uninitialized'    => "\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [25]
-    'unopened'         => "\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [5]
-    'unsafe'           => "\x00\x00\x00\x00\x00\x00\xa0\xaa\x2a", # [26..34]
-    'untie'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [33]
-    'utf8'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [34]
-    'void'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [35]
+    '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]
   );
 
+$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
 
 sub bits {
     my $mask ;
@@ -141,12 +184,34 @@ sub unimport {
 
 sub enabled
 {
-    my $string = shift ;
-
+    # If no parameters, check for any lexical warnings enabled
+    # in the users scope.
+    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 $bits{$string} && ${^WARNING_BITS} & $bits{$string} ;
+       if ($callers_bitmask & $Bits{$category}) ne $NONE ;
    
     return 0 ; 
 }
 
+sub warn
+{
+    croak "Usage: warnings::warn('category', 'message')"
+       unless @_ == 2 ;
+    my $category = shift ;
+    my $message = shift ;
+    local $Carp::CarpLevel = 1 ;
+    my $callers_bitmask = (caller(1))[9] ; 
+    croak($message) 
+       if defined $callers_bitmask &&
+           ($callers_bitmask & $DeadBits{$category}) ne $NONE ;
+    carp($message) ;
+}
+
 1;
index c4a7a90..ecebeb0 100644 (file)
--- a/malloc.c
+++ b/malloc.c
     } STMT_END
 #endif
 
+#ifdef PERL_IMPLICIT_CONTEXT
+#  define PERL_IS_ALIVE                aTHX
+#else
+#  define PERL_IS_ALIVE                TRUE
+#endif
+    
+
 /*
  * Layout of memory:
  * ~~~~~~~~~~~~~~~~
@@ -1513,11 +1520,22 @@ Perl_mfree(void *mp)
                if (!bad_free_warn)
                    return;
 #ifdef RCHECK
+#ifdef PERL_CORE
+               if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
+                 Perl_warner(WARN_MALLOC, "%s free() ignored",
+                   ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
+#else
                warn("%s free() ignored",
                    ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
+#endif         
+#else
+#ifdef PERL_CORE
+               if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
+                 Perl_warner(WARN_MALLOC, "%s", "Bad free() ignored");
 #else
                warn("%s", "Bad free() ignored");
 #endif
+#endif
                return;                         /* sanity */
            }
 #ifdef RCHECK
@@ -1595,12 +1613,24 @@ Perl_realloc(void *mp, size_t nbytes)
                if (!bad_free_warn)
                    return Nullch;
 #ifdef RCHECK
+#ifdef PERL_CORE
+               if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
+                 Perl_warner(WARN_MALLOC, "%srealloc() %signored",
+                   (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
+                    ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : "");
+#else
                warn("%srealloc() %signored",
                    (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
                     ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : "");
+#endif
+#else
+#ifdef PERL_CORE
+               if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
+                 Perl_warner(WARN_MALLOC, "%s", "Bad realloc() ignored");
 #else
                warn("%s", "Bad realloc() ignored");
 #endif
+#endif
                return Nullch;                  /* sanity */
            }
 
diff --git a/mg.c b/mg.c
index 24c35e8..a3607eb 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1009,7 +1009,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
     else {
        i = whichsig(s);        /* ...no, a brick */
        if (!i) {
-           if (ckWARN(WARN_SIGNAL) || strEQ(s,"ALARM"))
+           if (ckWARN(WARN_SIGNAL))
                Perl_warner(aTHX_ WARN_SIGNAL, "No such signal: SIG%s", s);
            return 0;
        }
diff --git a/op.c b/op.c
index 9ba8582..c8276e0 100644 (file)
--- a/op.c
+++ b/op.c
@@ -151,7 +151,7 @@ Perl_pad_allocmy(pTHX_ char *name)
        }
        yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
     }
-    if (ckWARN(WARN_UNSAFE) && AvFILLp(PL_comppad_name) >= 0) {
+    if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
        SV **svp = AvARRAY(PL_comppad_name);
        HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
        PADOFFSET top = AvFILLp(PL_comppad_name);
@@ -163,7 +163,7 @@ Perl_pad_allocmy(pTHX_ char *name)
                    || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
                && strEQ(name, SvPVX(sv)))
            {
-               Perl_warner(aTHX_ WARN_UNSAFE,
+               Perl_warner(aTHX_ WARN_MISC,
                    "\"%s\" variable %s masks earlier declaration in same %s", 
                    (PL_in_my == KEY_our ? "our" : "my"),
                    name,
@@ -179,9 +179,9 @@ Perl_pad_allocmy(pTHX_ char *name)
                    && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
                    && strEQ(name, SvPVX(sv)))
                {
-                   Perl_warner(aTHX_ WARN_UNSAFE,
+                   Perl_warner(aTHX_ WARN_MISC,
                        "\"our\" variable %s redeclared", name);
-                   Perl_warner(aTHX_ WARN_UNSAFE,
+                   Perl_warner(aTHX_ WARN_MISC,
                        "(Did you mean \"local\" instead of \"our\"?)\n");
                    break;
                }
@@ -1947,7 +1947,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
     dTHR;
     OP *o;
 
-    if (ckWARN(WARN_UNSAFE) &&
+    if (ckWARN(WARN_MISC) &&
       (left->op_type == OP_RV2AV ||
        left->op_type == OP_RV2HV ||
        left->op_type == OP_PADAV ||
@@ -1958,7 +1958,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
       const char *sample = ((left->op_type == OP_RV2AV ||
                             left->op_type == OP_PADAV)
                            ? "@array" : "%hash");
-      Perl_warner(aTHX_ WARN_UNSAFE,
+      Perl_warner(aTHX_ WARN_MISC,
              "Applying %s to %s will act on scalar(%s)", 
              desc, sample, sample);
     }
@@ -3516,7 +3516,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
     }
     if (first->op_type == OP_CONST) {
        if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
-           Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
+           Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional"); 
        if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
            op_free(first);
            *firstp = Nullop;
@@ -3534,7 +3534,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
        else
            scalar(other);
     }
-    else if (ckWARN(WARN_UNSAFE) && (first->op_flags & OPf_KIDS)) {
+    else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
        OP *k1 = ((UNOP*)first)->op_first;
        OP *k2 = k1->op_sibling;
        OPCODE warnop = 0;
@@ -3563,7 +3563,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
        if (warnop) {
            line_t oldline = CopLINE(PL_curcop);
            CopLINE_set(PL_curcop, PL_copline);
-           Perl_warner(aTHX_ WARN_UNSAFE,
+           Perl_warner(aTHX_ WARN_MISC,
                 "Value of %s%s can be \"0\"; test with defined()",
                 PL_op_desc[warnop],
                 ((warnop == OP_READLINE || warnop == OP_GLOB)
@@ -4224,7 +4224,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
 {
     dTHR;
 
-    if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_UNSAFE)) {
+    if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
        SV* msg = sv_newmortal();
        SV* name = Nullsv;
 
@@ -4240,7 +4240,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
            Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
        else
            sv_catpv(msg, "none");
-       Perl_warner(aTHX_ WARN_UNSAFE, "%"SVf, msg);
+       Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
     }
 }
 
@@ -4346,9 +4346,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                                           maximum a prototype before. */
        if (SvTYPE(gv) > SVt_NULL) {
            if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
-               && ckWARN_d(WARN_UNSAFE))
+               && ckWARN_d(WARN_PROTOTYPE))
            {
-               Perl_warner(aTHX_ WARN_UNSAFE, "Runaway prototype");
+               Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
            }
            cv_ckproto((CV*)gv, NULL, ps);
        }
@@ -4382,11 +4382,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                goto withattrs;
            if (const_sv = cv_const_sv(cv))
                const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
-           if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE) 
-                                       && !(CvGV(cv) && GvSTASH(CvGV(cv))
-                                       && HvNAME(GvSTASH(CvGV(cv)))
-                                       && strEQ(HvNAME(GvSTASH(CvGV(cv))),
-                                                "autouse")))
+           if ((const_sv || const_changed) && ckWARN(WARN_REDEFINE))
            {
                line_t oldline = CopLINE(PL_curcop);
                CopLINE_set(PL_curcop, PL_copline);
@@ -5364,8 +5360,8 @@ Perl_ck_fun(pTHX_ OP *o)
                    char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
                    OP *newop = newAVREF(newGVOP(OP_GV, 0,
                        gv_fetchpv(name, TRUE, SVt_PVAV) ));
-                   if (ckWARN(WARN_SYNTAX))
-                       Perl_warner(aTHX_ WARN_SYNTAX,
+                   if (ckWARN(WARN_DEPRECATED))
+                       Perl_warner(aTHX_ WARN_DEPRECATED,
                            "Array @%s missing the @ in argument %"IVdf" of %s()",
                            name, (IV)numargs, PL_op_desc[type]);
                    op_free(kid);
@@ -5384,8 +5380,8 @@ Perl_ck_fun(pTHX_ OP *o)
                    char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
                    OP *newop = newHVREF(newGVOP(OP_GV, 0,
                        gv_fetchpv(name, TRUE, SVt_PVHV) ));
-                   if (ckWARN(WARN_SYNTAX))
-                       Perl_warner(aTHX_ WARN_SYNTAX,
+                   if (ckWARN(WARN_DEPRECATED))
+                       Perl_warner(aTHX_ WARN_DEPRECATED,
                            "Hash %%%s missing the %% in argument %"IVdf" of %s()",
                            name, (IV)numargs, PL_op_desc[type]);
                    op_free(kid);
@@ -6392,13 +6388,13 @@ Perl_peep(pTHX_ register OP *o)
                    GvAVn(gv);
                }
            }
-           else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_UNSAFE)) {
+           else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
                GV *gv = cGVOPo_gv;
                if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
                    /* XXX could check prototype here instead of just carping */
                    SV *sv = sv_newmortal();
                    gv_efullname3(sv, gv, Nullch);
-                   Perl_warner(aTHX_ WARN_UNSAFE,
+                   Perl_warner(aTHX_ WARN_PROTOTYPE,
                                "%s() called too early to check prototype",
                                SvPV_nolen(sv));
                }
index d660f94..80616d9 100644 (file)
@@ -9,15 +9,26 @@ desperation):
 
     (W) A warning (optional).
     (D) A deprecation (optional).
-    (S) A severe warning (mandatory).
+    (S) A severe warning (default).
     (F) A fatal error (trappable).
     (P) An internal error you should never see (trappable).
     (X) A very fatal error (nontrappable).
     (A) An alien error message (not generated by Perl).
 
-Optional warnings are enabled by using the B<-w> switch.  Warnings may
-be captured by setting C<$SIG{__WARN__}> to a reference to a routine that
-will be called on each warning instead of printing it.  See L<perlvar>.
+The majority of messages from the first three classifications above (W,
+D & S) can be controlled using the C<warnings> pragma. 
+
+If a message can be controlled by the C<warnings> pragma, its warning
+category is included with the classification letter in the description
+below.
+
+Optional warnings are enabled by using the C<warnings> pragma or the B<-w>
+and B<-W> switches. Warnings may be captured by setting C<$SIG{__WARN__}>
+to a reference to a routine that will be called on each warning instead
+of printing it.  See L<perlvar>.
+
+Default warnings are always enabled unless they are explicitly disabled
+with the C<warnings> pragma or the B<-X> switch.
 
 Trappable errors may be trapped using the eval operator.  See
 L<perlfunc/eval>.  In almost all cases, warnings may be selectively
@@ -33,7 +44,7 @@ C<"%(-?@> sort before the letters, while C<[> and C<\> sort after.
 
 =item "%s" variable %s masks earlier declaration in same %s
 
-(W) A "my" or "our" variable has been redeclared in the current scope or statement,
+(W misc) A "my" or "our" variable has been redeclared in the current scope or statement,
 effectively eliminating all access to the previous instance.  This is almost
 always a typographical error.  Note that the earlier variable will still exist
 until the end of the scope or until all closure referents to it are
@@ -57,7 +68,7 @@ no useful value.  See L<perlmod>.
 
 =item "our" variable %s redeclared
 
-(W) You seem to have already declared the same global once before in the
+(W misc) You seem to have already declared the same global once before in the
 current lexical scope.
 
 =item "use" not allowed in expression
@@ -113,31 +124,31 @@ your signed integers.  See L<perlfunc/unpack>.
 
 =item /%s/: Unrecognized escape \\%c passed through
 
-(W) You used a backslash-character combination which is not recognized
+(W regexp) You used a backslash-character combination which is not recognized
 by Perl.  This combination appears in an interpolated variable or a 
 C<'>-delimited regular expression.  The character was understood literally.
 
 =item /%s/: Unrecognized escape \\%c in character class passed through
 
-(W) You used a backslash-character combination which is not recognized
+(W regexp) You used a backslash-character combination which is not recognized
 by Perl inside character classes.  The character was understood literally.
 
 =item /%s/ should probably be written as "%s"
 
-(W) You have used a pattern where Perl expected to find a string,
+(W syntax) You have used a pattern where Perl expected to find a string,
 as in the first argument to C<join>.  Perl will treat the true
 or false result of matching the pattern against $_ as the string,
 which is probably not what you had in mind.
 
 =item %s (...) interpreted as function
 
-(W) You've run afoul of the rule that says that any list operator followed
+(W syntax) You've run afoul of the rule that says that any list operator followed
 by parentheses turns into a function, with all the list operators arguments
 found inside the parentheses.  See L<perlop/Terms and List Operators (Leftward)>.
 
 =item %s() called too early to check prototype
 
-(W) You've called a function that has a prototype before the parser saw a
+(W prototype) You've called a function that has a prototype before the parser saw a
 definition or declaration for it, and Perl could not check that the call
 conforms to the prototype.  You need to either add an early prototype
 declaration for the subroutine in question, or move the subroutine
@@ -194,17 +205,17 @@ Further error messages would likely be uninformative.
 
 =item %s matches null string many times
 
-(W) The pattern you've specified would be an infinite loop if the
+(W regexp) The pattern you've specified would be an infinite loop if the
 regular expression engine didn't specifically check for that.  See L<perlre>.
 
 =item %s never introduced
 
-(S) The symbol in question was declared but somehow went out of scope
+(S internal) The symbol in question was declared but somehow went out of scope
 before it could possibly have been used.
 
 =item %s package attribute may clash with future reserved word: %s
 
-(W) A lowercase attribute name was used that had a package-specific handler.
+(W reserved) A lowercase attribute name was used that had a package-specific handler.
 That name might have a meaning to Perl itself some day, even though it
 doesn't yet.  Perhaps you should use a mixed-case attribute name, instead.
 See L<attributes>.
@@ -239,7 +250,7 @@ into Perl yourself.
 
 =item         (in cleanup) %s
 
-(W) This prefix usually indicates that a DESTROY() method raised
+(W misc) This prefix usually indicates that a DESTROY() method raised
 the indicated exception.  Since destructors are usually called by
 the system at arbitrary points during execution, and often a vast
 number of times, the warning is issued only once for any number
@@ -292,7 +303,7 @@ C<require 'file'>.
 
 =item accept() on closed socket %s
 
-(W) You tried to do an accept on a closed socket.  Did you forget to check
+(W closed) You tried to do an accept on a closed socket.  Did you forget to check
 the return value of your socket() call?  See L<perlfunc/accept>.
 
 =item Allocation too large: %lx
@@ -301,7 +312,7 @@ the return value of your socket() call?  See L<perlfunc/accept>.
 
 =item Applying %s to %s will act on scalar(%s)
 
-(W) The pattern match (//), substitution (s///), and transliteration (tr///)
+(W misc) The pattern match (//), substitution (s///), and transliteration (tr///)
 operators work on scalar values.  If you apply one of them to an array
 or a hash, it will convert the array or hash to a scalar value -- the
 length of an array, or the population info of a hash -- and then work on
@@ -314,13 +325,13 @@ L<perlfunc/grep> and L<perlfunc/map> for alternatives.
 
 =item Ambiguous use of %s resolved as %s
 
-(W)(S) You said something that may not be interpreted the way
+(W ambiguous)(S) You said something that may not be interpreted the way
 you thought.  Normally it's pretty easy to disambiguate it by supplying
 a missing quote, operator, parenthesis pair or declaration.
 
 =item Ambiguous call resolved as CORE::%s(), qualify as such or use &
 
-(W) A subroutine you have declared has the same name as a Perl keyword,
+(W ambiguous) A subroutine you have declared has the same name as a Perl keyword,
 and you have used the name without qualification for calling one or the
 other.  Perl decided to call the builtin because the subroutine is
 not imported.
@@ -344,13 +355,13 @@ for example, turn C<-w -U> into C<-wU>.
 
 =item Argument "%s" isn't numeric%s
 
-(W) The indicated string was fed as an argument to an operator that
+(W numeric) The indicated string was fed as an argument to an operator that
 expected a numeric value instead.  If you're fortunate the message
 will identify which operator was so unfortunate.
 
 =item Array @%s missing the @ in argument %d of %s()
 
-(D) Really old Perl let you omit the @ on array names in some spots.  This
+(D deprecated) Really old Perl let you omit the @ on array names in some spots.  This
 is now heavily deprecated.
 
 =item assertion botched: %s
@@ -369,20 +380,20 @@ know which context to supply to the right side.
 
 =item Attempt to free non-arena SV: 0x%lx
 
-(P) All SV objects are supposed to be allocated from arenas that will
+(P internal) All SV objects are supposed to be allocated from arenas that will
 be garbage collected on exit.  An SV was discovered to be outside any
 of those arenas.
 
 =item Attempt to free nonexistent shared string
 
-(P) Perl maintains a reference counted internal table of strings to
+(P internal) Perl maintains a reference counted internal table of strings to
 optimize the storage and access of hash keys and other strings.  This
 indicates someone tried to decrement the reference count of a string
 that can no longer be found in the table.
 
 =item Attempt to free temp prematurely
 
-(W) Mortalized values are supposed to be freed by the free_tmps()
+(W debugging) Mortalized values are supposed to be freed by the free_tmps()
 routine.  This indicates that something else is freeing the SV before
 the free_tmps() routine gets a chance, which means that the free_tmps()
 routine will be freeing an unreferenced scalar when it does try to free
@@ -390,11 +401,11 @@ it.
 
 =item Attempt to free unreferenced glob pointers
 
-(P) The reference counts got screwed up on symbol aliases.
+(P internal) The reference counts got screwed up on symbol aliases.
 
 =item Attempt to free unreferenced scalar
 
-(W) Perl went to decrement the reference count of a scalar to see if it
+(W internal) Perl went to decrement the reference count of a scalar to see if it
 would go to 0, and discovered that it had already gone to 0 earlier,
 and should have been freed, and in fact, probably was freed.  This
 could indicate that SvREFCNT_dec() was called too many times, or that
@@ -409,7 +420,7 @@ need to move the join() to some other thread.
 
 =item Attempt to pack pointer to temporary value
 
-(W) You tried to pass a temporary value (like the result of a
+(W pack) You tried to pass a temporary value (like the result of a
 function, or a computed expression) to the "p" pack() template.  This
 means the result contains a pointer to a location that could become
 invalid anytime, even before the end of the current statement.  Use
@@ -418,7 +429,7 @@ avoid this warning.
 
 =item Attempt to use reference as lvalue in substr
 
-(W) You supplied a reference as the first argument to substr() used
+(W substr) You supplied a reference as the first argument to substr() used
 as an lvalue, which is pretty strange.  Perhaps you forgot to
 dereference it first.  See L<perlfunc/substr>.
 
@@ -437,7 +448,7 @@ did it in another package.
 
 =item Bad free() ignored
 
-(S) An internal routine called free() on something that had never been
+(S malloc) An internal routine called free() on something that had never been
 malloc()ed in the first place. Mandatory, but can be disabled by
 setting environment variable C<PERL_BADFREE> to 1.
 
@@ -472,7 +483,7 @@ is not the same as
 
 =item Bad realloc() ignored
 
-(S) An internal routine called realloc() on something that had never been
+(S malloc) An internal routine called realloc() on something that had never been
 malloc()ed in the first place. Mandatory, but can be disabled by
 setting environment variable C<PERL_BADFREE> to 1.
 
@@ -505,13 +516,13 @@ Perhaps you need to predeclare a subroutine?
 
 =item Bareword "%s" refers to nonexistent package
 
-(W) You used a qualified bareword of the form C<Foo::>, but
+(W bareword) You used a qualified bareword of the form C<Foo::>, but
 the compiler saw no other uses of that namespace before that point.
 Perhaps you need to predeclare a package?
 
 =item Bareword found in conditional
 
-(W) The compiler found a bareword where it expected a conditional,
+(W bareword) The compiler found a bareword where it expected a conditional,
 which often indicates that an || or && was parsed as part of the
 last argument of the previous construct, for example:
 
@@ -540,18 +551,18 @@ likely depends on its correct operation, Perl just gave up.
 
 =item Binary number > 0b11111111111111111111111111111111 non-portable
 
-(W) The binary number you specified is larger than 2**32-1
+(W portable) The binary number you specified is larger than 2**32-1
 (4294967295) and therefore non-portable between systems.  See
 L<perlport> for more on portability concerns.
 
 =item bind() on closed socket %s
 
-(W) You tried to do a bind on a closed socket.  Did you forget to check
+(W closed) You tried to do a bind on a closed socket.  Did you forget to check
 the return value of your socket() call?  See L<perlfunc/bind>.
 
 =item Bit vector size > 32 non-portable
 
-(W) Using bit vector sizes larger than 32 is non-portable.
+(W portable) Using bit vector sizes larger than 32 is non-portable.
 
 =item Bizarre copy of %s in %s
 
@@ -559,7 +570,7 @@ the return value of your socket() call?  See L<perlfunc/bind>.
 
 =item Buffer overflow in prime_env_iter: %s
 
-(W) A warning peculiar to VMS.  While Perl was preparing to iterate over
+(W internal) A warning peculiar to VMS.  While Perl was preparing to iterate over
 %ENV, it encountered a logical name or symbol definition which was too long,
 so it was truncated to the string shown.
 
@@ -622,7 +633,7 @@ encapsulation of objects.  See L<perlobj>.
 
 =item Can't break at that line
 
-(S) A warning intended to only be printed while running within the debugger, indicating
+(S internal) A warning intended to only be printed while running within the debugger, indicating
 the line number specified wasn't the location of a statement that could
 be stopped at.
 
@@ -718,7 +729,7 @@ for other types of variables in future.
 
 =item Can't do inplace edit on %s: %s
 
-(S) The creation of the new file failed for the indicated reason.
+(S inplace) The creation of the new file failed for the indicated reason.
 
 =item Can't do inplace edit without backup
 
@@ -728,13 +739,13 @@ such.
 
 =item Can't do inplace edit: %s would not be unique
 
-(S) Your filesystem does not support filenames longer than 14
+(S inplace) Your filesystem does not support filenames longer than 14
 characters and Perl was unable to create a unique filename during
 inplace editing with the B<-i> switch.  The file was ignored.
 
 =item Can't do inplace edit: %s is not a regular file
 
-(S) You tried to use the B<-i> switch on a special file, such as a file in
+(S inplace) You tried to use the B<-i> switch on a special file, such as a file in
 /dev, or a FIFO.  The file was ignored.
 
 =item Can't do setegid!
@@ -772,7 +783,7 @@ For example, it'd be kind of silly to put a B<-x> on the #! line.
 
 =item Can't exec "%s": %s
 
-(W) An system(), exec(), or piped open call could not execute the named
+(W exec) An system(), exec(), or piped open call could not execute the named
 program for the indicated reason.  Typical reasons include: the permissions
 were wrong on the file, the file wasn't found in C<$ENV{PATH}>, the
 executable in question was compiled for another architecture, or the
@@ -863,7 +874,7 @@ L<perlfunc/goto>.
 
 =item Can't ignore signal CHLD, forcing to default
 
-(W) Perl has detected that it is being run with the SIGCHLD signal
+(W signal) Perl has detected that it is being run with the SIGCHLD signal
 (sometimes known as SIGCLD) disabled.  Since disabling this signal
 will interfere with proper determination of exit status of child
 processes, Perl has reset the signal to its default value.
@@ -916,7 +927,7 @@ method, nor does any of its base classes.  See L<perlobj>.
 
 =item Can't locate package %s for @%s::ISA
 
-(W) The @ISA array contained the name of another package that doesn't seem
+(W syntax) The @ISA array contained the name of another package that doesn't seem
 to exist.
 
 =item Can't make list assignment to \%ENV on this system
@@ -945,7 +956,7 @@ buffer.
 
 =item Can't open %s: %s
 
-(S) The implicit opening of a file through use of the C<E<lt>E<gt>>
+(S inplace) The implicit opening of a file through use of the C<E<lt>E<gt>>
 filehandle, either implicitly under the C<-n> or C<-p> command-line
 switches, or explicitly, failed for the indicated reason.  Usually this
 is because you don't have read permission for a file which you named
@@ -953,7 +964,7 @@ on the command line.
 
 =item Can't open bidirectional pipe
 
-(W) You tried to say C<open(CMD, "|cmd|")>, which is not supported.  You can
+(W pipe) You tried to say C<open(CMD, "|cmd|")>, which is not supported.  You can
 try any of several modules in the Perl library to do this, such as
 IPC::Open2.  Alternately, direct the pipe's output to a file using "E<gt>",
 and then read it in under a different file handle.
@@ -993,13 +1004,13 @@ this, you should write C<sort { &func } @x> instead of C<sort func @x>.
 
 =item Can't remove %s: %s, skipping file 
 
-(S) You requested an inplace edit without creating a backup file.  Perl
+(S inplace) You requested an inplace edit without creating a backup file.  Perl
 was unable to remove the original file to replace it with the modified
 file.  The file was left unmodified.
 
 =item Can't rename %s to %s: %s, skipping file
 
-(S) The rename done by the B<-i> switch failed for some reason,
+(S inplace) The rename done by the B<-i> switch failed for some reason,
 probably because you don't have write permission to the directory.
 
 =item Can't reopen input pipe (name: %s) in binary mode
@@ -1102,7 +1113,7 @@ test the type of the reference, if need be.
 
 =item Can't use \%c to mean $%c in expression
 
-(W) In an ordinary expression, backslash is a unary operator that creates
+(W syntax) In an ordinary expression, backslash is a unary operator that creates
 a reference to its argument.  The use of backslash to indicate a backreference
 to a matched substring is valid only as part of a regular expression pattern.
 Trying to do this in ordinary Perl code produces a value that prints
@@ -1166,7 +1177,7 @@ See L<perlre>.
 
 =item Character class syntax [%s] belongs inside character classes
 
-(W) The character class constructs [: :], [= =], and [. .]  go
+(W unsafe) The character class constructs [: :], [= =], and [. .]  go
 I<inside> character classes, the [] are part of the construct,
 for example: /[012[:alpha:]345]/.  Note that [= =] and [. .]
 are not currently implemented; they are simply placeholders for
@@ -1174,7 +1185,7 @@ future extensions.
 
 =item Character class syntax [. .] is reserved for future extensions
 
-(W) Within regular expression character classes ([]) the syntax beginning
+(W regexp) Within regular expression character classes ([]) the syntax beginning
 with "[." and ending with ".]" is reserved for future extensions.
 If you need to represent those character sequences inside a regular
 expression character class, just quote the square brackets with the
@@ -1182,7 +1193,7 @@ backslash: "\[." and ".\]".
 
 =item Character class syntax [= =] is reserved for future extensions
 
-(W) Within regular expression character classes ([]) the syntax
+(W regexp) Within regular expression character classes ([]) the syntax
 beginning with "[=" and ending with "=]" is reserved for future extensions.
 If you need to represent those character sequences inside a regular
 expression character class, just quote the square brackets with the
@@ -1190,7 +1201,7 @@ backslash: "\[=" and "=\]".
 
 =item chmod() mode argument is missing initial 0
 
-(W) A novice will sometimes say
+(W chmod) A novice will sometimes say
 
     chmod 777, $filename
 
@@ -1199,7 +1210,7 @@ to 01411.  Octal constants are introduced with a leading 0 in Perl, as in C.
 
 =item Close on unopened file E<lt>%sE<gt>
 
-(W) You tried to close a filehandle that was never opened.
+(W unopened) You tried to close a filehandle that was never opened.
 
 =item Compilation failed in require
 
@@ -1209,7 +1220,7 @@ were severe enough to halt compilation immediately.
 
 =item Complex regular subexpression recursion limit (%d) exceeded
 
-(W) The regular expression engine uses recursion in complex situations
+(W regexp) The regular expression engine uses recursion in complex situations
 where back-tracking is required.  Recursion depth is limited to 32766,
 or perhaps less in architectures where the stack cannot grow
 arbitrarily.  ("Simple" and "medium" situations are handled without
@@ -1221,7 +1232,7 @@ for information on I<Mastering Regular Expressions>.)
 
 =item connect() on closed socket %s
 
-(W) You tried to do a connect on a closed socket.  Did you forget to check
+(W closed) You tried to do a connect on a closed socket.  Did you forget to check
 the return value of your socket() call?  See L<perlfunc/connect>.
 
 =item Constant is not %s reference
@@ -1234,13 +1245,13 @@ See L<perlsub/"Constant Functions"> and L<constant>.
 
 =item Constant subroutine %s redefined
 
-(S|W) You redefined a subroutine which had previously been eligible for
+(S|W redefine) You redefined a subroutine which had previously been eligible for
 inlining.  See L<perlsub/"Constant Functions"> for commentary and
 workarounds.
 
 =item Constant subroutine %s undefined
 
-(W) You undefined a subroutine which had previously been eligible for
+(W misc) You undefined a subroutine which had previously been eligible for
 inlining.  See L<perlsub/"Constant Functions"> for commentary and
 workarounds.
 
@@ -1274,20 +1285,20 @@ a valid magic number.
 
 =item Deep recursion on subroutine "%s"
 
-(W) This subroutine has called itself (directly or indirectly) 100
+(W recursion) This subroutine has called itself (directly or indirectly) 100
 times more than it has returned.  This probably indicates an infinite
 recursion, unless you're writing strange benchmark programs, in which
 case it indicates something else.
 
 =item defined(@array) is deprecated
 
-(D) defined() is not usually useful on arrays because it checks for an
+(D deprecated) defined() is not usually useful on arrays because it checks for an
 undefined I<scalar> value.  If you want to see if the array is empty,
 just use C<if (@array) { # not empty }> for example.  
 
 =item defined(%hash) is deprecated
 
-(D) defined() is not usually useful on hashes because it checks for an
+(D deprecated) defined() is not usually useful on hashes because it checks for an
 undefined I<scalar> value.  If you want to see if the hash is empty,
 just use C<if (%hash) { # not empty }> for example.  
 
@@ -1307,7 +1318,7 @@ See Server error.
 
 =item Did you mean "local" instead of "our"?
 
-(W) Remember that "our" does not localize the declared global variable.
+(W misc) Remember that "our" does not localize the declared global variable.
 You have declared it again in the same lexical scope, which seems superfluous.
 
 =item Did you mean $ or @ instead of %?
@@ -1346,7 +1357,7 @@ See Server error.
 
 =item Duplicate free() ignored
 
-(S) An internal routine called free() on something that had already
+(S malloc) An internal routine called free() on something that had already
 been freed.
 
 =item elseif should be elsif
@@ -1409,35 +1420,40 @@ variable and glob that.
 
 =item Exiting eval via %s
 
-(W) You are exiting an eval by unconventional means, such as
+(W exiting) You are exiting an eval by unconventional means, such as
+a goto, or a loop control statement.
+
+=item Exiting format via %s
+
+(W exiting) You are exiting an eval by unconventional means, such as
 a goto, or a loop control statement.
 
 =item Exiting pseudo-block via %s
 
-(W) You are exiting a rather special block construct (like a sort block or
+(W exiting) You are exiting a rather special block construct (like a sort block or
 subroutine) by unconventional means, such as a goto, or a loop control
 statement.  See L<perlfunc/sort>.
 
 =item Exiting subroutine via %s
 
-(W) You are exiting a subroutine by unconventional means, such as
+(W exiting) You are exiting a subroutine by unconventional means, such as
 a goto, or a loop control statement.
 
 =item Exiting substitution via %s
 
-(W) You are exiting a substitution by unconventional means, such as
+(W exiting) You are exiting a substitution by unconventional means, such as
 a return, a goto, or a loop control statement.
 
 =item Explicit blessing to '' (assuming package main)
 
-(W) You are blessing a reference to a zero length string.  This has
+(W misc) You are blessing a reference to a zero length string.  This has
 the effect of blessing the reference into the package main.  This is
 usually not what you want.  Consider providing a default target
 package, e.g. bless($ref, $p || 'MyPackage');
 
 =item false [] range "%s" in regexp
 
-(W) A character class range must start and end at a literal character, not
+(W regexp) A character class range must start and end at a literal character, not
 another character class like C<\d> or C<[:alpha:]>.  The "-" in your false
 range is interpreted as a literal "-".  Consider quoting the "-",  "\-".
 See L<perlre>.
@@ -1456,13 +1472,13 @@ PDP-11 or something?
 
 =item Filehandle %s never opened
 
-(W) An I/O operation was attempted on a filehandle that was never initialized.
+(W unopened) An I/O operation was attempted on a filehandle that was never initialized.
 You need to do an open() or a socket() call, or call a constructor from
 the FileHandle package.
 
 =item Filehandle %s opened only for input
 
-(W) You tried to write on a read-only filehandle.  If you
+(W io) You tried to write on a read-only filehandle.  If you
 intended it to be a read-write filehandle, you needed to open it with
 "+E<lt>" or "+E<gt>" or "+E<gt>E<gt>" instead of with "E<lt>" or nothing.  If
 you intended only to write the file, use "E<gt>" or "E<gt>E<gt>".  See
@@ -1470,7 +1486,7 @@ L<perlfunc/open>.
 
 =item Filehandle %s opened only for output
 
-(W) You tried to read from a filehandle opened only for writing.  If you
+(W io) You tried to read from a filehandle opened only for writing.  If you
 intended it to be a read/write filehandle, you needed to open it with
 "+E<lt>" or "+E<gt>" or "+E<gt>E<gt>" instead of with "E<lt>" or nothing.  If
 you intended only to read from the file, use "E<lt>".  See
@@ -1492,13 +1508,13 @@ the name.
 
 =item flock() on closed filehandle %s
 
-(W) The filehandle you're attempting to flock() got itself closed some
+(W closed) The filehandle you're attempting to flock() got itself closed some
 time before now.  Check your logic flow.  flock() operates on filehandles.
 Are you attempting to call flock() on a dirhandle by the same name?
 
 =item Format %s redefined
 
-(W) You redefined a format.  To suppress this warning, say
+(W redefine) You redefined a format.  To suppress this warning, say
 
     {
        no warnings;
@@ -1512,7 +1528,7 @@ to the end of your file without finding such a line.
 
 =item Found = in conditional, should be ==
 
-(W) You said
+(W syntax) You said
 
     if ($foo = 123)
 
@@ -1534,7 +1550,7 @@ on the Internet.
 
 =item get%sname() on closed socket %s
 
-(W) You tried to get a socket or peer socket name on a closed socket.
+(W closed) You tried to get a socket or peer socket name on a closed socket.
 Did you forget to check the return value of your socket() call?
 
 =item getpwnam returned invalid UIC %#o for user "%s"
@@ -1542,6 +1558,20 @@ Did you forget to check the return value of your socket() call?
 (S) A warning peculiar to VMS.  The call to C<sys$getuai> underlying the
 C<getpwnam> operator returned an invalid UIC.
 
+=item glob failed (%s)
+
+(W glob) Something went wrong with the external program(s) used for C<glob>
+and C<E<lt>*.cE<gt>>.  Usually, this means that you supplied a C<glob>
+pattern that caused the external program to fail and exit with a nonzero
+status.  If the message indicates that the abnormal exit resulted in a
+coredump, this may also mean that your csh (C shell) is broken.  If so,
+you should change all of the csh-related variables in config.sh:  If you
+have tcsh, make the variables refer to it as if it were csh (e.g.
+C<full_csh='/usr/bin/tcsh'>); otherwise, make them all empty (except that
+C<d_csh> should be C<'undef'>) so that Perl will think csh is missing.
+In either case, after editing config.sh, run C<./Configure -S> and
+rebuild Perl.
+
 =item Glob not terminated
 
 (F) The lexer saw a left angle bracket in a place where it was expecting
@@ -1563,18 +1593,18 @@ unspecified destination.  See L<perlfunc/goto>.
 
 =item Had to create %s unexpectedly
 
-(S) A routine asked for a symbol from a symbol table that ought to have
+(S internal) A routine asked for a symbol from a symbol table that ought to have
 existed already, but for some reason it didn't, and had to be created on
 an emergency basis to prevent a core dump.
 
 =item Hash %%s missing the % in argument %d of %s()
 
-(D) Really old Perl let you omit the % on hash names in some spots.  This
+(D deprecated) Really old Perl let you omit the % on hash names in some spots.  This
 is now heavily deprecated.
 
 =item Hexadecimal number > 0xffffffff non-portable
 
-(W) The hexadecimal number you specified is larger than 2**32-1
+(W portable) The hexadecimal number you specified is larger than 2**32-1
 (4294967295) and therefore non-portable between systems.  See
 L<perlport> for more on portability concerns.
 
@@ -1587,13 +1617,13 @@ versions of Perl are likely to eliminate these arbitrary limitations.
 
 =item Ill-formed CRTL environ value "%s"
 
-(W) A warning peculiar to VMS.  Perl tried to read the CRTL's internal
+(W internal) A warning peculiar to VMS.  Perl tried to read the CRTL's internal
 environ array, and encountered an element without the C<=> delimiter
 used to spearate keys from values.  The element is ignored.
 
 =item Ill-formed message in prime_env_iter: |%s|
 
-(W) A warning peculiar to VMS.  Perl tried to read a logical name
+(W internal) A warning peculiar to VMS.  Perl tried to read a logical name
 or CLI symbol definition when preparing to iterate over %ENV, and
 didn't see the expected delimiter between key and value, so the
 line was ignored.
@@ -1626,17 +1656,17 @@ don't take to this kindly.
 
 =item Illegal binary digit %s ignored
 
-(W) You may have tried to use a digit other than 0 or 1 in a binary number.
+(W digit) You may have tried to use a digit other than 0 or 1 in a binary number.
 Interpretation of the binary number stopped before the offending digit.
 
 =item Illegal octal digit %s ignored
 
-(W) You may have tried to use an 8 or 9 in a octal number.  Interpretation
+(W digit) You may have tried to use an 8 or 9 in a octal number.  Interpretation
 of the octal number stopped before the 8 or 9.
 
 =item Illegal hexadecimal digit %s ignored
 
-(W) You may have tried to use a character other than 0 - 9 or A - F, a - f
+(W digit) You may have tried to use a character other than 0 - 9 or A - F, a - f
 in a hexadecimal number.  Interpretation of the hexadecimal number stopped
 before the illegal character.
 
@@ -1686,7 +1716,7 @@ known value, using trustworthy data.  See L<perlsec>.
 
 =item Integer overflow in %s number
 
-(W) The hexadecimal, octal or binary number you have specified either
+(W overflow) The hexadecimal, octal or binary number you have specified either
 as a literal or as an argument to hex() or oct() is too big for your
 architecture, and has been converted to a floating point number.  On a
 32-bit architecture the largest hexadecimal, octal or binary number
@@ -1710,20 +1740,6 @@ and execute the specified command.
 
 (P) Something went badly wrong in the regular expression parser.
 
-=item glob failed (%s)
-
-(W) Something went wrong with the external program(s) used for C<glob>
-and C<E<lt>*.cE<gt>>.  Usually, this means that you supplied a C<glob>
-pattern that caused the external program to fail and exit with a nonzero
-status.  If the message indicates that the abnormal exit resulted in a
-coredump, this may also mean that your csh (C shell) is broken.  If so,
-you should change all of the csh-related variables in config.sh:  If you
-have tcsh, make the variables refer to it as if it were csh (e.g.
-C<full_csh='/usr/bin/tcsh'>); otherwise, make them all empty (except that
-C<d_csh> should be C<'undef'>) so that Perl will think csh is missing.
-In either case, after editing config.sh, run C<./Configure -S> and
-rebuild Perl.
-
 =item internal urp in regexp at /%s/
 
 (P) Something went badly awry in the regular expression parser.
@@ -1745,7 +1761,7 @@ greater than the maximum character.  See L<perlre>.
 
 =item Invalid conversion in %s: "%s"
 
-(W) Perl does not understand the given format conversion.
+(W printf) Perl does not understand the given format conversion.
 See L<perlfunc/sprintf>.
 
 =item Invalid separator character %s in attribute list
@@ -1758,13 +1774,13 @@ too soon.  See L<attributes>.
 =item Invalid type in pack: '%s'
 
 (F) The given character is not a valid pack type.  See L<perlfunc/pack>.
-(W) The given character is not a valid pack type but used to be silently
+(W pack) The given character is not a valid pack type but used to be silently
 ignored.
 
 =item Invalid type in unpack: '%s'
 
 (F) The given character is not a valid unpack type.  See L<perlfunc/unpack>.
-(W) The given character is not a valid unpack type but used to be silently
+(W unpack) The given character is not a valid unpack type but used to be silently
 ignored.
 
 =item ioctl is not implemented
@@ -1801,7 +1817,7 @@ effective uids or gids failed.
 
 =item listen() on closed socket %s
 
-(W) You tried to do a listen on a closed socket.  Did you forget to check
+(W closed) You tried to do a listen on a closed socket.  Did you forget to check
 the return value of your socket() call?  See L<perlfunc/listen>.
 
 =item Lvalue subs returning %s not implemented yet
@@ -1827,7 +1843,7 @@ ended earlier on the current line.
 
 =item Misplaced _ in number
 
-(W) An underline in a decimal constant wasn't on a 3-digit boundary.
+(W syntax) An underline in a decimal constant wasn't on a 3-digit boundary.
 
 =item Missing $ on loop variable
 
@@ -1847,7 +1863,7 @@ double-quotish context.
 
 =item Missing command in piped open
 
-(W) You used the C<open(FH, "| command")> or C<open(FH, "command |")>
+(W pipe) You used the C<open(FH, "| command")> or C<open(FH, "command |")>
 construction, but the command was missing or blank.
 
 =item Missing operator before %s?
@@ -1893,7 +1909,7 @@ be created for some peculiar reason.
 
 =item Multidimensional syntax %s not supported
 
-(W) Multidimensional arrays aren't written like C<$foo[1,2,3]>.  They're written
+(W syntax) Multidimensional arrays aren't written like C<$foo[1,2,3]>.  They're written
 like C<$foo[1][2][3]>, as in C.
 
 =item Missing name in "my sub"
@@ -1903,7 +1919,7 @@ have a name with which they can be found.
 
 =item Name "%s::%s" used only once: possible typo
 
-(W) Typographical errors often show up as unique variable names.
+(W once) Typographical errors often show up as unique variable names.
 If you had a good reason for having a unique name, then just mention
 it again somehow to suppress the message.  The C<our> declaration is
 provided for this purpose.
@@ -2058,7 +2074,7 @@ an attempt to close an unopened filehandle.
 
 =item No such signal: SIG%s
 
-(W) You specified a signal name as a subscript to %SIG that was not recognized.
+(W signal) You specified a signal name as a subscript to %SIG that was not recognized.
 Say C<kill -l> in your shell to see the valid signal names on your system.
 
 =item no UTC offset information; assuming local time is UTC
@@ -2130,7 +2146,7 @@ function to find out what kind of ref it really was.  See L<perlref>.
 
 =item Not enough format arguments
 
-(W) A format specified more picture fields than the next line supplied.
+(W syntax) A format specified more picture fields than the next line supplied.
 See L<perlform>.
 
 =item Null filename used
@@ -2146,7 +2162,7 @@ supplied it an uninitialized value.  See L<perlform>.
 
 =item NULL OP IN RUN
 
-(P) Some internal routine called run() with a null opcode pointer.
+(P debugging) Some internal routine called run() with a null opcode pointer.
 
 =item Null realloc
 
@@ -2169,7 +2185,7 @@ try using scientific notation (e.g. "1e6" instead of "1_000_000").
 
 =item Octal number > 037777777777 non-portable
 
-(W) The octal number you specified is larger than 2**32-1 (4294967295)
+(W portable) The octal number you specified is larger than 2**32-1 (4294967295)
 and therefore non-portable between systems.  See L<perlport> for more
 on portability concerns.
 
@@ -2183,7 +2199,7 @@ version.
 
 =item Odd number of elements in hash assignment
 
-(W) You specified an odd number of elements to initialize a hash, which
+(W misc) You specified an odd number of elements to initialize a hash, which
 is odd, because hashes come in key/value pairs.
 
 =item Offset outside string
@@ -2195,11 +2211,11 @@ will extend the buffer and zero pad the new area.
 
 =item oops: oopsAV
 
-(S) An internal warning that the grammar is screwed up.
+(S internal) An internal warning that the grammar is screwed up.
 
 =item oops: oopsHV
 
-(S) An internal warning that the grammar is screwed up.
+(S internal) An internal warning that the grammar is screwed up.
 
 =item Operation `%s': no method found, %s
 
@@ -2211,7 +2227,7 @@ true.  See L<overload>.
 
 =item Operator or semicolon missing before %s
 
-(S) You used a variable or subroutine call where the parser was
+(S ambiguous) You used a variable or subroutine call where the parser was
 expecting an operator.  The parser has assumed you really meant
 to use an operator, but this is highly likely to be incorrect.
 For example, if you say "*foo *foo" it will be interpreted as
@@ -2254,7 +2270,7 @@ instead of C<$arr[$time]>.
 
 =item page overflow
 
-(W) A single call to write() produced more lines than can fit on a page.
+(W io) A single call to write() produced more lines than can fit on a page.
 See L<perlform>.
 
 =item panic: ck_grep
@@ -2421,7 +2437,7 @@ was string.
 
 =item Parentheses missing around "%s" list
 
-(W) You said something like
+(W parenthesis) You said something like
 
     my $foo, $bar = @_;
 
@@ -2443,7 +2459,7 @@ anyway?  See L<perlfunc/require>.
 
 =item pid %x not a child
 
-(W) A warning peculiar to VMS.  Waitpid() was asked to wait for a process which
+(W exec) A warning peculiar to VMS.  Waitpid() was asked to wait for a process which
 isn't a subprocess of the current process.  While this is fine from VMS'
 perspective, it's probably not what you intended.
 
@@ -2454,12 +2470,12 @@ the BSD version, which takes a pid.
 
 =item Possible Y2K bug: %s
 
-(W) You are concatenating the number 19 with another number, which
+(W y2k) You are concatenating the number 19 with another number, which
 could be a potential Year 2000 problem.
 
 =item Possible attempt to put comments in qw() list
 
-(W) qw() lists contain items separated by whitespace; as with literal
+(W qw) qw() lists contain items separated by whitespace; as with literal
 strings, comment characters are not ignored, but are instead treated
 as literal data.  (You may have used different delimiters than the
 parentheses shown here; braces are also frequently used.)
@@ -2488,7 +2504,7 @@ old-fashioned way, with quotes and commas:
 
 =item Possible attempt to separate words with commas
 
-(W) qw() lists contain items separated by whitespace; therefore commas
+(W qw) qw() lists contain items separated by whitespace; therefore commas
 aren't needed to separate the items.  (You may have used different
 delimiters than the parentheses shown here; braces are also frequently
 used.)
@@ -2511,7 +2527,7 @@ Perl assumes that memory is now corrupted.  See L<perlfunc/ioctl>.
 
 =item Precedence problem: open %s should be open(%s)
 
-(S) The old irregular construct
+(S precedence) The old irregular construct
 
     open FOO || die;
 
@@ -2530,17 +2546,17 @@ See Server error.
 
 =item print() on closed filehandle %s
 
-(W) The filehandle you're printing on got itself closed sometime before now.
+(W closed) The filehandle you're printing on got itself closed sometime before now.
 Check your logic flow.
 
 =item printf() on closed filehandle %s
 
-(W) The filehandle you're writing to got itself closed sometime before now.
+(W closed) The filehandle you're writing to got itself closed sometime before now.
 Check your logic flow.
 
 =item Prototype mismatch: %s vs %s
 
-(S) The subroutine being declared or defined had previously been declared
+(S unsafe) The subroutine being declared or defined had previously been declared
 or defined with a different function prototype.
 
 =item Range iterator outside integer range
@@ -2552,12 +2568,12 @@ increment by prepending "0" to your numbers.
 
 =item readline() on closed filehandle %s
 
-(W) The filehandle you're reading from got itself closed sometime before now.
+(W closed) The filehandle you're reading from got itself closed sometime before now.
 Check your logic flow.
 
 =item realloc() of freed memory ignored
 
-(S) An internal routine called realloc() on something that had already
+(S malloc) An internal routine called realloc() on something that had already
 been freed.
 
 =item Reallocation too large: %lx
@@ -2566,7 +2582,7 @@ been freed.
 
 =item Recompile perl with B<-D>DEBUGGING to use B<-D> switch
 
-(F) You can't use the B<-D> option unless the code to produce the
+(F debugging) You can't use the B<-D> option unless the code to produce the
 desired output is compiled into Perl, which entails some overhead,
 which is why it's currently left out of your copy.
 
@@ -2582,7 +2598,7 @@ method.  Probably indicates an unintended loop in your inheritance hierarchy.
 
 =item Reference found where even-sized list expected
 
-(W) You gave a single reference where Perl was expecting a list with
+(W misc) You gave a single reference where Perl was expecting a list with
 an even number of elements (for assignment to a hash). This
 usually means that you used the anon hash constructor when you meant 
 to use parens. In any case, a hash requires key/value B<pairs>.
@@ -2594,12 +2610,12 @@ to use parens. In any case, a hash requires key/value B<pairs>.
 
 =item Reference is already weak
 
-(W) You have attempted to weaken a reference that is already weak.
+(W misc) You have attempted to weaken a reference that is already weak.
 Doing so has no effect.
 
 =item Reference miscount in sv_replace()
 
-(W) The internal sv_replace() function was handed a new SV with a
+(W internal) The internal sv_replace() function was handed a new SV with a
 reference count of other than 1.
 
 =item regexp *+ operand could be empty
@@ -2618,7 +2634,7 @@ expression compiler gave it.
 
 =item Reversed %s= operator
 
-(W) You wrote your assignment operator backwards.  The = must always
+(W syntax) You wrote your assignment operator backwards.  The = must always
 comes last, to avoid ambiguity with subsequent unary operators.
 
 =item Runaway format
@@ -2631,7 +2647,7 @@ shifting or popping (for array variables).  See L<perlform>.
 
 =item Scalar value @%s[%s] better written as $%s[%s]
 
-(W) You've used an array slice (indicated by @) to select a single element of
+(W syntax) You've used an array slice (indicated by @) to select a single element of
 an array.  Generally it's better to ask for a scalar value (indicated by $).
 The difference is that C<$foo[&bar]> always behaves like a scalar, both when
 assigning to it and when evaluating its argument, while C<@foo[&bar]> behaves
@@ -2645,7 +2661,7 @@ L<perlref>.
 
 =item Scalar value @%s{%s} better written as $%s{%s}
 
-(W) You've used a hash slice (indicated by @) to select a single element of
+(W syntax) You've used a hash slice (indicated by @) to select a single element of
 a hash.  Generally it's better to ask for a scalar value (indicated by $).
 The difference is that C<$foo{&bar}> always behaves like a scalar, both when
 assigning to it and when evaluating its argument, while C<@foo{&bar}> behaves
@@ -2670,7 +2686,7 @@ Missing the leading C<$> from a variable C<$m> may cause this error.
 
 =item %sseek() on unopened file
 
-(W) You tried to use the seek() or sysseek() function on a filehandle that
+(W unopened) You tried to use the seek() or sysseek() function on a filehandle that
 was either never opened or has since been closed.
 
 =item select not implemented
@@ -2683,17 +2699,17 @@ was either never opened or has since been closed.
 
 =item semi-panic: attempt to dup freed string
 
-(S) The internal newSVsv() routine was called to duplicate a scalar
+(S internal) The internal newSVsv() routine was called to duplicate a scalar
 that had previously been marked as free.
 
 =item Semicolon seems to be missing
 
-(W) A nearby syntax error was probably caused by a missing semicolon,
+(W semicolon) A nearby syntax error was probably caused by a missing semicolon,
 or possibly some other missing operator, such as a comma.
 
 =item send() on closed socket %s
 
-(W) The socket you're sending to got itself closed sometime before now.
+(W closed) The socket you're sending to got itself closed sometime before now.
 Check your logic flow.
 
 =item Sequence (? incomplete
@@ -2782,11 +2798,11 @@ because the world might have written on it already.
 
 =item shutdown() on closed socket %s
 
-(W) You tried to do a shutdown on a closed socket.  Seems a bit superfluous.
+(W closed) You tried to do a shutdown on a closed socket.  Seems a bit superfluous.
 
 =item SIG%s handler "%s" not defined
 
-(W) The signal handler named in %SIG doesn't, in fact, exist.  Perhaps you
+(W signal) The signal handler named in %SIG doesn't, in fact, exist.  Perhaps you
 put it into the wrong package?
 
 =item sort is now a reserved word
@@ -2813,12 +2829,12 @@ See L<perlfunc/split>.
 
 =item Stat on unopened file E<lt>%sE<gt>
 
-(W) You tried to use the stat() function (or an equivalent file test)
+(W unopened) You tried to use the stat() function (or an equivalent file test)
 on a filehandle that was either never opened or has since been closed.
 
 =item Statement unlikely to be reached
 
-(W) You did an exec() with some statement after it other than a die().
+(W exec) You did an exec() with some statement after it other than a die().
 This is almost always an error, because exec() never returns unless
 there was a failure.  You probably wanted to use system() instead,
 which does return.  To suppress this warning, put the exec() in a block
@@ -2826,7 +2842,7 @@ by itself.
 
 =item Strange *+?{} on zero-length expression
 
-(W) You applied a regular expression quantifier in a place where it
+(W regexp) You applied a regular expression quantifier in a place where it
 makes no sense, such as on a zero-width assertion.
 Try putting the quantifier inside the assertion instead.  For example,
 the way to match "abc" provided that it is followed by three
@@ -2840,7 +2856,7 @@ may break this.
 
 =item Subroutine %s redefined
 
-(W) You redefined a subroutine.  To suppress this warning, say
+(W redefine) You redefined a subroutine.  To suppress this warning, say
 
     {
        no warnings;
@@ -2868,10 +2884,10 @@ Missing the leading C<$> from variable C<$s> may cause this error.
 
 =item substr outside of string
 
-(S),(W) You tried to reference a substr() that pointed outside of a
+(W substr),(F) You tried to reference a substr() that pointed outside of a
 string.  That is, the absolute value of the offset was larger than the
 length of the string.  See L<perlfunc/substr>.  This warning is
-mandatory if substr is used in an lvalue context (as the left hand side
+fatal if substr is used in an lvalue context (as the left hand side
 of an assignment or as a subroutine argument for example).
 
 =item suidperl is no longer needed since %s
@@ -2920,7 +2936,7 @@ unconfigured.  Consult your system support.
 
 =item syswrite() on closed filehandle %s
 
-(W) The filehandle you're writing to got itself closed sometime before now.
+(W closed) The filehandle you're writing to got itself closed sometime before now.
 Check your logic flow.
 
 =item Target of goto is too deeply nested
@@ -2930,12 +2946,12 @@ nested for Perl to reach.  Perl is doing you a favor by refusing.
 
 =item tell() on unopened file
 
-(W) You tried to use the tell() function on a filehandle that was either
+(W unopened) You tried to use the tell() function on a filehandle that was either
 never opened or has since been closed.
 
 =item Test on unopened file E<lt>%sE<gt>
 
-(W) You tried to invoke a file test operator on a filehandle that isn't
+(W unopened) You tried to invoke a file test operator on a filehandle that isn't
 open.  Check your logic.  See also L<perlfunc/-X>.
 
 =item That use of $[ is unsupported
@@ -2976,7 +2992,7 @@ the symlink to get to the real file.  Use an actual filename instead.
 
 =item This Perl can't set CRTL environ elements (%s=%s)
 
-(W) Warnings peculiar to VMS.  You tried to change or delete an element
+(W internal) Warnings peculiar to VMS.  You tried to change or delete an element
 of the CRTL's internal environ array, but your copy of Perl wasn't
 built with a CRTL that contained the setenv() function.  You'll need to
 rebuild Perl with a CRTL that does, or redefine F<PERL_ENV_TABLES> (see
@@ -3061,7 +3077,7 @@ certain type.  Arrays must be @NAME or C<@{EXPR}>.  Hashes must be
 
 =item umask: argument is missing initial 0
 
-(W) A umask of 222 is incorrect.  It should be 0222, because octal
+(W umask) A umask of 222 is incorrect.  It should be 0222, because octal
 literals always start with 0 in Perl, as in C.
 
 =item umask not implemented
@@ -3075,22 +3091,22 @@ to use it to restrict permissions for yourself (EXPR & 0700).
 
 =item Unbalanced context: %d more PUSHes than POPs
 
-(W) The exit code detected an internal inconsistency in how many execution
+(W internal) The exit code detected an internal inconsistency in how many execution
 contexts were entered and left.
 
 =item Unbalanced saves: %d more saves than restores
 
-(W) The exit code detected an internal inconsistency in how many
+(W internal) The exit code detected an internal inconsistency in how many
 values were temporarily localized.
 
 =item Unbalanced scopes: %d more ENTERs than LEAVEs
 
-(W) The exit code detected an internal inconsistency in how many blocks
+(W internal) The exit code detected an internal inconsistency in how many blocks
 were entered and left.
 
 =item Unbalanced tmps: %d more allocs than frees
 
-(W) The exit code detected an internal inconsistency in how many mortal
+(W internal) The exit code detected an internal inconsistency in how many mortal
 scalars were allocated and freed.
 
 =item Undefined format "%s" called
@@ -3125,7 +3141,7 @@ another package?  See L<perlform>.
 
 =item Undefined value assigned to typeglob
 
-(W) An undefined value was assigned to a typeglob, a la C<*foo = undef>.
+(W misc) An undefined value was assigned to a typeglob, a la C<*foo = undef>.
 This does nothing.  It's possible that you really mean C<undef *foo>.
 
 =item unexec of %s into %s failed!
@@ -3171,7 +3187,7 @@ See L<perlre>.
 
 =item Unquoted string "%s" may clash with future reserved word
 
-(W) You used a bareword that might someday be claimed as a reserved word.
+(W reserved) You used a bareword that might someday be claimed as a reserved word.
 It's best to put such a word in quotes, or capitalize it somehow, or insert
 an underbar into it.  You might also declare it as a subroutine.
 
@@ -3183,7 +3199,7 @@ script, a binary program, or a directory as a Perl program.
 
 =item Unrecognized escape \\%c passed through
 
-(W) You used a backslash-character combination which is not recognized
+(W misc) You used a backslash-character combination which is not recognized
 by Perl.
 
 =item Unrecognized signal name "%s"
@@ -3199,7 +3215,7 @@ supplying the bad switch on your behalf.)
 
 =item Unsuccessful %s on filename containing newline
 
-(W) A file operation was attempted on a filename, and that operation
+(W newline) A file operation was attempted on a filename, and that operation
 failed, PROBABLY because the filename contained a newline, PROBABLY
 because you forgot to chop() or chomp() it off.  See L<perlfunc/chomp>.
 
@@ -3248,12 +3264,12 @@ too soon.  See L<attributes>.
 
 =item Use of $# is deprecated
 
-(D) This was an ill-advised attempt to emulate a poorly defined B<awk> feature.
+(D deprecated) This was an ill-advised attempt to emulate a poorly defined B<awk> feature.
 Use an explicit printf() or sprintf() instead.
 
 =item Use of $* is deprecated
 
-(D) This variable magically turned on multi-line pattern matching, both for
+(D deprecated) This variable magically turned on multi-line pattern matching, both for
 you and for any luckless subroutine that you happen to call.  You should
 use the new C<//m> and C<//s> modifiers now to do that without the dangerous
 action-at-a-distance effects of C<$*>.
@@ -3265,18 +3281,18 @@ only C.  This usually means there's a better way to do it in Perl.
 
 =item Use of bare E<lt>E<lt> to mean E<lt>E<lt>"" is deprecated
 
-(D) You are now encouraged to use the explicitly quoted form if you
+(D deprecated) You are now encouraged to use the explicitly quoted form if you
 wish to use an empty line as the terminator of the here-document.
 
 =item Use of implicit split to @_ is deprecated
 
-(D) It makes a lot of work for the compiler when you clobber a
+(D deprecated) It makes a lot of work for the compiler when you clobber a
 subroutine's argument list, so it's better if you assign the results of
 a split() explicitly to an array (or list).
 
 =item Use of inherited AUTOLOAD for non-method %s() is deprecated
 
-(D) As an (ahem) accidental feature, C<AUTOLOAD> subroutines are looked
+(D deprecated) As an (ahem) accidental feature, C<AUTOLOAD> subroutines are looked
 up as methods (using the C<@ISA> hierarchy) even when the subroutines to
 be autoloaded were called as plain functions (e.g. C<Foo::bar()>), not
 as methods (e.g. C<Foo-E<gt>bar()> or C<$obj-E<gt>bar()>).
@@ -3298,7 +3314,7 @@ C<use AutoLoader 'AUTOLOAD';>.
 
 =item Use of reserved word "%s" is deprecated
 
-(D) The indicated bareword is a reserved word.  Future versions of perl
+(D deprecated) The indicated bareword is a reserved word.  Future versions of perl
 may use it as a keyword, so you're better off either explicitly quoting
 the word in a manner appropriate for its context of use, or using a
 different name altogether.  The warning can be suppressed for subroutine
@@ -3307,13 +3323,13 @@ e.g. C<&our()>, or C<Foo::our()>.
 
 =item Use of %s is deprecated
 
-(D) The construct indicated is no longer recommended for use, generally
+(D deprecated) The construct indicated is no longer recommended for use, generally
 because there's a better way to do it, and also because the old way has
 bad side effects.
 
 =item Use of uninitialized value%s
 
-(W) An undefined value was used as if it were already defined.  It was
+(W uninitialized) An undefined value was used as if it were already defined.  It was
 interpreted as a "" or a 0, but maybe it was a mistake.  To suppress this
 warning assign a defined value to your variables.
 
@@ -3323,7 +3339,7 @@ warning assign a defined value to your variables.
 
 =item Useless use of %s in void context
 
-(W) You did something without a side effect in a context that does nothing
+(W void) You did something without a side effect in a context that does nothing
 with the return value, such as a statement that doesn't return a value
 from a block, or the left side of a scalar comma operator.  Very often
 this points not to stupidity on your part, but a failure of Perl to parse
@@ -3354,12 +3370,12 @@ L<perlref> for more on this.
 
 =item untie attempted while %d inner references still exist
 
-(W) A copy of the object returned from C<tie> (or C<tied>) was still
+(W untie) A copy of the object returned from C<tie> (or C<tied>) was still
 valid when C<untie> was called.
 
 =item Value of %s can be "0"; test with defined()
 
-(W) In a conditional expression, you used <HANDLE>, <*> (glob), C<each()>,
+(W misc) In a conditional expression, you used <HANDLE>, <*> (glob), C<each()>,
 or C<readdir()> as a boolean value.  Each of these constructs can return a
 value of "0"; that would make the conditional expression false, which is
 probably not what you intended.  When using these constructs in conditional
@@ -3367,7 +3383,7 @@ expressions, test their values with the C<defined> operator.
 
 =item Value of CLI symbol "%s" too long
 
-(W) A warning peculiar to VMS.  Perl tried to read the value of an %ENV
+(W misc) A warning peculiar to VMS.  Perl tried to read the value of an %ENV
 element from a CLI symbol table, and found a resultant string longer
 than 1024 characters.  The return value has been truncated to 1024
 characters.
@@ -3382,7 +3398,7 @@ on the front of your variable.
 
 =item Variable "%s" may be unavailable
 
-(W) An inner (nested) I<anonymous> subroutine is inside a I<named>
+(W closure) An inner (nested) I<anonymous> subroutine is inside a I<named>
 subroutine, and outside that is another subroutine; and the anonymous
 (innermost) subroutine is referencing a lexical variable defined in
 the outermost subroutine.  For example:
@@ -3404,7 +3420,7 @@ subroutine in between interferes with this feature.
 
 =item Variable "%s" will not stay shared
 
-(W) An inner (nested) I<named> subroutine is referencing a lexical
+(W closure) An inner (nested) I<named> subroutine is referencing a lexical
 variable defined in an outer subroutine.
 
 When the inner subroutine is called, it will probably see the value of
@@ -3469,7 +3485,7 @@ close().  This usually indicates your file system ran out of disk space.
 
 =item Warning: Use of "%s" without parentheses is ambiguous
 
-(S) You wrote a unary operator followed by something that looks like a
+(S ambiguous) You wrote a unary operator followed by something that looks like a
 binary operator that could also have been interpreted as a term or
 unary operator.  For instance, if you know that the rand function
 has a default argument of 1.0, and you write
@@ -3488,7 +3504,7 @@ So put in parentheses to say what you really mean.
 
 =item write() on closed filehandle %s
 
-(W) The filehandle you're writing to got itself closed sometime before now.
+(W closed) The filehandle you're writing to got itself closed sometime before now.
 Check your logic flow.
 
 =item X outside of string
@@ -3524,20 +3540,20 @@ the eg directory to put a setuid C wrapper around your script.
 
 =item You need to quote "%s"
 
-(W) You assigned a bareword as a signal handler name.  Unfortunately, you
+(W syntax) You assigned a bareword as a signal handler name.  Unfortunately, you
 already have a subroutine of that name declared, which means that Perl 5
 will try to call the subroutine when the assignment is executed, which is
 probably not what you want.  (If it IS what you want, put an & in front.)
 
 =item %cetsockopt() on closed socket %s
 
-(W) You tried to get or set a socket option on a closed socket.
+(W closed) You tried to get or set a socket option on a closed socket.
 Did you forget to check the return value of your socket() call?
 See L<perlfunc/getsockopt> and L<perlfunc/setsockopt>.
 
 =item \1 better written as $1
 
-(W) Outside of patterns, backreferences live on as variables.  The use
+(W syntax) Outside of patterns, backreferences live on as variables.  The use
 of backslashes is grandfathered on the right-hand side of a
 substitution, but stylistically it's better to use the variable form
 because other Perl programmers will expect it, and it works better
index 5de9dc7..e11364d 100644 (file)
@@ -517,7 +517,7 @@ print a stack trace.  The value of EXPR indicates how many call frames
 to go back before the current one.
 
     ($package, $filename, $line, $subroutine, $hasargs,
-    $wantarray, $evaltext, $is_require, $hints) = caller($i);
+    $wantarray, $evaltext, $is_require, $hints, $bitmask) = caller($i);
 
 Here $subroutine may be C<(eval)> if the frame is not a subroutine
 call, but an C<eval>.  In such a case additional elements $evaltext and
@@ -526,9 +526,9 @@ C<require> or C<use> statement, $evaltext contains the text of the
 C<eval EXPR> statement.  In particular, for a C<eval BLOCK> statement,
 $filename is C<(eval)>, but $evaltext is undefined.  (Note also that
 each C<use> statement creates a C<require> frame inside an C<eval EXPR>)
-frame.  C<$hints> contains pragmatic hints that the caller was
-compiled with.  The C<$hints> value is subject to change between versions
-of Perl, and is not meant for external use.
+frame.  C<$hints> and C<$bitmask> contain pragmatic hints that the caller
+was compiled with.  The C<$hints> and C<$bitmask> values are subject to
+change between versions of Perl, and are not meant for external use.
 
 Furthermore, when called from within the DB package, caller returns more
 detailed information: it sets the list variable C<@DB::args> to be the
index 6078aef..d370f04 100644 (file)
@@ -55,13 +55,11 @@ warning about the "2:".
 
     my $a = "2:" + 3;
 
-though the result will be 5.
-
 With the introduction of lexical warnings, mandatory warnings now become
 I<default> warnings. The difference is that although the previously
 mandatory warnings are still enabled by default, they can then be
 subsequently enabled or disabled with the lexical warning pragma. For
-example, in the code below, an C<"integer overflow"> warning will only
+example, in the code below, an C<"isn't numeric"> warning will only
 be reported for the C<$a> variable.
 
     my $a = "2:" + 3;
@@ -166,8 +164,9 @@ How Lexical Warnings interact with B<-w>/C<$^W>:
 =item 1.
 
 If none of the three command line flags (B<-w>, B<-W> or B<-X>) that
-control warnings is used and neither C<$^W> or lexical warnings are used,
-then default warnings will be enabled and optional warnings disabled.
+control warnings is used and neither C<$^W> or the C<warnings> pragma
+are used, then default warnings will be enabled and optional warnings
+disabled.
 This means that legacy code that doesn't attempt to control the warnings
 will work unchanged.
 
@@ -185,7 +184,7 @@ disable/enable default warnings.
 
 =item 4.
  
-If a piece of code is under the control of the lexical warning pragma,
+If a piece of code is under the control of the C<warnings> pragma,
 both the C<$^W> variable and the B<-w> flag will be ignored for the
 scope of the lexical warning.
 
@@ -197,82 +196,109 @@ or B<-X> command line flags.
 =back
 
 The combined effect of 3 & 4 is that it will will allow code which uses
-the lexical warnings pragma to control the warning behavior of $^W-type
+the C<warnings> pragma to control the warning behavior of $^W-type
 code (using a C<local $^W=0>) if it really wants to, but not vice-versa.
 
-=head1 EXPERIMENTAL FEATURES
-
-The features described in this section are experimental, and so subject
-to change.
-
 =head2 Category Hierarchy
  
-A B<tentative> hierarchy of "categories" have been defined to allow groups
-of warnings to be enabled/disabled in isolation.  The current
-hierarchy is:
-
-    all - +--- unsafe -------+--- taint
-          |                  |
-          |                  +--- substr
-          |                  |
-          |                  +--- signal
-          |                  |
-          |                  +--- closure
-          |                  |
-          |                  +--- overflow
-          |                  |
-          |                  +--- portable
-          |                  |
-          |                  +--- untie
-          |                  |
-          |                  +--- utf8
-          |                  
-          +--- io   ---------+--- pipe
-          |                  |
-          |                  +--- unopened
-          |                  |
-          |                  +--- closed
-          |                  |
-          |                  +--- newline
-          |                  |
-          |                  +--- exec
-          |
-          +--- syntax    ----+--- ambiguous
-          |                  |
-          |                  +--- semicolon
-          |                  |
-          |                  +--- precedence
-          |                  |
-          |                  +--- reserved
-          |                  |
-          |                  +--- digit
-          |                  |
-          |                  +--- parenthesis
-          |                  |
-          |                  +--- deprecated
-          |                  |
-          |                  +--- printf
-          |
-          +--- severe    ----+--- inplace
-          |                  |
-          |                  +--- internal
-          |                  |
-          |                  +--- debugging
-          |
-          |--- uninitialized
-          |
-          +--- void
-          |
-          +--- recursion
-          |
-          +--- redefine
-          |
-          +--- numeric
-          |
-          +--- once
-          |
-          +--- misc
-
+A hierarchy of "categories" have been defined to allow groups of warnings
+to be enabled/disabled in isolation.
+
+The current hierarchy is:
+
+  all -+
+       |
+       +- chmod
+       |
+       +- closure
+       |
+       +- exiting
+       |
+       +- glob
+       |
+       +- io -----------+
+       |                |
+       |                +- closed
+       |                |
+       |                +- exec
+       |                |
+       |                +- newline
+       |                |
+       |                +- pipe
+       |                |
+       |                +- unopened
+       |
+       +- misc
+       |
+       +- numeric
+       |
+       +- once
+       |
+       +- overflow
+       |
+       +- pack
+       |
+       +- portable
+       |
+       +- recursion
+       |
+       +- redefine
+       |
+       +- regexp
+       |
+       +- severe -------+
+       |                |
+       |                +- debugging
+       |                |
+       |                +- inplace
+       |                |
+       |                +- internal
+       |                |
+       |                +- malloc
+       |
+       +- signal
+       |
+       +- substr
+       |
+       +- syntax -------+
+       |                |
+       |                +- ambiguous
+       |                |
+       |                +- bareword
+       |                |
+       |                +- deprecated
+       |                |
+       |                +- digit
+       |                |
+       |                +- parenthesis
+       |                |
+       |                +- precedence
+       |                |
+       |                +- printf
+       |                |
+       |                +- prototype
+       |                |
+       |                +- qw
+       |                |
+       |                +- reserved
+       |                |
+       |                +- semicolon
+       |
+       +- taint
+       |
+       +- umask
+       |
+       +- uninitialized
+       |
+       +- unpack
+       |
+       +- untie
+       |
+       +- utf8
+       |
+       +- void
+       |
+       +- y2k
 
 Just like the "strict" pragma any of these categories can be combined
 
@@ -280,7 +306,7 @@ Just like the "strict" pragma any of these categories can be combined
     no warnings qw(io syntax untie) ;
 
 Also like the "strict" pragma, if there is more than one instance of the
-warnings pragma in a given scope the cumulative effect is additive. 
+C<warnings> pragma in a given scope the cumulative effect is additive. 
 
     use warnings qw(void) ; # only "void" warnings enabled
     ...
@@ -288,14 +314,16 @@ warnings pragma in a given scope the cumulative effect is additive.
     ...
     no warnings qw(void) ;  # only "io" warnings enabled
 
+To determine which category a specific warning has been assigned to see
+L<perldiag>.
 
 =head2 Fatal Warnings
  
 The presence of the word "FATAL" in the category list will escalate any
-warnings from the category/categories specified that are detected in
-the lexical scope into fatal errors. In the code below, there are 3
-places where a deprecated warning will be detected, the middle one will
-produce a fatal error.
+warnings detected from the categories specified in the lexical scope
+into fatal errors. In the code below, there are 3 places where a
+deprecated warning will be detected, the middle one will produce a
+fatal error.
 
 
     use warnings ;
@@ -308,15 +336,54 @@ produce a fatal error.
     }
  
     $a = 1 if $a EQ $b ;
-=head1 TODO
-The experimental features need bottomed out.
 
-  perldiag.pod
-    Need to add warning class information and notes on
-    how to use the class info with the warnings pragma.
+=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.
+
+Consider the module C<abc> below.
+
+    package abc;
+
+    sub open
+    {
+        if (warnings::enabled("deprecated")) {
+            warnings::warn("deprecated", 
+                           "abc::open is deprecated. Use abc:new") ;
+        }
+        new(@_) ;
+    }
 
+    sub new
+    ...
+    1 ;
+
+The function C<open> has been deprecated, so code has been included to
+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;
+    ...
+    abc::open($filename) ;
+
+
+If the calling module has escalated the "deprecated" warnings category
+into a fatal error like this:
+
+    use warnings 'FATAL deprecated';
+    use abc;
+    ...
+    abc::open($filename) ;
+
+then C<warnings::warn> will detect this and die after displaying the
+warning message.
+
+=head1 TODO
   perl5db.pl
     The debugger saves and restores C<$^W> at runtime. I haven't checked
     whether the debugger will still work with the lexical warnings
@@ -330,7 +397,7 @@ The experimental features need bottomed out.
 
 =head1 SEE ALSO
 
-L<warnings>.
+L<warnings>, L<perldiag>.
  
 =head1 AUTHOR
  
diff --git a/pp.c b/pp.c
index 0b05764..b6275dd 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -585,8 +585,8 @@ PP(pp_bless)
        SV *ssv = POPs;
        STRLEN len;
        char *ptr = SvPV(ssv,len);
-       if (ckWARN(WARN_UNSAFE) && len == 0)
-           Perl_warner(aTHX_ WARN_UNSAFE
+       if (ckWARN(WARN_MISC) && len == 0)
+           Perl_warner(aTHX_ WARN_MISC
                   "Explicit blessing to '' (assuming package main)");
        stash = gv_stashpvn(ptr, len, TRUE);
     }
@@ -832,8 +832,8 @@ PP(pp_undef)
        hv_undef((HV*)sv);
        break;
     case SVt_PVCV:
-       if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
-           Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined",
+       if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
+           Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
                 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
        /* FALL THROUGH */
     case SVt_PVFM:
@@ -2012,7 +2012,9 @@ PP(pp_substr)
        rem -= pos;
     }
     if (fail < 0) {
-       if (ckWARN(WARN_SUBSTR) || lvalue || repl)
+       if (lvalue || repl)
+           Perl_croak(aTHX_ "substr outside of string");
+       if (ckWARN(WARN_SUBSTR))
            Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
        RETPUSHUNDEF;
     }
@@ -2881,8 +2883,8 @@ PP(pp_anonhash)
        SV *val = NEWSV(46, 0);
        if (MARK < SP)
            sv_setsv(val, *++MARK);
-       else if (ckWARN(WARN_UNSAFE))
-           Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
+       else if (ckWARN(WARN_MISC))
+           Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
        (void)hv_store_ent(hv,key,val,0);
     }
     SP = ORIGMARK;
@@ -3392,8 +3394,8 @@ PP(pp_unpack)
        default:
            DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
        case ',': /* grandfather in commas but with a warning */
-           if (commas++ == 0 && ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE,
+           if (commas++ == 0 && ckWARN(WARN_UNPACK))
+               Perl_warner(aTHX_ WARN_UNPACK,
                            "Invalid type in unpack: '%c'", (int)datumtype);
            break;
        case '%':
@@ -4455,8 +4457,8 @@ PP(pp_pack)
        default:
            DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
        case ',': /* grandfather in commas but with a warning */
-           if (commas++ == 0 && ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE,
+           if (commas++ == 0 && ckWARN(WARN_PACK))
+               Perl_warner(aTHX_ WARN_PACK,
                            "Invalid type in pack: '%c'", (int)datumtype);
            break;
        case '%':
@@ -4908,11 +4910,11 @@ PP(pp_pack)
                     * of pack() (and all copies of the result) are
                     * gone.
                     */
-                   if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr)
+                   if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
                                                || (SvPADTMP(fromstr)
                                                    && !SvREADONLY(fromstr))))
                    {
-                       Perl_warner(aTHX_ WARN_UNSAFE,
+                       Perl_warner(aTHX_ WARN_PACK,
                                "Attempt to pack pointer to temporary value");
                    }
                    if (SvPOK(fromstr) || SvNIOK(fromstr))
index 24fad37..7c69e35 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1075,28 +1075,28 @@ S_dopoptolabel(pTHX_ char *label)
        cx = &cxstack[i];
        switch (CxTYPE(cx)) {
        case CXt_SUBST:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_SUB:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_FORMAT:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_EVAL:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_NULL:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 
                        PL_op_name[PL_op->op_type]);
            return -1;
        case CXt_LOOP:
@@ -1201,28 +1201,28 @@ S_dopoptoloop(pTHX_ I32 startingblock)
        cx = &cxstack[i];
        switch (CxTYPE(cx)) {
        case CXt_SUBST:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_SUB:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_FORMAT:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_EVAL:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_NULL:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 
                        PL_op_name[PL_op->op_type]);
            return -1;
        case CXt_LOOP:
@@ -1347,9 +1347,9 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
                    SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
                    sv_catpvn(err, prefix, sizeof(prefix)-1);
                    sv_catpvn(err, message, msglen);
-                   if (ckWARN(WARN_UNSAFE)) {
+                   if (ckWARN(WARN_MISC)) {
                        STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
-                       Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
+                       Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
                    }
                }
            }
@@ -1456,7 +1456,7 @@ PP(pp_caller)
 
     if (MAXARG)
        count = POPi;
-    EXTEND(SP, 7);
+    EXTEND(SP, 10);
     for (;;) {
        /* we may be in a higher stacklevel, so dig down deeper */
        while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
@@ -1561,6 +1561,17 @@ PP(pp_caller)
      * use the global PL_hints) */
     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
                             HINT_PRIVATE_MASK)));
+    {
+       SV * mask ;
+       SV * old_warnings = cx->blk_oldcop->cop_warnings ;
+       if  (old_warnings == WARN_NONE || old_warnings == WARN_STD)
+            mask = newSVpvn(WARN_NONEstring, WARNsize) ;
+        else if (old_warnings == WARN_ALL)
+            mask = newSVpvn(WARN_ALLstring, WARNsize) ;
+        else
+            mask = newSVsv(old_warnings);
+        PUSHs(sv_2mortal(mask));
+    }
     RETURN;
 }
 
index 288bf5c..6027766 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -166,13 +166,13 @@ PP(pp_concat)
     s = SvPV(right,len);
     if (SvOK(TARG)) {
 #if defined(PERL_Y2KWARN)
-       if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_MISC)) {
+       if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
            STRLEN n;
            char *s = SvPV(TARG,n);
            if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
                && (n == 2 || !isDIGIT(s[n-3])))
            {
-               Perl_warner(aTHX_ WARN_MISC, "Possible Y2K bug: %s",
+               Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
                            "about to append an integer to '19'");
            }
        }
@@ -717,14 +717,14 @@ PP(pp_aassign)
                if (relem == lastrelem) {
                    if (*relem) {
                        HE *didstore;
-                       if (ckWARN(WARN_UNSAFE)) {
+                       if (ckWARN(WARN_MISC)) {
                            if (relem == firstrelem &&
                                SvROK(*relem) &&
                                ( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
                                  SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
-                               Perl_warner(aTHX_ WARN_UNSAFE, "Reference found where even-sized list expected");
+                               Perl_warner(aTHX_ WARN_MISC, "Reference found where even-sized list expected");
                            else
-                               Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
+                               Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
                        }
                        tmpstr = NEWSV(29,0);
                        didstore = hv_store_ent(hash,*relem,tmpstr,0);
@@ -1256,9 +1256,9 @@ Perl_do_readline(pTHX)
        }
     }
     if (!fp) {
-       if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) {
+       if (ckWARN2(WARN_GLOB,WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) {
            if (type == OP_GLOB)
-               Perl_warner(aTHX_ WARN_CLOSED,
+               Perl_warner(aTHX_ WARN_GLOB,
                            "glob failed (can't start child: %s)",
                            Strerror(errno));
            else
@@ -1307,8 +1307,8 @@ Perl_do_readline(pTHX)
                (void)do_close(PL_last_in_gv, FALSE);
            }
            else if (type == OP_GLOB) {
-               if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_CLOSED)) {
-                   Perl_warner(aTHX_ WARN_CLOSED,
+               if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
+                   Perl_warner(aTHX_ WARN_GLOB,
                           "glob failed (child exited with status %d%s)",
                           (int)(STATUS_CURRENT >> 8),
                           (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
index ca0b1d1..a3106dc 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -765,10 +765,10 @@ S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *da
                }
                if (!scan)              /* It was not CURLYX, but CURLY. */
                    scan = next;
-               if (ckWARN(WARN_UNSAFE) && (minnext + deltanext == 0) 
+               if (ckWARN(WARN_REGEXP) && (minnext + deltanext == 0) 
                    && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
                    && maxcount <= REG_INFTY/3) /* Complement check for big count */
-                   Perl_warner(aTHX_ WARN_UNSAFE,
+                   Perl_warner(aTHX_ WARN_REGEXP,
                                "Strange *+?{} on zero-length expression");
                min += minnext * mincount;
                is_inf_internal |= (maxcount == REG_INFTY 
@@ -2206,8 +2206,8 @@ S_regpiece(pTHX_ I32 *flagp)
        goto do_curly;
     }
   nest_check:
-    if (ckWARN(WARN_UNSAFE) && !SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3) {
-       Perl_warner(aTHX_ WARN_UNSAFE, "%.*s matches null string many times",
+    if (ckWARN(WARN_REGEXP) && !SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3) {
+       Perl_warner(aTHX_ WARN_REGEXP, "%.*s matches null string many times",
            PL_regcomp_parse - origparse, origparse);
     }
 
@@ -2634,8 +2634,8 @@ tryagain:
                            FAIL("trailing \\ in regexp");
                        /* FALL THROUGH */
                    default:
-                       if (!SIZE_ONLY && ckWARN(WARN_UNSAFE) && isALPHA(*p))
-                           Perl_warner(aTHX_ WARN_UNSAFE
+                       if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(*p))
+                           Perl_warner(aTHX_ WARN_REGEXP
                                        "/%.127s/: Unrecognized escape \\%c passed through",
                                        PL_regprecomp,
                                        *p);
@@ -2826,9 +2826,9 @@ S_regpposixcc(pTHX_ I32 value)
                            posixcc[skip + 1] == ']'))))
                        Perl_croak(aTHX_ "Character class [:%.*s:] unknown",
                                   t - s - 1, s + 1); 
-               } else if (ckWARN(WARN_UNSAFE) && !SIZE_ONLY)
+               } else if (ckWARN(WARN_REGEXP) && !SIZE_ONLY)
                    /* [[=foo=]] and [[.foo.]] are still future. */
-                   Perl_warner(aTHX_ WARN_UNSAFE,
+                   Perl_warner(aTHX_ WARN_REGEXP,
                                "Character class syntax [%c %c] is reserved for future extensions", c, c);
            } else {
                /* Maternal grandfather:
@@ -2844,7 +2844,7 @@ S_regpposixcc(pTHX_ I32 value)
 STATIC void
 S_checkposixcc(pTHX)
 {
-    if (!SIZE_ONLY && ckWARN(WARN_UNSAFE) &&
+    if (!SIZE_ONLY && ckWARN(WARN_REGEXP) &&
        (*PL_regcomp_parse == ':' ||
         *PL_regcomp_parse == '=' ||
         *PL_regcomp_parse == '.')) {
@@ -2854,10 +2854,10 @@ S_checkposixcc(pTHX)
        while(*s && isALNUM(*s))
            s++;
        if (*s && c == *s && s[1] == ']') {
-           Perl_warner(aTHX_ WARN_UNSAFE,
+           Perl_warner(aTHX_ WARN_REGEXP,
                        "Character class syntax [%c %c] belongs inside character classes", c, c);
            if (c == '=' || c == '.')
-               Perl_warner(aTHX_ WARN_UNSAFE,
+               Perl_warner(aTHX_ WARN_REGEXP,
                            "Character class syntax [%c %c] is reserved for future extensions", c, c);
        }
     }
@@ -2896,7 +2896,7 @@ S_regclass(pTHX)
            ANYOF_FLAGS(ret) |= ANYOF_INVERT;
     }
 
-    if (!SIZE_ONLY && ckWARN(WARN_UNSAFE))
+    if (!SIZE_ONLY && ckWARN(WARN_REGEXP))
        checkposixcc();
 
     if (*PL_regcomp_parse == ']' || *PL_regcomp_parse == '-')
@@ -2944,8 +2944,8 @@ S_regclass(pTHX)
                PL_regcomp_parse += numlen;
                break;
            default:
-               if (!SIZE_ONLY && ckWARN(WARN_UNSAFE) && isALPHA(value))
-                   Perl_warner(aTHX_ WARN_UNSAFE
+               if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value))
+                   Perl_warner(aTHX_ WARN_REGEXP
                                "/%.127s/: Unrecognized escape \\%c in character class passed through",
                                PL_regprecomp,
                                (int)value);
@@ -2958,8 +2958,8 @@ S_regclass(pTHX)
            need_class = 1;
            if (range) { /* a-\d, a-[:digit:] */
                if (!SIZE_ONLY) {
-                   if (ckWARN(WARN_UNSAFE))
-                       Perl_warner(aTHX_ WARN_UNSAFE,
+                   if (ckWARN(WARN_REGEXP))
+                       Perl_warner(aTHX_ WARN_REGEXP,
                                    "/%.127s/: false [] range \"%*.*s\" in regexp",
                                    PL_regprecomp,
                                    PL_regcomp_parse - rangebegin,
@@ -3243,8 +3243,8 @@ S_regclass(pTHX)
                PL_regcomp_parse[1] != ']') {
                PL_regcomp_parse++;
                if (namedclass > OOB_NAMEDCLASS) { /* \w-, [:word:]- */
-                   if (ckWARN(WARN_UNSAFE))
-                       Perl_warner(aTHX_ WARN_UNSAFE,
+                   if (ckWARN(WARN_REGEXP))
+                       Perl_warner(aTHX_ WARN_REGEXP,
                                    "/%.127s/: false [] range \"%*.*s\" in regexp",
                                    PL_regprecomp,
                                    PL_regcomp_parse - rangebegin,
@@ -3337,7 +3337,7 @@ S_regclassutf8(pTHX)
        listsv = newSVpvn("# comment\n",10);
     }
 
-    if (!SIZE_ONLY && ckWARN(WARN_UNSAFE))
+    if (!SIZE_ONLY && ckWARN(WARN_REGEXP))
        checkposixcc();
 
     if (*PL_regcomp_parse == ']' || *PL_regcomp_parse == '-')
@@ -3422,8 +3422,8 @@ S_regclassutf8(pTHX)
                PL_regcomp_parse += numlen;
                break;
            default:
-               if (!SIZE_ONLY && ckWARN(WARN_UNSAFE) && isALPHA(value))
-                   Perl_warner(aTHX_ WARN_UNSAFE
+               if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value))
+                   Perl_warner(aTHX_ WARN_REGEXP
                                "/%.127s/: Unrecognized escape \\%c in character class passed through",
                                PL_regprecomp,
                                (int)value);
@@ -3433,8 +3433,8 @@ S_regclassutf8(pTHX)
        if (namedclass > OOB_NAMEDCLASS) {
            if (range) { /* a-\d, a-[:digit:] */
                if (!SIZE_ONLY) {
-                   if (ckWARN(WARN_UNSAFE))
-                       Perl_warner(aTHX_ WARN_UNSAFE,
+                   if (ckWARN(WARN_REGEXP))
+                       Perl_warner(aTHX_ WARN_REGEXP,
                                    "/%.127s/: false [] range \"%*.*s\" in regexp",
                                    PL_regprecomp,
                                    PL_regcomp_parse - rangebegin,
@@ -3521,8 +3521,8 @@ S_regclassutf8(pTHX)
                PL_regcomp_parse[1] != ']') {
                PL_regcomp_parse++;
                if (namedclass > OOB_NAMEDCLASS) { /* \w-, [:word:]- */
-                   if (ckWARN(WARN_UNSAFE))
-                       Perl_warner(aTHX_ WARN_UNSAFE,
+                   if (ckWARN(WARN_REGEXP))
+                       Perl_warner(aTHX_ WARN_REGEXP,
                                    "/%.127s/: false [] range \"%*.*s\" in regexp",
                                    PL_regprecomp,
                                    PL_regcomp_parse - rangebegin,
index d2ebc44..bddf820 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -2663,10 +2663,10 @@ S_regmatch(pTHX_ regnode *prog)
                    PL_regcc = cc;
 
                    if (n >= cc->max) { /* Maximum greed exceeded? */
-                       if (ckWARN(WARN_UNSAFE) && n >= REG_INFTY 
+                       if (ckWARN(WARN_REGEXP) && n >= REG_INFTY 
                            && !(PL_reg_flags & RF_warned)) {
                            PL_reg_flags |= RF_warned;
-                           Perl_warner(aTHX_ WARN_UNSAFE, "%s limit (%d) exceeded",
+                           Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
                                 "Complex regular subexpression recursion",
                                 REG_INFTY - 1);
                        }
@@ -2715,10 +2715,10 @@ S_regmatch(pTHX_ regnode *prog)
                                      REPORT_CODE_OFF+PL_regindent*2, "")
                        );
                }
-               if (ckWARN(WARN_UNSAFE) && n >= REG_INFTY 
+               if (ckWARN(WARN_REGEXP) && n >= REG_INFTY 
                        && !(PL_reg_flags & RF_warned)) {
                    PL_reg_flags |= RF_warned;
-                   Perl_warner(aTHX_ WARN_UNSAFE, "%s limit (%d) exceeded",
+                   Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
                         "Complex regular subexpression recursion",
                         REG_INFTY - 1);
                }
diff --git a/sv.c b/sv.c
index 43ed4e4..fcabe6b 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2662,16 +2662,11 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                                    Perl_croak(aTHX_ 
                                    "Can't redefine active sort subroutine %s",
                                          GvENAME((GV*)dstr));
-                               if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
-                                   if (!(CvGV(cv) && GvSTASH(CvGV(cv))
-                                         && HvNAME(GvSTASH(CvGV(cv)))
-                                         && strEQ(HvNAME(GvSTASH(CvGV(cv))),
-                                                  "autouse")))
-                                       Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? 
+                               if ((const_changed || const_sv) && ckWARN(WARN_REDEFINE))
+                                   Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? 
                                             "Constant subroutine %s redefined"
                                             : "Subroutine %s redefined", 
                                             GvENAME((GV*)dstr));
-                               }
                            }
                            cv_ckproto(cv, (GV*)dstr,
                                       SvPOK(sref) ? SvPVX(sref) : Nullch);
@@ -2812,8 +2807,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
     }
     else {
        if (dtype == SVt_PVGV) {
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
+           if (ckWARN(WARN_MISC))
+               Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
        }
        else
            (void)SvOK_off(dstr);
@@ -6153,13 +6148,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                break;
            default:            /* it had better be ten or less */
 #if defined(PERL_Y2KWARN)
-               if (ckWARN(WARN_MISC)) {
+               if (ckWARN(WARN_Y2K)) {
                    STRLEN n;
                    char *s = SvPV(sv,n);
                    if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
                        && (n == 2 || !isDIGIT(s[n-3])))
                    {
-                       Perl_warner(aTHX_ WARN_MISC,
+                       Perl_warner(aTHX_ WARN_Y2K,
                                    "Possible Y2K bug: %%%c %s",
                                    c, "format string following '19'");
                    }
index 8d31a9a..5764e67 100755 (executable)
@@ -1,12 +1,14 @@
-#!./perl
 
-print "1..108\n";
+print "1..125\n";
 
 #P = start of string  Q = start of substr  R = end of substr  S = end of string
 
-$a = 'abcdefxyz';
-BEGIN { $^W = 1 };
+BEGIN {
+    unshift @INC, '../lib' if -d '../lib' ;
+}
+use warnings ;
 
+$a = 'abcdefxyz';
 $SIG{__WARN__} = sub {
      if ($_[0] =~ /^substr outside of string/) {
           $w++;
@@ -19,139 +21,198 @@ $SIG{__WARN__} = sub {
      }
 };
 
-sub fail { !defined(shift) && $w-- };
+sub ok { print (($_[1] ? "" : "not ") . "ok $_[0]\n") }
+
+$FATAL_MSG = '^substr outside of string' ;
 
-print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n");   # P=Q R S
-print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n");   # P Q R S
-print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n"); # P Q S R
-print (fail(substr($a,999,999)) ? "ok 4\n" : "not ok 4\n");  # P R Q S
-print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n");  # P=Q R S
-print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n");    # P Q R S
+ok 1, substr($a,0,3) eq 'abc';   # P=Q R S
+ok 2, substr($a,3,3) eq 'def';   # P Q R S
+ok 3, substr($a,6,999) eq 'xyz'; # P Q S R
+$b = substr($a,999,999) ; # warn # P R Q S
+ok 4, $w-- == 1 ;
+eval{substr($a,999,999) = "" ; };# P R Q S
+ok 5, $@ =~ /$FATAL_MSG/;
+ok 6, substr($a,0,-6) eq 'abc';  # P=Q R S
+ok 7, substr($a,-3,1) eq 'x';    # P Q R S
 
 $[ = 1;
 
-print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n");   # P=Q R S
-print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n");   # P Q R S
-print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n"); # P Q S R
-print (fail(substr($a,999,999)) ? "ok 10\n" : "not ok 10\n");# P R Q S
-print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n");# P=Q R S
-print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n");  # P Q R S
+ok 8, substr($a,1,3) eq 'abc' ;  # P=Q R S
+ok 9, substr($a,4,3) eq 'def' ;  # P Q R S
+ok 10, substr($a,7,999) eq 'xyz';# P Q S R
+$b = substr($a,999,999) ; # warn # P R Q S
+ok 11, $w-- == 1 ;
+eval{substr($a,999,999) = "" ; } ; # P R Q S
+ok 12, $@ =~ /$FATAL_MSG/;
+ok 13, substr($a,1,-6) eq 'abc' ;# P=Q R S
+ok 14, substr($a,-3,1) eq 'x' ;  # P Q R S
 
 $[ = 0;
 
 substr($a,3,3) = 'XYZ';
-print $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n";
+ok 15, $a eq 'abcXYZxyz' ;
 substr($a,0,2) = '';
-print $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n";
+ok 16, $a eq 'cXYZxyz' ;
 substr($a,0,0) = 'ab';
-print $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n";
+ok 17, $a eq 'abcXYZxyz' ;
 substr($a,0,0) = '12345678';
-print $a eq '12345678abcXYZxyz' ? "ok 16\n" : "not ok 16\n";
+ok 18, $a eq '12345678abcXYZxyz' ;
 substr($a,-3,3) = 'def';
-print $a eq '12345678abcXYZdef' ? "ok 17\n" : "not ok 17\n";
+ok 19, $a eq '12345678abcXYZdef';
 substr($a,-3,3) = '<';
-print $a eq '12345678abcXYZ<' ? "ok 18\n" : "not ok 18\n";
+ok 20, $a eq '12345678abcXYZ<' ;
 substr($a,-1,1) = '12345678';
-print $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n";
+ok 21, $a eq '12345678abcXYZ12345678' ;
 
 $a = 'abcdefxyz';
 
-print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n");   # P Q R=S
-print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n");  # P Q R=S
-print (fail(substr($a,999)) ? "ok 22\n" : "not ok 22\n");    # P R=S Q
-print (substr($a,0) eq 'abcdefxyz' ? "ok 23\n" : "not ok 23\n");# P=Q R=S
-print (substr($a,9) eq '' ? "ok 24\n" : "not ok 24\n");      # P Q=R=S
-print (substr($a,-11) eq 'abcdefxyz' ? "ok 25\n" : "not ok 25\n");# Q P R=S
-print (substr($a,-9) eq 'abcdefxyz' ? "ok 26\n" : "not ok 26\n");  # P=Q R=S
+ok 22, substr($a,6) eq 'xyz' ;        # P Q R=S
+ok 23, substr($a,-3) eq 'xyz' ;       # P Q R=S
+$b = substr($a,999,999) ; # warning   # P R=S Q
+ok 24, $w-- == 1 ;
+eval{substr($a,999,999) = "" ; } ;    # P R=S Q
+ok 25, $@ =~ /$FATAL_MSG/;
+ok 26, substr($a,0) eq 'abcdefxyz' ;  # P=Q R=S
+ok 27, substr($a,9) eq '' ;           # P Q=R=S
+ok 28, substr($a,-11) eq 'abcdefxyz'; # Q P R=S
+ok 29, substr($a,-9) eq 'abcdefxyz';  # P=Q R=S
 
 $a = '54321';
 
-print (fail(substr($a,-7, 1)) ? "ok 27\n" : "not ok 27\n");  # Q R P S
-print (fail(substr($a,-7,-6)) ? "ok 28\n" : "not ok 28\n");  # Q R P S
-print (substr($a,-5,-7) eq '' ? "ok 29\n" : "not ok 29\n");  # R P=Q S
-print (substr($a, 2,-7) eq '' ? "ok 30\n" : "not ok 30\n");  # R P Q S
-print (substr($a,-3,-7) eq '' ? "ok 31\n" : "not ok 31\n");  # R P Q S
-print (substr($a, 2,-5) eq '' ? "ok 32\n" : "not ok 32\n");  # P=R Q S
-print (substr($a,-3,-5) eq '' ? "ok 33\n" : "not ok 33\n");  # P=R Q S
-print (substr($a, 2,-4) eq '' ? "ok 34\n" : "not ok 34\n");  # P R Q S
-print (substr($a,-3,-4) eq '' ? "ok 35\n" : "not ok 35\n");  # P R Q S
-print (substr($a, 5,-6) eq '' ? "ok 36\n" : "not ok 36\n");  # R P Q=S
-print (substr($a, 5,-5) eq '' ? "ok 37\n" : "not ok 37\n");  # P=R Q S
-print (substr($a, 5,-3) eq '' ? "ok 38\n" : "not ok 38\n");  # P R Q=S
-print (fail(substr($a, 7,-7)) ? "ok 39\n" : "not ok 39\n");  # R P S Q
-print (fail(substr($a, 7,-5)) ? "ok 40\n" : "not ok 40\n");  # P=R S Q
-print (fail(substr($a, 7,-3)) ? "ok 41\n" : "not ok 41\n");  # P R S Q
-print (fail(substr($a, 7, 0)) ? "ok 42\n" : "not ok 42\n");  # P S Q=R
-
-print (substr($a,-7,2) eq '' ? "ok 43\n" : "not ok 43\n");   # Q P=R S
-print (substr($a,-7,4) eq '54' ? "ok 44\n" : "not ok 44\n"); # Q P R S
-print (substr($a,-7,7) eq '54321' ? "ok 45\n" : "not ok 45\n");# Q P R=S
-print (substr($a,-7,9) eq '54321' ? "ok 46\n" : "not ok 46\n");# Q P S R
-print (substr($a,-5,0) eq '' ? "ok 47\n" : "not ok 47\n");   # P=Q=R S
-print (substr($a,-5,3) eq '543' ? "ok 48\n" : "not ok 48\n");# P=Q R S
-print (substr($a,-5,5) eq '54321' ? "ok 49\n" : "not ok 49\n");# P=Q R=S
-print (substr($a,-5,7) eq '54321' ? "ok 50\n" : "not ok 50\n");# P=Q S R
-print (substr($a,-3,0) eq '' ? "ok 51\n" : "not ok 51\n");   # P Q=R S
-print (substr($a,-3,3) eq '321' ? "ok 52\n" : "not ok 52\n");# P Q R=S
-print (substr($a,-2,3) eq '21' ? "ok 53\n" : "not ok 53\n"); # P Q S R
-print (substr($a,0,-5) eq '' ? "ok 54\n" : "not ok 54\n");   # P=Q=R S
-print (substr($a,2,-3) eq '' ? "ok 55\n" : "not ok 55\n");   # P Q=R S
-print (substr($a,0,0) eq '' ? "ok 56\n" : "not ok 56\n");    # P=Q=R S
-print (substr($a,0,5) eq '54321' ? "ok 57\n" : "not ok 57\n");# P=Q R=S
-print (substr($a,0,7) eq '54321' ? "ok 58\n" : "not ok 58\n");# P=Q S R
-print (substr($a,2,0) eq '' ? "ok 59\n" : "not ok 59\n");    # P Q=R S
-print (substr($a,2,3) eq '321' ? "ok 60\n" : "not ok 60\n"); # P Q R=S
-print (substr($a,5,0) eq '' ? "ok 61\n" : "not ok 61\n");    # P Q=R=S
-print (substr($a,5,2) eq '' ? "ok 62\n" : "not ok 62\n");    # P Q=S R
-print (substr($a,-7,-5) eq '' ? "ok 63\n" : "not ok 63\n");  # Q P=R S
-print (substr($a,-7,-2) eq '543' ? "ok 64\n" : "not ok 64\n");# Q P R S
-print (substr($a,-5,-5) eq '' ? "ok 65\n" : "not ok 65\n");  # P=Q=R S
-print (substr($a,-5,-2) eq '543' ? "ok 66\n" : "not ok 66\n");# P=Q R S
-print (substr($a,-3,-3) eq '' ? "ok 67\n" : "not ok 67\n");  # P Q=R S
-print (substr($a,-3,-1) eq '32' ? "ok 68\n" : "not ok 68\n");# P Q R S
+$b = substr($a,-7, 1) ; # warn  # Q R P S
+ok 30, $w-- == 1 ;
+eval{substr($a,-7, 1) = "" ; }; # Q R P S
+ok 31, $@ =~ /$FATAL_MSG/;
+$b = substr($a,-7,-6) ; # warn  # Q R P S
+ok 32, $w-- == 1 ;
+eval{substr($a,-7,-6) = "" ; }; # Q R P S
+ok 33, $@ =~ /$FATAL_MSG/;
+ok 34, substr($a,-5,-7) eq '';  # R P=Q S
+ok 35, substr($a, 2,-7) eq '';  # R P Q S
+ok 36, substr($a,-3,-7) eq '';  # R P Q S
+ok 37, substr($a, 2,-5) eq '';  # P=R Q S
+ok 38, substr($a,-3,-5) eq '';  # P=R Q S
+ok 39, substr($a, 2,-4) eq '';  # P R Q S
+ok 40, substr($a,-3,-4) eq '';  # P R Q S
+ok 41, substr($a, 5,-6) eq '';  # R P Q=S
+ok 42, substr($a, 5,-5) eq '';  # P=R Q S
+ok 43, substr($a, 5,-3) eq '';  # P R Q=S
+$b = substr($a, 7,-7) ; # warn  # R P S Q
+ok 44, $w-- == 1 ;
+eval{substr($a, 7,-7) = "" ; }; # R P S Q
+ok 45, $@ =~ /$FATAL_MSG/;
+$b = substr($a, 7,-5) ; # warn  # P=R S Q
+ok 46, $w-- == 1 ;
+eval{substr($a, 7,-5) = "" ; }; # P=R S Q
+ok 47, $@ =~ /$FATAL_MSG/;
+$b = substr($a, 7,-3) ; # warn  # P Q S Q
+ok 48, $w-- == 1 ;
+eval{substr($a, 7,-3) = "" ; }; # P Q S Q
+ok 49, $@ =~ /$FATAL_MSG/;
+$b = substr($a, 7, 0) ; # warn  # P S Q=R
+ok 50, $w-- == 1 ;
+eval{substr($a, 7, 0) = "" ; }; # P S Q=R
+ok 51, $@ =~ /$FATAL_MSG/;
+
+ok 52, substr($a,-7,2) eq '';   # Q P=R S
+ok 53, substr($a,-7,4) eq '54'; # Q P R S
+ok 54, substr($a,-7,7) eq '54321';# Q P R=S
+ok 55, substr($a,-7,9) eq '54321';# Q P S R
+ok 56, substr($a,-5,0) eq '';   # P=Q=R S
+ok 57, substr($a,-5,3) eq '543';# P=Q R S
+ok 58, substr($a,-5,5) eq '54321';# P=Q R=S
+ok 59, substr($a,-5,7) eq '54321';# P=Q S R
+ok 60, substr($a,-3,0) eq '';   # P Q=R S
+ok 61, substr($a,-3,3) eq '321';# P Q R=S
+ok 62, substr($a,-2,3) eq '21'; # P Q S R
+ok 63, substr($a,0,-5) eq '';   # P=Q=R S
+ok 64, substr($a,2,-3) eq '';   # P Q=R S
+ok 65, substr($a,0,0) eq '';    # P=Q=R S
+ok 66, substr($a,0,5) eq '54321';# P=Q R=S
+ok 67, substr($a,0,7) eq '54321';# P=Q S R
+ok 68, substr($a,2,0) eq '';    # P Q=R S
+ok 69, substr($a,2,3) eq '321'; # P Q R=S
+ok 70, substr($a,5,0) eq '';    # P Q=R=S
+ok 71, substr($a,5,2) eq '';    # P Q=S R
+ok 72, substr($a,-7,-5) eq '';  # Q P=R S
+ok 73, substr($a,-7,-2) eq '543';# Q P R S
+ok 74, substr($a,-5,-5) eq '';  # P=Q=R S
+ok 75, substr($a,-5,-2) eq '543';# P=Q R S
+ok 76, substr($a,-3,-3) eq '';  # P Q=R S
+ok 77, substr($a,-3,-1) eq '32';# P Q R S
 
 $a = '';
 
-print (substr($a,-2,2) eq '' ? "ok 69\n" : "not ok 69\n");   # Q P=R=S
-print (substr($a,0,0) eq '' ? "ok 70\n" : "not ok 70\n");    # P=Q=R=S
-print (substr($a,0,1) eq '' ? "ok 71\n" : "not ok 71\n");    # P=Q=S R
-print (substr($a,-2,3) eq '' ? "ok 72\n" : "not ok 72\n");   # Q P=S R
-print (substr($a,-2) eq '' ? "ok 73\n" : "not ok 73\n");     # Q P=R=S
-print (substr($a,0) eq '' ? "ok 74\n" : "not ok 74\n");      # P=Q=R=S
+ok 78, substr($a,-2,2) eq '';   # Q P=R=S
+ok 79, substr($a,0,0) eq '';    # P=Q=R=S
+ok 80, substr($a,0,1) eq '';    # P=Q=S R
+ok 81, substr($a,-2,3) eq '';   # Q P=S R
+ok 82, substr($a,-2) eq '';     # Q P=R=S
+ok 83, substr($a,0) eq '';      # P=Q=R=S
+
+
+ok 84, substr($a,0,-1) eq '';   # R P=Q=S
+$b = substr($a,-2, 0) ; # warn  # Q=R P=S
+ok 85, $w-- == 1 ;
+eval{substr($a,-2, 0) = "" ; }; # Q=R P=S
+ok 86, $@ =~ /$FATAL_MSG/;
 
+$b = substr($a,-2, 1) ; # warn  # Q R P=S
+ok 87, $w-- == 1 ;
+eval{substr($a,-2, 1) = "" ; }; # Q R P=S
+ok 88, $@ =~ /$FATAL_MSG/;
 
-print (substr($a,0,-1) eq '' ? "ok 75\n" : "not ok 75\n");   # R P=Q=S
-print (fail(substr($a,-2,0)) ? "ok 76\n" : "not ok 76\n");   # Q=R P=S
-print (fail(substr($a,-2,1)) ? "ok 77\n" : "not ok 77\n");   # Q R P=S
-print (fail(substr($a,-2,-1)) ? "ok 78\n" : "not ok 78\n");  # Q R P=S
-print (fail(substr($a,-2,-2)) ? "ok 79\n" : "not ok 79\n");  # Q=R P=S
-print (fail(substr($a,1,-2)) ? "ok 80\n" : "not ok 81\n");   # R P=S Q
-print (fail(substr($a,1,1)) ? "ok 81\n" : "not ok 81\n");    # P=S Q R
-print (fail(substr($a,1,0)) ? "ok 82\n" : "not ok 82\n");    # P=S Q=R
-print (fail(substr($a,1)) ? "ok 83\n" : "not ok 83\n");      # P=R=S Q
+$b = substr($a,-2,-1) ; # warn  # Q R P=S
+ok 89, $w-- == 1 ;
+eval{substr($a,-2,-1) = "" ; }; # Q R P=S
+ok 90, $@ =~ /$FATAL_MSG/;
 
+$b = substr($a,-2,-2) ; # warn  # Q=R P=S
+ok 91, $w-- == 1 ;
+eval{substr($a,-2,-2) = "" ; }; # Q=R P=S
+ok 92, $@ =~ /$FATAL_MSG/;
+
+$b = substr($a, 1,-2) ; # warn  # R P=S Q
+ok 93, $w-- == 1 ;
+eval{substr($a, 1,-2) = "" ; }; # R P=S Q
+ok 94, $@ =~ /$FATAL_MSG/;
+
+$b = substr($a, 1, 1) ; # warn  # P=S Q R
+ok 95, $w-- == 1 ;
+eval{substr($a, 1, 1) = "" ; }; # P=S Q R
+ok 96, $@ =~ /$FATAL_MSG/;
+
+$b = substr($a, 1, 0) ;# warn   # P=S Q=R
+ok 97, $w-- == 1 ;
+eval{substr($a, 1, 0) = "" ; }; # P=S Q=R
+ok 98, $@ =~ /$FATAL_MSG/;
+
+$b = substr($a,1) ; # warning   # P=R=S Q
+ok 99, $w-- == 1 ;
+eval{substr($a,1) = "" ; };     # P=R=S Q
+ok 100, $@ =~ /$FATAL_MSG/;
 
 my $a = 'zxcvbnm';
 substr($a,2,0) = '';
-print $a eq 'zxcvbnm' ? "ok 84\n" : "not ok 84\n";
+ok 101, $a eq 'zxcvbnm';
 substr($a,7,0) = '';
-print $a eq 'zxcvbnm' ? "ok 85\n" : "not ok 85\n";
+ok 102, $a eq 'zxcvbnm';
 substr($a,5,0) = '';
-print $a eq 'zxcvbnm' ? "ok 86\n" : "not ok 86\n";
+ok 103, $a eq 'zxcvbnm';
 substr($a,0,2) = 'pq';
-print $a eq 'pqcvbnm' ? "ok 87\n" : "not ok 87\n";
+ok 104, $a eq 'pqcvbnm';
 substr($a,2,0) = 'r';
-print $a eq 'pqrcvbnm' ? "ok 88\n" : "not ok 88\n";
+ok 105, $a eq 'pqrcvbnm';
 substr($a,8,0) = 'asd';
-print $a eq 'pqrcvbnmasd' ? "ok 89\n" : "not ok 89\n";
+ok 106, $a eq 'pqrcvbnmasd';
 substr($a,0,2) = 'iop';
-print $a eq 'ioprcvbnmasd' ? "ok 90\n" : "not ok 90\n";
+ok 107, $a eq 'ioprcvbnmasd';
 substr($a,0,5) = 'fgh';
-print $a eq 'fghvbnmasd' ? "ok 91\n" : "not ok 91\n";
+ok 108, $a eq 'fghvbnmasd';
 substr($a,3,5) = 'jkl';
-print $a eq 'fghjklsd' ? "ok 92\n" : "not ok 92\n";
+ok 109, $a eq 'fghjklsd';
 substr($a,3,2) = '1234';
-print $a eq 'fgh1234lsd' ? "ok 93\n" : "not ok 93\n";
+ok 110, $a eq 'fgh1234lsd';
 
 
 # with lexicals (and in re-entered scopes)
@@ -160,58 +221,50 @@ for (0,1) {
   unless ($_) {
     $txt = "Foo";
     substr($txt, -1) = "X";
-    print $txt eq "FoX" ? "ok 94\n" : "not ok 94\n";
+    ok 111, $txt eq "FoX";
   }
   else {
-    local $^W = 0;    # because of (spurious?) "uninitialised value"
     substr($txt, 0, 1) = "X";
-    print $txt eq "X" ? "ok 95\n" : "not ok 95\n";
+    ok 112, $txt eq "X";
   }
 }
 
+$w = 0 ;
 # coercion of references
 {
   my $s = [];
   substr($s, 0, 1) = 'Foo';
-  print substr($s,0,7) eq "FooRRAY" && !($w-=2) ? "ok 96\n" : "not ok 96\n";
+  ok 113, substr($s,0,7) eq "FooRRAY" && !($w-=2);
 }
 
 # check no spurious warnings
-print $w ? "not ok 97\n" : "ok 97\n";
+ok 114, $w == 0;
 
 # check new 4 arg replacement syntax
 $a = "abcxyz";
 $w = 0;
-print "not " unless substr($a, 0, 3, "") eq "abc" && $a eq "xyz";
-print "ok 98\n";
-print "not " unless substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz";
-print "ok 99\n";
-print "not " unless substr($a, 3, -1, "") eq "xy" && $a eq "abcz";
-print "ok 100\n";
-
-print "not " unless substr($a, 3, undef, "xy") eq "" && $a eq "abcxyz"
+ok 115, substr($a, 0, 3, "") eq "abc" && $a eq "xyz";
+ok 116, substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz";
+ok 117, substr($a, 3, -1, "") eq "xy" && $a eq "abcz";
+
+ok 118, substr($a, 3, undef, "xy") eq "" && $a eq "abcxyz"
                  && $w == 3;
-print "ok 101\n";
+
 $w = 0;
 
-print "not " unless substr($a, 3, 9999999, "") eq "xyz" && $a eq "abc";
-print "ok 102\n";
-print "not " unless fail(substr($a, -99, 0, ""));
-print "ok 103\n";
-print "not " unless fail(substr($a, 99, 3, ""));
-print "ok 104\n";
+ok 119, substr($a, 3, 9999999, "") eq "xyz" && $a eq "abc";
+eval{substr($a, -99, 0, "") };
+ok 120, $@ =~ /$FATAL_MSG/;
+eval{substr($a, 99, 3, "") };
+ok 121, $@ =~ /$FATAL_MSG/;
 
 substr($a, 0, length($a), "foo");
-print "not " unless $a eq "foo" && !$w;
-print "ok 105\n";
+ok 122, $a eq "foo" && !$w;
 
 # using 4 arg substr as lvalue is a compile time error
 eval 'substr($a,0,0,"") = "abc"';
-print "not " unless $@ && $@ =~ /Can't modify substr/ && $a eq "foo";
-print "ok 106\n";
+ok 123, $@ && $@ =~ /Can't modify substr/ && $a eq "foo";
 
 $a = "abcdefgh";
-print "not " unless sub { shift }->(substr($a, 0, 4, "xxxx")) eq 'abcd';
-print "ok 107\n";
-print "not " unless $a eq 'xxxxefgh';
-print "ok 108\n";
+ok 124, sub { shift }->(substr($a, 0, 4, "xxxx")) eq 'abcd';
+ok 125, $a eq 'xxxxefgh';
index 9fd418e..d70a333 100644 (file)
@@ -59,7 +59,7 @@
        local $a, $b = (1,2);
  
      Bareword found in conditional at -e line 1.
-       use warnings 'syntax'; my $x = print(ABC || 1);
+       use warnings 'bareword'; my $x = print(ABC || 1);
  
      Value of %s may be \"0\"; use \"defined\" 
        $x = 1 if $x = <FH> ;
 
 __END__
 # op.c
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 my $x ;
 my $x ;
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 my $x ;
 EXPECT
 "my" variable $x masks earlier declaration in same scope at - line 4.
 ########
 # op.c
-use warnings 'unsafe' ;
+use warnings 'closure' ;
 sub x {
       my $x;
       sub y {
@@ -137,7 +137,7 @@ EXPECT
 Variable "$x" will not stay shared at - line 7.
 ########
 # op.c
-no warnings 'unsafe' ;
+no warnings 'closure' ;
 sub x {
       my $x;
       sub y {
@@ -148,7 +148,7 @@ EXPECT
 
 ########
 # op.c
-use warnings 'unsafe' ;
+use warnings 'closure' ;
 sub x {
       my $x;
       sub y {
@@ -159,7 +159,7 @@ EXPECT
 Variable "$x" may be unavailable at - line 6.
 ########
 # op.c
-no warnings 'unsafe' ;
+no warnings 'closure' ;
 sub x {
       my $x;
       sub y {
@@ -559,7 +559,7 @@ Useless use of a constant in void context at - line 4.
 ########
 # op.c
 BEGIN{ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; } # known scalar leak
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
 @a =~ /abc/ ;
 @a =~ s/a/b/ ;
@@ -574,7 +574,7 @@ my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
 %$c =~ s/a/b/ ;
 %$c =~ tr/a/b/ ;
 {
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
 @a =~ /abc/ ;
 @a =~ s/a/b/ ;
@@ -622,9 +622,9 @@ EXPECT
 Parentheses missing around "local" list at - line 3.
 ########
 # op.c
-use warnings 'syntax' ;
+use warnings 'bareword' ;
 print (ABC || 1) ;
-no warnings 'syntax' ;
+no warnings 'bareword' ;
 print (ABC || 1) ;
 EXPECT
 Bareword found in conditional at - line 3.
@@ -633,54 +633,54 @@ Bareword found in conditional at - line 3.
 
 --FILE--
 # op.c
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 open FH, "<abc" ;
 $x = 1 if $x = <FH> ;
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 $x = 1 if $x = <FH> ;
 EXPECT
 Value of <HANDLE> construct can be "0"; test with defined() at - line 4.
 ########
 # op.c
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 opendir FH, "." ;
 $x = 1 if $x = readdir FH ;
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 $x = 1 if $x = readdir FH ;
 closedir FH ;
 EXPECT
 Value of readdir() operator can be "0"; test with defined() at - line 4.
 ########
 # op.c
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 $x = 1 if $x = <*> ;
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 $x = 1 if $x = <*> ;
 EXPECT
 Value of glob construct can be "0"; test with defined() at - line 3.
 ########
 # op.c
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 %a = (1,2,3,4) ;
 $x = 1 if $x = each %a ;
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 $x = 1 if $x = each %a ;
 EXPECT
 Value of each() operator can be "0"; test with defined() at - line 4.
 ########
 # op.c
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 $x = 1 while $x = <*> and 0 ;
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 $x = 1 while $x = <*> and 0 ;
 EXPECT
 Value of glob construct can be "0"; test with defined() at - line 3.
 ########
 # op.c
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 opendir FH, "." ;
 $x = 1 while $x = readdir FH and 0 ;
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 $x = 1 while $x = readdir FH and 0 ;
 closedir FH ;
 EXPECT
@@ -717,17 +717,17 @@ EXPECT
 Format FRED redefined at - line 5.
 ########
 # op.c
-use warnings 'syntax' ;
+use warnings 'deprecated' ;
 push FRED;
-no warnings 'syntax' ;
+no warnings 'deprecated' ;
 push FRED;
 EXPECT
 Array @FRED missing the @ in argument 1 of push() at - line 3.
 ########
 # op.c
-use warnings 'syntax' ;
+use warnings 'deprecated' ;
 @a = keys FRED ;
-no warnings 'syntax' ;
+no warnings 'deprecated' ;
 @a = keys FRED ;
 EXPECT
 Hash %FRED missing the % in argument 1 of keys() at - line 3.
@@ -779,10 +779,10 @@ $^W = 0 ;
 sub fred() ;
 sub fred($) {}
 {
-    no warnings 'unsafe' ;
+    no warnings 'prototype' ;
     sub Fred() ;
     sub Fred($) {}
-    use warnings 'unsafe' ;
+    use warnings 'prototype' ;
     sub freD() ;
     sub freD($) {}
 }
@@ -800,10 +800,10 @@ EXPECT
 /---/ should probably be written as "---" at - line 3.
 ########
 # op.c [Perl_peep]
-use warnings 'unsafe' ;
+use warnings 'prototype' ;
 fred() ; 
 sub fred ($$) {}
-no warnings 'unsafe' ;
+no warnings 'prototype' ;
 joe() ; 
 sub joe ($$) {}
 EXPECT
index 4c70fd5..b392029 100644 (file)
@@ -1,7 +1,7 @@
   pp.c TODO
 
   substr outside of string
-    $a = "ab" ; $a = substr($a, 4,5)
+    $a = "ab" ; $b = substr($a, 4,5) ;
 
   Attempt to use reference as lvalue in substr 
     $a = "ab" ; $b = \$a ;  substr($b, 1,1) = $b
@@ -37,10 +37,10 @@ __END__
 # pp.c
 use warnings 'substr' ;
 $a = "ab" ; 
-$a = substr($a, 4,5);
+$b = substr($a, 4,5) ;
 no warnings 'substr' ;
 $a = "ab" ; 
-$a = substr($a, 4,5);
+$b = substr($a, 4,5)  ;
 EXPECT
 substr outside of string at - line 4.
 ########
@@ -61,23 +61,25 @@ EXPECT
 
 ########
 # pp.c
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 my $a = { 1,2,3};
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 my $b = { 1,2,3};
 EXPECT
 Odd number of elements in hash assignment at - line 3.
 ########
 # pp.c
-use warnings 'unsafe' ;
+use warnings 'pack' ;
+use warnings 'unpack' ;
 my @a = unpack ("A,A", "22") ;
 my $a = pack ("A,A", 1,2) ;
-no warnings 'unsafe' ;
+no warnings 'pack' ;
+no warnings 'unpack' ;
 my @b = unpack ("A,A", "22") ;
 my $b = pack ("A,A", 1,2) ;
 EXPECT
-Invalid type in unpack: ',' at - line 3.
-Invalid type in pack: ',' at - line 4.
+Invalid type in unpack: ',' at - line 4.
+Invalid type in pack: ',' at - line 5.
 ########
 # pp.c
 use warnings 'uninitialized' ;
@@ -89,18 +91,18 @@ EXPECT
 Use of uninitialized value in scalar dereference at - line 4.
 ########
 # pp.c
-use warnings 'unsafe' ;
+use warnings 'pack' ;
 sub foo { my $a = "a"; return $a . $a++ . $a++ }
 my $a = pack("p", &foo) ;
-no warnings 'unsafe' ;
+no warnings 'pack' ;
 my $b = pack("p", &foo) ;
 EXPECT
 Attempt to pack pointer to temporary value at - line 4.
 ########
 # pp.c
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 bless \[], "" ;
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 bless \[], "" ;
 EXPECT
 Explicit blessing to '' (assuming package main) at - line 3.
index f61da1a..0deccd3 100644 (file)
@@ -81,14 +81,14 @@ EXPECT
 1
 ########
 # pp_ctl.c
-use warnings 'unsafe' ;
+use warnings 'exiting' ;
 $_ = "abc" ;
  
 while ($i ++ == 0)
 {
     s/ab/last/e ;
 }
-no warnings 'unsafe' ;
+no warnings 'exiting' ;
 while ($i ++ == 0)
 {
     s/ab/last/e ;
@@ -97,10 +97,10 @@ EXPECT
 Exiting substitution via last at - line 7.
 ########
 # pp_ctl.c
-use warnings 'unsafe' ;
+use warnings 'exiting' ;
 sub fred { last }
 { fred() }
-no warnings 'unsafe' ;
+no warnings 'exiting' ;
 sub joe { last }
 { joe() }
 EXPECT
@@ -108,35 +108,35 @@ Exiting subroutine via last at - line 3.
 ########
 # pp_ctl.c
 {
-  eval "use warnings 'unsafe' ; last;" 
+  eval "use warnings 'exiting' ; last;" 
 }
 print STDERR $@ ;
 {
-  eval "no warnings 'unsafe' ;last;" 
+  eval "no warnings 'exiting' ;last;" 
 } 
 print STDERR $@ ;
 EXPECT
 Exiting eval via last at (eval 1) line 1.
 ########
 # pp_ctl.c
-use warnings 'unsafe' ;
+use warnings 'exiting' ;
 @a = (1,2) ;
 @b = sort { last } @a ;
-no warnings 'unsafe' ;
+no warnings 'exiting' ;
 @b = sort { last } @a ;
 EXPECT
 Exiting pseudo-block via last at - line 4.
 Can't "last" outside a loop block at - line 4.
 ########
 # pp_ctl.c
-use warnings 'unsafe' ;
+use warnings 'exiting' ;
 $_ = "abc" ;
 fred: 
 while ($i ++ == 0)
 {
     s/ab/last fred/e ;
 }
-no warnings 'unsafe' ;
+no warnings 'exiting' ;
 while ($i ++ == 0)
 {
     s/ab/last fred/e ;
@@ -145,10 +145,10 @@ EXPECT
 Exiting substitution via last at - line 7.
 ########
 # pp_ctl.c
-use warnings 'unsafe' ;
+use warnings 'exiting' ;
 sub fred { last joe }
 joe: { fred() }
-no warnings 'unsafe' ;
+no warnings 'exiting' ;
 sub Fred { last Joe }
 Joe: { Fred() }
 EXPECT
@@ -156,19 +156,19 @@ Exiting subroutine via last at - line 3.
 ########
 # pp_ctl.c
 joe:
-{ eval "use warnings 'unsafe' ; last joe;" }
+{ eval "use warnings 'exiting' ; last joe;" }
 print STDERR $@ ;
 Joe:
-{ eval "no warnings 'unsafe' ; last Joe;" }
+{ eval "no warnings 'exiting' ; last Joe;" }
 print STDERR $@ ;
 EXPECT
 Exiting eval via last at (eval 1) line 1.
 ########
 # pp_ctl.c
-use warnings 'unsafe' ;
+use warnings 'exiting' ;
 @a = (1,2) ;
 fred: @b = sort { last fred } @a ;
-no warnings 'unsafe' ;
+no warnings 'exiting' ;
 Fred: @b = sort { last Fred } @a ;
 EXPECT
 Exiting pseudo-block via last at - line 4.
@@ -198,7 +198,7 @@ fred()
 EXPECT
 ########
 # pp_ctl.c
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 package Foo;
 DESTROY { die "@{$_[0]} foo bar" }
 { bless ['A'], 'Foo' for 1..10 }
@@ -208,7 +208,7 @@ EXPECT
        (in cleanup) B foo bar at - line 4.
 ########
 # pp_ctl.c
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 package Foo;
 DESTROY { die "@{$_[0]} foo bar" }
 { bless ['A'], 'Foo' for 1..10 }
index 312f7da..0cbbc43 100644 (file)
@@ -114,17 +114,17 @@ EXPECT
 Use of uninitialized value in hash dereference at - line 4.
 ########
 # pp_hot.c [pp_aassign]
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 my %X ; %X = (1,2,3) ;
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 my %Y ; %Y = (1,2,3) ;
 EXPECT
 Odd number of elements in hash assignment at - line 3.
 ########
 # pp_hot.c [pp_aassign]
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 my %X ; %X = [1 .. 3] ;
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 my %Y ; %Y = [1 .. 3] ;
 EXPECT
 Reference found where even-sized list expected at - line 3.
@@ -205,7 +205,7 @@ $b = sub
 EXPECT
 ########
 # pp_hot.c [pp_concat]
-use warnings 'misc';
+use warnings 'y2k';
 use Config;
 BEGIN {
     unless ($Config{ccflags} =~ /Y2KWARN/) {
@@ -219,7 +219,7 @@ $x     = "19$yy\n";
 $x     = "19" . $yy . "\n";
 $x     = "319$yy\n";
 $x     = "319" . $yy . "\n";
-no warnings 'misc';
+no warnings 'y2k';
 $x     = "19$yy\n";
 $x     = "19" . $yy . "\n";
 EXPECT
index bb208db..7d485f2 100644 (file)
@@ -7,7 +7,7 @@
        $a = "ABC123" ; $a =~ /(?=a)*/'
 
   /%.127s/: Unrecognized escape \\%c passed through"   [S_regatom] 
-       /\m/
+       $x = '\m' ; /$x/
 
   Character class syntax [. .] is reserved for future extensions [S_regpposixcc]
 
 
 __END__
 # regcomp.c [S_regpiece]
-use warnings 'unsafe' ;
+use warnings 'regexp' ;
 my $a = "ABC123" ; 
 $a =~ /(?=a)*/ ;
-no warnings 'unsafe' ;
+no warnings 'regexp' ;
 $a =~ /(?=a)*/ ;
 EXPECT
 (?=a)* matches null string many times at - line 4.
 ########
 # regcomp.c [S_study_chunk]
-use warnings 'unsafe' ;
+use warnings 'regexp' ;
 $_ = "" ;
 /(?=a)?/;
-no warnings 'unsafe' ;
+no warnings 'regexp' ;
 /(?=a)?/;
 EXPECT
 Strange *+?{} on zero-length expression at - line 4.
 ########
 # regcomp.c [S_regatom]
-use warnings 'unsafe' ;
-$a =~ /a\mb\b/ ;
-no warnings 'unsafe' ;
-$a =~ /a\mb\b/ ;
+$x = '\m' ;
+use warnings 'regexp' ;
+$a =~ /a$x/ ;
+no warnings 'regexp' ;
+$a =~ /a$x/ ;
 EXPECT
-Unrecognized escape \m passed through at - line 3.
+/a\m/: Unrecognized escape \m passed through at - line 4.
 ########
 # regcomp.c [S_regpposixcc S_checkposixcc]
-use warnings 'unsafe' ;
+use warnings 'regexp' ;
 $_ = "" ;
 /[:alpha:]/;
 /[.bar.]/;
@@ -60,7 +61,7 @@ $_ = "" ;
 /[[.foo.]]/;
 /[[=bar=]]/;
 /[:zog:]/;
-no warnings 'unsafe' ;
+no warnings 'regexp' ;
 /[:alpha:]/;
 /[.foo.]/;
 /[=bar=]/;
@@ -83,7 +84,7 @@ Character class [:zog:] unknown at - line 20.
 ########
 # regcomp.c [S_regclass]
 $_ = "";
-use warnings 'unsafe' ;
+use warnings 'regexp' ;
 /[a-b]/;
 /[a-\d]/;
 /[\d-b]/;
@@ -93,7 +94,7 @@ use warnings 'unsafe' ;
 /[[:digit:]-b]/;
 /[[:alpha:]-[:digit:]]/;
 /[[:digit:]-[:alpha:]]/;
-no warnings 'unsafe' ;
+no warnings 'regexp' ;
 /[a-b]/;
 /[a-\d]/;
 /[\d-b]/;
@@ -122,7 +123,7 @@ BEGIN {
 }
 use utf8;
 $_ = "";
-use warnings 'unsafe' ;
+use warnings 'regexp' ;
 /[a-b]/;
 /[a-\d]/;
 /[\d-b]/;
@@ -132,7 +133,7 @@ use warnings 'unsafe' ;
 /[[:digit:]-b]/;
 /[[:alpha:]-[:digit:]]/;
 /[[:digit:]-[:alpha:]]/;
-no warnings 'unsafe' ;
+no warnings 'regexp' ;
 /[a-b]/;
 /[a-\d]/;
 /[\d-b]/;
@@ -153,9 +154,9 @@ EXPECT
 /[[:digit:]-[:alpha:]]/: false [] range "[:digit:]-" in regexp at - line 19.
 ########
 # regcomp.c [S_regclass S_regclassutf8]
-use warnings 'unsafe' ;
+use warnings 'regexp' ;
 $a =~ /[a\zb]/ ;
-no warnings 'unsafe' ;
+no warnings 'regexp' ;
 $a =~ /[a\zb]/ ;
 EXPECT
 /[a\zb]/: Unrecognized escape \z in character class passed through at - line 3.
index b9ba790..73696df 100644 (file)
@@ -16,7 +16,7 @@
 __END__
 # regexec.c
 print("SKIPPED\n# most systems run into stacksize limits\n"),exit;
-use warnings 'unsafe' ;
+use warnings 'regexp' ;
 $SIG{__WARN__} = sub{local ($m) = shift;
                  $m =~ s/\(\d+\)/(*MASKED*)/;
                  print STDERR $m};
@@ -42,7 +42,7 @@ Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9.
 ########
 # regexec.c
 print("SKIPPED\n# most systems run into stacksize limits\n"),exit;
-no warnings 'unsafe' ;
+no warnings 'regexp' ;
 $SIG{__WARN__} = sub{local ($m) = shift;
                  $m =~ s/\(\d+\)/(*MASKED*)/;
                  print STDERR $m};
@@ -68,7 +68,7 @@ EXPECT
 ########
 # regexec.c
 print("SKIPPED\n# most systems run into stacksize limits\n"),exit;
-use warnings 'unsafe' ;
+use warnings 'regexp' ;
 $SIG{__WARN__} = sub{local ($m) = shift;
                  $m =~ s/\(\d+\)/(*MASKED*)/;
                  print STDERR $m};
@@ -94,7 +94,7 @@ Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9.
 ########
 # regexec.c
 print("SKIPPED\n# most systems run into stacksize limits\n"),exit;
-no warnings 'unsafe' ;
+no warnings 'regexp' ;
 $SIG{__WARN__} = sub{local ($m) = shift;
                  $m =~ s/\(\d+\)/(*MASKED*)/;
                  print STDERR $m};
index cdec48e..9a2428e 100644 (file)
@@ -261,9 +261,9 @@ Invalid conversion in printf: end of string at - line 6.
 Invalid conversion in printf: "%\002" at - line 8.
 ########
 # sv.c
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 *a = undef ;
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 *b = undef ;
 EXPECT
 Undefined value assigned to typeglob at - line 3.
@@ -288,7 +288,7 @@ EXPECT
 \xff will produce malformed UTF-8 character; use \x{ff} for that at - line 12.
 ########
 # sv.c
-use warnings 'misc';
+use warnings 'y2k';
 use Config;
 BEGIN {
     unless ($Config{ccflags} =~ /Y2KWARN/) {
@@ -305,7 +305,7 @@ $x     = printf  " 19%02d\n", 78;
 $x     = sprintf "19%02d\n", 78;
 $x     = printf  "319%02d\n", $yy;
 $x     = sprintf "319%02d\n", $yy;
-no warnings 'misc';
+no warnings 'y2k';
 $x     = printf  "19%02d\n", $yy;
 $x     = sprintf "19%02d\n", $yy;
 $x     = printf  "19%02d\n", 78;
index 6ba9c56..271ef63 100644 (file)
@@ -300,33 +300,33 @@ EXPECT
 Unquoted string "abc" may clash with future reserved word at - line 3.
 ########
 # toke.c
-use warnings 'octal' ;
+use warnings 'chmod' ;
 chmod 3;
-no warnings 'octal' ;
+no warnings 'chmod' ;
 chmod 3;
 EXPECT
 chmod() mode argument is missing initial 0 at - line 3.
 ########
 # toke.c
-use warnings 'syntax' ;
+use warnings 'qw' ;
 @a = qw(a, b, c) ;
-no warnings 'syntax' ;
+no warnings 'qw' ;
 @a = qw(a, b, c) ;
 EXPECT
 Possible attempt to separate words with commas at - line 3.
 ########
 # toke.c
-use warnings 'syntax' ;
+use warnings 'qw' ;
 @a = qw(a b #) ;
-no warnings 'syntax' ;
+no warnings 'qw' ;
 @a = qw(a b #) ;
 EXPECT
 Possible attempt to put comments in qw() list at - line 3.
 ########
 # toke.c
-use warnings 'octal' ;
+use warnings 'umask' ;
 umask 3;
-no warnings 'octal' ;
+no warnings 'umask' ;
 umask 3;
 EXPECT
 umask: argument is missing initial 0 at - line 3.
@@ -417,10 +417,10 @@ Misplaced _ in number at - line 4.
 Misplaced _ in number at - line 4.
 ########
 # toke.c
-use warnings 'unsafe' ;
+use warnings 'bareword' ;
 #line 25 "bar"
 $a = FRED:: ;
-no warnings 'unsafe' ;
+no warnings 'bareword' ;
 #line 25 "bar"
 $a = FRED:: ;
 EXPECT
@@ -512,9 +512,9 @@ Precedence problem: open FOO should be open(FOO) at - line 2.
 $^W = 0 ;
 open FOO || time;
 {
-    no warnings 'ambiguous' ;
+    no warnings 'precedence' ;
     open FOO || time;
-    use warnings 'ambiguous' ;
+    use warnings 'precedence' ;
     open FOO || time;
 }
 open FOO || time;
@@ -542,9 +542,9 @@ Operator or semicolon missing before *foo at - line 10.
 Ambiguous use of * resolved as operator * at - line 10.
 ########
 # toke.c
-use warnings 'unsafe' ;
+use warnings 'misc' ;
 my $a = "\m" ;
-no warnings 'unsafe' ;
+no warnings 'misc' ;
 $a = "\m" ;
 EXPECT
 Unrecognized escape \m passed through at - line 3.
diff --git a/toke.c b/toke.c
index 6000aba..398c5f9 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -1339,8 +1339,8 @@ S_scan_const(pTHX_ char *start)
            default:
                {
                    dTHR;
-                   if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
-                       Perl_warner(aTHX_ WARN_UNSAFE
+                   if (ckWARN(WARN_MISC) && isALPHA(*s))
+                       Perl_warner(aTHX_ WARN_MISC
                               "Unrecognized escape \\%c passed through",
                               *s);
                    /* default action is to copy the quoted character */
@@ -3627,8 +3627,8 @@ Perl_yylex(pTHX)
                if (len > 2 &&
                    PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
                {
-                   if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
-                       Perl_warner(aTHX_ WARN_UNSAFE
+                   if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
+                       Perl_warner(aTHX_ WARN_BAREWORD
                            "Bareword \"%s\" refers to nonexistent package",
                             PL_tokenbuf);
                    len -= 2;
@@ -3951,10 +3951,10 @@ Perl_yylex(pTHX)
            LOP(OP_CRYPT,XTERM);
 
        case KEY_chmod:
-           if (ckWARN(WARN_OCTAL)) {
+           if (ckWARN(WARN_CHMOD)) {
                for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
                if (*d != '0' && isDIGIT(*d))
-                   Perl_warner(aTHX_ WARN_OCTAL,
+                   Perl_warner(aTHX_ WARN_CHMOD,
                                "chmod() mode argument is missing initial 0");
            }
            LOP(OP_CHMOD,XTERM);
@@ -4325,8 +4325,8 @@ Perl_yylex(pTHX)
                char *t;
                for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
                t = skipspace(d);
-               if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS))
-                   Perl_warner(aTHX_ WARN_AMBIGUOUS,
+               if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
+                   Perl_warner(aTHX_ WARN_PRECEDENCE,
                           "Precedence problem: open %.*s should be open(%.*s)",
                            d-s,s, d-s,s);
            }
@@ -4398,15 +4398,15 @@ Perl_yylex(pTHX)
                    for (; isSPACE(*d) && len; --len, ++d) ;
                    if (len) {
                        char *b = d;
-                       if (!warned && ckWARN(WARN_SYNTAX)) {
+                       if (!warned && ckWARN(WARN_QW)) {
                            for (; !isSPACE(*d) && len; --len, ++d) {
                                if (*d == ',') {
-                                   Perl_warner(aTHX_ WARN_SYNTAX,
+                                   Perl_warner(aTHX_ WARN_QW,
                                        "Possible attempt to separate words with commas");
                                    ++warned;
                                }
                                else if (*d == '#') {
-                                   Perl_warner(aTHX_ WARN_SYNTAX,
+                                   Perl_warner(aTHX_ WARN_QW,
                                        "Possible attempt to put comments in qw() list");
                                    ++warned;
                                }
@@ -4813,10 +4813,10 @@ Perl_yylex(pTHX)
            LOP(OP_UTIME,XTERM);
 
        case KEY_umask:
-           if (ckWARN(WARN_OCTAL)) {
+           if (ckWARN(WARN_UMASK)) {
                for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
                if (*d != '0' && isDIGIT(*d)) 
-                   Perl_warner(aTHX_ WARN_OCTAL,
+                   Perl_warner(aTHX_ WARN_UMASK,
                                "umask: argument is missing initial 0");
            }
            UNI(OP_UMASK);
index 23e6d1c..31942e1 100644 (file)
 #define isWARN_ONCE    (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
 #define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
 
-#define WARN_IO                        0
-#define WARN_CLOSED            1
-#define WARN_EXEC              2
-#define WARN_NEWLINE           3
-#define WARN_PIPE              4
-#define WARN_UNOPENED          5
-#define WARN_MISC              6
-#define WARN_NUMERIC           7
-#define WARN_ONCE              8
-#define WARN_RECURSION         9
-#define WARN_REDEFINE          10
-#define WARN_SEVERE            11
-#define WARN_DEBUGGING         12
-#define WARN_INPLACE           13
-#define WARN_INTERNAL          14
-#define WARN_SYNTAX            15
-#define WARN_AMBIGUOUS         16
-#define WARN_BAREWORD          17
-#define WARN_DEPRECATED                18
-#define WARN_DIGIT             19
-#define WARN_OCTAL             20
-#define WARN_PARENTHESIS       21
-#define WARN_PRINTF            22
-#define WARN_RESERVED          23
-#define WARN_SEMICOLON         24
-#define WARN_UNINITIALIZED     25
-#define WARN_UNSAFE            26
-#define WARN_CLOSURE           27
-#define WARN_OVERFLOW          28
-#define WARN_PORTABLE          29
-#define WARN_SIGNAL            30
-#define WARN_SUBSTR            31
-#define WARN_TAINT             32
-#define WARN_UNTIE             33
-#define WARN_UTF8              34
-#define WARN_VOID              35
-
-#define WARNsize               9
-#define WARN_ALLstring         "\125\125\125\125\125\125\125\125\125"
-#define WARN_NONEstring                "\0\0\0\0\0\0\0\0\0"
+#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 WARNsize               12
+#define WARN_ALLstring         "\125\125\125\125\125\125\125\125\125\125\125\125"
+#define WARN_NONEstring                "\0\0\0\0\0\0\0\0\0\0\0\0"
 
 /* end of file warnings.h */
 
index c6f1313..0952305 100644 (file)
@@ -9,43 +9,52 @@ sub DEFAULT_ON  () { 1 }
 sub DEFAULT_OFF () { 2 }
 
 my $tree = {
-                'unsafe'       => {    'untie'         => DEFAULT_OFF,
-                               'substr'        => DEFAULT_OFF,
-                               'taint'         => DEFAULT_OFF,
-                               'signal'        => DEFAULT_OFF,
-                               'closure'       => DEFAULT_OFF,
-                               'overflow'      => DEFAULT_OFF,
-                               'portable'      => DEFAULT_OFF,
-                               'utf8'          => DEFAULT_OFF,
-                          } ,
-                'io'           => {    'pipe'          => DEFAULT_OFF,
+               'io'            => {    'pipe'          => DEFAULT_OFF,
                                        'unopened'      => DEFAULT_OFF,
                                        'closed'        => DEFAULT_OFF,
                                        'newline'       => DEFAULT_OFF,
                                        'exec'          => DEFAULT_OFF,
-                                       #'wr in in file'=> DEFAULT_OFF,
                           },
-                'syntax'       => {    'ambiguous'     => DEFAULT_OFF,
+               'syntax'        => {    'ambiguous'     => DEFAULT_OFF,
                                'semicolon'     => DEFAULT_OFF,
+                               'precedence'    => DEFAULT_OFF,
                                'bareword'      => DEFAULT_OFF,
                                'reserved'      => DEFAULT_OFF,
-                               'octal'         => DEFAULT_OFF,
                                'digit'         => DEFAULT_OFF,
                                'parenthesis'   => DEFAULT_OFF,
                                        'deprecated'    => DEFAULT_OFF,
                                        'printf'        => DEFAULT_OFF,
+                                       'prototype'     => DEFAULT_OFF,
+                                       'qw'            => DEFAULT_OFF,
                           },
-                'severe'       => {    'inplace'       => DEFAULT_ON,
+               'severe'        => {    'inplace'       => DEFAULT_ON,
                                'internal'      => DEFAULT_ON,
                                'debugging'     => DEFAULT_ON,
+                               'malloc'        => DEFAULT_ON,
                           },
-                'void'         => DEFAULT_OFF,
-                'recursion'    => DEFAULT_OFF,
-                'redefine'     => DEFAULT_OFF,
-                'numeric'      => DEFAULT_OFF,
-         'uninitialized'=> DEFAULT_OFF,
-                'once'         => DEFAULT_OFF,
-                'misc'         => DEFAULT_OFF,
+               'void'          => DEFAULT_OFF,
+               'recursion'     => DEFAULT_OFF,
+               'redefine'      => DEFAULT_OFF,
+               'numeric'       => DEFAULT_OFF,
+        'uninitialized'        => DEFAULT_OFF,
+               'once'          => DEFAULT_OFF,
+               'misc'          => DEFAULT_OFF,
+               'regexp'        => DEFAULT_OFF,
+               'glob'          => DEFAULT_OFF,
+               'y2k'           => DEFAULT_OFF,
+               'chmod'         => DEFAULT_OFF,
+               'umask'         => DEFAULT_OFF,
+               'untie'         => DEFAULT_OFF,
+       'substr'        => DEFAULT_OFF,
+       'taint'         => DEFAULT_OFF,
+       'signal'        => DEFAULT_OFF,
+       'closure'       => DEFAULT_OFF,
+       'overflow'      => DEFAULT_OFF,
+       'portable'      => DEFAULT_OFF,
+       'utf8'          => DEFAULT_OFF,
+               'exiting'       => DEFAULT_OFF,
+               'pack'          => DEFAULT_OFF,
+               'unpack'        => DEFAULT_OFF,
                 #'default'     => DEFAULT_ON,
        } ;
 
@@ -103,6 +112,32 @@ sub mkRange
 }
 
 ###########################################################################
+sub printTree
+{
+    my $tre = shift ;
+    my $prefix = shift ;
+    my $indent = shift ;
+    my ($k, $v) ;
+
+    my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
+
+    $prefix .= " " x $indent ;
+    foreach $k (sort keys %$tre) {
+       $v = $tre->{$k};
+       print $prefix . "|\n" ;
+       print $prefix . "+- $k" ;
+       if (ref $v)
+       { 
+           print " " . "-" x ($max - length $k ) . "+\n" ;
+           printTree ($v, $prefix . "|" , $max + $indent - 1) 
+       }
+       else
+         { print "\n" }
+    }
+
+}
+
+###########################################################################
 
 sub mkHex
 {
@@ -124,6 +159,12 @@ sub mkHex
 
 ###########################################################################
 
+if (@ARGV && $ARGV[0] eq "tree")
+{
+    print "  all -+\n" ;
+    printTree($tree, "   ", 4) ;
+    exit ;
+}
 
 #unlink "warnings.h";
 #unlink "lib/warnings.pm";
@@ -255,6 +296,7 @@ foreach $k (sort keys  %list) {
 }
 
 print PM "  );\n\n" ;
+print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
 while (<DATA>) {
     print PM $_ ;
 }
@@ -281,13 +323,35 @@ warnings - Perl pragma to control optional warnings
     use warnings "all";
     no warnings "all";
 
+    if (warnings::enabled("void") {
+        warnings::warn("void", "some warning");
+    }
+
 =head1 DESCRIPTION
 
 If no import list is supplied, all possible warnings are either enabled
 or disabled.
 
-See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
+Two functions are provided to assist module authors.
+
+=over 4
+
+=item warnings::enabled($category)
+
+Returns TRUE if the warnings category in C<$category> is enabled in the
+calling module. Otherwise returns FALSE.
+
+
+=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.
+
+=back
+
+See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
 
 =cut
 
@@ -326,12 +390,34 @@ sub unimport {
 
 sub enabled
 {
-    my $string = shift ;
-
+    # If no parameters, check for any lexical warnings enabled
+    # in the users scope.
+    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 $bits{$string} && ${^WARNING_BITS} & $bits{$string} ;
+       if ($callers_bitmask & $Bits{$category}) ne $NONE ;
    
     return 0 ; 
 }
 
+sub warn
+{
+    croak "Usage: warnings::warn('category', 'message')"
+       unless @_ == 2 ;
+    my $category = shift ;
+    my $message = shift ;
+    local $Carp::CarpLevel = 1 ;
+    my $callers_bitmask = (caller(1))[9] ; 
+    croak($message) 
+       if defined $callers_bitmask &&
+           ($callers_bitmask & $DeadBits{$category}) ne $NONE ;
+    carp($message) ;
+}
+
 1;