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 NULL
280 #define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */
281 #define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */
283 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
286 /* if PL_warnhook is set to this value, then warnings die */
287 #define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
293 #@{ $list{"all"} } = walk ($tree) ;
295 my $index = orderValues();
297 die <<EOM if $index > 255 ;
298 Too many warnings categories -- max is 255
299 rewrite packWARN* & unpackWARN* macros
305 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
309 foreach $k (sort { $a <=> $b } keys %ValueToName) {
310 my ($name, $version) = @{ $ValueToName{$k} };
311 print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
312 if $last_ver != $version ;
313 print WARN tab(5, "#define WARN_$name"), "$k\n" ;
314 $last_ver = $version ;
318 print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
319 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
320 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
321 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\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((U8 *)(c + 1), 2*(x)))
329 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
331 #define DUP_WARNINGS(p) \
332 (specialWARN(p) ? (STRLEN*)(p) \
333 : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
336 #define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
337 #define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
338 #define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
339 #define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
341 #define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
342 #define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
343 #define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
344 #define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
346 #define packWARN(a) (a )
347 #define packWARN2(a,b) ((a) | ((b)<<8) )
348 #define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
349 #define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
351 #define unpackWARN1(x) ((x) & 0xFF)
352 #define unpackWARN2(x) (((x) >>8) & 0xFF)
353 #define unpackWARN3(x) (((x) >>16) & 0xFF)
354 #define unpackWARN4(x) (((x) >>24) & 0xFF)
357 ( ! specialWARN(PL_curcop->cop_warnings) && \
358 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
359 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
360 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
361 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
362 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
364 /* end of file warnings.h */
371 last if /^KEYWORDS$/ ;
375 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
378 print PM "our %Offsets = (\n" ;
379 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
380 my ($name, $version) = @{ $ValueToName{$k} };
383 if ( $last_ver != $version ) {
385 print PM tab(4, " # Warnings Categories added in Perl $version");
388 print PM tab(4, " '$name'"), "=> $k,\n" ;
389 $last_ver = $version;
394 print PM "our %Bits = (\n" ;
395 foreach $k (sort keys %list) {
398 my @list = sort { $a <=> $b } @$v ;
400 print PM tab(4, " '$k'"), '=> "',
401 # mkHex($warn_size, @list),
402 mkHex($warn_size, map $_ * 2 , @list),
403 '", # [', mkRange(@list), "]\n" ;
408 print PM "our %DeadBits = (\n" ;
409 foreach $k (sort keys %list) {
412 my @list = sort { $a <=> $b } @$v ;
414 print PM tab(4, " '$k'"), '=> "',
415 # mkHex($warn_size, @list),
416 mkHex($warn_size, map $_ * 2 + 1 , @list),
417 '", # [', mkRange(@list), "]\n" ;
421 print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
422 print PM '$LAST_BIT = ' . "$index ;\n" ;
423 print PM '$BYTES = ' . "$warn_size ;\n" ;
428 print PM "# ex: set ro:\n";
432 # -*- buffer-read-only: t -*-
433 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
434 # This file was created by warnings.pl
435 # Any changes made here will be lost.
440 our $VERSION = '1.05';
444 warnings - Perl pragma to control optional warnings
454 use warnings::register;
455 if (warnings::enabled()) {
456 warnings::warn("some warning");
459 if (warnings::enabled("void")) {
460 warnings::warn("void", "some warning");
463 if (warnings::enabled($object)) {
464 warnings::warn($object, "some warning");
467 warnings::warnif("some warning");
468 warnings::warnif("void", "some warning");
469 warnings::warnif($object, "some warning");
473 The C<warnings> pragma is a replacement for the command line flag C<-w>,
474 but the pragma is limited to the enclosing block, while the flag is global.
475 See L<perllexwarn> for more information.
477 If no import list is supplied, all possible warnings are either enabled
480 A number of functions are provided to assist module authors.
484 =item use warnings::register
486 Creates a new warnings category with the same name as the package where
487 the call to the pragma is used.
489 =item warnings::enabled()
491 Use the warnings category with the same name as the current package.
493 Return TRUE if that warnings category is enabled in the calling module.
494 Otherwise returns FALSE.
496 =item warnings::enabled($category)
498 Return TRUE if the warnings category, C<$category>, is enabled in the
500 Otherwise returns FALSE.
502 =item warnings::enabled($object)
504 Use the name of the class for the object reference, C<$object>, as the
507 Return TRUE if that warnings category is enabled in the first scope
508 where the object is used.
509 Otherwise returns FALSE.
511 =item warnings::warn($message)
513 Print C<$message> to STDERR.
515 Use the warnings category with the same name as the current package.
517 If that warnings category has been set to "FATAL" in the calling module
518 then die. Otherwise return.
520 =item warnings::warn($category, $message)
522 Print C<$message> to STDERR.
524 If the warnings category, C<$category>, has been set to "FATAL" in the
525 calling module then die. Otherwise return.
527 =item warnings::warn($object, $message)
529 Print C<$message> to STDERR.
531 Use the name of the class for the object reference, C<$object>, as the
534 If that warnings category has been set to "FATAL" in the scope where C<$object>
535 is first used then die. Otherwise return.
538 =item warnings::warnif($message)
542 if (warnings::enabled())
543 { warnings::warn($message) }
545 =item warnings::warnif($category, $message)
549 if (warnings::enabled($category))
550 { warnings::warn($category, $message) }
552 =item warnings::warnif($object, $message)
556 if (warnings::enabled($object))
557 { warnings::warn($object, $message) }
561 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
567 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
571 require Carp::Heavy; # this initializes %CarpInternal
572 local $Carp::CarpInternal{'warnings'};
573 delete $Carp::CarpInternal{'warnings'};
579 # called from B::Deparse.pm
581 push @_, 'all' unless @_;
588 foreach my $word ( @_ ) {
589 if ($word eq 'FATAL') {
593 elsif ($word eq 'NONFATAL') {
597 elsif ($catmask = $Bits{$word}) {
599 $mask |= $DeadBits{$word} if $fatal ;
600 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
603 { Croaker("Unknown warnings category '$word'")}
617 my $mask = ${^WARNING_BITS} ;
619 if (vec($mask, $Offsets{'all'}, 1)) {
620 $mask |= $Bits{'all'} ;
621 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
624 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'")}
644 ${^WARNING_BITS} = $mask ;
652 my $mask = ${^WARNING_BITS} ;
654 if (vec($mask, $Offsets{'all'}, 1)) {
655 $mask |= $Bits{'all'} ;
656 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
659 push @_, 'all' unless @_;
661 foreach my $word ( @_ ) {
662 if ($word eq 'FATAL') {
665 elsif ($catmask = $Bits{$word}) {
666 $mask &= ~($catmask | $DeadBits{$word} | $All);
669 { Croaker("Unknown warnings category '$word'")}
672 ${^WARNING_BITS} = $mask ;
675 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
684 # check the category supplied.
686 if (my $type = ref $category) {
687 Croaker("not an object")
688 if exists $builtin_type{$type};
692 $offset = $Offsets{$category};
693 Croaker("Unknown warnings category '$category'")
694 unless defined $offset;
697 $category = (caller(1))[0] ;
698 $offset = $Offsets{$category};
699 Croaker("package '$category' not registered for warnings")
700 unless defined $offset ;
703 my $this_pkg = (caller(1))[0] ;
708 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
709 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
714 $i = _error_loc(); # see where Carp will allocate the error
717 my $callers_bitmask = (caller($i))[9] ;
718 return ($callers_bitmask, $offset, $i) ;
723 goto &Carp::short_error_loc; # don't introduce another stack frame
728 Croaker("Usage: warnings::enabled([category])")
729 unless @_ == 1 || @_ == 0 ;
731 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
733 return 0 unless defined $callers_bitmask ;
734 return vec($callers_bitmask, $offset, 1) ||
735 vec($callers_bitmask, $Offsets{'all'}, 1) ;
741 Croaker("Usage: warnings::warn([category,] 'message')")
742 unless @_ == 2 || @_ == 1 ;
745 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
747 Carp::croak($message)
748 if vec($callers_bitmask, $offset+1, 1) ||
749 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
750 Carp::carp($message) ;
755 Croaker("Usage: warnings::warnif([category,] 'message')")
756 unless @_ == 2 || @_ == 1 ;
759 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
762 unless defined $callers_bitmask &&
763 (vec($callers_bitmask, $offset, 1) ||
764 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
767 Carp::croak($message)
768 if vec($callers_bitmask, $offset+1, 1) ||
769 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
771 Carp::carp($message) ;