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 || \
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((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) ? (p) \
333 : CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, char)
335 #define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
336 #define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
337 #define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
338 #define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
340 #define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
341 #define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
342 #define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
343 #define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
345 #define packWARN(a) (a )
346 #define packWARN2(a,b) ((a) | ((b)<<8) )
347 #define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
348 #define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
350 #define unpackWARN1(x) ((x) & 0xFF)
351 #define unpackWARN2(x) (((x) >>8) & 0xFF)
352 #define unpackWARN3(x) (((x) >>16) & 0xFF)
353 #define unpackWARN4(x) (((x) >>24) & 0xFF)
356 ( ! specialWARN(PL_curcop->cop_warnings) && \
357 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
358 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
359 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
360 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
361 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
363 /* end of file warnings.h */
370 last if /^KEYWORDS$/ ;
374 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
377 print PM "our %Offsets = (\n" ;
378 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
379 my ($name, $version) = @{ $ValueToName{$k} };
382 if ( $last_ver != $version ) {
384 print PM tab(4, " # Warnings Categories added in Perl $version");
387 print PM tab(4, " '$name'"), "=> $k,\n" ;
388 $last_ver = $version;
393 print PM "our %Bits = (\n" ;
394 foreach $k (sort keys %list) {
397 my @list = sort { $a <=> $b } @$v ;
399 print PM tab(4, " '$k'"), '=> "',
400 # mkHex($warn_size, @list),
401 mkHex($warn_size, map $_ * 2 , @list),
402 '", # [', mkRange(@list), "]\n" ;
407 print PM "our %DeadBits = (\n" ;
408 foreach $k (sort keys %list) {
411 my @list = sort { $a <=> $b } @$v ;
413 print PM tab(4, " '$k'"), '=> "',
414 # mkHex($warn_size, @list),
415 mkHex($warn_size, map $_ * 2 + 1 , @list),
416 '", # [', mkRange(@list), "]\n" ;
420 print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
421 print PM '$LAST_BIT = ' . "$index ;\n" ;
422 print PM '$BYTES = ' . "$warn_size ;\n" ;
427 print PM "# ex: set ro:\n";
431 # -*- buffer-read-only: t -*-
432 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
433 # This file was created by warnings.pl
434 # Any changes made here will be lost.
439 our $VERSION = '1.05';
443 warnings - Perl pragma to control optional warnings
453 use warnings::register;
454 if (warnings::enabled()) {
455 warnings::warn("some warning");
458 if (warnings::enabled("void")) {
459 warnings::warn("void", "some warning");
462 if (warnings::enabled($object)) {
463 warnings::warn($object, "some warning");
466 warnings::warnif("some warning");
467 warnings::warnif("void", "some warning");
468 warnings::warnif($object, "some warning");
472 The C<warnings> pragma is a replacement for the command line flag C<-w>,
473 but the pragma is limited to the enclosing block, while the flag is global.
474 See L<perllexwarn> for more information.
476 If no import list is supplied, all possible warnings are either enabled
479 A number of functions are provided to assist module authors.
483 =item use warnings::register
485 Creates a new warnings category with the same name as the package where
486 the call to the pragma is used.
488 =item warnings::enabled()
490 Use the warnings category with the same name as the current package.
492 Return TRUE if that warnings category is enabled in the calling module.
493 Otherwise returns FALSE.
495 =item warnings::enabled($category)
497 Return TRUE if the warnings category, C<$category>, is enabled in the
499 Otherwise returns FALSE.
501 =item warnings::enabled($object)
503 Use the name of the class for the object reference, C<$object>, as the
506 Return TRUE if that warnings category is enabled in the first scope
507 where the object is used.
508 Otherwise returns FALSE.
510 =item warnings::warn($message)
512 Print C<$message> to STDERR.
514 Use the warnings category with the same name as the current package.
516 If that warnings category has been set to "FATAL" in the calling module
517 then die. Otherwise return.
519 =item warnings::warn($category, $message)
521 Print C<$message> to STDERR.
523 If the warnings category, C<$category>, has been set to "FATAL" in the
524 calling module then die. Otherwise return.
526 =item warnings::warn($object, $message)
528 Print C<$message> to STDERR.
530 Use the name of the class for the object reference, C<$object>, as the
533 If that warnings category has been set to "FATAL" in the scope where C<$object>
534 is first used then die. Otherwise return.
537 =item warnings::warnif($message)
541 if (warnings::enabled())
542 { warnings::warn($message) }
544 =item warnings::warnif($category, $message)
548 if (warnings::enabled($category))
549 { warnings::warn($category, $message) }
551 =item warnings::warnif($object, $message)
555 if (warnings::enabled($object))
556 { warnings::warn($object, $message) }
560 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
566 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
570 require Carp::Heavy; # this initializes %CarpInternal
571 local $Carp::CarpInternal{'warnings'};
572 delete $Carp::CarpInternal{'warnings'};
578 # called from B::Deparse.pm
580 push @_, 'all' unless @_;
587 foreach my $word ( @_ ) {
588 if ($word eq 'FATAL') {
592 elsif ($word eq 'NONFATAL') {
596 elsif ($catmask = $Bits{$word}) {
598 $mask |= $DeadBits{$word} if $fatal ;
599 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
602 { Croaker("Unknown warnings category '$word'")}
616 my $mask = ${^WARNING_BITS} ;
618 if (vec($mask, $Offsets{'all'}, 1)) {
619 $mask |= $Bits{'all'} ;
620 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
623 push @_, 'all' unless @_;
625 foreach my $word ( @_ ) {
626 if ($word eq 'FATAL') {
630 elsif ($word eq 'NONFATAL') {
634 elsif ($catmask = $Bits{$word}) {
636 $mask |= $DeadBits{$word} if $fatal ;
637 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
640 { Croaker("Unknown warnings category '$word'")}
643 ${^WARNING_BITS} = $mask ;
651 my $mask = ${^WARNING_BITS} ;
653 if (vec($mask, $Offsets{'all'}, 1)) {
654 $mask |= $Bits{'all'} ;
655 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
658 push @_, 'all' unless @_;
660 foreach my $word ( @_ ) {
661 if ($word eq 'FATAL') {
664 elsif ($catmask = $Bits{$word}) {
665 $mask &= ~($catmask | $DeadBits{$word} | $All);
668 { Croaker("Unknown warnings category '$word'")}
671 ${^WARNING_BITS} = $mask ;
674 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
683 # check the category supplied.
685 if (my $type = ref $category) {
686 Croaker("not an object")
687 if exists $builtin_type{$type};
691 $offset = $Offsets{$category};
692 Croaker("Unknown warnings category '$category'")
693 unless defined $offset;
696 $category = (caller(1))[0] ;
697 $offset = $Offsets{$category};
698 Croaker("package '$category' not registered for warnings")
699 unless defined $offset ;
702 my $this_pkg = (caller(1))[0] ;
707 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
708 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
713 $i = _error_loc(); # see where Carp will allocate the error
716 my $callers_bitmask = (caller($i))[9] ;
717 return ($callers_bitmask, $offset, $i) ;
722 goto &Carp::short_error_loc; # don't introduce another stack frame
727 Croaker("Usage: warnings::enabled([category])")
728 unless @_ == 1 || @_ == 0 ;
730 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
732 return 0 unless defined $callers_bitmask ;
733 return vec($callers_bitmask, $offset, 1) ||
734 vec($callers_bitmask, $Offsets{'all'}, 1) ;
740 Croaker("Usage: warnings::warn([category,] 'message')")
741 unless @_ == 2 || @_ == 1 ;
744 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
746 Carp::croak($message)
747 if vec($callers_bitmask, $offset+1, 1) ||
748 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
749 Carp::carp($message) ;
754 Croaker("Usage: warnings::warnif([category,] 'message')")
755 unless @_ == 2 || @_ == 1 ;
758 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
761 unless defined $callers_bitmask &&
762 (vec($callers_bitmask, $offset, 1) ||
763 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
766 Carp::croak($message)
767 if vec($callers_bitmask, $offset+1, 1) ||
768 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
770 Carp::carp($message) ;