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 'assertions' => [ 5.009, DEFAULT_OFF],
67 #'default' => [ 5.008, DEFAULT_ON ],
71 ###########################################################################
74 $t .= "\t" x ($l - (length($t) + 1) / 8);
78 ###########################################################################
94 foreach $k (sort keys %$tre) {
96 die "duplicate key $k\n" if defined $list{$k} ;
97 die "Value associated with key '$k' is not an ARRAY reference"
98 if !ref $v || ref $v ne 'ARRAY' ;
100 my ($ver, $rest) = @{ $v } ;
101 push @{ $v_list{$ver} }, $k;
104 { valueWalk ($rest) }
113 foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
114 foreach my $name (@{ $v_list{$ver} } ) {
115 $ValueToName{ $index } = [ uc $name, $ver ] ;
116 $NameToValue{ uc $name } = $index ++ ;
123 ###########################################################################
131 foreach $k (sort keys %$tre) {
133 die "duplicate key $k\n" if defined $list{$k} ;
134 #$Value{$index} = uc $k ;
135 die "Can't find key '$k'"
136 if ! defined $NameToValue{uc $k} ;
137 push @{ $list{$k} }, $NameToValue{uc $k} ;
138 die "Value associated with key '$k' is not an ARRAY reference"
139 if !ref $v || ref $v ne 'ARRAY' ;
141 my ($ver, $rest) = @{ $v } ;
143 { push (@{ $list{$k} }, walk ($rest)) }
145 push @list, @{ $list{$k} } ;
151 ###########################################################################
160 for ($i = 1 ; $i < @a; ++ $i) {
162 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
165 my $out = join(",",@out);
167 $out =~ s/,(\.\.,)+/../g ;
171 ###########################################################################
178 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
179 my @keys = sort keys %$tre ;
181 while ($k = shift @keys) {
183 die "Value associated with key '$k' is not an ARRAY reference"
184 if !ref $v || ref $v ne 'ARRAY' ;
188 print $prefix . "|\n" ;
189 print $prefix . "+- $k" ;
190 $offset = ' ' x ($max + 4) ;
193 print $prefix . "$k" ;
194 $offset = ' ' x ($max + 1) ;
197 my ($ver, $rest) = @{ $v } ;
200 my $bar = @keys ? "|" : " ";
201 print " -" . "-" x ($max - length $k ) . "+\n" ;
202 printTree ($rest, $prefix . $bar . $offset )
210 ###########################################################################
214 my ($f, $max, @a) = @_ ;
215 my $mask = "\x00" x $max ;
219 vec($mask, $_, 1) = 1 ;
222 foreach (unpack("C*", $mask)) {
224 $string .= '\x' . sprintf("%2.2x", $_)
227 $string .= '\\' . sprintf("%o", $_)
236 return mkHexOct("x", $max, @a);
242 return mkHexOct("o", $max, @a);
245 ###########################################################################
247 if (@ARGV && $ARGV[0] eq "tree")
249 printTree($tree, " ") ;
254 unlink "lib/warnings.pm";
255 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
257 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
261 /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
262 This file is built by warnings.pl
263 Any changes made here will be lost!
267 #define Off(x) ((x) / 8)
268 #define Bit(x) (1 << ((x) % 8))
269 #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
272 #define G_WARN_OFF 0 /* $^W == 0 */
273 #define G_WARN_ON 1 /* -w flag and $^W != 0 */
274 #define G_WARN_ALL_ON 2 /* -W flag */
275 #define G_WARN_ALL_OFF 4 /* -X flag */
276 #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
277 #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
279 #define pWARN_STD Nullsv
280 #define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
281 #define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
283 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
290 #@{ $list{"all"} } = walk ($tree) ;
292 my $index = orderValues();
294 die <<EOM if $index > 255 ;
295 Too many warnings categories -- max is 255
296 rewrite packWARN* & unpackWARN* macros
302 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
306 foreach $k (sort { $a <=> $b } keys %ValueToName) {
307 my ($name, $version) = @{ $ValueToName{$k} };
308 print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
309 if $last_ver != $version ;
310 print WARN tab(5, "#define WARN_$name"), "$k\n" ;
311 $last_ver = $version ;
315 print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
316 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
317 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
318 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
319 my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
321 print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
325 #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
326 #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
327 #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
328 #define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
329 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
332 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
333 (PL_curcop->cop_warnings == pWARN_ALL || \
334 isWARN_on(PL_curcop->cop_warnings, x) ) ) \
335 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
337 #define ckWARN2(x,y) \
338 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
339 (PL_curcop->cop_warnings == pWARN_ALL || \
340 isWARN_on(PL_curcop->cop_warnings, x) || \
341 isWARN_on(PL_curcop->cop_warnings, y) ) ) \
342 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
344 #define ckWARN3(x,y,z) \
345 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
346 (PL_curcop->cop_warnings == pWARN_ALL || \
347 isWARN_on(PL_curcop->cop_warnings, x) || \
348 isWARN_on(PL_curcop->cop_warnings, y) || \
349 isWARN_on(PL_curcop->cop_warnings, z) ) ) \
350 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
352 #define ckWARN4(x,y,z,t) \
353 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
354 (PL_curcop->cop_warnings == pWARN_ALL || \
355 isWARN_on(PL_curcop->cop_warnings, x) || \
356 isWARN_on(PL_curcop->cop_warnings, y) || \
357 isWARN_on(PL_curcop->cop_warnings, z) || \
358 isWARN_on(PL_curcop->cop_warnings, t) ) ) \
359 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
361 #define ckWARN_d(x) \
362 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
363 (PL_curcop->cop_warnings != pWARN_NONE && \
364 isWARN_on(PL_curcop->cop_warnings, x) ) )
366 #define ckWARN2_d(x,y) \
367 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
368 (PL_curcop->cop_warnings != pWARN_NONE && \
369 (isWARN_on(PL_curcop->cop_warnings, x) || \
370 isWARN_on(PL_curcop->cop_warnings, y) ) ) )
372 #define ckWARN3_d(x,y,z) \
373 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
374 (PL_curcop->cop_warnings != pWARN_NONE && \
375 (isWARN_on(PL_curcop->cop_warnings, x) || \
376 isWARN_on(PL_curcop->cop_warnings, y) || \
377 isWARN_on(PL_curcop->cop_warnings, z) ) ) )
379 #define ckWARN4_d(x,y,z,t) \
380 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
381 (PL_curcop->cop_warnings != pWARN_NONE && \
382 (isWARN_on(PL_curcop->cop_warnings, x) || \
383 isWARN_on(PL_curcop->cop_warnings, y) || \
384 isWARN_on(PL_curcop->cop_warnings, z) || \
385 isWARN_on(PL_curcop->cop_warnings, t) ) ) )
387 #define packWARN(a) (a )
388 #define packWARN2(a,b) ((a) | (b)<<8 )
389 #define packWARN3(a,b,c) ((a) | (b)<<8 | (c) <<16 )
390 #define packWARN4(a,b,c,d) ((a) | (b)<<8 | (c) <<16 | (d) <<24)
392 #define unpackWARN1(x) ((x) & 0xFF)
393 #define unpackWARN2(x) (((x) >>8) & 0xFF)
394 #define unpackWARN3(x) (((x) >>16) & 0xFF)
395 #define unpackWARN4(x) (((x) >>24) & 0xFF)
398 ( ! specialWARN(PL_curcop->cop_warnings) && \
399 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
400 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
401 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
402 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
403 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
405 /* end of file warnings.h */
412 last if /^KEYWORDS$/ ;
416 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
419 print PM "our %Offsets = (\n" ;
420 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
421 my ($name, $version) = @{ $ValueToName{$k} };
424 if ( $last_ver != $version ) {
426 print PM tab(4, " # Warnings Categories added in Perl $version");
429 print PM tab(4, " '$name'"), "=> $k,\n" ;
430 $last_ver = $version;
435 print PM "our %Bits = (\n" ;
436 foreach $k (sort keys %list) {
439 my @list = sort { $a <=> $b } @$v ;
441 print PM tab(4, " '$k'"), '=> "',
442 # mkHex($warn_size, @list),
443 mkHex($warn_size, map $_ * 2 , @list),
444 '", # [', mkRange(@list), "]\n" ;
449 print PM "our %DeadBits = (\n" ;
450 foreach $k (sort keys %list) {
453 my @list = sort { $a <=> $b } @$v ;
455 print PM tab(4, " '$k'"), '=> "',
456 # mkHex($warn_size, @list),
457 mkHex($warn_size, map $_ * 2 + 1 , @list),
458 '", # [', mkRange(@list), "]\n" ;
462 print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
463 print PM '$LAST_BIT = ' . "$index ;\n" ;
464 print PM '$BYTES = ' . "$warn_size ;\n" ;
473 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
474 # This file was created by warnings.pl
475 # Any changes made here will be lost.
480 our $VERSION = '1.04';
484 warnings - Perl pragma to control optional warnings
494 use warnings::register;
495 if (warnings::enabled()) {
496 warnings::warn("some warning");
499 if (warnings::enabled("void")) {
500 warnings::warn("void", "some warning");
503 if (warnings::enabled($object)) {
504 warnings::warn($object, "some warning");
507 warnings::warnif("some warning");
508 warnings::warnif("void", "some warning");
509 warnings::warnif($object, "some warning");
513 The C<warnings> pragma is a replacement for the command line flag C<-w>,
514 but the pragma is limited to the enclosing block, while the flag is global.
515 See L<perllexwarn> for more information.
517 If no import list is supplied, all possible warnings are either enabled
520 A number of functions are provided to assist module authors.
524 =item use warnings::register
526 Creates a new warnings category with the same name as the package where
527 the call to the pragma is used.
529 =item warnings::enabled()
531 Use the warnings category with the same name as the current package.
533 Return TRUE if that warnings category is enabled in the calling module.
534 Otherwise returns FALSE.
536 =item warnings::enabled($category)
538 Return TRUE if the warnings category, C<$category>, is enabled in the
540 Otherwise returns FALSE.
542 =item warnings::enabled($object)
544 Use the name of the class for the object reference, C<$object>, as the
547 Return TRUE if that warnings category is enabled in the first scope
548 where the object is used.
549 Otherwise returns FALSE.
551 =item warnings::warn($message)
553 Print C<$message> to STDERR.
555 Use the warnings category with the same name as the current package.
557 If that warnings category has been set to "FATAL" in the calling module
558 then die. Otherwise return.
560 =item warnings::warn($category, $message)
562 Print C<$message> to STDERR.
564 If the warnings category, C<$category>, has been set to "FATAL" in the
565 calling module then die. Otherwise return.
567 =item warnings::warn($object, $message)
569 Print C<$message> to STDERR.
571 Use the name of the class for the object reference, C<$object>, as the
574 If that warnings category has been set to "FATAL" in the scope where C<$object>
575 is first used then die. Otherwise return.
578 =item warnings::warnif($message)
582 if (warnings::enabled())
583 { warnings::warn($message) }
585 =item warnings::warnif($category, $message)
589 if (warnings::enabled($category))
590 { warnings::warn($category, $message) }
592 =item warnings::warnif($object, $message)
596 if (warnings::enabled($object))
597 { warnings::warn($object, $message) }
601 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
607 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
612 delete $Carp::CarpInternal{'warnings'};
618 # called from B::Deparse.pm
620 push @_, 'all' unless @_;
627 foreach my $word ( @_ ) {
628 if ($word eq 'FATAL') {
632 elsif ($word eq 'NONFATAL') {
636 elsif ($catmask = $Bits{$word}) {
638 $mask |= $DeadBits{$word} if $fatal ;
639 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
642 { Croaker("Unknown warnings category '$word'")}
656 my $mask = ${^WARNING_BITS} ;
658 if (vec($mask, $Offsets{'all'}, 1)) {
659 $mask |= $Bits{'all'} ;
660 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
663 push @_, 'all' unless @_;
665 foreach my $word ( @_ ) {
666 if ($word eq 'FATAL') {
670 elsif ($word eq 'NONFATAL') {
674 elsif ($catmask = $Bits{$word}) {
676 $mask |= $DeadBits{$word} if $fatal ;
677 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
680 { Croaker("Unknown warnings category '$word'")}
683 ${^WARNING_BITS} = $mask ;
691 my $mask = ${^WARNING_BITS} ;
693 if (vec($mask, $Offsets{'all'}, 1)) {
694 $mask |= $Bits{'all'} ;
695 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
698 push @_, 'all' unless @_;
700 foreach my $word ( @_ ) {
701 if ($word eq 'FATAL') {
704 elsif ($catmask = $Bits{$word}) {
705 $mask &= ~($catmask | $DeadBits{$word} | $All);
708 { Croaker("Unknown warnings category '$word'")}
711 ${^WARNING_BITS} = $mask ;
714 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
723 # check the category supplied.
725 if (my $type = ref $category) {
726 Croaker("not an object")
727 if exists $builtin_type{$type};
731 $offset = $Offsets{$category};
732 Croaker("Unknown warnings category '$category'")
733 unless defined $offset;
736 $category = (caller(1))[0] ;
737 $offset = $Offsets{$category};
738 Croaker("package '$category' not registered for warnings")
739 unless defined $offset ;
742 my $this_pkg = (caller(1))[0] ;
747 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
748 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
753 $i = _error_loc(); # see where Carp will allocate the error
756 my $callers_bitmask = (caller($i))[9] ;
757 return ($callers_bitmask, $offset, $i) ;
762 goto &Carp::short_error_loc; # don't introduce another stack frame
767 Croaker("Usage: warnings::enabled([category])")
768 unless @_ == 1 || @_ == 0 ;
770 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
772 return 0 unless defined $callers_bitmask ;
773 return vec($callers_bitmask, $offset, 1) ||
774 vec($callers_bitmask, $Offsets{'all'}, 1) ;
780 Croaker("Usage: warnings::warn([category,] 'message')")
781 unless @_ == 2 || @_ == 1 ;
784 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
786 Carp::croak($message)
787 if vec($callers_bitmask, $offset+1, 1) ||
788 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
789 Carp::carp($message) ;
794 Croaker("Usage: warnings::warnif([category,] 'message')")
795 unless @_ == 2 || @_ == 1 ;
798 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
801 unless defined $callers_bitmask &&
802 (vec($callers_bitmask, $offset, 1) ||
803 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
806 Carp::croak($message)
807 if vec($callers_bitmask, $offset+1, 1) ||
808 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
810 Carp::carp($message) ;