10 sub DEFAULT_ON () { 1 }
11 sub DEFAULT_OFF () { 2 }
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],
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],
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],
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 ],
69 ###########################################################################
72 $t .= "\t" x ($l - (length($t) + 1) / 8);
76 ###########################################################################
92 foreach $k (sort keys %$tre) {
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' ;
98 my ($ver, $rest) = @{ $v } ;
99 push @{ $v_list{$ver} }, $k;
102 { valueWalk ($rest) }
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 ++ ;
121 ###########################################################################
129 foreach $k (sort keys %$tre) {
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' ;
139 my ($ver, $rest) = @{ $v } ;
141 { push (@{ $list{$k} }, walk ($rest)) }
143 push @list, @{ $list{$k} } ;
149 ###########################################################################
158 for ($i = 1 ; $i < @a; ++ $i) {
160 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
163 my $out = join(",",@out);
165 $out =~ s/,(\.\.,)+/../g ;
169 ###########################################################################
176 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
177 my @keys = sort keys %$tre ;
179 while ($k = shift @keys) {
181 die "Value associated with key '$k' is not an ARRAY reference"
182 if !ref $v || ref $v ne 'ARRAY' ;
186 print $prefix . "|\n" ;
187 print $prefix . "+- $k" ;
188 $offset = ' ' x ($max + 4) ;
191 print $prefix . "$k" ;
192 $offset = ' ' x ($max + 1) ;
195 my ($ver, $rest) = @{ $v } ;
198 my $bar = @keys ? "|" : " ";
199 print " -" . "-" x ($max - length $k ) . "+\n" ;
200 printTree ($rest, $prefix . $bar . $offset )
208 ###########################################################################
212 my ($f, $max, @a) = @_ ;
213 my $mask = "\x00" x $max ;
217 vec($mask, $_, 1) = 1 ;
220 foreach (unpack("C*", $mask)) {
222 $string .= '\x' . sprintf("%2.2x", $_)
225 $string .= '\\' . sprintf("%o", $_)
234 return mkHexOct("x", $max, @a);
240 return mkHexOct("o", $max, @a);
243 ###########################################################################
245 if (@ARGV && $ARGV[0] eq "tree")
247 printTree($tree, " ") ;
252 unlink "lib/warnings.pm";
253 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
254 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
257 /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
258 This file is built by warnings.pl
259 Any changes made here will be lost!
263 #define Off(x) ((x) / 8)
264 #define Bit(x) (1 << ((x) % 8))
265 #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
268 #define G_WARN_OFF 0 /* $^W == 0 */
269 #define G_WARN_ON 1 /* -w flag and $^W != 0 */
270 #define G_WARN_ALL_ON 2 /* -W flag */
271 #define G_WARN_ALL_OFF 4 /* -X flag */
272 #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
273 #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
275 #define pWARN_STD Nullsv
276 #define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
277 #define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
279 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
286 #@{ $list{"all"} } = walk ($tree) ;
288 my $index = orderValues();
290 die <<EOM if $index > 255 ;
291 Too many warnings categories -- max is 255
292 rewrite packWARN* & unpackWARN* macros
298 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
302 foreach $k (sort { $a <=> $b } keys %ValueToName) {
303 my ($name, $version) = @{ $ValueToName{$k} };
304 print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
305 if $last_ver != $version ;
306 print WARN tab(5, "#define WARN_$name"), "$k\n" ;
307 $last_ver = $version ;
311 print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
312 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
313 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
314 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
315 my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
317 print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
321 #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
322 #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
323 #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
324 #define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
325 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
328 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
329 (PL_curcop->cop_warnings == pWARN_ALL || \
330 isWARN_on(PL_curcop->cop_warnings, x) ) ) \
331 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
333 #define ckWARN2(x,y) \
334 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
335 (PL_curcop->cop_warnings == pWARN_ALL || \
336 isWARN_on(PL_curcop->cop_warnings, x) || \
337 isWARN_on(PL_curcop->cop_warnings, y) ) ) \
338 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
340 #define ckWARN3(x,y,z) \
341 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
342 (PL_curcop->cop_warnings == pWARN_ALL || \
343 isWARN_on(PL_curcop->cop_warnings, x) || \
344 isWARN_on(PL_curcop->cop_warnings, y) || \
345 isWARN_on(PL_curcop->cop_warnings, z) ) ) \
346 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
348 #define ckWARN4(x,y,z,t) \
349 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
350 (PL_curcop->cop_warnings == pWARN_ALL || \
351 isWARN_on(PL_curcop->cop_warnings, x) || \
352 isWARN_on(PL_curcop->cop_warnings, y) || \
353 isWARN_on(PL_curcop->cop_warnings, z) || \
354 isWARN_on(PL_curcop->cop_warnings, t) ) ) \
355 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
357 #define ckWARN_d(x) \
358 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
359 (PL_curcop->cop_warnings != pWARN_NONE && \
360 isWARN_on(PL_curcop->cop_warnings, x) ) )
362 #define ckWARN2_d(x,y) \
363 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
364 (PL_curcop->cop_warnings != pWARN_NONE && \
365 (isWARN_on(PL_curcop->cop_warnings, x) || \
366 isWARN_on(PL_curcop->cop_warnings, y) ) ) )
368 #define ckWARN3_d(x,y,z) \
369 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
370 (PL_curcop->cop_warnings != pWARN_NONE && \
371 (isWARN_on(PL_curcop->cop_warnings, x) || \
372 isWARN_on(PL_curcop->cop_warnings, y) || \
373 isWARN_on(PL_curcop->cop_warnings, z) ) ) )
375 #define ckWARN4_d(x,y,z,t) \
376 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
377 (PL_curcop->cop_warnings != pWARN_NONE && \
378 (isWARN_on(PL_curcop->cop_warnings, x) || \
379 isWARN_on(PL_curcop->cop_warnings, y) || \
380 isWARN_on(PL_curcop->cop_warnings, z) || \
381 isWARN_on(PL_curcop->cop_warnings, t) ) ) )
383 #define packWARN(a) (a )
384 #define packWARN2(a,b) ((a) | (b)<<8 )
385 #define packWARN3(a,b,c) ((a) | (b)<<8 | (c) <<16 )
386 #define packWARN4(a,b,c,d) ((a) | (b)<<8 | (c) <<16 | (d) <<24)
388 #define unpackWARN1(x) ((x) & 0xFF)
389 #define unpackWARN2(x) (((x) >>8) & 0xFF)
390 #define unpackWARN3(x) (((x) >>16) & 0xFF)
391 #define unpackWARN4(x) (((x) >>24) & 0xFF)
394 ( ! specialWARN(PL_curcop->cop_warnings) && \
395 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
396 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
397 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
398 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
399 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
401 /* end of file warnings.h */
408 last if /^KEYWORDS$/ ;
412 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
415 print PM "our %Offsets = (\n" ;
416 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
417 my ($name, $version) = @{ $ValueToName{$k} };
420 if ( $last_ver != $version ) {
422 print PM tab(4, " # Warnings Categories added in Perl $version");
425 print PM tab(4, " '$name'"), "=> $k,\n" ;
426 $last_ver = $version;
431 print PM "our %Bits = (\n" ;
432 foreach $k (sort keys %list) {
435 my @list = sort { $a <=> $b } @$v ;
437 print PM tab(4, " '$k'"), '=> "',
438 # mkHex($warn_size, @list),
439 mkHex($warn_size, map $_ * 2 , @list),
440 '", # [', mkRange(@list), "]\n" ;
445 print PM "our %DeadBits = (\n" ;
446 foreach $k (sort keys %list) {
449 my @list = sort { $a <=> $b } @$v ;
451 print PM tab(4, " '$k'"), '=> "',
452 # mkHex($warn_size, @list),
453 mkHex($warn_size, map $_ * 2 + 1 , @list),
454 '", # [', mkRange(@list), "]\n" ;
458 print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
459 print PM '$LAST_BIT = ' . "$index ;\n" ;
460 print PM '$BYTES = ' . "$warn_size ;\n" ;
469 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
470 # This file was created by warnings.pl
471 # Any changes made here will be lost.
476 our $VERSION = '1.03';
480 warnings - Perl pragma to control optional warnings
490 use warnings::register;
491 if (warnings::enabled()) {
492 warnings::warn("some warning");
495 if (warnings::enabled("void")) {
496 warnings::warn("void", "some warning");
499 if (warnings::enabled($object)) {
500 warnings::warn($object, "some warning");
503 warnings::warnif("some warning");
504 warnings::warnif("void", "some warning");
505 warnings::warnif($object, "some warning");
509 The C<warnings> pragma is a replacement for the command line flag C<-w>,
510 but the pragma is limited to the enclosing block, while the flag is global.
511 See L<perllexwarn> for more information.
513 If no import list is supplied, all possible warnings are either enabled
516 A number of functions are provided to assist module authors.
520 =item use warnings::register
522 Creates a new warnings category with the same name as the package where
523 the call to the pragma is used.
525 =item warnings::enabled()
527 Use the warnings category with the same name as the current package.
529 Return TRUE if that warnings category is enabled in the calling module.
530 Otherwise returns FALSE.
532 =item warnings::enabled($category)
534 Return TRUE if the warnings category, C<$category>, is enabled in the
536 Otherwise returns FALSE.
538 =item warnings::enabled($object)
540 Use the name of the class for the object reference, C<$object>, as the
543 Return TRUE if that warnings category is enabled in the first scope
544 where the object is used.
545 Otherwise returns FALSE.
547 =item warnings::warn($message)
549 Print C<$message> to STDERR.
551 Use the warnings category with the same name as the current package.
553 If that warnings category has been set to "FATAL" in the calling module
554 then die. Otherwise return.
556 =item warnings::warn($category, $message)
558 Print C<$message> to STDERR.
560 If the warnings category, C<$category>, has been set to "FATAL" in the
561 calling module then die. Otherwise return.
563 =item warnings::warn($object, $message)
565 Print C<$message> to STDERR.
567 Use the name of the class for the object reference, C<$object>, as the
570 If that warnings category has been set to "FATAL" in the scope where C<$object>
571 is first used then die. Otherwise return.
574 =item warnings::warnif($message)
578 if (warnings::enabled())
579 { warnings::warn($message) }
581 =item warnings::warnif($category, $message)
585 if (warnings::enabled($category))
586 { warnings::warn($category, $message) }
588 =item warnings::warnif($object, $message)
592 if (warnings::enabled($object))
593 { warnings::warn($object, $message) }
597 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
605 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
609 delete $Carp::CarpInternal{'warnings'};
615 # called from B::Deparse.pm
617 push @_, 'all' unless @_;
624 foreach my $word ( @_ ) {
625 if ($word eq 'FATAL') {
629 elsif ($word eq 'NONFATAL') {
633 elsif ($catmask = $Bits{$word}) {
635 $mask |= $DeadBits{$word} if $fatal ;
636 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
639 { Croaker("Unknown warnings category '$word'")}
653 my $mask = ${^WARNING_BITS} ;
655 if (vec($mask, $Offsets{'all'}, 1)) {
656 $mask |= $Bits{'all'} ;
657 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
660 push @_, 'all' unless @_;
662 foreach my $word ( @_ ) {
663 if ($word eq 'FATAL') {
667 elsif ($word eq 'NONFATAL') {
671 elsif ($catmask = $Bits{$word}) {
673 $mask |= $DeadBits{$word} if $fatal ;
674 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
677 { Croaker("Unknown warnings category '$word'")}
680 ${^WARNING_BITS} = $mask ;
688 my $mask = ${^WARNING_BITS} ;
690 if (vec($mask, $Offsets{'all'}, 1)) {
691 $mask |= $Bits{'all'} ;
692 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
695 push @_, 'all' unless @_;
697 foreach my $word ( @_ ) {
698 if ($word eq 'FATAL') {
701 elsif ($catmask = $Bits{$word}) {
702 $mask &= ~($catmask | $DeadBits{$word} | $All);
705 { Croaker("Unknown warnings category '$word'")}
708 ${^WARNING_BITS} = $mask ;
718 # check the category supplied.
721 Croaker ("not an object")
722 if $category !~ /^([^=]+)=/ ;
726 $offset = $Offsets{$category};
727 Croaker("Unknown warnings category '$category'")
728 unless defined $offset;
731 $category = (caller(1))[0] ;
732 $offset = $Offsets{$category};
733 Croaker("package '$category' not registered for warnings")
734 unless defined $offset ;
737 my $this_pkg = (caller(1))[0] ;
742 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
743 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
748 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
749 last if $pkg ne $this_pkg ;
752 if !$pkg || $pkg eq $this_pkg ;
755 my $callers_bitmask = (caller($i))[9] ;
756 return ($callers_bitmask, $offset, $i) ;
761 Croaker("Usage: warnings::enabled([category])")
762 unless @_ == 1 || @_ == 0 ;
764 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
766 return 0 unless defined $callers_bitmask ;
767 return vec($callers_bitmask, $offset, 1) ||
768 vec($callers_bitmask, $Offsets{'all'}, 1) ;
774 Croaker("Usage: warnings::warn([category,] 'message')")
775 unless @_ == 2 || @_ == 1 ;
778 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
779 Carp::croak($message)
780 if vec($callers_bitmask, $offset+1, 1) ||
781 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
782 Carp::carp($message) ;
787 Croaker("Usage: warnings::warnif([category,] 'message')")
788 unless @_ == 2 || @_ == 1 ;
791 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
794 unless defined $callers_bitmask &&
795 (vec($callers_bitmask, $offset, 1) ||
796 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
798 Carp::croak($message)
799 if vec($callers_bitmask, $offset+1, 1) ||
800 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
802 Carp::carp($message) ;