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 'imprecision' => [ 5.011, 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.06';
442 # Verify that we're called correctly so that warnings will work.
443 # see also strict.pm.
444 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
445 my (undef, $f, $l) = caller;
446 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
451 warnings - Perl pragma to control optional warnings
461 use warnings::register;
462 if (warnings::enabled()) {
463 warnings::warn("some warning");
466 if (warnings::enabled("void")) {
467 warnings::warn("void", "some warning");
470 if (warnings::enabled($object)) {
471 warnings::warn($object, "some warning");
474 warnings::warnif("some warning");
475 warnings::warnif("void", "some warning");
476 warnings::warnif($object, "some warning");
480 The C<warnings> pragma is a replacement for the command line flag C<-w>,
481 but the pragma is limited to the enclosing block, while the flag is global.
482 See L<perllexwarn> for more information.
484 If no import list is supplied, all possible warnings are either enabled
487 A number of functions are provided to assist module authors.
491 =item use warnings::register
493 Creates a new warnings category with the same name as the package where
494 the call to the pragma is used.
496 =item warnings::enabled()
498 Use the warnings category with the same name as the current package.
500 Return TRUE if that warnings category is enabled in the calling module.
501 Otherwise returns FALSE.
503 =item warnings::enabled($category)
505 Return TRUE if the warnings category, C<$category>, is enabled in the
507 Otherwise returns FALSE.
509 =item warnings::enabled($object)
511 Use the name of the class for the object reference, C<$object>, as the
514 Return TRUE if that warnings category is enabled in the first scope
515 where the object is used.
516 Otherwise returns FALSE.
518 =item warnings::warn($message)
520 Print C<$message> to STDERR.
522 Use the warnings category with the same name as the current package.
524 If that warnings category has been set to "FATAL" in the calling module
525 then die. Otherwise return.
527 =item warnings::warn($category, $message)
529 Print C<$message> to STDERR.
531 If the warnings category, C<$category>, has been set to "FATAL" in the
532 calling module then die. Otherwise return.
534 =item warnings::warn($object, $message)
536 Print C<$message> to STDERR.
538 Use the name of the class for the object reference, C<$object>, as the
541 If that warnings category has been set to "FATAL" in the scope where C<$object>
542 is first used then die. Otherwise return.
545 =item warnings::warnif($message)
549 if (warnings::enabled())
550 { warnings::warn($message) }
552 =item warnings::warnif($category, $message)
556 if (warnings::enabled($category))
557 { warnings::warn($category, $message) }
559 =item warnings::warnif($object, $message)
563 if (warnings::enabled($object))
564 { warnings::warn($object, $message) }
568 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
574 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
578 require Carp::Heavy; # this initializes %CarpInternal
579 local $Carp::CarpInternal{'warnings'};
580 delete $Carp::CarpInternal{'warnings'};
586 # called from B::Deparse.pm
588 push @_, 'all' unless @_;
595 foreach my $word ( @_ ) {
596 if ($word eq 'FATAL') {
600 elsif ($word eq 'NONFATAL') {
604 elsif ($catmask = $Bits{$word}) {
606 $mask |= $DeadBits{$word} if $fatal ;
607 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
610 { Croaker("Unknown warnings category '$word'")}
624 my $mask = ${^WARNING_BITS} ;
626 if (vec($mask, $Offsets{'all'}, 1)) {
627 $mask |= $Bits{'all'} ;
628 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
631 push @_, 'all' unless @_;
633 foreach my $word ( @_ ) {
634 if ($word eq 'FATAL') {
638 elsif ($word eq 'NONFATAL') {
642 elsif ($catmask = $Bits{$word}) {
644 $mask |= $DeadBits{$word} if $fatal ;
645 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
648 { Croaker("Unknown warnings category '$word'")}
651 ${^WARNING_BITS} = $mask ;
659 my $mask = ${^WARNING_BITS} ;
661 if (vec($mask, $Offsets{'all'}, 1)) {
662 $mask |= $Bits{'all'} ;
663 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
666 push @_, 'all' unless @_;
668 foreach my $word ( @_ ) {
669 if ($word eq 'FATAL') {
672 elsif ($catmask = $Bits{$word}) {
673 $mask &= ~($catmask | $DeadBits{$word} | $All);
676 { Croaker("Unknown warnings category '$word'")}
679 ${^WARNING_BITS} = $mask ;
682 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
691 # check the category supplied.
693 if (my $type = ref $category) {
694 Croaker("not an object")
695 if exists $builtin_type{$type};
699 $offset = $Offsets{$category};
700 Croaker("Unknown warnings category '$category'")
701 unless defined $offset;
704 $category = (caller(1))[0] ;
705 $offset = $Offsets{$category};
706 Croaker("package '$category' not registered for warnings")
707 unless defined $offset ;
710 my $this_pkg = (caller(1))[0] ;
715 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
716 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
721 $i = _error_loc(); # see where Carp will allocate the error
724 my $callers_bitmask = (caller($i))[9] ;
725 return ($callers_bitmask, $offset, $i) ;
730 goto &Carp::short_error_loc; # don't introduce another stack frame
735 Croaker("Usage: warnings::enabled([category])")
736 unless @_ == 1 || @_ == 0 ;
738 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
740 return 0 unless defined $callers_bitmask ;
741 return vec($callers_bitmask, $offset, 1) ||
742 vec($callers_bitmask, $Offsets{'all'}, 1) ;
748 Croaker("Usage: warnings::warn([category,] 'message')")
749 unless @_ == 2 || @_ == 1 ;
752 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
754 Carp::croak($message)
755 if vec($callers_bitmask, $offset+1, 1) ||
756 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
757 Carp::carp($message) ;
762 Croaker("Usage: warnings::warnif([category,] 'message')")
763 unless @_ == 2 || @_ == 1 ;
766 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
769 unless defined $callers_bitmask &&
770 (vec($callers_bitmask, $offset, 1) ||
771 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
774 Carp::croak($message)
775 if vec($callers_bitmask, $offset+1, 1) ||
776 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
778 Carp::carp($message) ;