From: Gurusamy Sarathy Date: Sun, 20 Feb 2000 22:58:09 +0000 (+0000) Subject: lexical warnings update, ability to inspect bitmask in calling X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e476b1b5c29f354cf8dad61a9fc6d855bdfb5b7d;p=p5sagit%2Fp5-mst-13.2.git lexical warnings update, ability to inspect bitmask in calling scope, among other things (from Paul Marquess) p4raw-id: //depot/perl@5170 --- diff --git a/MANIFEST b/MANIFEST index 2ea10b0..1d8e59c 100644 --- 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 diff --git a/lib/warnings.pm b/lib/warnings.pm index b952295..11fd5b0 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -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 and L. +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 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 and L. =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; diff --git a/malloc.c b/malloc.c index c4a7a90..ecebeb0 100644 --- a/malloc.c +++ b/malloc.c @@ -332,6 +332,13 @@ } 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 --- 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 --- 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)); } diff --git a/pod/perldiag.pod b/pod/perldiag.pod index d660f94..80616d9 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -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. +The majority of messages from the first three classifications above (W, +D & S) can be controlled using the C pragma. + +If a message can be controlled by the C pragma, its warning +category is included with the classification letter in the description +below. + +Optional warnings are enabled by using the C 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. + +Default warnings are always enabled unless they are explicitly disabled +with the C pragma or the B<-X> switch. Trappable errors may be trapped using the eval operator. See L. 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. =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. =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. 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. =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. =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. @@ -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. =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. =item Allocation too large: %lx @@ -301,7 +312,7 @@ the return value of your socket() call? See L. =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 and L 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. @@ -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 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 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, but +(W bareword) You used a qualified bareword of the form C, 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 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. =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. =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. =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. =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. =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 CE> +(S inplace) The implicit opening of a file through use of the CE> 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, which is not supported. You can +(W pipe) You tried to say C, 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", and then read it in under a different file handle. @@ -993,13 +1004,13 @@ this, you should write C instead of C. =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. =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 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%sE -(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.) =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. =item Constant is not %s reference @@ -1234,13 +1245,13 @@ See L and L. =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 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 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 value. If you want to see if the array is empty, just use C 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 value. If you want to see if the hash is empty, just use C 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. =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. @@ -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" or "+E" or "+EE" instead of with "E" or nothing. If you intended only to write the file, use "E" or "EE". See @@ -1470,7 +1486,7 @@ L. =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" or "+E" or "+EE" instead of with "E" or nothing. If you intended only to read from the file, use "E". 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 underlying the C operator returned an invalid UIC. +=item glob failed (%s) + +(W glob) Something went wrong with the external program(s) used for C +and C*.cE>. Usually, this means that you supplied a C +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); otherwise, make them all empty (except that +C 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. =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 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. =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 -and C*.cE>. Usually, this means that you supplied a C -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); otherwise, make them all empty (except that -C 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. =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. =item Invalid separator character %s in attribute list @@ -1758,13 +1774,13 @@ too soon. See L. =item Invalid type in pack: '%s' (F) The given character is not a valid pack type. See L. -(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. -(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. =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 or C +(W pipe) You used the C or C 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 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 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. =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. =item Null filename used @@ -2146,7 +2162,7 @@ supplied it an uninitialized value. See L. =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 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. =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. =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. =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. =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. @@ -2594,12 +2610,12 @@ to use parens. In any case, a hash requires key/value B. =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. =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. =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. =item Stat on unopened file E%sE -(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. 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%sE -(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. =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 (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. =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. =item unexec of %s into %s failed! @@ -3171,7 +3187,7 @@ See L. =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. @@ -3248,12 +3264,12 @@ too soon. See L. =item Use of $# is deprecated -(D) This was an ill-advised attempt to emulate a poorly defined B feature. +(D deprecated) This was an ill-advised attempt to emulate a poorly defined B 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 and C 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 EE to mean EE"" 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 subroutines are looked +(D deprecated) As an (ahem) accidental feature, C 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), not as methods (e.g. Cbar()> or C<$obj-Ebar()>). @@ -3298,7 +3314,7 @@ C. =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. =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 for more on this. =item untie attempted while %d inner references still exist -(W) A copy of the object returned from C (or C) was still +(W untie) A copy of the object returned from C (or C) was still valid when C was called. =item Value of %s can be "0"; test with defined() -(W) In a conditional expression, you used , <*> (glob), C, +(W misc) In a conditional expression, you used , <*> (glob), C, or C 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 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 subroutine is inside a I +(W closure) An inner (nested) I subroutine is inside a I 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 subroutine is referencing a lexical +(W closure) An inner (nested) I 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 and L. =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 diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 5de9dc7..e11364d 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -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. In such a case additional elements $evaltext and @@ -526,9 +526,9 @@ C or C statement, $evaltext contains the text of the C statement. In particular, for a C statement, $filename is C<(eval)>, but $evaltext is undefined. (Note also that each C statement creates a C frame inside an C) -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 diff --git a/pod/perllexwarn.pod b/pod/perllexwarn.pod index 6078aef..d370f04 100644 --- a/pod/perllexwarn.pod +++ b/pod/perllexwarn.pod @@ -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 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 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 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 pragma to control the warning behavior of $^W-type code (using a C) 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 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 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. =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 pragma provides two functions, namely C +and C, 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 pragma. + +Consider the module C 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 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 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. +L, L. =head1 AUTHOR diff --git a/pp.c b/pp.c index 0b05764..b6275dd 100644 --- 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)) diff --git a/pp_ctl.c b/pp_ctl.c index 24fad37..7c69e35 100644 --- 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; } diff --git a/pp_hot.c b/pp_hot.c index 288bf5c..6027766 100644 --- 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" : ""); diff --git a/regcomp.c b/regcomp.c index ca0b1d1..a3106dc 100644 --- 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, diff --git a/regexec.c b/regexec.c index d2ebc44..bddf820 100644 --- 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 --- 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'"); } diff --git a/t/op/substr.t b/t/op/substr.t index 8d31a9a..5764e67 100755 --- a/t/op/substr.t +++ b/t/op/substr.t @@ -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'; diff --git a/t/pragma/warn/op b/t/pragma/warn/op index 9fd418e..d70a333 100644 --- a/t/pragma/warn/op +++ b/t/pragma/warn/op @@ -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 = ; @@ -117,16 +117,16 @@ __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, " ; -no warnings 'unsafe' ; +no warnings 'misc' ; $x = 1 if $x = ; EXPECT Value of 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 diff --git a/t/pragma/warn/pp b/t/pragma/warn/pp index 4c70fd5..b392029 100644 --- a/t/pragma/warn/pp +++ b/t/pragma/warn/pp @@ -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. diff --git a/t/pragma/warn/pp_ctl b/t/pragma/warn/pp_ctl index f61da1a..0deccd3 100644 --- a/t/pragma/warn/pp_ctl +++ b/t/pragma/warn/pp_ctl @@ -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 } diff --git a/t/pragma/warn/pp_hot b/t/pragma/warn/pp_hot index 312f7da..0cbbc43 100644 --- a/t/pragma/warn/pp_hot +++ b/t/pragma/warn/pp_hot @@ -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 diff --git a/t/pragma/warn/regcomp b/t/pragma/warn/regcomp index bb208db..7d485f2 100644 --- a/t/pragma/warn/regcomp +++ b/t/pragma/warn/regcomp @@ -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] @@ -25,33 +25,34 @@ __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. diff --git a/t/pragma/warn/regexec b/t/pragma/warn/regexec index b9ba790..73696df 100644 --- a/t/pragma/warn/regexec +++ b/t/pragma/warn/regexec @@ -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}; diff --git a/t/pragma/warn/sv b/t/pragma/warn/sv index cdec48e..9a2428e 100644 --- a/t/pragma/warn/sv +++ b/t/pragma/warn/sv @@ -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; diff --git a/t/pragma/warn/toke b/t/pragma/warn/toke index 6ba9c56..271ef63 100644 --- a/t/pragma/warn/toke +++ b/t/pragma/warn/toke @@ -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 --- 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); diff --git a/warnings.h b/warnings.h index 23e6d1c..31942e1 100644 --- a/warnings.h +++ b/warnings.h @@ -61,46 +61,56 @@ #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 */ diff --git a/warnings.pl b/warnings.pl index c6f1313..0952305 100644 --- a/warnings.pl +++ b/warnings.pl @@ -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 () { 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 and L. +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 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 and L. =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;