| 1 | #!/usr/bin/perl
|
|---|
| 2 |
|
|---|
| 3 | $VERSION = '1.02_02';
|
|---|
| 4 |
|
|---|
| 5 | BEGIN {
|
|---|
| 6 | push @INC, './lib';
|
|---|
| 7 | }
|
|---|
| 8 | use strict ;
|
|---|
| 9 |
|
|---|
| 10 | sub DEFAULT_ON () { 1 }
|
|---|
| 11 | sub DEFAULT_OFF () { 2 }
|
|---|
| 12 |
|
|---|
| 13 | my $tree = {
|
|---|
| 14 |
|
|---|
| 15 | 'all' => [ 5.008, {
|
|---|
| 16 | 'io' => [ 5.008, {
|
|---|
| 17 | 'pipe' => [ 5.008, DEFAULT_OFF],
|
|---|
| 18 | 'unopened' => [ 5.008, DEFAULT_OFF],
|
|---|
| 19 | 'closed' => [ 5.008, DEFAULT_OFF],
|
|---|
| 20 | 'newline' => [ 5.008, DEFAULT_OFF],
|
|---|
| 21 | 'exec' => [ 5.008, DEFAULT_OFF],
|
|---|
| 22 | 'layer' => [ 5.008, DEFAULT_OFF],
|
|---|
| 23 | }],
|
|---|
| 24 | 'syntax' => [ 5.008, {
|
|---|
| 25 | 'ambiguous' => [ 5.008, DEFAULT_OFF],
|
|---|
| 26 | 'semicolon' => [ 5.008, DEFAULT_OFF],
|
|---|
| 27 | 'precedence' => [ 5.008, DEFAULT_OFF],
|
|---|
| 28 | 'bareword' => [ 5.008, DEFAULT_OFF],
|
|---|
| 29 | 'reserved' => [ 5.008, DEFAULT_OFF],
|
|---|
| 30 | 'digit' => [ 5.008, DEFAULT_OFF],
|
|---|
| 31 | 'parenthesis' => [ 5.008, DEFAULT_OFF],
|
|---|
| 32 | 'printf' => [ 5.008, DEFAULT_OFF],
|
|---|
| 33 | 'prototype' => [ 5.008, DEFAULT_OFF],
|
|---|
| 34 | 'qw' => [ 5.008, DEFAULT_OFF],
|
|---|
| 35 | }],
|
|---|
| 36 | 'severe' => [ 5.008, {
|
|---|
| 37 | 'inplace' => [ 5.008, DEFAULT_ON],
|
|---|
| 38 | 'internal' => [ 5.008, DEFAULT_ON],
|
|---|
| 39 | 'debugging' => [ 5.008, DEFAULT_ON],
|
|---|
| 40 | 'malloc' => [ 5.008, DEFAULT_ON],
|
|---|
| 41 | }],
|
|---|
| 42 | 'deprecated' => [ 5.008, DEFAULT_OFF],
|
|---|
| 43 | 'void' => [ 5.008, DEFAULT_OFF],
|
|---|
| 44 | 'recursion' => [ 5.008, DEFAULT_OFF],
|
|---|
| 45 | 'redefine' => [ 5.008, DEFAULT_OFF],
|
|---|
| 46 | 'numeric' => [ 5.008, DEFAULT_OFF],
|
|---|
| 47 | 'uninitialized' => [ 5.008, DEFAULT_OFF],
|
|---|
| 48 | 'once' => [ 5.008, DEFAULT_OFF],
|
|---|
| 49 | 'misc' => [ 5.008, DEFAULT_OFF],
|
|---|
| 50 | 'regexp' => [ 5.008, DEFAULT_OFF],
|
|---|
| 51 | 'glob' => [ 5.008, DEFAULT_OFF],
|
|---|
| 52 | 'y2k' => [ 5.008, DEFAULT_OFF],
|
|---|
| 53 | 'untie' => [ 5.008, DEFAULT_OFF],
|
|---|
| 54 | 'substr' => [ 5.008, DEFAULT_OFF],
|
|---|
| 55 | 'taint' => [ 5.008, DEFAULT_OFF],
|
|---|
| 56 | 'signal' => [ 5.008, DEFAULT_OFF],
|
|---|
| 57 | 'closure' => [ 5.008, DEFAULT_OFF],
|
|---|
| 58 | 'overflow' => [ 5.008, DEFAULT_OFF],
|
|---|
| 59 | 'portable' => [ 5.008, DEFAULT_OFF],
|
|---|
| 60 | 'utf8' => [ 5.008, DEFAULT_OFF],
|
|---|
| 61 | 'exiting' => [ 5.008, DEFAULT_OFF],
|
|---|
| 62 | 'pack' => [ 5.008, DEFAULT_OFF],
|
|---|
| 63 | 'unpack' => [ 5.008, DEFAULT_OFF],
|
|---|
| 64 | 'threads' => [ 5.008, DEFAULT_OFF],
|
|---|
| 65 | #'default' => [ 5.008, DEFAULT_ON ],
|
|---|
| 66 | }],
|
|---|
| 67 | } ;
|
|---|
| 68 |
|
|---|
| 69 | ###########################################################################
|
|---|
| 70 | sub tab {
|
|---|
| 71 | my($l, $t) = @_;
|
|---|
| 72 | $t .= "\t" x ($l - (length($t) + 1) / 8);
|
|---|
| 73 | $t;
|
|---|
| 74 | }
|
|---|
| 75 |
|
|---|
| 76 | ###########################################################################
|
|---|
| 77 |
|
|---|
| 78 | my %list ;
|
|---|
| 79 | my %Value ;
|
|---|
| 80 | my %ValueToName ;
|
|---|
| 81 | my %NameToValue ;
|
|---|
| 82 | my $index ;
|
|---|
| 83 |
|
|---|
| 84 | my %v_list = () ;
|
|---|
| 85 |
|
|---|
| 86 | sub valueWalk
|
|---|
| 87 | {
|
|---|
| 88 | my $tre = shift ;
|
|---|
| 89 | my @list = () ;
|
|---|
| 90 | my ($k, $v) ;
|
|---|
| 91 |
|
|---|
| 92 | foreach $k (sort keys %$tre) {
|
|---|
| 93 | $v = $tre->{$k};
|
|---|
| 94 | die "duplicate key $k\n" if defined $list{$k} ;
|
|---|
| 95 | die "Value associated with key '$k' is not an ARRAY reference"
|
|---|
| 96 | if !ref $v || ref $v ne 'ARRAY' ;
|
|---|
| 97 |
|
|---|
| 98 | my ($ver, $rest) = @{ $v } ;
|
|---|
| 99 | push @{ $v_list{$ver} }, $k;
|
|---|
| 100 |
|
|---|
| 101 | if (ref $rest)
|
|---|
| 102 | { valueWalk ($rest) }
|
|---|
| 103 |
|
|---|
| 104 | }
|
|---|
| 105 |
|
|---|
| 106 | }
|
|---|
| 107 |
|
|---|
| 108 | sub orderValues
|
|---|
| 109 | {
|
|---|
| 110 | my $index = 0;
|
|---|
| 111 | foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
|
|---|
| 112 | foreach my $name (@{ $v_list{$ver} } ) {
|
|---|
| 113 | $ValueToName{ $index } = [ uc $name, $ver ] ;
|
|---|
| 114 | $NameToValue{ uc $name } = $index ++ ;
|
|---|
| 115 | }
|
|---|
| 116 | }
|
|---|
| 117 |
|
|---|
| 118 | return $index ;
|
|---|
| 119 | }
|
|---|
| 120 |
|
|---|
| 121 | ###########################################################################
|
|---|
| 122 |
|
|---|
| 123 | sub walk
|
|---|
| 124 | {
|
|---|
| 125 | my $tre = shift ;
|
|---|
| 126 | my @list = () ;
|
|---|
| 127 | my ($k, $v) ;
|
|---|
| 128 |
|
|---|
| 129 | foreach $k (sort keys %$tre) {
|
|---|
| 130 | $v = $tre->{$k};
|
|---|
| 131 | die "duplicate key $k\n" if defined $list{$k} ;
|
|---|
| 132 | #$Value{$index} = uc $k ;
|
|---|
| 133 | die "Can't find key '$k'"
|
|---|
| 134 | if ! defined $NameToValue{uc $k} ;
|
|---|
| 135 | push @{ $list{$k} }, $NameToValue{uc $k} ;
|
|---|
| 136 | die "Value associated with key '$k' is not an ARRAY reference"
|
|---|
| 137 | if !ref $v || ref $v ne 'ARRAY' ;
|
|---|
| 138 |
|
|---|
| 139 | my ($ver, $rest) = @{ $v } ;
|
|---|
| 140 | if (ref $rest)
|
|---|
| 141 | { push (@{ $list{$k} }, walk ($rest)) }
|
|---|
| 142 |
|
|---|
| 143 | push @list, @{ $list{$k} } ;
|
|---|
| 144 | }
|
|---|
| 145 |
|
|---|
| 146 | return @list ;
|
|---|
| 147 | }
|
|---|
| 148 |
|
|---|
| 149 | ###########################################################################
|
|---|
| 150 |
|
|---|
| 151 | sub mkRange
|
|---|
| 152 | {
|
|---|
| 153 | my @a = @_ ;
|
|---|
| 154 | my @out = @a ;
|
|---|
| 155 | my $i ;
|
|---|
| 156 |
|
|---|
| 157 |
|
|---|
| 158 | for ($i = 1 ; $i < @a; ++ $i) {
|
|---|
| 159 | $out[$i] = ".."
|
|---|
| 160 | if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
|
|---|
| 161 | }
|
|---|
| 162 |
|
|---|
| 163 | my $out = join(",",@out);
|
|---|
| 164 |
|
|---|
| 165 | $out =~ s/,(\.\.,)+/../g ;
|
|---|
| 166 | return $out;
|
|---|
| 167 | }
|
|---|
| 168 |
|
|---|
| 169 | ###########################################################################
|
|---|
| 170 | sub printTree
|
|---|
| 171 | {
|
|---|
| 172 | my $tre = shift ;
|
|---|
| 173 | my $prefix = shift ;
|
|---|
| 174 | my ($k, $v) ;
|
|---|
| 175 |
|
|---|
| 176 | my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
|
|---|
| 177 | my @keys = sort keys %$tre ;
|
|---|
| 178 |
|
|---|
| 179 | while ($k = shift @keys) {
|
|---|
| 180 | $v = $tre->{$k};
|
|---|
| 181 | die "Value associated with key '$k' is not an ARRAY reference"
|
|---|
| 182 | if !ref $v || ref $v ne 'ARRAY' ;
|
|---|
| 183 |
|
|---|
| 184 | my $offset ;
|
|---|
| 185 | if ($tre ne $tree) {
|
|---|
| 186 | print $prefix . "|\n" ;
|
|---|
| 187 | print $prefix . "+- $k" ;
|
|---|
| 188 | $offset = ' ' x ($max + 4) ;
|
|---|
| 189 | }
|
|---|
| 190 | else {
|
|---|
| 191 | print $prefix . "$k" ;
|
|---|
| 192 | $offset = ' ' x ($max + 1) ;
|
|---|
| 193 | }
|
|---|
| 194 |
|
|---|
| 195 | my ($ver, $rest) = @{ $v } ;
|
|---|
| 196 | if (ref $rest)
|
|---|
| 197 | {
|
|---|
| 198 | my $bar = @keys ? "|" : " ";
|
|---|
| 199 | print " -" . "-" x ($max - length $k ) . "+\n" ;
|
|---|
| 200 | printTree ($rest, $prefix . $bar . $offset )
|
|---|
| 201 | }
|
|---|
| 202 | else
|
|---|
| 203 | { print "\n" }
|
|---|
| 204 | }
|
|---|
| 205 |
|
|---|
| 206 | }
|
|---|
| 207 |
|
|---|
| 208 | ###########################################################################
|
|---|
| 209 |
|
|---|
| 210 | sub mkHexOct
|
|---|
| 211 | {
|
|---|
| 212 | my ($f, $max, @a) = @_ ;
|
|---|
| 213 | my $mask = "\x00" x $max ;
|
|---|
| 214 | my $string = "" ;
|
|---|
| 215 |
|
|---|
| 216 | foreach (@a) {
|
|---|
| 217 | vec($mask, $_, 1) = 1 ;
|
|---|
| 218 | }
|
|---|
| 219 |
|
|---|
| 220 | foreach (unpack("C*", $mask)) {
|
|---|
| 221 | if ($f eq 'x') {
|
|---|
| 222 | $string .= '\x' . sprintf("%2.2x", $_)
|
|---|
| 223 | }
|
|---|
| 224 | else {
|
|---|
| 225 | $string .= '\\' . sprintf("%o", $_)
|
|---|
| 226 | }
|
|---|
| 227 | }
|
|---|
| 228 | return $string ;
|
|---|
| 229 | }
|
|---|
| 230 |
|
|---|
| 231 | sub mkHex
|
|---|
| 232 | {
|
|---|
| 233 | my($max, @a) = @_;
|
|---|
| 234 | return mkHexOct("x", $max, @a);
|
|---|
| 235 | }
|
|---|
| 236 |
|
|---|
| 237 | sub mkOct
|
|---|
| 238 | {
|
|---|
| 239 | my($max, @a) = @_;
|
|---|
| 240 | return mkHexOct("o", $max, @a);
|
|---|
| 241 | }
|
|---|
| 242 |
|
|---|
| 243 | ###########################################################################
|
|---|
| 244 |
|
|---|
| 245 | if (@ARGV && $ARGV[0] eq "tree")
|
|---|
| 246 | {
|
|---|
| 247 | printTree($tree, " ") ;
|
|---|
| 248 | exit ;
|
|---|
| 249 | }
|
|---|
| 250 |
|
|---|
| 251 | unlink "warnings.h";
|
|---|
| 252 | unlink "lib/warnings.pm";
|
|---|
| 253 | open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
|
|---|
| 254 | binmode WARN;
|
|---|
| 255 | open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
|
|---|
| 256 | binmode PM;
|
|---|
| 257 |
|
|---|
| 258 | print WARN <<'EOM' ;
|
|---|
| 259 | /* -*- buffer-read-only: t -*-
|
|---|
| 260 | !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
|
|---|
| 261 | This file is built by warnings.pl
|
|---|
| 262 | Any changes made here will be lost!
|
|---|
| 263 | */
|
|---|
| 264 |
|
|---|
| 265 |
|
|---|
| 266 | #define Off(x) ((x) / 8)
|
|---|
| 267 | #define Bit(x) (1 << ((x) % 8))
|
|---|
| 268 | #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
|
|---|
| 269 |
|
|---|
| 270 |
|
|---|
| 271 | #define G_WARN_OFF 0 /* $^W == 0 */
|
|---|
| 272 | #define G_WARN_ON 1 /* -w flag and $^W != 0 */
|
|---|
| 273 | #define G_WARN_ALL_ON 2 /* -W flag */
|
|---|
| 274 | #define G_WARN_ALL_OFF 4 /* -X flag */
|
|---|
| 275 | #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
|
|---|
| 276 | #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
|
|---|
| 277 |
|
|---|
| 278 | #define pWARN_STD Nullsv
|
|---|
| 279 | #define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
|
|---|
| 280 | #define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
|
|---|
| 281 |
|
|---|
| 282 | #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
|
|---|
| 283 | (x) == pWARN_NONE)
|
|---|
| 284 | EOM
|
|---|
| 285 |
|
|---|
| 286 | my $offset = 0 ;
|
|---|
| 287 |
|
|---|
| 288 | $index = $offset ;
|
|---|
| 289 | #@{ $list{"all"} } = walk ($tree) ;
|
|---|
| 290 | valueWalk ($tree) ;
|
|---|
| 291 | my $index = orderValues();
|
|---|
| 292 |
|
|---|
| 293 | die <<EOM if $index > 255 ;
|
|---|
| 294 | Too many warnings categories -- max is 255
|
|---|
| 295 | rewrite packWARN* & unpackWARN* macros
|
|---|
| 296 | EOM
|
|---|
| 297 |
|
|---|
| 298 | walk ($tree) ;
|
|---|
| 299 |
|
|---|
| 300 | $index *= 2 ;
|
|---|
| 301 | my $warn_size = int($index / 8) + ($index % 8 != 0) ;
|
|---|
| 302 |
|
|---|
| 303 | my $k ;
|
|---|
| 304 | my $last_ver = 0;
|
|---|
| 305 | foreach $k (sort { $a <=> $b } keys %ValueToName) {
|
|---|
| 306 | my ($name, $version) = @{ $ValueToName{$k} };
|
|---|
| 307 | print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
|
|---|
| 308 | if $last_ver != $version ;
|
|---|
| 309 | print WARN tab(5, "#define WARN_$name"), "$k\n" ;
|
|---|
| 310 | $last_ver = $version ;
|
|---|
| 311 | }
|
|---|
| 312 | print WARN "\n" ;
|
|---|
| 313 |
|
|---|
| 314 | print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
|
|---|
| 315 | #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
|
|---|
| 316 | print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
|
|---|
| 317 | print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
|
|---|
| 318 | my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
|
|---|
| 319 |
|
|---|
| 320 | print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
|
|---|
| 321 |
|
|---|
| 322 | print WARN <<'EOM';
|
|---|
| 323 |
|
|---|
| 324 | #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
|
|---|
| 325 | #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
|
|---|
| 326 | #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
|
|---|
| 327 | #define isWARN_on(c,x) (IsSet(SvPVX_const(c), 2*(x)))
|
|---|
| 328 | #define isWARNf_on(c,x) (IsSet(SvPVX_const(c), 2*(x)+1))
|
|---|
| 329 |
|
|---|
| 330 | #define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
|
|---|
| 331 | #define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
|
|---|
| 332 | #define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
|
|---|
| 333 | #define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
|
|---|
| 334 |
|
|---|
| 335 | #define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
|
|---|
| 336 | #define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
|
|---|
| 337 | #define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
|
|---|
| 338 | #define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
|
|---|
| 339 |
|
|---|
| 340 | #define packWARN(a) (a )
|
|---|
| 341 | #define packWARN2(a,b) ((a) | ((b)<<8) )
|
|---|
| 342 | #define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
|
|---|
| 343 | #define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
|
|---|
| 344 |
|
|---|
| 345 | #define unpackWARN1(x) ((x) & 0xFF)
|
|---|
| 346 | #define unpackWARN2(x) (((x) >>8) & 0xFF)
|
|---|
| 347 | #define unpackWARN3(x) (((x) >>16) & 0xFF)
|
|---|
| 348 | #define unpackWARN4(x) (((x) >>24) & 0xFF)
|
|---|
| 349 |
|
|---|
| 350 | #define ckDEAD(x) \
|
|---|
| 351 | ( ! specialWARN(PL_curcop->cop_warnings) && \
|
|---|
| 352 | ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
|
|---|
| 353 | isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
|
|---|
| 354 | isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
|
|---|
| 355 | isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
|
|---|
| 356 | isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
|
|---|
| 357 |
|
|---|
| 358 | /* end of file warnings.h */
|
|---|
| 359 | /* ex: set ro: */
|
|---|
| 360 | EOM
|
|---|
| 361 |
|
|---|
| 362 | close WARN ;
|
|---|
| 363 |
|
|---|
| 364 | while (<DATA>) {
|
|---|
| 365 | last if /^KEYWORDS$/ ;
|
|---|
| 366 | print PM $_ ;
|
|---|
| 367 | }
|
|---|
| 368 |
|
|---|
| 369 | #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
|
|---|
| 370 |
|
|---|
| 371 | $last_ver = 0;
|
|---|
| 372 | print PM "our %Offsets = (\n" ;
|
|---|
| 373 | foreach my $k (sort { $a <=> $b } keys %ValueToName) {
|
|---|
| 374 | my ($name, $version) = @{ $ValueToName{$k} };
|
|---|
| 375 | $name = lc $name;
|
|---|
| 376 | $k *= 2 ;
|
|---|
| 377 | if ( $last_ver != $version ) {
|
|---|
| 378 | print PM "\n";
|
|---|
| 379 | print PM tab(4, " # Warnings Categories added in Perl $version");
|
|---|
| 380 | print PM "\n\n";
|
|---|
| 381 | }
|
|---|
| 382 | print PM tab(4, " '$name'"), "=> $k,\n" ;
|
|---|
| 383 | $last_ver = $version;
|
|---|
| 384 | }
|
|---|
| 385 |
|
|---|
| 386 | print PM " );\n\n" ;
|
|---|
| 387 |
|
|---|
| 388 | print PM "our %Bits = (\n" ;
|
|---|
| 389 | foreach $k (sort keys %list) {
|
|---|
| 390 |
|
|---|
| 391 | my $v = $list{$k} ;
|
|---|
| 392 | my @list = sort { $a <=> $b } @$v ;
|
|---|
| 393 |
|
|---|
| 394 | print PM tab(4, " '$k'"), '=> "',
|
|---|
| 395 | # mkHex($warn_size, @list),
|
|---|
| 396 | mkHex($warn_size, map $_ * 2 , @list),
|
|---|
| 397 | '", # [', mkRange(@list), "]\n" ;
|
|---|
| 398 | }
|
|---|
| 399 |
|
|---|
| 400 | print PM " );\n\n" ;
|
|---|
| 401 |
|
|---|
| 402 | print PM "our %DeadBits = (\n" ;
|
|---|
| 403 | foreach $k (sort keys %list) {
|
|---|
| 404 |
|
|---|
| 405 | my $v = $list{$k} ;
|
|---|
| 406 | my @list = sort { $a <=> $b } @$v ;
|
|---|
| 407 |
|
|---|
| 408 | print PM tab(4, " '$k'"), '=> "',
|
|---|
| 409 | # mkHex($warn_size, @list),
|
|---|
| 410 | mkHex($warn_size, map $_ * 2 + 1 , @list),
|
|---|
| 411 | '", # [', mkRange(@list), "]\n" ;
|
|---|
| 412 | }
|
|---|
| 413 |
|
|---|
| 414 | print PM " );\n\n" ;
|
|---|
| 415 | print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
|
|---|
| 416 | print PM '$LAST_BIT = ' . "$index ;\n" ;
|
|---|
| 417 | print PM '$BYTES = ' . "$warn_size ;\n" ;
|
|---|
| 418 | while (<DATA>) {
|
|---|
| 419 | print PM $_ ;
|
|---|
| 420 | }
|
|---|
| 421 |
|
|---|
| 422 | print PM "# ex: set ro:\n";
|
|---|
| 423 | close PM ;
|
|---|
| 424 |
|
|---|
| 425 | __END__
|
|---|
| 426 | # -*- buffer-read-only: t -*-
|
|---|
| 427 | # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
|
|---|
| 428 | # This file was created by warnings.pl
|
|---|
| 429 | # Any changes made here will be lost.
|
|---|
| 430 | #
|
|---|
| 431 |
|
|---|
| 432 | package warnings;
|
|---|
| 433 |
|
|---|
| 434 | our $VERSION = '1.05';
|
|---|
| 435 |
|
|---|
| 436 | =head1 NAME
|
|---|
| 437 |
|
|---|
| 438 | warnings - Perl pragma to control optional warnings
|
|---|
| 439 |
|
|---|
| 440 | =head1 SYNOPSIS
|
|---|
| 441 |
|
|---|
| 442 | use warnings;
|
|---|
| 443 | no warnings;
|
|---|
| 444 |
|
|---|
| 445 | use warnings "all";
|
|---|
| 446 | no warnings "all";
|
|---|
| 447 |
|
|---|
| 448 | use warnings::register;
|
|---|
| 449 | if (warnings::enabled()) {
|
|---|
| 450 | warnings::warn("some warning");
|
|---|
| 451 | }
|
|---|
| 452 |
|
|---|
| 453 | if (warnings::enabled("void")) {
|
|---|
| 454 | warnings::warn("void", "some warning");
|
|---|
| 455 | }
|
|---|
| 456 |
|
|---|
| 457 | if (warnings::enabled($object)) {
|
|---|
| 458 | warnings::warn($object, "some warning");
|
|---|
| 459 | }
|
|---|
| 460 |
|
|---|
| 461 | warnings::warnif("some warning");
|
|---|
| 462 | warnings::warnif("void", "some warning");
|
|---|
| 463 | warnings::warnif($object, "some warning");
|
|---|
| 464 |
|
|---|
| 465 | =head1 DESCRIPTION
|
|---|
| 466 |
|
|---|
| 467 | The C<warnings> pragma is a replacement for the command line flag C<-w>,
|
|---|
| 468 | but the pragma is limited to the enclosing block, while the flag is global.
|
|---|
| 469 | See L<perllexwarn> for more information.
|
|---|
| 470 |
|
|---|
| 471 | If no import list is supplied, all possible warnings are either enabled
|
|---|
| 472 | or disabled.
|
|---|
| 473 |
|
|---|
| 474 | A number of functions are provided to assist module authors.
|
|---|
| 475 |
|
|---|
| 476 | =over 4
|
|---|
| 477 |
|
|---|
| 478 | =item use warnings::register
|
|---|
| 479 |
|
|---|
| 480 | Creates a new warnings category with the same name as the package where
|
|---|
| 481 | the call to the pragma is used.
|
|---|
| 482 |
|
|---|
| 483 | =item warnings::enabled()
|
|---|
| 484 |
|
|---|
| 485 | Use the warnings category with the same name as the current package.
|
|---|
| 486 |
|
|---|
| 487 | Return TRUE if that warnings category is enabled in the calling module.
|
|---|
| 488 | Otherwise returns FALSE.
|
|---|
| 489 |
|
|---|
| 490 | =item warnings::enabled($category)
|
|---|
| 491 |
|
|---|
| 492 | Return TRUE if the warnings category, C<$category>, is enabled in the
|
|---|
| 493 | calling module.
|
|---|
| 494 | Otherwise returns FALSE.
|
|---|
| 495 |
|
|---|
| 496 | =item warnings::enabled($object)
|
|---|
| 497 |
|
|---|
| 498 | Use the name of the class for the object reference, C<$object>, as the
|
|---|
| 499 | warnings category.
|
|---|
| 500 |
|
|---|
| 501 | Return TRUE if that warnings category is enabled in the first scope
|
|---|
| 502 | where the object is used.
|
|---|
| 503 | Otherwise returns FALSE.
|
|---|
| 504 |
|
|---|
| 505 | =item warnings::warn($message)
|
|---|
| 506 |
|
|---|
| 507 | Print C<$message> to STDERR.
|
|---|
| 508 |
|
|---|
| 509 | Use the warnings category with the same name as the current package.
|
|---|
| 510 |
|
|---|
| 511 | If that warnings category has been set to "FATAL" in the calling module
|
|---|
| 512 | then die. Otherwise return.
|
|---|
| 513 |
|
|---|
| 514 | =item warnings::warn($category, $message)
|
|---|
| 515 |
|
|---|
| 516 | Print C<$message> to STDERR.
|
|---|
| 517 |
|
|---|
| 518 | If the warnings category, C<$category>, has been set to "FATAL" in the
|
|---|
| 519 | calling module then die. Otherwise return.
|
|---|
| 520 |
|
|---|
| 521 | =item warnings::warn($object, $message)
|
|---|
| 522 |
|
|---|
| 523 | Print C<$message> to STDERR.
|
|---|
| 524 |
|
|---|
| 525 | Use the name of the class for the object reference, C<$object>, as the
|
|---|
| 526 | warnings category.
|
|---|
| 527 |
|
|---|
| 528 | If that warnings category has been set to "FATAL" in the scope where C<$object>
|
|---|
| 529 | is first used then die. Otherwise return.
|
|---|
| 530 |
|
|---|
| 531 |
|
|---|
| 532 | =item warnings::warnif($message)
|
|---|
| 533 |
|
|---|
| 534 | Equivalent to:
|
|---|
| 535 |
|
|---|
| 536 | if (warnings::enabled())
|
|---|
| 537 | { warnings::warn($message) }
|
|---|
| 538 |
|
|---|
| 539 | =item warnings::warnif($category, $message)
|
|---|
| 540 |
|
|---|
| 541 | Equivalent to:
|
|---|
| 542 |
|
|---|
| 543 | if (warnings::enabled($category))
|
|---|
| 544 | { warnings::warn($category, $message) }
|
|---|
| 545 |
|
|---|
| 546 | =item warnings::warnif($object, $message)
|
|---|
| 547 |
|
|---|
| 548 | Equivalent to:
|
|---|
| 549 |
|
|---|
| 550 | if (warnings::enabled($object))
|
|---|
| 551 | { warnings::warn($object, $message) }
|
|---|
| 552 |
|
|---|
| 553 | =back
|
|---|
| 554 |
|
|---|
| 555 | See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
|
|---|
| 556 |
|
|---|
| 557 | =cut
|
|---|
| 558 |
|
|---|
| 559 | use Carp ();
|
|---|
| 560 |
|
|---|
| 561 | KEYWORDS
|
|---|
| 562 |
|
|---|
| 563 | $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
|
|---|
| 564 |
|
|---|
| 565 | sub Croaker
|
|---|
| 566 | {
|
|---|
| 567 | local $Carp::CarpInternal{'warnings'};
|
|---|
| 568 | delete $Carp::CarpInternal{'warnings'};
|
|---|
| 569 | Carp::croak(@_);
|
|---|
| 570 | }
|
|---|
| 571 |
|
|---|
| 572 | sub bits
|
|---|
| 573 | {
|
|---|
| 574 | # called from B::Deparse.pm
|
|---|
| 575 |
|
|---|
| 576 | push @_, 'all' unless @_;
|
|---|
| 577 |
|
|---|
| 578 | my $mask;
|
|---|
| 579 | my $catmask ;
|
|---|
| 580 | my $fatal = 0 ;
|
|---|
| 581 | my $no_fatal = 0 ;
|
|---|
| 582 |
|
|---|
| 583 | foreach my $word ( @_ ) {
|
|---|
| 584 | if ($word eq 'FATAL') {
|
|---|
| 585 | $fatal = 1;
|
|---|
| 586 | $no_fatal = 0;
|
|---|
| 587 | }
|
|---|
| 588 | elsif ($word eq 'NONFATAL') {
|
|---|
| 589 | $fatal = 0;
|
|---|
| 590 | $no_fatal = 1;
|
|---|
| 591 | }
|
|---|
| 592 | elsif ($catmask = $Bits{$word}) {
|
|---|
| 593 | $mask |= $catmask ;
|
|---|
| 594 | $mask |= $DeadBits{$word} if $fatal ;
|
|---|
| 595 | $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
|
|---|
| 596 | }
|
|---|
| 597 | else
|
|---|
| 598 | { Croaker("Unknown warnings category '$word'")}
|
|---|
| 599 | }
|
|---|
| 600 |
|
|---|
| 601 | return $mask ;
|
|---|
| 602 | }
|
|---|
| 603 |
|
|---|
| 604 | sub import
|
|---|
| 605 | {
|
|---|
| 606 | shift;
|
|---|
| 607 |
|
|---|
| 608 | my $catmask ;
|
|---|
| 609 | my $fatal = 0 ;
|
|---|
| 610 | my $no_fatal = 0 ;
|
|---|
| 611 |
|
|---|
| 612 | my $mask = ${^WARNING_BITS} ;
|
|---|
| 613 |
|
|---|
| 614 | if (vec($mask, $Offsets{'all'}, 1)) {
|
|---|
| 615 | $mask |= $Bits{'all'} ;
|
|---|
| 616 | $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
|
|---|
| 617 | }
|
|---|
| 618 |
|
|---|
| 619 | push @_, 'all' unless @_;
|
|---|
| 620 |
|
|---|
| 621 | foreach my $word ( @_ ) {
|
|---|
| 622 | if ($word eq 'FATAL') {
|
|---|
| 623 | $fatal = 1;
|
|---|
| 624 | $no_fatal = 0;
|
|---|
| 625 | }
|
|---|
| 626 | elsif ($word eq 'NONFATAL') {
|
|---|
| 627 | $fatal = 0;
|
|---|
| 628 | $no_fatal = 1;
|
|---|
| 629 | }
|
|---|
| 630 | elsif ($catmask = $Bits{$word}) {
|
|---|
| 631 | $mask |= $catmask ;
|
|---|
| 632 | $mask |= $DeadBits{$word} if $fatal ;
|
|---|
| 633 | $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
|
|---|
| 634 | }
|
|---|
| 635 | else
|
|---|
| 636 | { Croaker("Unknown warnings category '$word'")}
|
|---|
| 637 | }
|
|---|
| 638 |
|
|---|
| 639 | ${^WARNING_BITS} = $mask ;
|
|---|
| 640 | }
|
|---|
| 641 |
|
|---|
| 642 | sub unimport
|
|---|
| 643 | {
|
|---|
| 644 | shift;
|
|---|
| 645 |
|
|---|
| 646 | my $catmask ;
|
|---|
| 647 | my $mask = ${^WARNING_BITS} ;
|
|---|
| 648 |
|
|---|
| 649 | if (vec($mask, $Offsets{'all'}, 1)) {
|
|---|
| 650 | $mask |= $Bits{'all'} ;
|
|---|
| 651 | $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
|
|---|
| 652 | }
|
|---|
| 653 |
|
|---|
| 654 | push @_, 'all' unless @_;
|
|---|
| 655 |
|
|---|
| 656 | foreach my $word ( @_ ) {
|
|---|
| 657 | if ($word eq 'FATAL') {
|
|---|
| 658 | next;
|
|---|
| 659 | }
|
|---|
| 660 | elsif ($catmask = $Bits{$word}) {
|
|---|
| 661 | $mask &= ~($catmask | $DeadBits{$word} | $All);
|
|---|
| 662 | }
|
|---|
| 663 | else
|
|---|
| 664 | { Croaker("Unknown warnings category '$word'")}
|
|---|
| 665 | }
|
|---|
| 666 |
|
|---|
| 667 | ${^WARNING_BITS} = $mask ;
|
|---|
| 668 | }
|
|---|
| 669 |
|
|---|
| 670 | my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
|
|---|
| 671 |
|
|---|
| 672 | sub __chk
|
|---|
| 673 | {
|
|---|
| 674 | my $category ;
|
|---|
| 675 | my $offset ;
|
|---|
| 676 | my $isobj = 0 ;
|
|---|
| 677 |
|
|---|
| 678 | if (@_) {
|
|---|
| 679 | # check the category supplied.
|
|---|
| 680 | $category = shift ;
|
|---|
| 681 | if (my $type = ref $category) {
|
|---|
| 682 | Croaker("not an object")
|
|---|
| 683 | if exists $builtin_type{$type};
|
|---|
| 684 | $category = $type;
|
|---|
| 685 | $isobj = 1 ;
|
|---|
| 686 | }
|
|---|
| 687 | $offset = $Offsets{$category};
|
|---|
| 688 | Croaker("Unknown warnings category '$category'")
|
|---|
| 689 | unless defined $offset;
|
|---|
| 690 | }
|
|---|
| 691 | else {
|
|---|
| 692 | $category = (caller(1))[0] ;
|
|---|
| 693 | $offset = $Offsets{$category};
|
|---|
| 694 | Croaker("package '$category' not registered for warnings")
|
|---|
| 695 | unless defined $offset ;
|
|---|
| 696 | }
|
|---|
| 697 |
|
|---|
| 698 | my $this_pkg = (caller(1))[0] ;
|
|---|
| 699 | my $i = 2 ;
|
|---|
| 700 | my $pkg ;
|
|---|
| 701 |
|
|---|
| 702 | if ($isobj) {
|
|---|
| 703 | while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
|
|---|
| 704 | last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
|
|---|
| 705 | }
|
|---|
| 706 | $i -= 2 ;
|
|---|
| 707 | }
|
|---|
| 708 | else {
|
|---|
| 709 | for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
|
|---|
| 710 | last if $pkg ne $this_pkg ;
|
|---|
| 711 | }
|
|---|
| 712 | $i = 2
|
|---|
| 713 | if !$pkg || $pkg eq $this_pkg ;
|
|---|
| 714 | }
|
|---|
| 715 |
|
|---|
| 716 | my $callers_bitmask = (caller($i))[9] ;
|
|---|
| 717 | return ($callers_bitmask, $offset, $i) ;
|
|---|
| 718 | }
|
|---|
| 719 |
|
|---|
| 720 | sub enabled
|
|---|
| 721 | {
|
|---|
| 722 | Croaker("Usage: warnings::enabled([category])")
|
|---|
| 723 | unless @_ == 1 || @_ == 0 ;
|
|---|
| 724 |
|
|---|
| 725 | my ($callers_bitmask, $offset, $i) = __chk(@_) ;
|
|---|
| 726 |
|
|---|
| 727 | return 0 unless defined $callers_bitmask ;
|
|---|
| 728 | return vec($callers_bitmask, $offset, 1) ||
|
|---|
| 729 | vec($callers_bitmask, $Offsets{'all'}, 1) ;
|
|---|
| 730 | }
|
|---|
| 731 |
|
|---|
| 732 |
|
|---|
| 733 | sub warn
|
|---|
| 734 | {
|
|---|
| 735 | Croaker("Usage: warnings::warn([category,] 'message')")
|
|---|
| 736 | unless @_ == 2 || @_ == 1 ;
|
|---|
| 737 |
|
|---|
| 738 | my $message = pop ;
|
|---|
| 739 | my ($callers_bitmask, $offset, $i) = __chk(@_) ;
|
|---|
| 740 | Carp::croak($message)
|
|---|
| 741 | if vec($callers_bitmask, $offset+1, 1) ||
|
|---|
| 742 | vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
|
|---|
| 743 | Carp::carp($message) ;
|
|---|
| 744 | }
|
|---|
| 745 |
|
|---|
| 746 | sub warnif
|
|---|
| 747 | {
|
|---|
| 748 | Croaker("Usage: warnings::warnif([category,] 'message')")
|
|---|
| 749 | unless @_ == 2 || @_ == 1 ;
|
|---|
| 750 |
|
|---|
| 751 | my $message = pop ;
|
|---|
| 752 | my ($callers_bitmask, $offset, $i) = __chk(@_) ;
|
|---|
| 753 |
|
|---|
| 754 | return
|
|---|
| 755 | unless defined $callers_bitmask &&
|
|---|
| 756 | (vec($callers_bitmask, $offset, 1) ||
|
|---|
| 757 | vec($callers_bitmask, $Offsets{'all'}, 1)) ;
|
|---|
| 758 |
|
|---|
| 759 | Carp::croak($message)
|
|---|
| 760 | if vec($callers_bitmask, $offset+1, 1) ||
|
|---|
| 761 | vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
|
|---|
| 762 |
|
|---|
| 763 | Carp::carp($message) ;
|
|---|
| 764 | }
|
|---|
| 765 |
|
|---|
| 766 | 1;
|
|---|
