diff options
42 files changed, 1282 insertions, 391 deletions
@@ -939,6 +939,7 @@ lib/utf8_heavy.pl Support routines for utf8 pragma lib/validate.pl Perl library supporting wholesale file mode validation lib/vars.pm Declare pseudo-imported global variables lib/warnings.pm For "use warnings" +lib/warnings/register.pm For "use warnings::register" makeaperl.SH perl script that produces a new perl binary makedef.pl Create symbol export lists for linking makedepend.SH Precursor to makedepend @@ -300,6 +300,7 @@ #define to_uni_upper_lc Perl_to_uni_upper_lc #define to_uni_title_lc Perl_to_uni_title_lc #define to_uni_lower_lc Perl_to_uni_lower_lc +#define is_utf8_char Perl_is_utf8_char #define is_utf8_alnum Perl_is_utf8_alnum #define is_utf8_alnumc Perl_is_utf8_alnumc #define is_utf8_idfirst Perl_is_utf8_idfirst @@ -1744,6 +1745,7 @@ #define to_uni_upper_lc(a) Perl_to_uni_upper_lc(aTHX_ a) #define to_uni_title_lc(a) Perl_to_uni_title_lc(aTHX_ a) #define to_uni_lower_lc(a) Perl_to_uni_lower_lc(aTHX_ a) +#define is_utf8_char(a) Perl_is_utf8_char(aTHX_ a) #define is_utf8_alnum(a) Perl_is_utf8_alnum(aTHX_ a) #define is_utf8_alnumc(a) Perl_is_utf8_alnumc(aTHX_ a) #define is_utf8_idfirst(a) Perl_is_utf8_idfirst(aTHX_ a) @@ -3420,6 +3422,8 @@ #define to_uni_title_lc Perl_to_uni_title_lc #define Perl_to_uni_lower_lc CPerlObj::Perl_to_uni_lower_lc #define to_uni_lower_lc Perl_to_uni_lower_lc +#define Perl_is_utf8_char CPerlObj::Perl_is_utf8_char +#define is_utf8_char Perl_is_utf8_char #define Perl_is_utf8_alnum CPerlObj::Perl_is_utf8_alnum #define is_utf8_alnum Perl_is_utf8_alnum #define Perl_is_utf8_alnumc CPerlObj::Perl_is_utf8_alnumc @@ -1597,6 +1597,7 @@ Ap |bool |is_uni_xdigit_lc|U32 c Ap |U32 |to_uni_upper_lc|U32 c Ap |U32 |to_uni_title_lc|U32 c Ap |U32 |to_uni_lower_lc|U32 c +Ap |int |is_utf8_char |U8 *p Ap |bool |is_utf8_alnum |U8 *p Ap |bool |is_utf8_alnumc |U8 *p Ap |bool |is_utf8_idfirst|U8 *p diff --git a/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm index 1d8cda6fbf..df92b04b74 100644 --- a/ext/IO/lib/IO/Select.pm +++ b/ext/IO/lib/IO/Select.pm @@ -7,10 +7,11 @@ package IO::Select; use strict; +use warnings::register; use vars qw($VERSION @ISA); require Exporter; -$VERSION = "1.13"; +$VERSION = "1.14"; @ISA = qw(Exporter); # This is only so we can do version checking @@ -129,9 +130,8 @@ sub has_exception sub has_error { - require Carp; - Carp::carp("Call to depreciated method 'has_error', use 'has_exception'") - if $^W; + warnings::warn("Call to depreciated method 'has_error', use 'has_exception'") + if warnings::enabled(); goto &has_exception; } diff --git a/ext/Socket/Socket.pm b/ext/Socket/Socket.pm index f83cb18399..02f098df77 100644 --- a/ext/Socket/Socket.pm +++ b/ext/Socket/Socket.pm @@ -1,7 +1,7 @@ package Socket; our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); -$VERSION = "1.71"; +$VERSION = "1.72"; =head1 NAME @@ -160,6 +160,7 @@ have AF_UNIX in the right place. =cut use Carp; +use warnings::register; require Exporter; use XSLoader (); @@ -302,7 +303,8 @@ BEGIN { sub sockaddr_in { if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die my($af, $port, @quad) = @_; - carp "6-ARG sockaddr_in call is deprecated" if $^W; + warnings::warn "6-ARG sockaddr_in call is deprecated" + if warnings::enabled(); pack_sockaddr_in($port, inet_aton(join('.', @quad))); } elsif (wantarray) { croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1; diff --git a/global.sym b/global.sym index 10b5303d78..ea77dfe001 100644 --- a/global.sym +++ b/global.sym @@ -180,6 +180,7 @@ Perl_is_uni_xdigit_lc Perl_to_uni_upper_lc Perl_to_uni_title_lc Perl_to_uni_lower_lc +Perl_is_utf8_char Perl_is_utf8_alnum Perl_is_utf8_alnumc Perl_is_utf8_idfirst @@ -448,10 +448,10 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) /* =for apidoc gv_stashpv -Returns a pointer to the stash for a specified package. If C<create> is -set then the package will be created if it does not already exist. If -C<create> is not set and the package does not exist then NULL is -returned. +Returns a pointer to the stash for a specified package. C<name> should +be a valid UTF-8 string. If C<create> is set then the package will be +created if it does not already exist. If C<create> is not set and the +package does not exist then NULL is returned. =cut */ @@ -494,8 +494,8 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) /* =for apidoc gv_stashsv -Returns a pointer to the stash for a specified package. See -C<gv_stashpv>. +Returns a pointer to the stash for a specified package, which must be a +valid UTF-8 string. See C<gv_stashpv>. =cut */ diff --git a/lib/Class/Struct.pm b/lib/Class/Struct.pm index b4f2117557..63eddac739 100644 --- a/lib/Class/Struct.pm +++ b/lib/Class/Struct.pm @@ -5,6 +5,7 @@ package Class::Struct; use 5.005_64; use strict; +use warnings::register; our(@ISA, @EXPORT, $VERSION); use Carp; @@ -167,8 +168,8 @@ sub struct { $cnt = 0; foreach $name (@methods){ if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) { - carp "function '$name' already defined, overrides struct accessor method" - if $^W; + warnings::warn "function '$name' already defined, overrides struct accessor method" + if warnings::enabled(); } else { $pre = $pst = $cmt = $sel = ''; diff --git a/lib/I18N/Collate.pm b/lib/I18N/Collate.pm index 580ca39785..64a03a284b 100644 --- a/lib/I18N/Collate.pm +++ b/lib/I18N/Collate.pm @@ -108,6 +108,7 @@ European character set. # --- use POSIX qw(strxfrm LC_COLLATE); +use warnings::register; require Exporter; @@ -123,9 +124,9 @@ cmp collate_cmp sub new { my $new = $_[1]; - if ($^W && $] >= 5.003_06) { + if (warnings::enabled() && $] >= 5.003_06) { unless ($please_use_I18N_Collate_even_if_deprecated) { - warn <<___EOD___; + warnings::warn <<___EOD___; *** WARNING: starting from the Perl version 5.003_06 diff --git a/lib/Tie/Handle.pm b/lib/Tie/Handle.pm index cbac73535d..588ecead89 100644 --- a/lib/Tie/Handle.pm +++ b/lib/Tie/Handle.pm @@ -108,6 +108,7 @@ The L<perltie> section contains an example of tying handles. =cut use Carp; +use warnings::register; sub new { my $pkg = shift; @@ -119,8 +120,8 @@ sub new { sub TIEHANDLE { my $pkg = shift; if (defined &{"{$pkg}::new"}) { - carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing" - if $^W; + warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing" + if warnings::enabled(); $pkg->new(@_); } else { diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm index 928b798e45..c6ec3d4f5c 100644 --- a/lib/Tie/Hash.pm +++ b/lib/Tie/Hash.pm @@ -102,6 +102,7 @@ good working examples. =cut use Carp; +use warnings::register; sub new { my $pkg = shift; @@ -113,8 +114,8 @@ sub new { sub TIEHASH { my $pkg = shift; if (defined &{"${pkg}::new"}) { - carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing" - if $^W; + warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing" + if warnings::enabled(); $pkg->new(@_); } else { diff --git a/lib/Tie/Scalar.pm b/lib/Tie/Scalar.pm index 1e2caee379..0c6759006f 100644 --- a/lib/Tie/Scalar.pm +++ b/lib/Tie/Scalar.pm @@ -79,6 +79,7 @@ process IDs with priority. =cut use Carp; +use warnings::register; sub new { my $pkg = shift; @@ -90,8 +91,8 @@ sub new { sub TIESCALAR { my $pkg = shift; if (defined &{"{$pkg}::new"}) { - carp "WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing" - if $^W; + warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing" + if warnings::enabled(); $pkg->new(@_); } else { diff --git a/lib/constant.pm b/lib/constant.pm index b4fcd421ac..72ad793653 100644 --- a/lib/constant.pm +++ b/lib/constant.pm @@ -2,9 +2,10 @@ package constant; use strict; use 5.005_64; +use warnings::register; our($VERSION, %declared); -$VERSION = '1.01'; +$VERSION = '1.02'; #======================================================================= @@ -51,18 +52,17 @@ sub import { # Maybe the name is tolerable } elsif ($name =~ /^[A-Za-z_]\w*\z/) { # Then we'll warn only if you've asked for warnings - if ($^W) { - require Carp; + if (warnings::enabled()) { if ($keywords{$name}) { - Carp::carp("Constant name '$name' is a Perl keyword"); + warnings::warn("Constant name '$name' is a Perl keyword"); } elsif ($forced_into_main{$name}) { - Carp::carp("Constant name '$name' is " . + warnings::warn("Constant name '$name' is " . "forced into package main::"); } else { # Catch-all - what did I miss? If you get this error, # please let me know what your constant's name was. # Write to <rootbeer@redcat.com>. Thanks! - Carp::carp("Constant name '$name' has unknown problems"); + warnings::warn("Constant name '$name' has unknown problems"); } } diff --git a/lib/syslog.pl b/lib/syslog.pl index 9e03399e4d..70c439b9ae 100644 --- a/lib/syslog.pl +++ b/lib/syslog.pl @@ -29,10 +29,12 @@ package syslog; +use warnings::register; + $host = 'localhost' unless $host; # set $syslog'host to change -if ($] >= 5) { - warn "You should 'use Sys::Syslog' instead; continuing" # if $^W +if ($] >= 5 && warnings::enabled()) { + warnings::warn "You should 'use Sys::Syslog' instead; continuing"; } require 'syslog.ph'; diff --git a/lib/vars.pm b/lib/vars.pm index 6ae5373f89..bde0b2a0e8 100644 --- a/lib/vars.pm +++ b/lib/vars.pm @@ -8,6 +8,7 @@ require 5.002; # if Carp hasn't been loaded in earlier compile time. :-( # We'll let those bugs get found on the development track. require Carp if $] < 5.00450; +use warnings::register(); sub import { my $callpack = caller; @@ -22,9 +23,8 @@ sub import { } elsif ($sym =~ /^\w+[[{].*[]}]$/) { require Carp; Carp::croak("Can't declare individual elements of hash or array"); - } elsif ($^W and length($sym) == 1 and $sym !~ tr/a-zA-Z//) { - require Carp; - Carp::carp("No need to declare built-in vars"); + } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) { + warnings::warn("No need to declare built-in vars"); } } *{"${callpack}::$sym"} = diff --git a/lib/warnings.pm b/lib/warnings.pm index 11fd5b0718..11558d50d4 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -17,7 +17,12 @@ warnings - Perl pragma to control optional warnings use warnings "all"; no warnings "all"; - if (warnings::enabled("void") { + use warnings::register; + if (warnings::enabled()) { + warnings::warn("some warning"); + } + + if (warnings::enabled("void")) { warnings::warn("void", "some warning"); } @@ -26,23 +31,33 @@ warnings - Perl pragma to control optional warnings If no import list is supplied, all possible warnings are either enabled or disabled. -Two functions are provided to assist module authors. +A number of functions are provided to assist module authors. =over 4 -=item warnings::enabled($category) +=item use warnings::register + +Creates a new warnings category which has the same name as the module +where the call to the pragma is used. -Returns TRUE if the warnings category in C<$category> is enabled in the -calling module. Otherwise returns FALSE. +=item warnings::enabled([$category]) +Returns TRUE if the warnings category C<$category> is enabled in the +calling module. Otherwise returns FALSE. -=item warnings::warn($category, $message) +If the parameter, C<$category>, isn't supplied, the current package name +will be used. + +=item warnings::warn([$category,] $message) If the calling module has I<not> set C<$category> to "FATAL", print C<$message> to STDERR. If the calling module has set C<$category> to "FATAL", print C<$message> STDERR then die. +If the parameter, C<$category>, isn't supplied, the current package name +will be used. + =back See L<perlmod/Pragmatic Modules> and L<perllexwarn>. @@ -51,107 +66,161 @@ See L<perlmod/Pragmatic Modules> and L<perllexwarn>. use Carp ; +%Offsets = ( + 'all' => 0, + 'chmod' => 2, + 'closure' => 4, + 'exiting' => 6, + 'glob' => 8, + 'io' => 10, + 'closed' => 12, + 'exec' => 14, + 'newline' => 16, + 'pipe' => 18, + 'unopened' => 20, + 'misc' => 22, + 'numeric' => 24, + 'once' => 26, + 'overflow' => 28, + 'pack' => 30, + 'portable' => 32, + 'recursion' => 34, + 'redefine' => 36, + 'regexp' => 38, + 'severe' => 40, + 'debugging' => 42, + 'inplace' => 44, + 'internal' => 46, + 'malloc' => 48, + 'signal' => 50, + 'substr' => 52, + 'syntax' => 54, + 'ambiguous' => 56, + 'bareword' => 58, + 'deprecated' => 60, + 'digit' => 62, + 'parenthesis' => 64, + 'precedence' => 66, + 'printf' => 68, + 'prototype' => 70, + 'qw' => 72, + 'reserved' => 74, + 'semicolon' => 76, + 'taint' => 78, + 'umask' => 80, + 'uninitialized' => 82, + 'unpack' => 84, + 'untie' => 86, + 'utf8' => 88, + 'void' => 90, + 'y2k' => 92, + ); + %Bits = ( - 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47] - 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27] - 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28] - 'chmod' => "\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [0] - 'closed' => "\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5] - 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] - 'debugging' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20] - 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29] - 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30] - 'exec' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] - 'exiting' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] - 'glob' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] - 'inplace' => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21] - 'internal' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22] - 'io' => "\x00\x55\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9] - 'malloc' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23] - 'misc' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] - 'newline' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] - 'numeric' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] - 'once' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12] - 'overflow' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13] - 'pack' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14] - 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31] - 'pipe' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] - 'portable' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15] - 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32] - 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33] - 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34] - 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35] - 'recursion' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16] - 'redefine' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17] - 'regexp' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18] - 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36] - 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37] - 'severe' => "\x00\x00\x00\x00\x40\x55\x00\x00\x00\x00\x00\x00", # [19..23] - 'signal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24] - 'substr' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25] - 'syntax' => "\x00\x00\x00\x00\x00\x00\x50\x55\x55\x05\x00\x00", # [26..37] - 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38] - 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39] - 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40] - 'unopened' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] - 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41] - 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42] - 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43] - 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44] - 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45] + 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46] + 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28] + 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29] + 'chmod' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] + 'closure' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'debugging' => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21] + 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30] + 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31] + 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] + 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] + 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] + 'inplace' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22] + 'internal' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23] + 'io' => "\x00\x54\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10] + 'malloc' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24] + 'misc' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] + 'newline' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] + 'numeric' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12] + 'once' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13] + 'overflow' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14] + 'pack' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15] + 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32] + 'pipe' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] + 'portable' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16] + 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33] + 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34] + 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35] + 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36] + 'recursion' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17] + 'redefine' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18] + 'regexp' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19] + 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37] + 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38] + 'severe' => "\x00\x00\x00\x00\x00\x55\x01\x00\x00\x00\x00\x00", # [20..24] + 'signal' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25] + 'substr' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26] + 'syntax' => "\x00\x00\x00\x00\x00\x00\x40\x55\x55\x15\x00\x00", # [27..38] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39] + 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41] + 'unopened' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] + 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45] + 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46] ); %DeadBits = ( - 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47] - 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27] - 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28] - 'chmod' => "\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [0] - 'closed' => "\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5] - 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] - 'debugging' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20] - 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29] - 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30] - 'exec' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] - 'exiting' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] - 'glob' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] - 'inplace' => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21] - 'internal' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22] - 'io' => "\x00\xaa\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9] - 'malloc' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23] - 'misc' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] - 'newline' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] - 'numeric' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] - 'once' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12] - 'overflow' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13] - 'pack' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14] - 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31] - 'pipe' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] - 'portable' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15] - 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32] - 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33] - 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34] - 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35] - 'recursion' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16] - 'redefine' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17] - 'regexp' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18] - 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36] - 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37] - 'severe' => "\x00\x00\x00\x00\x80\xaa\x00\x00\x00\x00\x00\x00", # [19..23] - 'signal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24] - 'substr' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25] - 'syntax' => "\x00\x00\x00\x00\x00\x00\xa0\xaa\xaa\x0a\x00\x00", # [26..37] - 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38] - 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39] - 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40] - 'unopened' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] - 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41] - 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42] - 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43] - 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44] - 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45] + 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46] + 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28] + 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29] + 'chmod' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] + 'closure' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'debugging' => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21] + 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30] + 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31] + 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] + 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] + 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] + 'inplace' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22] + 'internal' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23] + 'io' => "\x00\xa8\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10] + 'malloc' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24] + 'misc' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] + 'newline' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] + 'numeric' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12] + 'once' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13] + 'overflow' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14] + 'pack' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15] + 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32] + 'pipe' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] + 'portable' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16] + 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33] + 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34] + 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35] + 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36] + 'recursion' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17] + 'redefine' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18] + 'regexp' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19] + 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37] + 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38] + 'severe' => "\x00\x00\x00\x00\x00\xaa\x02\x00\x00\x00\x00\x00", # [20..24] + 'signal' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25] + 'substr' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26] + 'syntax' => "\x00\x00\x00\x00\x00\x00\x80\xaa\xaa\x2a\x00\x00", # [27..38] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39] + 'umask' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41] + 'unopened' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] + 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45] + 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46] ); -$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0"; +$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0"; +$LAST_BIT = 94 ; +$BYTES = 12 ; + +$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; sub bits { my $mask ; @@ -161,12 +230,12 @@ sub bits { if ($word eq 'FATAL') { $fatal = 1; } - else { - if ($catmask = $Bits{$word}) { - $mask |= $catmask ; - $mask |= $DeadBits{$word} if $fatal ; - } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; } + else + { croak("unknown warnings category '$word'")} } return $mask ; @@ -179,38 +248,70 @@ sub import { sub unimport { shift; - ${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ; + my $mask = ${^WARNING_BITS} ; + if (vec($mask, $Offsets{'all'}, 1)) { + $mask = $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ; } sub enabled { - # If no parameters, check for any lexical warnings enabled - # in the users scope. + croak("Usage: warnings::enabled([category])") + unless @_ == 1 || @_ == 0 ; + local $Carp::CarpLevel = 1 ; + my $category ; + my $offset ; my $callers_bitmask = (caller(1))[9] ; - return ($callers_bitmask ne $NONE) if @_ == 0 ; - - # otherwise check for the category supplied. - my $category = shift ; - return 0 - unless $Bits{$category} ; return 0 unless defined $callers_bitmask ; - return 1 - if ($callers_bitmask & $Bits{$category}) ne $NONE ; - - return 0 ; + + + if (@_) { + # check the category supplied. + $category = shift ; + $offset = $Offsets{$category}; + croak("unknown warnings category '$category'") + unless defined $offset; + } + else { + $category = (caller(0))[0] ; + $offset = $Offsets{$category}; + croak("package '$category' not registered for warnings") + unless defined $offset ; + } + + return vec($callers_bitmask, $offset, 1) || + vec($callers_bitmask, $Offsets{'all'}, 1) ; } + sub warn { - croak "Usage: warnings::warn('category', 'message')" - unless @_ == 2 ; - my $category = shift ; - my $message = shift ; + croak("Usage: warnings::warn([category,] 'message')") + unless @_ == 2 || @_ == 1 ; local $Carp::CarpLevel = 1 ; + my $category ; + my $offset ; my $callers_bitmask = (caller(1))[9] ; + + if (@_ == 2) { + $category = shift ; + $offset = $Offsets{$category}; + croak("unknown warnings category '$category'") + unless defined $offset ; + } + else { + $category = (caller(0))[0] ; + $offset = $Offsets{$category}; + croak("package '$category' not registered for warnings") + unless defined $offset ; + } + + my $message = shift ; croak($message) - if defined $callers_bitmask && - ($callers_bitmask & $DeadBits{$category}) ne $NONE ; + if vec($callers_bitmask, $offset+1, 1) || + vec($callers_bitmask, $Offsets{'all'}+1, 1) ; carp($message) ; } diff --git a/lib/warnings/register.pm b/lib/warnings/register.pm new file mode 100644 index 0000000000..da6be97952 --- /dev/null +++ b/lib/warnings/register.pm @@ -0,0 +1,30 @@ +package warnings::register ; + +require warnings ; + +sub mkMask +{ + my ($bit) = @_ ; + my $mask = "" ; + + vec($mask, $bit, 1) = 1 ; + return $mask ; +} + +sub import +{ + shift ; + my $package = (caller(0))[0] ; + if (! defined $warnings::Bits{$package}) { + $warnings::Bits{$package} = mkMask($warnings::LAST_BIT) ; + vec($warnings::Bits{'all'}, $warnings::LAST_BIT, 1) = 1 ; + $warnings::Offsets{$package} = $warnings::LAST_BIT ++ ; + foreach my $k (keys %warnings::Bits) { + vec($warnings::Bits{$k}, $warnings::LAST_BIT, 1) = 0 ; + } + $warnings::DeadBits{$package} = mkMask($warnings::LAST_BIT); + vec($warnings::DeadBits{'all'}, $warnings::LAST_BIT++, 1) = 1 ; + } +} + +1 ; @@ -565,17 +565,18 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (*(mg->mg_ptr+1) == '\0') sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE)); else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) { - if (PL_compiling.cop_warnings == WARN_NONE || - PL_compiling.cop_warnings == WARN_STD) + if (PL_compiling.cop_warnings == pWARN_NONE || + PL_compiling.cop_warnings == pWARN_STD) { sv_setpvn(sv, WARN_NONEstring, WARNsize) ; } - else if (PL_compiling.cop_warnings == WARN_ALL) { + else if (PL_compiling.cop_warnings == pWARN_ALL) { sv_setpvn(sv, WARN_ALLstring, WARNsize) ; } else { sv_setsv(sv, PL_compiling.cop_warnings); } + SvPOK_only(sv); } else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) sv_setiv(sv, (IV)PL_widesyscalls); @@ -1715,23 +1716,31 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { if (!SvPOK(sv) && PL_localizing) { sv_setpvn(sv, WARN_NONEstring, WARNsize); - PL_compiling.cop_warnings = WARN_NONE; + PL_compiling.cop_warnings = pWARN_NONE; break; } - if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize)) { - PL_compiling.cop_warnings = WARN_ALL; + if (isWARN_on(sv, WARN_ALL)) { + PL_compiling.cop_warnings = pWARN_ALL; PL_dowarn |= G_WARN_ONCE ; } - else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize)) - PL_compiling.cop_warnings = WARN_NONE; - else { - if (specialWARN(PL_compiling.cop_warnings)) - PL_compiling.cop_warnings = newSVsv(sv) ; - else - sv_setsv(PL_compiling.cop_warnings, sv); - if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) - PL_dowarn |= G_WARN_ONCE ; - } + else { + int i ; + int accumulate = 0 ; + int len ; + char * ptr = (char*)SvPV(sv, len) ; + for (i = 0 ; i < len ; ++i) + accumulate += ptr[i] ; + if (!accumulate) + PL_compiling.cop_warnings = pWARN_NONE; + else { + if (specialWARN(PL_compiling.cop_warnings)) + PL_compiling.cop_warnings = newSVsv(sv) ; + else + sv_setsv(PL_compiling.cop_warnings, sv); + if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) + PL_dowarn |= G_WARN_ONCE ; + } + } } } else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) @@ -687,6 +687,10 @@ #define Perl_to_uni_lower_lc pPerl->Perl_to_uni_lower_lc #undef to_uni_lower_lc #define to_uni_lower_lc Perl_to_uni_lower_lc +#undef Perl_is_utf8_char +#define Perl_is_utf8_char pPerl->Perl_is_utf8_char +#undef is_utf8_char +#define is_utf8_char Perl_is_utf8_char #undef Perl_is_utf8_alnum #define Perl_is_utf8_alnum pPerl->Perl_is_utf8_alnum #undef is_utf8_alnum @@ -2233,12 +2233,12 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); return s; case 'W': PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; - PL_compiling.cop_warnings = WARN_ALL ; + PL_compiling.cop_warnings = pWARN_ALL ; s++; return s; case 'X': PL_dowarn = G_WARN_ALL_OFF; - PL_compiling.cop_warnings = WARN_NONE ; + PL_compiling.cop_warnings = pWARN_NONE ; s++; return s; case '*': @@ -1288,6 +1288,13 @@ Perl_to_uni_lower_lc(pTHXo_ U32 c) return ((CPerlObj*)pPerl)->Perl_to_uni_lower_lc(c); } +#undef Perl_is_utf8_char +int +Perl_is_utf8_char(pTHXo_ U8 *p) +{ + return ((CPerlObj*)pPerl)->Perl_is_utf8_char(p); +} + #undef Perl_is_utf8_alnum bool Perl_is_utf8_alnum(pTHXo_ U8 *p) diff --git a/pod/perlapi.pod b/pod/perlapi.pod index e4dedbe21b..c13dcde6ff 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -381,17 +381,17 @@ C<call_sv> apply equally to these functions. =item gv_stashpv -Returns a pointer to the stash for a specified package. If C<create> is -set then the package will be created if it does not already exist. If -C<create> is not set and the package does not exist then NULL is -returned. +Returns a pointer to the stash for a specified package. C<name> should +be a valid UTF-8 string. If C<create> is set then the package will be +created if it does not already exist. If C<create> is not set and the +package does not exist then NULL is returned. HV* gv_stashpv(const char* name, I32 create) =item gv_stashsv -Returns a pointer to the stash for a specified package. See -C<gv_stashpv>. +Returns a pointer to the stash for a specified package, which must be a +valid UTF-8 string. See C<gv_stashpv>. HV* gv_stashsv(SV* sv, I32 create) diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 7bae55a802..e4930816e5 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -1432,6 +1432,12 @@ program, passing it C<"surprise"> an argument. The second version didn't--it tried to run a program literally called I<"echo surprise">, didn't find it, and set C<$?> to a non-zero value indicating failure. +Beginning with v5.6.0, Perl will attempt to flush all files opened for +output before the exec, but this may not be supported on some platforms +(see L<perlport>). To be safe, you may need to set C<$|> ($AUTOFLUSH +in English) or call the C<autoflush()> method of C<IO::Handle> on any +open handles in order to avoid lost output. + Note that C<exec> will not call your C<END> blocks, nor will it call any C<DESTROY> methods in your objects. @@ -1650,7 +1656,11 @@ fork(), great care has gone into making it extremely efficient (for example, using copy-on-write technology on data pages), making it the dominant paradigm for multitasking over the last few decades. -All files opened for output are flushed before forking the child process. +Beginning with v5.6.0, Perl will attempt to flush all files opened for +output before forking the child process, but this may not be supported +on some platforms (see L<perlport>). To be safe, you may need to set +C<$|> ($AUTOFLUSH in English) or call the C<autoflush()> method of +C<IO::Handle> on any open handles in order to avoid duplicate output. If you C<fork> without ever waiting on your children, you will accumulate zombies. On some systems, you can avoid this by setting @@ -2753,8 +2763,13 @@ The following triples are more or less equivalent: See L<perlipc/"Safe Pipe Opens"> for more examples of this. -NOTE: On any operation that may do a fork, all files opened for output -are flushed before the fork is attempted. On systems that support a +Beginning with v5.6.0, Perl will attempt to flush all files opened for +output before any operation that may do a fork, but this may not be +supported on some platforms (see L<perlport>). To be safe, you may need +to set C<$|> ($AUTOFLUSH in English) or call the C<autoflush()> method +of C<IO::Handle> on any open handles. + +On systems that support a close-on-exec flag on files, the flag will be set for the newly opened file descriptor as determined by the value of $^F. See L<perlvar/$^F>. @@ -4910,7 +4925,11 @@ platforms). If there are no shell metacharacters in the argument, it is split into words and passed directly to C<execvp>, which is more efficient. -All files opened for output are flushed before attempting the exec(). +Beginning with v5.6.0, Perl will attempt to flush all files opened for +output before any operation that may do a fork, but this may not be +supported on some platforms (see L<perlport>). To be safe, you may need +to set C<$|> ($AUTOFLUSH in English) or call the C<autoflush()> method +of C<IO::Handle> on any open handles. The return value is the exit status of the program as returned by the C<wait> call. To get the actual exit value divide by diff --git a/pod/perllexwarn.pod b/pod/perllexwarn.pod index af1a910334..cee1687537 100644 --- a/pod/perllexwarn.pod +++ b/pod/perllexwarn.pod @@ -339,20 +339,49 @@ fatal error. =head2 Reporting Warnings from a Module -The C<warnings> pragma provides two functions, namely C<warnings::enabled> -and C<warnings::warn>, that are useful for module authors. They are -used when you want to report a module-specific warning, but only when -the calling module has enabled warnings via the C<warnings> pragma. +The C<warnings> pragma provides a number of functions that are useful for +module authors. These are used when you want to report a module-specific +warning when the calling module has enabled warnings via the C<warnings> +pragma. -Consider the module C<abc> below. +Consider the module C<MyMod::Abc> below. - package abc; + package MyMod::Abc; - sub open - { + use warnings::register; + + sub open { + my $path = shift ; + if (warnings::enabled() && $path !~ m#^/#) { + warnings::warn("changing relative path to /tmp/"); + $path = "/tmp/$path" ; + } + } + + 1 ; + +The call to C<warnings::register> will create a new warnings category +called "MyMod::abc", i.e. the new category name matches the module +name. The C<open> function in the module will display a warning message +if it gets given a relative path as a parameter. This warnings will only +be displayed if the code that uses C<MyMod::Abc> has actually enabled +them with the C<warnings> pragma like below. + + use MyMod::Abc; + use warnings 'MyMod::Abc'; + ... + abc::open("../fred.txt"); + +It is also possible to test whether the pre-defined warnings categories are +set in the calling module with the C<warnings::enabled> function. Consider +this snippet of code: + + package MyMod::Abc; + + sub open { if (warnings::enabled("deprecated")) { warnings::warn("deprecated", - "abc::open is deprecated. Use abc:new") ; + "open is deprecated, use new instead") ; } new(@_) ; } @@ -366,21 +395,21 @@ display a warning message whenever the calling module has (at least) the "deprecated" warnings category enabled. Something like this, say. use warnings 'deprecated'; - use abc; + use MyMod::Abc; ... - abc::open($filename) ; - + MyMod::Abc::open($filename) ; -If the calling module has escalated the "deprecated" warnings category -into a fatal error like this: +The C<warnings::warn> function should be used to actually display the +warnings message. This is because they can make use of the feature that +allows warnings to be escalated into fatal errors. So in this case - use warnings 'FATAL deprecated'; - use abc; + use MyMod::Abc; + use warnings FATAL => 'MyMod::Abc'; ... - abc::open($filename) ; + MyMod::Abc::open('../fred.txt'); -then C<warnings::warn> will detect this and die after displaying the -warning message. +the C<warnings::warn> function will detect this and die after +displaying the warning message. =head1 TODO diff --git a/pod/perlop.pod b/pod/perlop.pod index 5e4ce937fa..a81f7fe8b2 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -1051,6 +1051,12 @@ multiple commands in a single line by separating them with the command separator character, if your shell supports that (e.g. C<;> on many Unix shells; C<&> on the Windows NT C<cmd> shell). +Beginning with v5.6.0, Perl will attempt to flush all files opened for +output before starting the child process, but this may not be supported +on some platforms (see L<perlport>). To be safe, you may need to set +C<$|> ($AUTOFLUSH in English) or call the C<autoflush()> method of +C<IO::Handle> on any open handles. + Beware that some command shells may place restrictions on the length of the command line. You must ensure your strings don't exceed this limit after any necessary interpolations. See the platform-specific diff --git a/pod/perlport.pod b/pod/perlport.pod index 10723ee3a4..44b4ebed81 100644 --- a/pod/perlport.pod +++ b/pod/perlport.pod @@ -1287,6 +1287,9 @@ Not implemented. (S<Mac OS>) Implemented via Spawn. (VM/ESA) +Does not automatically flush output handles on some platforms. +(SunOS, Solaris, HP-UX) + =item fcntl FILEHANDLE,FUNCTION,SCALAR Not implemented. (Win32, VMS) @@ -1299,7 +1302,12 @@ Available only on Windows NT (not on Windows 95). (Win32) =item fork -Not implemented. (S<Mac OS>, Win32, AmigaOS, S<RISC OS>, VOS, VM/ESA) +Not implemented. (S<Mac OS>, AmigaOS, S<RISC OS>, VOS, VM/ESA) + +Emulated using multiple interpreters. See L<perlfork>. (Win32) + +Does not automatically flush output handles on some platforms. +(SunOS, Solaris, HP-UX) =item getlogin @@ -1502,6 +1510,9 @@ The C<|> variants are supported only if ToolServer is installed. open to C<|-> and C<-|> are unsupported. (S<Mac OS>, Win32, S<RISC OS>) +Opening a process does not automatically flush output handles on some +platforms. (SunOS, Solaris, HP-UX) + =item pipe READHANDLE,WRITEHANDLE Not implemented. (S<Mac OS>) @@ -1618,6 +1629,9 @@ Far from being POSIX compliant. Because there may be no underlying first token in its argument string. Handles basic redirection ("<" or ">") on its own behalf. (MiNT) +Does not automatically flush output handles on some platforms. +(SunOS, Solaris, HP-UX) + =item times Only the first entry returned is nonzero. (S<Mac OS>) @@ -1562,9 +1562,9 @@ PP(pp_caller) { SV * mask ; SV * old_warnings = cx->blk_oldcop->cop_warnings ; - if (old_warnings == WARN_NONE || old_warnings == WARN_STD) + if (old_warnings == pWARN_NONE || old_warnings == pWARN_STD) mask = newSVpvn(WARN_NONEstring, WARNsize) ; - else if (old_warnings == WARN_ALL) + else if (old_warnings == pWARN_ALL) mask = newSVpvn(WARN_ALLstring, WARNsize) ; else mask = newSVsv(old_warnings); @@ -1848,15 +1848,21 @@ PP(pp_return) *++newsp = SvREFCNT_inc(*SP); FREETMPS; sv_2mortal(*newsp); - } else { + } + else { + sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */ FREETMPS; - *++newsp = sv_mortalcopy(*SP); + *++newsp = sv_mortalcopy(sv); + SvREFCNT_dec(sv); } - } else + } + else *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); - } else + } + else *++newsp = sv_mortalcopy(*SP); - } else + } + else *++newsp = &PL_sv_undef; } else if (gimme == G_ARRAY) { @@ -3161,11 +3167,11 @@ PP(pp_require) PL_hints = 0; SAVESPTR(PL_compiling.cop_warnings); if (PL_dowarn & G_WARN_ALL_ON) - PL_compiling.cop_warnings = WARN_ALL ; + PL_compiling.cop_warnings = pWARN_ALL ; else if (PL_dowarn & G_WARN_ALL_OFF) - PL_compiling.cop_warnings = WARN_NONE ; + PL_compiling.cop_warnings = pWARN_NONE ; else - PL_compiling.cop_warnings = WARN_STD ; + PL_compiling.cop_warnings = pWARN_STD ; if (filter_sub || filter_child_proc) { SV *datasv = filter_add(run_user_filter, Nullsv); @@ -653,7 +653,7 @@ S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem, sv_setsv(tmpstr,relem[1]); /* value */ relem[1] = tmpstr; if (avhv_store_ent(ary,relem[0],tmpstr,0)) - SvREFCNT_inc(tmpstr); + (void)SvREFCNT_inc(tmpstr); if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr)) mg_set(tmpstr); relem += 2; @@ -687,7 +687,7 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) /* pseudohash */ tmpstr = sv_newmortal(); if (avhv_store_ent((AV*)hash,*relem,tmpstr,0)) - SvREFCNT_inc(tmpstr); + (void)SvREFCNT_inc(tmpstr); if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr)) mg_set(tmpstr); } @@ -2012,8 +2012,10 @@ PP(pp_leavesub) sv_2mortal(*MARK); } else { + sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ FREETMPS; - *MARK = sv_mortalcopy(TOPs); + *MARK = sv_mortalcopy(sv); + SvREFCNT_dec(sv); } } else @@ -2161,8 +2163,10 @@ PP(pp_leavesublv) sv_2mortal(*MARK); } else { + sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ FREETMPS; - *MARK = sv_mortalcopy(TOPs); + *MARK = sv_mortalcopy(sv); + SvREFCNT_dec(sv); } } else @@ -365,6 +365,7 @@ PERL_CALLCONV bool Perl_is_uni_xdigit_lc(pTHX_ U32 c); PERL_CALLCONV U32 Perl_to_uni_upper_lc(pTHX_ U32 c); PERL_CALLCONV U32 Perl_to_uni_title_lc(pTHX_ U32 c); PERL_CALLCONV U32 Perl_to_uni_lower_lc(pTHX_ U32 c); +PERL_CALLCONV int Perl_is_utf8_char(pTHX_ U8 *p); PERL_CALLCONV bool Perl_is_utf8_alnum(pTHX_ U8 *p); PERL_CALLCONV bool Perl_is_utf8_alnumc(pTHX_ U8 *p); PERL_CALLCONV bool Perl_is_utf8_idfirst(pTHX_ U8 *p); diff --git a/t/lib/filepath.t b/t/lib/filepath.t index 40e6e213c1..5628d0c726 100755 --- a/t/lib/filepath.t +++ b/t/lib/filepath.t @@ -9,7 +9,7 @@ use File::Path; use strict; my $count = 0; -$^W = 1; +use warnings; print "1..4\n"; diff --git a/t/lib/io_sel.t b/t/lib/io_sel.t index e0d7a45338..85e14ab0c0 100755 --- a/t/lib/io_sel.t +++ b/t/lib/io_sel.t @@ -10,7 +10,7 @@ BEGIN { select(STDERR); $| = 1; select(STDOUT); $| = 1; -print "1..21\n"; +print "1..23\n"; use IO::Select 1.09; @@ -114,3 +114,19 @@ print "ok 20\n"; $sel->remove($sel->handles); print "not " unless $sel->count == 0 && !defined($sel->bits); print "ok 21\n"; + +# check warnings +$SIG{__WARN__} = sub { + ++ $w + if $_[0] =~ /^Call to depreciated method 'has_error', use 'has_exception'/ + } ; +$w = 0 ; +IO::Select::has_error(); +print "not " unless $w == 0 ; +$w = 0 ; +print "ok 22\n" ; +use warnings 'IO::Select' ; +IO::Select::has_error(); +print "not " unless $w == 1 ; +$w = 0 ; +print "ok 23\n" ; diff --git a/t/lib/socket.t b/t/lib/socket.t index 8f945ac6f7..d5e1848a3e 100755 --- a/t/lib/socket.t +++ b/t/lib/socket.t @@ -13,7 +13,7 @@ BEGIN { use Socket; -print "1..6\n"; +print "1..8\n"; if (socket(T,PF_INET,SOCK_STREAM,6)) { print "ok 1\n"; @@ -74,3 +74,14 @@ else { print "# $!\n"; print "not ok 4\n"; } + +# warnings +$SIG{__WARN__} = sub { + ++ $w if $_[0] =~ /^6-ARG sockaddr_in call is deprecated/ ; +} ; +$w = 0 ; +sockaddr_in(1,2,3,4,5,6) ; +print ($w == 1 ? "not ok 7\n" : "ok 7\n") ; +use warnings 'Socket' ; +sockaddr_in(1,2,3,4,5,6) ; +print ($w == 1 ? "ok 8\n" : "not ok 8\n") ; diff --git a/t/lib/tie-stdhandle.t b/t/lib/tie-stdhandle.t index cb8303d94d..cf3a1831d0 100755 --- a/t/lib/tie-stdhandle.t +++ b/t/lib/tie-stdhandle.t @@ -45,5 +45,3 @@ print "ok 12\n"; print "not " unless close($f); print "ok 13\n"; unlink("afile"); - - diff --git a/t/op/recurse.t b/t/op/recurse.t index 6594940a90..dc823ed966 100755 --- a/t/op/recurse.t +++ b/t/op/recurse.t @@ -4,7 +4,7 @@ # test recursive functions. # -print "1..23\n"; +print "1..25\n"; sub gcd ($$) { return gcd($_[0] - $_[1], $_[1]) if ($_[0] > $_[1]); @@ -84,3 +84,33 @@ for $x (0..3) { print 'not ' unless (($t = takeuchi($x, $y, $z)) == $z + 1); print "ok ", $i++, "\n"; print "# takeuchi($x, $y, $z) = $t\n"; + +{ + sub get_first1 { + get_list1(@_)->[0]; + } + + sub get_list1 { + return [24] unless $_[0]; + my $u = get_first1(0); + [$u]; + } + my $x = get_first1(1); + print "ok $x\n"; +} + +{ + sub get_first2 { + return get_list2(@_)->[0]; + } + + sub get_list2 { + return [25] unless $_[0]; + my $u = get_first2(0); + return [$u]; + } + my $x = get_first2(1); + print "ok $x\n"; +} + +$i = 26; diff --git a/t/op/tie.t b/t/op/tie.t index 105b1d6f18..9543420a42 100755 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -78,7 +78,6 @@ EXPECT # strict behaviour, without any extra references use warnings 'untie'; -#local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; @@ -87,7 +86,6 @@ EXPECT # strict behaviour, with 1 extra references generating an error use warnings 'untie'; -#local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; @@ -97,7 +95,6 @@ untie attempted while 1 inner references still exist # strict behaviour, with 1 extra references via tied generating an error use warnings 'untie'; -#local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; @@ -108,7 +105,6 @@ untie attempted while 1 inner references still exist # strict behaviour, with 1 extra references which are destroyed use warnings 'untie'; -#local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $a = 0 ; @@ -118,7 +114,6 @@ EXPECT # strict behaviour, with extra 1 references via tied which are destroyed use warnings 'untie'; -#local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; @@ -129,7 +124,6 @@ EXPECT # strict error behaviour, with 2 extra references use warnings 'untie'; -#local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $b = tied %h ; @@ -140,13 +134,11 @@ untie attempted while 2 inner references still exist # strict behaviour, check scope of strictness. no warnings 'untie'; -#local $^W = 0 ; use Tie::Hash ; $A = tie %H, Tie::StdHash; $C = $B = tied %H ; { use warnings 'untie'; - #local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; diff --git a/t/pragma/constant.t b/t/pragma/constant.t index 5904a4f2b6..443bcf6423 100755 --- a/t/pragma/constant.t +++ b/t/pragma/constant.t @@ -14,7 +14,7 @@ END { print @warnings } ######################### We start with some black magic to print on failure. -BEGIN { $| = 1; print "1..58\n"; } +BEGIN { $| = 1; print "1..73\n"; } END {print "not ok 1\n" unless $loaded;} use constant 1.01; $loaded = 1; @@ -96,11 +96,8 @@ test 23, length(MESS) == 8; use constant TRAILING => '12 cats'; { - my $save_warn; - local $^W; - BEGIN { $save_warn = $^W; $^W = 0 } + no warnings 'numeric'; test 24, TRAILING == 12; - BEGIN { $^W = $save_warn } } test 25, TRAILING eq '12 cats'; @@ -194,3 +191,41 @@ test 52, !$constant::declared{'main::PIE'}; test 57, declared 'Other::IN_OTHER_PACK'; test 58, $constant::declared{'Other::IN_OTHER_PACK'}; + +@warnings = (); +eval q{ +{ + use warnings 'constant'; + use constant 'BEGIN' => 1 ; + use constant 'INIT' => 1 ; + use constant 'CHECK' => 1 ; + use constant 'END' => 1 ; + use constant 'DESTROY' => 1 ; + use constant 'AUTOLOAD' => 1 ; + use constant 'STDIN' => 1 ; + use constant 'STDOUT' => 1 ; + use constant 'STDERR' => 1 ; + use constant 'ARGV' => 1 ; + use constant 'ARGVOUT' => 1 ; + use constant 'ENV' => 1 ; + use constant 'INC' => 1 ; + use constant 'SIG' => 1 ; +} +}; + +test 59, @warnings == 14 ; +test 60, (shift @warnings) =~ /^Constant name 'BEGIN' is a Perl keyword at/; +test 61, (shift @warnings) =~ /^Constant name 'INIT' is a Perl keyword at/; +test 62, (shift @warnings) =~ /^Constant name 'CHECK' is a Perl keyword at/; +test 63, (shift @warnings) =~ /^Constant name 'END' is a Perl keyword at/; +test 64, (shift @warnings) =~ /^Constant name 'DESTROY' is a Perl keyword at/; +test 65, (shift @warnings) =~ /^Constant name 'AUTOLOAD' is a Perl keyword at/; +test 66, (shift @warnings) =~ /^Constant name 'STDIN' is forced into package main:: a/; +test 67, (shift @warnings) =~ /^Constant name 'STDOUT' is forced into package main:: at/; +test 68, (shift @warnings) =~ /^Constant name 'STDERR' is forced into package main:: at/; +test 69, (shift @warnings) =~ /^Constant name 'ARGV' is forced into package main:: at/; +test 70, (shift @warnings) =~ /^Constant name 'ARGVOUT' is forced into package main:: at/; +test 71, (shift @warnings) =~ /^Constant name 'ENV' is forced into package main:: at/; +test 72, (shift @warnings) =~ /^Constant name 'INC' is forced into package main:: at/; +test 73, (shift @warnings) =~ /^Constant name 'SIG' is forced into package main:: at/; +@warnings = (); diff --git a/t/pragma/diagnostics.t b/t/pragma/diagnostics.t index 8c9a152a18..15cd6b5927 100755 --- a/t/pragma/diagnostics.t +++ b/t/pragma/diagnostics.t @@ -11,11 +11,12 @@ BEGIN { # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) use strict; +use warnings; use vars qw($Test_Num $Total_tests); my $loaded; -BEGIN { $| = 1; $^W = 1; $Test_Num = 1 } +BEGIN { $| = 1; $Test_Num = 1 } END {print "not ok $Test_Num\n" unless $loaded;} print "1..$Total_tests\n"; BEGIN { require diagnostics; } # Don't want diagnostics' noise yet. diff --git a/t/pragma/warn/2use b/t/pragma/warn/2use index 396f20142c..60a60c313c 100644 --- a/t/pragma/warn/2use +++ b/t/pragma/warn/2use @@ -5,9 +5,11 @@ TODO __END__ -# ignore unknown warning categories +# check illegal category is caught use warnings 'this-should-never-be-a-warning-category' ; EXPECT +unknown warnings category 'this-should-never-be-a-warning-category' at - line 3 +BEGIN failed--compilation aborted at - line 3. ######## # Check compile time scope of pragma diff --git a/t/pragma/warn/9enabled b/t/pragma/warn/9enabled index 1ecf24a0c0..7facf996f5 100755 --- a/t/pragma/warn/9enabled +++ b/t/pragma/warn/9enabled @@ -5,7 +5,7 @@ __END__ --FILE-- abc.pm package abc ; use warnings "io" ; -print "ok1\n" if ! warnings::enabled() ; +print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if ! warnings::enabled("io") ; 1; --FILE-- @@ -19,7 +19,7 @@ ok2 --FILE-- abc.pm package abc ; no warnings ; -print "ok1\n" if warnings::enabled() ; +print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; 1; --FILE-- @@ -33,7 +33,7 @@ ok2 --FILE-- abc.pm package abc ; use warnings 'syntax' ; -print "ok1\n" if warnings::enabled() ; +print "ok1\n" if warnings::enabled('io') ; print "ok2\n" if ! warnings::enabled("syntax") ; 1; --FILE-- @@ -46,7 +46,7 @@ ok2 --FILE-- abc no warnings ; -print "ok1\n" if warnings::enabled() ; +print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; 1; --FILE-- @@ -59,7 +59,7 @@ ok2 --FILE-- abc use warnings 'syntax' ; -print "ok1\n" if warnings::enabled ; +print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if ! warnings::enabled("syntax") ; print "ok3\n" if warnings::enabled("io") ; 1; @@ -76,7 +76,7 @@ ok3 package abc ; no warnings ; sub check { - print "ok1\n" if warnings::enabled ; + print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; } 1; @@ -93,8 +93,8 @@ ok2 package abc ; use warnings 'io' ; sub check { - print "ok1\n" if warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; + print "ok1\n" if ! warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if ! warnings::enabled("io") ; } 1; @@ -112,7 +112,7 @@ ok3 package abc ; no warnings ; sub check { - print "ok1\n" if warnings::enabled ; + print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; } 1; @@ -129,8 +129,8 @@ ok2 package abc ; use warnings 'io' ; sub check { - print "ok1\n" if warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; + print "ok1\n" if ! warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if ! warnings::enabled("io") ; } 1; @@ -147,7 +147,7 @@ ok3 --FILE-- abc.pm package abc ; use warnings "io" ; -print "ok1\n" if ! warnings::enabled() ; +print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if ! warnings::enabled("io") ; 1; --FILE-- def.pm @@ -165,13 +165,13 @@ ok2 --FILE-- abc.pm package abc ; no warnings ; -print "ok1\n" if warnings::enabled() ; +print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if !warnings::enabled("io") ; 1; --FILE-- def.pm use warnings 'syntax' ; -print "ok4\n" if warnings::enabled() ; +print "ok4\n" if !warnings::enabled('all') ; print "ok5\n" if warnings::enabled("io") ; use abc ; 1; @@ -190,7 +190,7 @@ ok5 package abc ; no warnings ; sub check { - print "ok1\n" if warnings::enabled ; + print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; } 1; @@ -208,8 +208,8 @@ ok2 package abc ; use warnings 'io' ; sub check { - print "ok1\n" if warnings::enabled ; - print "ok2\n" if warnings::enabled("syntax") ; + print "ok1\n" if ! warnings::enabled('all') ; + print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if ! warnings::enabled("io") ; } 1; @@ -228,7 +228,7 @@ ok3 package abc ; no warnings ; sub check { - print "ok1\n" if warnings::enabled ; + print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; } 1; @@ -246,7 +246,7 @@ ok2 package abc ; use warnings 'io' ; sub check { - print "ok1\n" if warnings::enabled ; + print "ok1\n" if !warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if warnings::enabled("io") ; } @@ -269,7 +269,7 @@ ok2 package abc ; use warnings 'io' ; sub check { - print "ok1\n" if warnings::enabled ; + print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if ! warnings::enabled("io") ; } @@ -289,7 +289,7 @@ ok3 package abc ; use warnings 'io' ; sub check { - print "ok1\n" if ! warnings::enabled ; + print "ok1\n" if ! warnings::enabled('all') ; } 1; --FILE-- @@ -305,7 +305,7 @@ ok1 package abc ; use warnings 'misc' ; sub check { - print "ok1\n" if warnings::enabled ; + print "ok1\n" if ! warnings::enabled('all') ; print "ok2\n" if warnings::enabled("syntax") ; print "ok3\n" if warnings::enabled("io") ; print "ok4\n" if ! warnings::enabled("misc") ; @@ -327,11 +327,12 @@ ok4 use warnings ; eval { warnings::warn() } ; print $@ ; -eval { warnings::warn("fred") } ; +eval { warnings::warn("fred", "joe") } ; print $@ ; EXPECT -Usage: warnings::warn('category', 'message') at - line 4 -Usage: warnings::warn('category', 'message') at - line 6 +Usage: warnings::warn([category,] 'message') at - line 4 +unknown warnings category 'fred' at - line 6 + require 0 called at - line 6 ######## --FILE-- abc.pm @@ -388,3 +389,431 @@ print "[[$@]]\n"; EXPECT [[hello at - line 3 ]] +######## +-W +--FILE-- abc.pm +package abc ; +use warnings "io" ; +print "ok1\n" if warnings::enabled("io") ; +print "ok2\n" if warnings::enabled("all") ; +1; +--FILE-- +no warnings; +use abc ; +EXPECT +ok1 +ok2 +######## +-X +--FILE-- abc.pm +package abc ; +use warnings "io" ; +print "ok1\n" if !warnings::enabled("io") ; +print "ok2\n" if !warnings::enabled("all") ; +1; +--FILE-- +use warnings; +use abc ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +sub check { + print "ok\n" if ! warnings::enabled() ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +package 'abc' not registered for warnings at - line 3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if !warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +use warnings 'abc' ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if !warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +use warnings 'abc' ; +eval { abc::check() ; }; +print $@ ; +EXPECT +ok1 +ok2 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if !warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +eval { abc::check() ; } ; +print $@ ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if !warnings::enabled("io") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +use warnings 'abc' ; +sub fred { abc::check() } +fred() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'io' ; +use warnings::register ; +sub check { + print "ok1\n" if ! warnings::enabled ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +sub fred { no warnings ; abc::check() } +fred() ; +EXPECT +ok1 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +use warnings::register; +sub check { + print "ok1\n" if warnings::enabled ; + print "ok2\n" if warnings::enabled("syntax") ; + print "ok3\n" if warnings::enabled("io") ; + print "ok4\n" if ! warnings::enabled("misc") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +use warnings 'abc' ; +sub fred { use warnings 'io' ; abc::check() } +fred() ; +EXPECT +ok1 +ok2 +ok3 +ok4 +######## + +--FILE-- abc.pm +package abc ; +use warnings 'misc' ; +use warnings::register; +sub check { warnings::warn("hello") } +1; +--FILE-- +use abc; +use warnings "abc" ; +abc::check() ; +EXPECT +hello at - line 3 +######## + +--FILE-- abc.pm +package abc ; +use warnings::register; +sub check { warnings::warn("hello") } +1; +--FILE-- +use abc; +abc::check() ; +EXPECT +hello at - line 2 +######## + +--FILE-- abc.pm +package abc ; +use warnings::register ; +sub check { warnings::warn("hello") } +1; +--FILE-- +use abc; +use warnings qw( FATAL deprecated ) ; +eval { abc::check() ; } ; +print "[[$@]]\n"; +EXPECT +hello at - line 3 +[[]] +######## + +--FILE-- abc.pm +package abc ; +use warnings::register ; +sub check { warnings::warn("hello") } +1; +--FILE-- +use abc; +use warnings qw( FATAL abc ) ; +eval { abc::check() ; } ; +print "[[$@]]\n"; +EXPECT +[[hello at - line 3 +]] +######## +-W +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if warnings::enabled("io") ; + print "ok3\n" if warnings::enabled("all") ; +} +1; +--FILE-- +no warnings; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## +-X +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +no warnings; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if warnings::enabled("io") ; + print "ok3\n" if warnings::enabled("all") ; +} +1; +--FILE-- +use warnings 'all'; +use abc ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +no warnings ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; +} +1; +--FILE-- +use abc ; +use warnings 'abc'; +no warnings ; +abc::check() ; +EXPECT +ok1 +ok2 +ok3 +######## + +--FILE-- abc.pm +package abc ; +use warnings "io" ; +use warnings::register ; +sub check { + print "abc self" . (warnings::enabled() ? "" : " not") . " enabled\n" ; + print "abc def" . (warnings::enabled('def') ? "" : " not") . " enabled\n" ; + print "abc all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ; +} +1; +--FILE-- def.pm +package def ; +use warnings "io" ; +use warnings::register ; +sub check { + print "def self" . (warnings::enabled() ? "" : " not") . " enabled\n" ; + print "def abc" . (warnings::enabled('abc') ? "" : " not") . " enabled\n" ; + print "def all" . (warnings::enabled('all') ? "" : " not") . " enabled\n" ; +} +1; +--FILE-- +use abc ; +use def ; +use warnings 'abc'; +abc::check() ; +def::check() ; +no warnings 'abc' ; +use warnings 'def' ; +abc::check() ; +def::check() ; +use warnings 'abc' ; +use warnings 'def' ; +abc::check() ; +def::check() ; +no warnings 'abc' ; +no warnings 'def' ; +abc::check() ; +def::check() ; +use warnings; +abc::check() ; +def::check() ; +no warnings 'abc' ; +abc::check() ; +def::check() ; +EXPECT +abc self enabled +abc def not enabled +abc all not enabled +def self not enabled +def abc enabled +def all not enabled +abc self not enabled +abc def enabled +abc all not enabled +def self enabled +def abc not enabled +def all not enabled +abc self enabled +abc def enabled +abc all not enabled +def self enabled +def abc enabled +def all not enabled +abc self not enabled +abc def not enabled +abc all not enabled +def self not enabled +def abc not enabled +def all not enabled +abc self enabled +abc def enabled +abc all enabled +def self enabled +def abc enabled +def all enabled +abc self not enabled +abc def enabled +abc all not enabled +def self enabled +def abc not enabled +def all not enabled @@ -101,6 +101,39 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) #endif } +/* Tests if some arbitrary number of bytes begins in a valid UTF-8 character. + * The actual number of bytes in the UTF-8 character will be returned if it + * is valid, otherwise 0. */ +int +Perl_is_utf8_char(pTHX_ U8 *s) +{ + U8 u = *s; + int slen, len; + + if (!(u & 0x80)) + return 1; + + if (!(u & 0x40)) + return 0; + + if (!(u & 0x20)) { len = 2; } + else if (!(u & 0x10)) { len = 3; } + else if (!(u & 0x08)) { len = 4; } + else if (!(u & 0x04)) { len = 5; } + else if (!(u & 0x02)) { len = 6; } + else if (!(u & 0x01)) { len = 7; } + else { len = 13; } /* whoa! */ + + slen = len - 1; + s++; + while (slen--) { + if ((*s & 0xc0) != 0x80) + return 0; + s++; + } + return len; +} + UV Perl_utf8_to_uv(pTHX_ U8* s, I32* retlen) { @@ -500,6 +533,8 @@ Perl_to_uni_lower_lc(pTHX_ U32 c) bool Perl_is_utf8_alnum(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_alnum) PL_utf8_alnum = swash_init("utf8", "IsAlnum", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_alnum, p); @@ -515,6 +550,8 @@ Perl_is_utf8_alnum(pTHX_ U8 *p) bool Perl_is_utf8_alnumc(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_alnum) PL_utf8_alnum = swash_init("utf8", "IsAlnumC", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_alnum, p); @@ -536,6 +573,8 @@ Perl_is_utf8_idfirst(pTHX_ U8 *p) bool Perl_is_utf8_alpha(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_alpha) PL_utf8_alpha = swash_init("utf8", "IsAlpha", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_alpha, p); @@ -544,6 +583,8 @@ Perl_is_utf8_alpha(pTHX_ U8 *p) bool Perl_is_utf8_ascii(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_ascii) PL_utf8_ascii = swash_init("utf8", "IsAscii", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_ascii, p); @@ -552,6 +593,8 @@ Perl_is_utf8_ascii(pTHX_ U8 *p) bool Perl_is_utf8_space(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_space) PL_utf8_space = swash_init("utf8", "IsSpace", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_space, p); @@ -560,6 +603,8 @@ Perl_is_utf8_space(pTHX_ U8 *p) bool Perl_is_utf8_digit(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_digit) PL_utf8_digit = swash_init("utf8", "IsDigit", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_digit, p); @@ -568,6 +613,8 @@ Perl_is_utf8_digit(pTHX_ U8 *p) bool Perl_is_utf8_upper(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_upper) PL_utf8_upper = swash_init("utf8", "IsUpper", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_upper, p); @@ -576,6 +623,8 @@ Perl_is_utf8_upper(pTHX_ U8 *p) bool Perl_is_utf8_lower(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_lower) PL_utf8_lower = swash_init("utf8", "IsLower", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_lower, p); @@ -584,6 +633,8 @@ Perl_is_utf8_lower(pTHX_ U8 *p) bool Perl_is_utf8_cntrl(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_cntrl) PL_utf8_cntrl = swash_init("utf8", "IsCntrl", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_cntrl, p); @@ -592,6 +643,8 @@ Perl_is_utf8_cntrl(pTHX_ U8 *p) bool Perl_is_utf8_graph(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_graph) PL_utf8_graph = swash_init("utf8", "IsGraph", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_graph, p); @@ -600,6 +653,8 @@ Perl_is_utf8_graph(pTHX_ U8 *p) bool Perl_is_utf8_print(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_print) PL_utf8_print = swash_init("utf8", "IsPrint", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_print, p); @@ -608,6 +663,8 @@ Perl_is_utf8_print(pTHX_ U8 *p) bool Perl_is_utf8_punct(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_punct) PL_utf8_punct = swash_init("utf8", "IsPunct", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_punct, p); @@ -616,6 +673,8 @@ Perl_is_utf8_punct(pTHX_ U8 *p) bool Perl_is_utf8_xdigit(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_xdigit) PL_utf8_xdigit = swash_init("utf8", "IsXDigit", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_xdigit, p); @@ -624,6 +683,8 @@ Perl_is_utf8_xdigit(pTHX_ U8 *p) bool Perl_is_utf8_mark(pTHX_ U8 *p) { + if (!is_utf8_char(p)) + return FALSE; if (!PL_utf8_mark) PL_utf8_mark = swash_init("utf8", "IsM", &PL_sv_undef, 0, 0); return swash_fetch(PL_utf8_mark, p); diff --git a/warnings.h b/warnings.h index 31942e1e66..a2bcaeb43e 100644 --- a/warnings.h +++ b/warnings.h @@ -16,97 +16,98 @@ #define G_WARN_ONCE 8 /* set if 'once' ever enabled */ #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF) -#define WARN_STD Nullsv -#define WARN_ALL (Nullsv+1) /* use warnings 'all' */ -#define WARN_NONE (Nullsv+2) /* no warnings 'all' */ +#define pWARN_STD Nullsv +#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */ +#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */ -#define specialWARN(x) ((x) == WARN_STD || (x) == WARN_ALL || \ - (x) == WARN_NONE) +#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \ + (x) == pWARN_NONE) #define ckDEAD(x) \ ( ! specialWARN(PL_curcop->cop_warnings) && \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1)) #define ckWARN(x) \ - ( (PL_curcop->cop_warnings != WARN_STD && \ - PL_curcop->cop_warnings != WARN_NONE && \ - (PL_curcop->cop_warnings == WARN_ALL || \ + ( (PL_curcop->cop_warnings != pWARN_STD && \ + PL_curcop->cop_warnings != pWARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_ALL || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \ - || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) ) + || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) ) #define ckWARN2(x,y) \ - ( (PL_curcop->cop_warnings != WARN_STD && \ - PL_curcop->cop_warnings != WARN_NONE && \ - (PL_curcop->cop_warnings == WARN_ALL || \ + ( (PL_curcop->cop_warnings != pWARN_STD && \ + PL_curcop->cop_warnings != pWARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_ALL || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \ - || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) ) + || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) ) #define ckWARN_d(x) \ - (PL_curcop->cop_warnings == WARN_STD || \ - PL_curcop->cop_warnings == WARN_ALL || \ - (PL_curcop->cop_warnings != WARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_STD || \ + PL_curcop->cop_warnings == pWARN_ALL || \ + (PL_curcop->cop_warnings != pWARN_NONE && \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) #define ckWARN2_d(x,y) \ - (PL_curcop->cop_warnings == WARN_STD || \ - PL_curcop->cop_warnings == WARN_ALL || \ - (PL_curcop->cop_warnings != WARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_STD || \ + PL_curcop->cop_warnings == pWARN_ALL || \ + (PL_curcop->cop_warnings != pWARN_NONE && \ (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) ) -#define isLEXWARN_on (PL_curcop->cop_warnings != WARN_STD) -#define isLEXWARN_off (PL_curcop->cop_warnings == WARN_STD) +#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD) +#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD) #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) #define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) -#define WARN_CHMOD 0 -#define WARN_CLOSURE 1 -#define WARN_EXITING 2 -#define WARN_GLOB 3 -#define WARN_IO 4 -#define WARN_CLOSED 5 -#define WARN_EXEC 6 -#define WARN_NEWLINE 7 -#define WARN_PIPE 8 -#define WARN_UNOPENED 9 -#define WARN_MISC 10 -#define WARN_NUMERIC 11 -#define WARN_ONCE 12 -#define WARN_OVERFLOW 13 -#define WARN_PACK 14 -#define WARN_PORTABLE 15 -#define WARN_RECURSION 16 -#define WARN_REDEFINE 17 -#define WARN_REGEXP 18 -#define WARN_SEVERE 19 -#define WARN_DEBUGGING 20 -#define WARN_INPLACE 21 -#define WARN_INTERNAL 22 -#define WARN_MALLOC 23 -#define WARN_SIGNAL 24 -#define WARN_SUBSTR 25 -#define WARN_SYNTAX 26 -#define WARN_AMBIGUOUS 27 -#define WARN_BAREWORD 28 -#define WARN_DEPRECATED 29 -#define WARN_DIGIT 30 -#define WARN_PARENTHESIS 31 -#define WARN_PRECEDENCE 32 -#define WARN_PRINTF 33 -#define WARN_PROTOTYPE 34 -#define WARN_QW 35 -#define WARN_RESERVED 36 -#define WARN_SEMICOLON 37 -#define WARN_TAINT 38 -#define WARN_UMASK 39 -#define WARN_UNINITIALIZED 40 -#define WARN_UNPACK 41 -#define WARN_UNTIE 42 -#define WARN_UTF8 43 -#define WARN_VOID 44 -#define WARN_Y2K 45 +#define WARN_ALL 0 +#define WARN_CHMOD 1 +#define WARN_CLOSURE 2 +#define WARN_EXITING 3 +#define WARN_GLOB 4 +#define WARN_IO 5 +#define WARN_CLOSED 6 +#define WARN_EXEC 7 +#define WARN_NEWLINE 8 +#define WARN_PIPE 9 +#define WARN_UNOPENED 10 +#define WARN_MISC 11 +#define WARN_NUMERIC 12 +#define WARN_ONCE 13 +#define WARN_OVERFLOW 14 +#define WARN_PACK 15 +#define WARN_PORTABLE 16 +#define WARN_RECURSION 17 +#define WARN_REDEFINE 18 +#define WARN_REGEXP 19 +#define WARN_SEVERE 20 +#define WARN_DEBUGGING 21 +#define WARN_INPLACE 22 +#define WARN_INTERNAL 23 +#define WARN_MALLOC 24 +#define WARN_SIGNAL 25 +#define WARN_SUBSTR 26 +#define WARN_SYNTAX 27 +#define WARN_AMBIGUOUS 28 +#define WARN_BAREWORD 29 +#define WARN_DEPRECATED 30 +#define WARN_DIGIT 31 +#define WARN_PARENTHESIS 32 +#define WARN_PRECEDENCE 33 +#define WARN_PRINTF 34 +#define WARN_PROTOTYPE 35 +#define WARN_QW 36 +#define WARN_RESERVED 37 +#define WARN_SEMICOLON 38 +#define WARN_TAINT 39 +#define WARN_UMASK 40 +#define WARN_UNINITIALIZED 41 +#define WARN_UNPACK 42 +#define WARN_UNTIE 43 +#define WARN_UTF8 44 +#define WARN_VOID 45 +#define WARN_Y2K 46 #define WARNsize 12 #define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125" diff --git a/warnings.pl b/warnings.pl index 0952305b28..61602d5608 100644 --- a/warnings.pl +++ b/warnings.pl @@ -9,6 +9,8 @@ sub DEFAULT_ON () { 1 } sub DEFAULT_OFF () { 2 } my $tree = { + +'all' => { 'io' => { 'pipe' => DEFAULT_OFF, 'unopened' => DEFAULT_OFF, 'closed' => DEFAULT_OFF, @@ -56,7 +58,8 @@ my $tree = { 'pack' => DEFAULT_OFF, 'unpack' => DEFAULT_OFF, #'default' => DEFAULT_ON, - } ; + } +} ; ########################################################################### @@ -70,7 +73,7 @@ sub tab { my %list ; my %Value ; -my $index = 0 ; +my $index ; sub walk { @@ -161,7 +164,7 @@ sub mkHex if (@ARGV && $ARGV[0] eq "tree") { - print " all -+\n" ; + #print " all -+\n" ; printTree($tree, " ", 4) ; exit ; } @@ -190,56 +193,59 @@ print WARN <<'EOM' ; #define G_WARN_ONCE 8 /* set if 'once' ever enabled */ #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF) -#define WARN_STD Nullsv -#define WARN_ALL (Nullsv+1) /* use warnings 'all' */ -#define WARN_NONE (Nullsv+2) /* no warnings 'all' */ +#define pWARN_STD Nullsv +#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */ +#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */ -#define specialWARN(x) ((x) == WARN_STD || (x) == WARN_ALL || \ - (x) == WARN_NONE) +#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \ + (x) == pWARN_NONE) #define ckDEAD(x) \ ( ! specialWARN(PL_curcop->cop_warnings) && \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1)) #define ckWARN(x) \ - ( (PL_curcop->cop_warnings != WARN_STD && \ - PL_curcop->cop_warnings != WARN_NONE && \ - (PL_curcop->cop_warnings == WARN_ALL || \ + ( (PL_curcop->cop_warnings != pWARN_STD && \ + PL_curcop->cop_warnings != pWARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_ALL || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \ - || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) ) + || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) ) #define ckWARN2(x,y) \ - ( (PL_curcop->cop_warnings != WARN_STD && \ - PL_curcop->cop_warnings != WARN_NONE && \ - (PL_curcop->cop_warnings == WARN_ALL || \ + ( (PL_curcop->cop_warnings != pWARN_STD && \ + PL_curcop->cop_warnings != pWARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_ALL || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \ - || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) ) + || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) ) #define ckWARN_d(x) \ - (PL_curcop->cop_warnings == WARN_STD || \ - PL_curcop->cop_warnings == WARN_ALL || \ - (PL_curcop->cop_warnings != WARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_STD || \ + PL_curcop->cop_warnings == pWARN_ALL || \ + (PL_curcop->cop_warnings != pWARN_NONE && \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) #define ckWARN2_d(x,y) \ - (PL_curcop->cop_warnings == WARN_STD || \ - PL_curcop->cop_warnings == WARN_ALL || \ - (PL_curcop->cop_warnings != WARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_STD || \ + PL_curcop->cop_warnings == pWARN_ALL || \ + (PL_curcop->cop_warnings != pWARN_NONE && \ (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) ) -#define isLEXWARN_on (PL_curcop->cop_warnings != WARN_STD) -#define isLEXWARN_off (PL_curcop->cop_warnings == WARN_STD) +#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD) +#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD) #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) #define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) EOM +my $offset = 0 ; + +$index = $offset ; +#@{ $list{"all"} } = walk ($tree) ; +walk ($tree) ; -$index = 0 ; -@{ $list{"all"} } = walk ($tree) ; $index *= 2 ; my $warn_size = int($index / 8) + ($index % 8 != 0) ; @@ -268,7 +274,19 @@ while (<DATA>) { print PM $_ ; } -$list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ; +#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ; + +#my %Keys = map {lc $Value{$_}, $_} keys %Value ; + +print PM "%Offsets = (\n" ; +foreach my $k (sort { $a <=> $b } keys %Value) { + my $v = lc $Value{$k} ; + $k *= 2 ; + print PM tab(4, " '$v'"), "=> $k,\n" ; +} + +print PM " );\n\n" ; + print PM "%Bits = (\n" ; foreach $k (sort keys %list) { @@ -296,7 +314,9 @@ foreach $k (sort keys %list) { } print PM " );\n\n" ; -print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ; +print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ; +print PM '$LAST_BIT = ' . "$index ;\n" ; +print PM '$BYTES = ' . "$warn_size ;\n" ; while (<DATA>) { print PM $_ ; } @@ -323,7 +343,12 @@ warnings - Perl pragma to control optional warnings use warnings "all"; no warnings "all"; - if (warnings::enabled("void") { + use warnings::register; + if (warnings::enabled()) { + warnings::warn("some warning"); + } + + if (warnings::enabled("void")) { warnings::warn("void", "some warning"); } @@ -332,23 +357,33 @@ warnings - Perl pragma to control optional warnings If no import list is supplied, all possible warnings are either enabled or disabled. -Two functions are provided to assist module authors. +A number of functions are provided to assist module authors. =over 4 -=item warnings::enabled($category) +=item use warnings::register + +Creates a new warnings category which has the same name as the module +where the call to the pragma is used. + +=item warnings::enabled([$category]) -Returns TRUE if the warnings category in C<$category> is enabled in the -calling module. Otherwise returns FALSE. +Returns TRUE if the warnings category C<$category> is enabled in the +calling module. Otherwise returns FALSE. +If the parameter, C<$category>, isn't supplied, the current package name +will be used. -=item warnings::warn($category, $message) +=item warnings::warn([$category,] $message) If the calling module has I<not> set C<$category> to "FATAL", print C<$message> to STDERR. If the calling module has set C<$category> to "FATAL", print C<$message> STDERR then die. +If the parameter, C<$category>, isn't supplied, the current package name +will be used. + =back See L<perlmod/Pragmatic Modules> and L<perllexwarn>. @@ -359,6 +394,8 @@ use Carp ; KEYWORDS +$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; + sub bits { my $mask ; my $catmask ; @@ -367,12 +404,12 @@ sub bits { if ($word eq 'FATAL') { $fatal = 1; } - else { - if ($catmask = $Bits{$word}) { - $mask |= $catmask ; - $mask |= $DeadBits{$word} if $fatal ; - } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; } + else + { croak("unknown warnings category '$word'")} } return $mask ; @@ -385,38 +422,70 @@ sub import { sub unimport { shift; - ${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ; + my $mask = ${^WARNING_BITS} ; + if (vec($mask, $Offsets{'all'}, 1)) { + $mask = $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ; } sub enabled { - # If no parameters, check for any lexical warnings enabled - # in the users scope. + croak("Usage: warnings::enabled([category])") + unless @_ == 1 || @_ == 0 ; + local $Carp::CarpLevel = 1 ; + my $category ; + my $offset ; my $callers_bitmask = (caller(1))[9] ; - return ($callers_bitmask ne $NONE) if @_ == 0 ; - - # otherwise check for the category supplied. - my $category = shift ; - return 0 - unless $Bits{$category} ; return 0 unless defined $callers_bitmask ; - return 1 - if ($callers_bitmask & $Bits{$category}) ne $NONE ; - - return 0 ; + + + if (@_) { + # check the category supplied. + $category = shift ; + $offset = $Offsets{$category}; + croak("unknown warnings category '$category'") + unless defined $offset; + } + else { + $category = (caller(0))[0] ; + $offset = $Offsets{$category}; + croak("package '$category' not registered for warnings") + unless defined $offset ; + } + + return vec($callers_bitmask, $offset, 1) || + vec($callers_bitmask, $Offsets{'all'}, 1) ; } + sub warn { - croak "Usage: warnings::warn('category', 'message')" - unless @_ == 2 ; - my $category = shift ; - my $message = shift ; + croak("Usage: warnings::warn([category,] 'message')") + unless @_ == 2 || @_ == 1 ; local $Carp::CarpLevel = 1 ; + my $category ; + my $offset ; my $callers_bitmask = (caller(1))[9] ; + + if (@_ == 2) { + $category = shift ; + $offset = $Offsets{$category}; + croak("unknown warnings category '$category'") + unless defined $offset ; + } + else { + $category = (caller(0))[0] ; + $offset = $Offsets{$category}; + croak("package '$category' not registered for warnings") + unless defined $offset ; + } + + my $message = shift ; croak($message) - if defined $callers_bitmask && - ($callers_bitmask & $DeadBits{$category}) ne $NONE ; + if vec($callers_bitmask, $offset+1, 1) || + vec($callers_bitmask, $Offsets{'all'}+1, 1) ; carp($message) ; } |