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 'untie' => [ 5.008, DEFAULT_OFF],
53 'substr' => [ 5.008, DEFAULT_OFF],
54 'taint' => [ 5.008, DEFAULT_OFF],
55 'signal' => [ 5.008, DEFAULT_OFF],
56 'closure' => [ 5.008, DEFAULT_OFF],
57 'overflow' => [ 5.008, DEFAULT_OFF],
58 'portable' => [ 5.008, DEFAULT_OFF],
59 'utf8' => [ 5.008, DEFAULT_OFF],
60 'exiting' => [ 5.008, DEFAULT_OFF],
61 'pack' => [ 5.008, DEFAULT_OFF],
62 'unpack' => [ 5.008, DEFAULT_OFF],
63 'threads' => [ 5.008, DEFAULT_OFF],
64 'assertions' => [ 5.009, DEFAULT_OFF],
66 #'default' => [ 5.008, DEFAULT_ON ],
70 ###########################################################################
73 $t .= "\t" x ($l - (length($t) + 1) / 8);
77 ###########################################################################
93 foreach $k (sort keys %$tre) {
95 die "duplicate key $k\n" if defined $list{$k} ;
96 die "Value associated with key '$k' is not an ARRAY reference"
97 if !ref $v || ref $v ne 'ARRAY' ;
99 my ($ver, $rest) = @{ $v } ;
100 push @{ $v_list{$ver} }, $k;
103 { valueWalk ($rest) }
112 foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
113 foreach my $name (@{ $v_list{$ver} } ) {
114 $ValueToName{ $index } = [ uc $name, $ver ] ;
115 $NameToValue{ uc $name } = $index ++ ;
122 ###########################################################################
130 foreach $k (sort keys %$tre) {
132 die "duplicate key $k\n" if defined $list{$k} ;
133 #$Value{$index} = uc $k ;
134 die "Can't find key '$k'"
135 if ! defined $NameToValue{uc $k} ;
136 push @{ $list{$k} }, $NameToValue{uc $k} ;
137 die "Value associated with key '$k' is not an ARRAY reference"
138 if !ref $v || ref $v ne 'ARRAY' ;
140 my ($ver, $rest) = @{ $v } ;
142 { push (@{ $list{$k} }, walk ($rest)) }
144 push @list, @{ $list{$k} } ;
150 ###########################################################################
159 for ($i = 1 ; $i < @a; ++ $i) {
161 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
164 my $out = join(",",@out);
166 $out =~ s/,(\.\.,)+/../g ;
170 ###########################################################################
177 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
178 my @keys = sort keys %$tre ;
180 while ($k = shift @keys) {
182 die "Value associated with key '$k' is not an ARRAY reference"
183 if !ref $v || ref $v ne 'ARRAY' ;
187 print $prefix . "|\n" ;
188 print $prefix . "+- $k" ;
189 $offset = ' ' x ($max + 4) ;
192 print $prefix . "$k" ;
193 $offset = ' ' x ($max + 1) ;
196 my ($ver, $rest) = @{ $v } ;
199 my $bar = @keys ? "|" : " ";
200 print " -" . "-" x ($max - length $k ) . "+\n" ;
201 printTree ($rest, $prefix . $bar . $offset )
209 ###########################################################################
213 my ($f, $max, @a) = @_ ;
214 my $mask = "\x00" x $max ;
218 vec($mask, $_, 1) = 1 ;
221 foreach (unpack("C*", $mask)) {
223 $string .= '\x' . sprintf("%2.2x", $_)
226 $string .= '\\' . sprintf("%o", $_)
235 return mkHexOct("x", $max, @a);
241 return mkHexOct("o", $max, @a);
244 ###########################################################################
246 if (@ARGV && $ARGV[0] eq "tree")
248 printTree($tree, " ") ;
253 unlink "lib/warnings.pm";
254 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
256 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
260 /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
261 This file is built by warnings.pl
262 Any changes made here will be lost!
266 #define Off(x) ((x) / 8)
267 #define Bit(x) (1 << ((x) % 8))
268 #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
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)
278 #define pWARN_STD Nullsv
279 #define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
280 #define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
282 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
289 #@{ $list{"all"} } = walk ($tree) ;
291 my $index = orderValues();
293 die <<EOM if $index > 255 ;
294 Too many warnings categories -- max is 255
295 rewrite packWARN* & unpackWARN* macros
301 my $warn_size = int($index / 8) + ($index % 8 != 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 ;
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'} });
320 print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
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(c), 2*(x)))
328 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
331 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
332 (PL_curcop->cop_warnings == pWARN_ALL || \
333 isWARN_on(PL_curcop->cop_warnings, x) ) ) \
334 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
336 #define ckWARN2(x,y) \
337 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
338 (PL_curcop->cop_warnings == pWARN_ALL || \
339 isWARN_on(PL_curcop->cop_warnings, x) || \
340 isWARN_on(PL_curcop->cop_warnings, y) ) ) \
341 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
343 #define ckWARN3(x,y,z) \
344 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
345 (PL_curcop->cop_warnings == pWARN_ALL || \
346 isWARN_on(PL_curcop->cop_warnings, x) || \
347 isWARN_on(PL_curcop->cop_warnings, y) || \
348 isWARN_on(PL_curcop->cop_warnings, z) ) ) \
349 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
351 #define ckWARN4(x,y,z,t) \
352 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
353 (PL_curcop->cop_warnings == pWARN_ALL || \
354 isWARN_on(PL_curcop->cop_warnings, x) || \
355 isWARN_on(PL_curcop->cop_warnings, y) || \
356 isWARN_on(PL_curcop->cop_warnings, z) || \
357 isWARN_on(PL_curcop->cop_warnings, t) ) ) \
358 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
360 #define ckWARN_d(x) \
361 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
362 (PL_curcop->cop_warnings != pWARN_NONE && \
363 isWARN_on(PL_curcop->cop_warnings, x) ) )
365 #define ckWARN2_d(x,y) \
366 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
367 (PL_curcop->cop_warnings != pWARN_NONE && \
368 (isWARN_on(PL_curcop->cop_warnings, x) || \
369 isWARN_on(PL_curcop->cop_warnings, y) ) ) )
371 #define ckWARN3_d(x,y,z) \
372 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
373 (PL_curcop->cop_warnings != pWARN_NONE && \
374 (isWARN_on(PL_curcop->cop_warnings, x) || \
375 isWARN_on(PL_curcop->cop_warnings, y) || \
376 isWARN_on(PL_curcop->cop_warnings, z) ) ) )
378 #define ckWARN4_d(x,y,z,t) \
379 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
380 (PL_curcop->cop_warnings != pWARN_NONE && \
381 (isWARN_on(PL_curcop->cop_warnings, x) || \
382 isWARN_on(PL_curcop->cop_warnings, y) || \
383 isWARN_on(PL_curcop->cop_warnings, z) || \
384 isWARN_on(PL_curcop->cop_warnings, t) ) ) )
386 #define packWARN(a) (a )
387 #define packWARN2(a,b) ((a) | (b)<<8 )
388 #define packWARN3(a,b,c) ((a) | (b)<<8 | (c) <<16 )
389 #define packWARN4(a,b,c,d) ((a) | (b)<<8 | (c) <<16 | (d) <<24)
391 #define unpackWARN1(x) ((x) & 0xFF)
392 #define unpackWARN2(x) (((x) >>8) & 0xFF)
393 #define unpackWARN3(x) (((x) >>16) & 0xFF)
394 #define unpackWARN4(x) (((x) >>24) & 0xFF)
397 ( ! specialWARN(PL_curcop->cop_warnings) && \
398 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
399 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
400 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
401 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
402 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
404 /* end of file warnings.h */
411 last if /^KEYWORDS$/ ;
415 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
418 print PM "our %Offsets = (\n" ;
419 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
420 my ($name, $version) = @{ $ValueToName{$k} };
423 if ( $last_ver != $version ) {
425 print PM tab(4, " # Warnings Categories added in Perl $version");
428 print PM tab(4, " '$name'"), "=> $k,\n" ;
429 $last_ver = $version;
434 print PM "our %Bits = (\n" ;
435 foreach $k (sort keys %list) {
438 my @list = sort { $a <=> $b } @$v ;
440 print PM tab(4, " '$k'"), '=> "',
441 # mkHex($warn_size, @list),
442 mkHex($warn_size, map $_ * 2 , @list),
443 '", # [', mkRange(@list), "]\n" ;
448 print PM "our %DeadBits = (\n" ;
449 foreach $k (sort keys %list) {
452 my @list = sort { $a <=> $b } @$v ;
454 print PM tab(4, " '$k'"), '=> "',
455 # mkHex($warn_size, @list),
456 mkHex($warn_size, map $_ * 2 + 1 , @list),
457 '", # [', mkRange(@list), "]\n" ;
461 print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
462 print PM '$LAST_BIT = ' . "$index ;\n" ;
463 print PM '$BYTES = ' . "$warn_size ;\n" ;
472 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
473 # This file was created by warnings.pl
474 # Any changes made here will be lost.
479 our $VERSION = '1.04';
483 warnings - Perl pragma to control optional warnings
493 use warnings::register;
494 if (warnings::enabled()) {
495 warnings::warn("some warning");
498 if (warnings::enabled("void")) {
499 warnings::warn("void", "some warning");
502 if (warnings::enabled($object)) {
503 warnings::warn($object, "some warning");
506 warnings::warnif("some warning");
507 warnings::warnif("void", "some warning");
508 warnings::warnif($object, "some warning");
512 The C<warnings> pragma is a replacement for the command line flag C<-w>,
513 but the pragma is limited to the enclosing block, while the flag is global.
514 See L<perllexwarn> for more information.
516 If no import list is supplied, all possible warnings are either enabled
519 A number of functions are provided to assist module authors.
523 =item use warnings::register
525 Creates a new warnings category with the same name as the package where
526 the call to the pragma is used.
528 =item warnings::enabled()
530 Use the warnings category with the same name as the current package.
532 Return TRUE if that warnings category is enabled in the calling module.
533 Otherwise returns FALSE.
535 =item warnings::enabled($category)
537 Return TRUE if the warnings category, C<$category>, is enabled in the
539 Otherwise returns FALSE.
541 =item warnings::enabled($object)
543 Use the name of the class for the object reference, C<$object>, as the
546 Return TRUE if that warnings category is enabled in the first scope
547 where the object is used.
548 Otherwise returns FALSE.
550 =item warnings::warn($message)
552 Print C<$message> to STDERR.
554 Use the warnings category with the same name as the current package.
556 If that warnings category has been set to "FATAL" in the calling module
557 then die. Otherwise return.
559 =item warnings::warn($category, $message)
561 Print C<$message> to STDERR.
563 If the warnings category, C<$category>, has been set to "FATAL" in the
564 calling module then die. Otherwise return.
566 =item warnings::warn($object, $message)
568 Print C<$message> to STDERR.
570 Use the name of the class for the object reference, C<$object>, as the
573 If that warnings category has been set to "FATAL" in the scope where C<$object>
574 is first used then die. Otherwise return.
577 =item warnings::warnif($message)
581 if (warnings::enabled())
582 { warnings::warn($message) }
584 =item warnings::warnif($category, $message)
588 if (warnings::enabled($category))
589 { warnings::warn($category, $message) }
591 =item warnings::warnif($object, $message)
595 if (warnings::enabled($object))
596 { warnings::warn($object, $message) }
600 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
606 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
611 delete $Carp::CarpInternal{'warnings'};
617 # called from B::Deparse.pm
619 push @_, 'all' unless @_;
626 foreach my $word ( @_ ) {
627 if ($word eq 'FATAL') {
631 elsif ($word eq 'NONFATAL') {
635 elsif ($catmask = $Bits{$word}) {
637 $mask |= $DeadBits{$word} if $fatal ;
638 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
641 { Croaker("Unknown warnings category '$word'")}
655 my $mask = ${^WARNING_BITS} ;
657 if (vec($mask, $Offsets{'all'}, 1)) {
658 $mask |= $Bits{'all'} ;
659 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
662 push @_, 'all' unless @_;
664 foreach my $word ( @_ ) {
665 if ($word eq 'FATAL') {
669 elsif ($word eq 'NONFATAL') {
673 elsif ($catmask = $Bits{$word}) {
675 $mask |= $DeadBits{$word} if $fatal ;
676 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
679 { Croaker("Unknown warnings category '$word'")}
682 ${^WARNING_BITS} = $mask ;
690 my $mask = ${^WARNING_BITS} ;
692 if (vec($mask, $Offsets{'all'}, 1)) {
693 $mask |= $Bits{'all'} ;
694 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
697 push @_, 'all' unless @_;
699 foreach my $word ( @_ ) {
700 if ($word eq 'FATAL') {
703 elsif ($catmask = $Bits{$word}) {
704 $mask &= ~($catmask | $DeadBits{$word} | $All);
707 { Croaker("Unknown warnings category '$word'")}
710 ${^WARNING_BITS} = $mask ;
713 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
722 # check the category supplied.
724 if (my $type = ref $category) {
725 Croaker("not an object")
726 if exists $builtin_type{$type};
730 $offset = $Offsets{$category};
731 Croaker("Unknown warnings category '$category'")
732 unless defined $offset;
735 $category = (caller(1))[0] ;
736 $offset = $Offsets{$category};
737 Croaker("package '$category' not registered for warnings")
738 unless defined $offset ;
741 my $this_pkg = (caller(1))[0] ;
746 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
747 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
752 $i = _error_loc(); # see where Carp will allocate the error
755 my $callers_bitmask = (caller($i))[9] ;
756 return ($callers_bitmask, $offset, $i) ;
761 goto &Carp::short_error_loc; # don't introduce another stack frame
766 Croaker("Usage: warnings::enabled([category])")
767 unless @_ == 1 || @_ == 0 ;
769 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
771 return 0 unless defined $callers_bitmask ;
772 return vec($callers_bitmask, $offset, 1) ||
773 vec($callers_bitmask, $Offsets{'all'}, 1) ;
779 Croaker("Usage: warnings::warn([category,] 'message')")
780 unless @_ == 2 || @_ == 1 ;
783 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
785 Carp::croak($message)
786 if vec($callers_bitmask, $offset+1, 1) ||
787 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
788 Carp::carp($message) ;
793 Croaker("Usage: warnings::warnif([category,] 'message')")
794 unless @_ == 2 || @_ == 1 ;
797 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
800 unless defined $callers_bitmask &&
801 (vec($callers_bitmask, $offset, 1) ||
802 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
805 Carp::croak($message)
806 if vec($callers_bitmask, $offset+1, 1) ||
807 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
809 Carp::carp($message) ;