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 /* -*- buffer-read-only: t -*-
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_const(c), 2*(x)))
329 #define isWARNf_on(c,x) (IsSet(SvPVX_const(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" ;
469 print PM "# ex: set ro:\n";
473 # -*- buffer-read-only: t -*-
474 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
475 # This file was created by warnings.pl
476 # Any changes made here will be lost.
481 our $VERSION = '1.04';
485 warnings - Perl pragma to control optional warnings
495 use warnings::register;
496 if (warnings::enabled()) {
497 warnings::warn("some warning");
500 if (warnings::enabled("void")) {
501 warnings::warn("void", "some warning");
504 if (warnings::enabled($object)) {
505 warnings::warn($object, "some warning");
508 warnings::warnif("some warning");
509 warnings::warnif("void", "some warning");
510 warnings::warnif($object, "some warning");
514 The C<warnings> pragma is a replacement for the command line flag C<-w>,
515 but the pragma is limited to the enclosing block, while the flag is global.
516 See L<perllexwarn> for more information.
518 If no import list is supplied, all possible warnings are either enabled
521 A number of functions are provided to assist module authors.
525 =item use warnings::register
527 Creates a new warnings category with the same name as the package where
528 the call to the pragma is used.
530 =item warnings::enabled()
532 Use the warnings category with the same name as the current package.
534 Return TRUE if that warnings category is enabled in the calling module.
535 Otherwise returns FALSE.
537 =item warnings::enabled($category)
539 Return TRUE if the warnings category, C<$category>, is enabled in the
541 Otherwise returns FALSE.
543 =item warnings::enabled($object)
545 Use the name of the class for the object reference, C<$object>, as the
548 Return TRUE if that warnings category is enabled in the first scope
549 where the object is used.
550 Otherwise returns FALSE.
552 =item warnings::warn($message)
554 Print C<$message> to STDERR.
556 Use the warnings category with the same name as the current package.
558 If that warnings category has been set to "FATAL" in the calling module
559 then die. Otherwise return.
561 =item warnings::warn($category, $message)
563 Print C<$message> to STDERR.
565 If the warnings category, C<$category>, has been set to "FATAL" in the
566 calling module then die. Otherwise return.
568 =item warnings::warn($object, $message)
570 Print C<$message> to STDERR.
572 Use the name of the class for the object reference, C<$object>, as the
575 If that warnings category has been set to "FATAL" in the scope where C<$object>
576 is first used then die. Otherwise return.
579 =item warnings::warnif($message)
583 if (warnings::enabled())
584 { warnings::warn($message) }
586 =item warnings::warnif($category, $message)
590 if (warnings::enabled($category))
591 { warnings::warn($category, $message) }
593 =item warnings::warnif($object, $message)
597 if (warnings::enabled($object))
598 { warnings::warn($object, $message) }
602 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
608 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
613 delete $Carp::CarpInternal{'warnings'};
619 # called from B::Deparse.pm
621 push @_, 'all' unless @_;
628 foreach my $word ( @_ ) {
629 if ($word eq 'FATAL') {
633 elsif ($word eq 'NONFATAL') {
637 elsif ($catmask = $Bits{$word}) {
639 $mask |= $DeadBits{$word} if $fatal ;
640 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
643 { Croaker("Unknown warnings category '$word'")}
657 my $mask = ${^WARNING_BITS} ;
659 if (vec($mask, $Offsets{'all'}, 1)) {
660 $mask |= $Bits{'all'} ;
661 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
664 push @_, 'all' unless @_;
666 foreach my $word ( @_ ) {
667 if ($word eq 'FATAL') {
671 elsif ($word eq 'NONFATAL') {
675 elsif ($catmask = $Bits{$word}) {
677 $mask |= $DeadBits{$word} if $fatal ;
678 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
681 { Croaker("Unknown warnings category '$word'")}
684 ${^WARNING_BITS} = $mask ;
692 my $mask = ${^WARNING_BITS} ;
694 if (vec($mask, $Offsets{'all'}, 1)) {
695 $mask |= $Bits{'all'} ;
696 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
699 push @_, 'all' unless @_;
701 foreach my $word ( @_ ) {
702 if ($word eq 'FATAL') {
705 elsif ($catmask = $Bits{$word}) {
706 $mask &= ~($catmask | $DeadBits{$word} | $All);
709 { Croaker("Unknown warnings category '$word'")}
712 ${^WARNING_BITS} = $mask ;
715 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
724 # check the category supplied.
726 if (my $type = ref $category) {
727 Croaker("not an object")
728 if exists $builtin_type{$type};
732 $offset = $Offsets{$category};
733 Croaker("Unknown warnings category '$category'")
734 unless defined $offset;
737 $category = (caller(1))[0] ;
738 $offset = $Offsets{$category};
739 Croaker("package '$category' not registered for warnings")
740 unless defined $offset ;
743 my $this_pkg = (caller(1))[0] ;
748 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
749 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
754 $i = _error_loc(); # see where Carp will allocate the error
757 my $callers_bitmask = (caller($i))[9] ;
758 return ($callers_bitmask, $offset, $i) ;
763 goto &Carp::short_error_loc; # don't introduce another stack frame
768 Croaker("Usage: warnings::enabled([category])")
769 unless @_ == 1 || @_ == 0 ;
771 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
773 return 0 unless defined $callers_bitmask ;
774 return vec($callers_bitmask, $offset, 1) ||
775 vec($callers_bitmask, $Offsets{'all'}, 1) ;
781 Croaker("Usage: warnings::warn([category,] 'message')")
782 unless @_ == 2 || @_ == 1 ;
785 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
787 Carp::croak($message)
788 if vec($callers_bitmask, $offset+1, 1) ||
789 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
790 Carp::carp($message) ;
795 Croaker("Usage: warnings::warnif([category,] 'message')")
796 unless @_ == 2 || @_ == 1 ;
799 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
802 unless defined $callers_bitmask &&
803 (vec($callers_bitmask, $offset, 1) ||
804 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
807 Carp::croak($message)
808 if vec($callers_bitmask, $offset+1, 1) ||
809 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
811 Carp::carp($message) ;