X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=warnings.pl;h=99671756357e578500a8714941f41d4e83cd7cfc;hb=c0e1089ae3d29de8c9817373e1b7f36eaf9a9cd8;hp=75778a159b3b7ac941a7739f481d2230465d839d;hpb=388759296cc69a19099065bacd8fc616910d1c3d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/warnings.pl b/warnings.pl index 75778a1..9967175 100644 --- a/warnings.pl +++ b/warnings.pl @@ -1,7 +1,6 @@ #!/usr/bin/perl - -$VERSION = '1.00'; +$VERSION = '1.02'; BEGIN { push @INC, './lib'; @@ -50,7 +49,6 @@ my $tree = { 'misc' => [ 5.008, DEFAULT_OFF], 'regexp' => [ 5.008, DEFAULT_OFF], 'glob' => [ 5.008, DEFAULT_OFF], - 'y2k' => [ 5.008, DEFAULT_OFF], 'untie' => [ 5.008, DEFAULT_OFF], 'substr' => [ 5.008, DEFAULT_OFF], 'taint' => [ 5.008, DEFAULT_OFF], @@ -63,6 +61,8 @@ my $tree = { 'pack' => [ 5.008, DEFAULT_OFF], 'unpack' => [ 5.008, DEFAULT_OFF], 'threads' => [ 5.008, DEFAULT_OFF], + 'assertions' => [ 5.009, DEFAULT_OFF], + #'default' => [ 5.008, DEFAULT_ON ], }], } ; @@ -252,10 +252,13 @@ if (@ARGV && $ARGV[0] eq "tree") unlink "warnings.h"; unlink "lib/warnings.pm"; open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n"; +binmode WARN; open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n"; +binmode PM; print WARN <<'EOM' ; -/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +/* -*- buffer-read-only: t -*- + !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by warnings.pl Any changes made here will be lost! */ @@ -322,8 +325,8 @@ print WARN <<'EOM'; #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 isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1)) +#define isWARN_on(c,x) (IsSet(SvPVX_const(c), 2*(x))) +#define isWARNf_on(c,x) (IsSet(SvPVX_const(c), 2*(x)+1)) #define ckWARN(x) \ ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \ @@ -400,7 +403,7 @@ print WARN <<'EOM'; isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x)))) /* end of file warnings.h */ - +/* ex: set ro: */ EOM close WARN ; @@ -413,7 +416,7 @@ while () { #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ; $last_ver = 0; -print PM "%Offsets = (\n" ; +print PM "our %Offsets = (\n" ; foreach my $k (sort { $a <=> $b } keys %ValueToName) { my ($name, $version) = @{ $ValueToName{$k} }; $name = lc $name; @@ -429,7 +432,7 @@ foreach my $k (sort { $a <=> $b } keys %ValueToName) { print PM " );\n\n" ; -print PM "%Bits = (\n" ; +print PM "our %Bits = (\n" ; foreach $k (sort keys %list) { my $v = $list{$k} ; @@ -443,7 +446,7 @@ foreach $k (sort keys %list) { print PM " );\n\n" ; -print PM "%DeadBits = (\n" ; +print PM "our %DeadBits = (\n" ; foreach $k (sort keys %list) { my $v = $list{$k} ; @@ -463,10 +466,11 @@ while () { print PM $_ ; } +print PM "# ex: set ro:\n"; close PM ; __END__ - +# -*- buffer-read-only: t -*- # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! # This file was created by warnings.pl # Any changes made here will be lost. @@ -474,7 +478,7 @@ __END__ package warnings; -our $VERSION = '1.00'; +our $VERSION = '1.04'; =head1 NAME @@ -507,6 +511,10 @@ warnings - Perl pragma to control optional warnings =head1 DESCRIPTION +The C pragma is a replacement for the command line flag C<-w>, +but the pragma is limited to the enclosing block, while the flag is global. +See L for more information. + If no import list is supplied, all possible warnings are either enabled or disabled. @@ -595,29 +603,41 @@ See L and L. =cut -use Carp ; - KEYWORDS $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; sub Croaker { + require Carp; delete $Carp::CarpInternal{'warnings'}; - croak @_ ; + Carp::croak(@_); } -sub bits { - my $mask ; +sub bits +{ + # called from B::Deparse.pm + + push @_, 'all' unless @_; + + my $mask; my $catmask ; my $fatal = 0 ; - foreach my $word (@_) { - if ($word eq 'FATAL') { + my $no_fatal = 0 ; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { $fatal = 1; + $no_fatal = 0; + } + elsif ($word eq 'NONFATAL') { + $fatal = 0; + $no_fatal = 1; } elsif ($catmask = $Bits{$word}) { $mask |= $catmask ; $mask |= $DeadBits{$word} if $fatal ; + $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; } else { Croaker("Unknown warnings category '$word'")} @@ -626,26 +646,74 @@ sub bits { return $mask ; } -sub import { +sub import +{ shift; + + my $catmask ; + my $fatal = 0 ; + my $no_fatal = 0 ; + 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') ; + + push @_, 'all' unless @_; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + $fatal = 1; + $no_fatal = 0; + } + elsif ($word eq 'NONFATAL') { + $fatal = 0; + $no_fatal = 1; + } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; + $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; + } + else + { Croaker("Unknown warnings category '$word'")} + } + + ${^WARNING_BITS} = $mask ; } -sub unimport { +sub unimport +{ shift; + + my $catmask ; 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('FATAL' => (@_ ? @_ : 'all')) | $All) ; + + push @_, 'all' unless @_; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + next; + } + elsif ($catmask = $Bits{$word}) { + $mask &= ~($catmask | $DeadBits{$word} | $All); + } + else + { Croaker("Unknown warnings category '$word'")} + } + + ${^WARNING_BITS} = $mask ; } +my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); + sub __chk { my $category ; @@ -655,10 +723,10 @@ sub __chk if (@_) { # check the category supplied. $category = shift ; - if (ref $category) { - Croaker ("not an object") - if $category !~ /^([^=]+)=/ ; - $category = $1 ; + if (my $type = ref $category) { + Croaker("not an object") + if exists $builtin_type{$type}; + $category = $type; $isobj = 1 ; } $offset = $Offsets{$category}; @@ -683,17 +751,18 @@ sub __chk $i -= 2 ; } else { - for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) { - last if $pkg ne $this_pkg ; - } - $i = 2 - if !$pkg || $pkg eq $this_pkg ; + $i = _error_loc(); # see where Carp will allocate the error } my $callers_bitmask = (caller($i))[9] ; return ($callers_bitmask, $offset, $i) ; } +sub _error_loc { + require Carp::Heavy; + goto &Carp::short_error_loc; # don't introduce another stack frame +} + sub enabled { Croaker("Usage: warnings::enabled([category])") @@ -714,10 +783,11 @@ sub warn my $message = pop ; my ($callers_bitmask, $offset, $i) = __chk(@_) ; - croak($message) + require Carp; + Carp::croak($message) if vec($callers_bitmask, $offset+1, 1) || vec($callers_bitmask, $Offsets{'all'}+1, 1) ; - carp($message) ; + Carp::carp($message) ; } sub warnif @@ -733,11 +803,12 @@ sub warnif (vec($callers_bitmask, $offset, 1) || vec($callers_bitmask, $Offsets{'all'}, 1)) ; - croak($message) + require Carp; + Carp::croak($message) if vec($callers_bitmask, $offset+1, 1) || vec($callers_bitmask, $Offsets{'all'}+1, 1) ; - carp($message) ; + Carp::carp($message) ; } 1;