11 sub DEFAULT_ON () { 1 }
12 sub DEFAULT_OFF () { 2 }
17 'io' => { 'pipe' => DEFAULT_OFF,
18 'unopened' => DEFAULT_OFF,
19 'closed' => DEFAULT_OFF,
20 'newline' => DEFAULT_OFF,
21 'exec' => DEFAULT_OFF,
22 'layer' => DEFAULT_OFF,
24 'syntax' => { 'ambiguous' => DEFAULT_OFF,
25 'semicolon' => DEFAULT_OFF,
26 'precedence' => DEFAULT_OFF,
27 'bareword' => DEFAULT_OFF,
28 'reserved' => DEFAULT_OFF,
29 'digit' => DEFAULT_OFF,
30 'parenthesis' => DEFAULT_OFF,
31 'printf' => DEFAULT_OFF,
32 'prototype' => DEFAULT_OFF,
35 'severe' => { 'inplace' => DEFAULT_ON,
36 'internal' => DEFAULT_ON,
37 'debugging' => DEFAULT_ON,
38 'malloc' => DEFAULT_ON,
40 'deprecated' => DEFAULT_OFF,
41 'void' => DEFAULT_OFF,
42 'recursion' => DEFAULT_OFF,
43 'redefine' => DEFAULT_OFF,
44 'numeric' => DEFAULT_OFF,
45 'uninitialized' => DEFAULT_OFF,
46 'once' => DEFAULT_OFF,
47 'misc' => DEFAULT_OFF,
48 'regexp' => DEFAULT_OFF,
49 'glob' => DEFAULT_OFF,
51 'untie' => DEFAULT_OFF,
52 'substr' => DEFAULT_OFF,
53 'taint' => DEFAULT_OFF,
54 'signal' => DEFAULT_OFF,
55 'closure' => DEFAULT_OFF,
56 'overflow' => DEFAULT_OFF,
57 'portable' => DEFAULT_OFF,
58 'utf8' => DEFAULT_OFF,
59 'exiting' => DEFAULT_OFF,
60 'pack' => DEFAULT_OFF,
61 'unpack' => DEFAULT_OFF,
62 #'default' => DEFAULT_ON,
67 ###########################################################################
70 $t .= "\t" x ($l - (length($t) + 1) / 8);
74 ###########################################################################
86 foreach $k (sort keys %$tre) {
88 die "duplicate key $k\n" if defined $list{$k} ;
89 $Value{$index} = uc $k ;
90 push @{ $list{$k} }, $index ++ ;
92 { push (@{ $list{$k} }, walk ($v)) }
93 push @list, @{ $list{$k} } ;
99 ###########################################################################
108 for ($i = 1 ; $i < @a; ++ $i) {
110 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
113 my $out = join(",",@out);
115 $out =~ s/,(\.\.,)+/../g ;
119 ###########################################################################
127 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
129 $prefix .= " " x $indent ;
130 foreach $k (sort keys %$tre) {
132 print $prefix . "|\n" ;
133 print $prefix . "+- $k" ;
136 print " " . "-" x ($max - length $k ) . "+\n" ;
137 printTree ($v, $prefix . "|" , $max + $indent - 1)
145 ###########################################################################
149 my ($f, $max, @a) = @_ ;
150 my $mask = "\x00" x $max ;
154 vec($mask, $_, 1) = 1 ;
157 foreach (unpack("C*", $mask)) {
159 $string .= '\x' . sprintf("%2.2x", $_)
162 $string .= '\\' . sprintf("%o", $_)
171 return mkHexOct("x", $max, @a);
177 return mkHexOct("o", $max, @a);
180 ###########################################################################
182 if (@ARGV && $ARGV[0] eq "tree")
185 printTree($tree, " ", 4) ;
190 unlink "lib/warnings.pm";
191 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
192 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
195 /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
196 This file is built by warnings.pl
197 Any changes made here will be lost!
201 #define Off(x) ((x) / 8)
202 #define Bit(x) (1 << ((x) % 8))
203 #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
206 #define G_WARN_OFF 0 /* $^W == 0 */
207 #define G_WARN_ON 1 /* -w flag and $^W != 0 */
208 #define G_WARN_ALL_ON 2 /* -W flag */
209 #define G_WARN_ALL_OFF 4 /* -X flag */
210 #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
211 #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
213 #define pWARN_STD Nullsv
214 #define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
215 #define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
217 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
224 #@{ $list{"all"} } = walk ($tree) ;
227 die <<EOM if $index > 255 ;
228 Too many warnings categories -- max is 255
229 rewrite packWARN* & unpackWARN* macros
233 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
236 foreach $k (sort { $a <=> $b } keys %Value) {
237 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
241 print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
242 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
243 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
244 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
245 my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
247 print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
251 #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
252 #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
253 #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
254 #define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
255 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
258 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
259 (PL_curcop->cop_warnings == pWARN_ALL || \
260 isWARN_on(PL_curcop->cop_warnings, x) ) ) \
261 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
263 #define ckWARN2(x,y) \
264 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
265 (PL_curcop->cop_warnings == pWARN_ALL || \
266 isWARN_on(PL_curcop->cop_warnings, x) || \
267 isWARN_on(PL_curcop->cop_warnings, y) ) ) \
268 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
270 #define ckWARN3(x,y,z) \
271 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
272 (PL_curcop->cop_warnings == pWARN_ALL || \
273 isWARN_on(PL_curcop->cop_warnings, x) || \
274 isWARN_on(PL_curcop->cop_warnings, y) || \
275 isWARN_on(PL_curcop->cop_warnings, z) ) ) \
276 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
278 #define ckWARN4(x,y,z,t) \
279 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
280 (PL_curcop->cop_warnings == pWARN_ALL || \
281 isWARN_on(PL_curcop->cop_warnings, x) || \
282 isWARN_on(PL_curcop->cop_warnings, y) || \
283 isWARN_on(PL_curcop->cop_warnings, z) || \
284 isWARN_on(PL_curcop->cop_warnings, t) ) ) \
285 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
287 #define ckWARN_d(x) \
288 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
289 (PL_curcop->cop_warnings != pWARN_NONE && \
290 isWARN_on(PL_curcop->cop_warnings, x) ) )
292 #define ckWARN2_d(x,y) \
293 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
294 (PL_curcop->cop_warnings != pWARN_NONE && \
295 (isWARN_on(PL_curcop->cop_warnings, x) || \
296 isWARN_on(PL_curcop->cop_warnings, y) ) ) )
298 #define ckWARN3_d(x,y,z) \
299 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
300 (PL_curcop->cop_warnings != pWARN_NONE && \
301 (isWARN_on(PL_curcop->cop_warnings, x) || \
302 isWARN_on(PL_curcop->cop_warnings, y) || \
303 isWARN_on(PL_curcop->cop_warnings, z) ) ) )
305 #define ckWARN4_d(x,y,z,t) \
306 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
307 (PL_curcop->cop_warnings != pWARN_NONE && \
308 (isWARN_on(PL_curcop->cop_warnings, x) || \
309 isWARN_on(PL_curcop->cop_warnings, y) || \
310 isWARN_on(PL_curcop->cop_warnings, z) || \
311 isWARN_on(PL_curcop->cop_warnings, t) ) ) )
313 #define packWARN(a) (a )
314 #define packWARN2(a,b) ((a) | (b)<<8 )
315 #define packWARN3(a,b,c) ((a) | (b)<<8 | (c) <<16 )
316 #define packWARN4(a,b,c,d) ((a) | (b)<<8 | (c) <<16 | (d) <<24)
318 #define unpackWARN1(x) ((x) & 0xFF)
319 #define unpackWARN2(x) (((x) >>8) & 0xFF)
320 #define unpackWARN3(x) (((x) >>16) & 0xFF)
321 #define unpackWARN4(x) (((x) >>24) & 0xFF)
324 ( ! specialWARN(PL_curcop->cop_warnings) && \
325 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
326 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
327 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
328 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
329 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
331 /* end of file warnings.h */
338 last if /^KEYWORDS$/ ;
342 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
344 #my %Keys = map {lc $Value{$_}, $_} keys %Value ;
346 print PM "%Offsets = (\n" ;
347 foreach my $k (sort { $a <=> $b } keys %Value) {
348 my $v = lc $Value{$k} ;
350 print PM tab(4, " '$v'"), "=> $k,\n" ;
355 print PM "%Bits = (\n" ;
356 foreach $k (sort keys %list) {
359 my @list = sort { $a <=> $b } @$v ;
361 print PM tab(4, " '$k'"), '=> "',
362 # mkHex($warn_size, @list),
363 mkHex($warn_size, map $_ * 2 , @list),
364 '", # [', mkRange(@list), "]\n" ;
369 print PM "%DeadBits = (\n" ;
370 foreach $k (sort keys %list) {
373 my @list = sort { $a <=> $b } @$v ;
375 print PM tab(4, " '$k'"), '=> "',
376 # mkHex($warn_size, @list),
377 mkHex($warn_size, map $_ * 2 + 1 , @list),
378 '", # [', mkRange(@list), "]\n" ;
382 print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
383 print PM '$LAST_BIT = ' . "$index ;\n" ;
384 print PM '$BYTES = ' . "$warn_size ;\n" ;
393 # This file was created by warnings.pl
394 # Any changes made here will be lost.
399 our $VERSION = '1.00';
403 warnings - Perl pragma to control optional warnings
413 use warnings::register;
414 if (warnings::enabled()) {
415 warnings::warn("some warning");
418 if (warnings::enabled("void")) {
419 warnings::warn("void", "some warning");
422 if (warnings::enabled($object)) {
423 warnings::warn($object, "some warning");
426 warnings::warnif("some warning");
427 warnings::warnif("void", "some warning");
428 warnings::warnif($object, "some warning");
432 If no import list is supplied, all possible warnings are either enabled
435 A number of functions are provided to assist module authors.
439 =item use warnings::register
441 Creates a new warnings category with the same name as the package where
442 the call to the pragma is used.
444 =item warnings::enabled()
446 Use the warnings category with the same name as the current package.
448 Return TRUE if that warnings category is enabled in the calling module.
449 Otherwise returns FALSE.
451 =item warnings::enabled($category)
453 Return TRUE if the warnings category, C<$category>, is enabled in the
455 Otherwise returns FALSE.
457 =item warnings::enabled($object)
459 Use the name of the class for the object reference, C<$object>, as the
462 Return TRUE if that warnings category is enabled in the first scope
463 where the object is used.
464 Otherwise returns FALSE.
466 =item warnings::warn($message)
468 Print C<$message> to STDERR.
470 Use the warnings category with the same name as the current package.
472 If that warnings category has been set to "FATAL" in the calling module
473 then die. Otherwise return.
475 =item warnings::warn($category, $message)
477 Print C<$message> to STDERR.
479 If the warnings category, C<$category>, has been set to "FATAL" in the
480 calling module then die. Otherwise return.
482 =item warnings::warn($object, $message)
484 Print C<$message> to STDERR.
486 Use the name of the class for the object reference, C<$object>, as the
489 If that warnings category has been set to "FATAL" in the scope where C<$object>
490 is first used then die. Otherwise return.
493 =item warnings::warnif($message)
497 if (warnings::enabled())
498 { warnings::warn($message) }
500 =item warnings::warnif($category, $message)
504 if (warnings::enabled($category))
505 { warnings::warn($category, $message) }
507 =item warnings::warnif($object, $message)
511 if (warnings::enabled($object))
512 { warnings::warn($object, $message) }
516 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
524 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
528 delete $Carp::CarpInternal{'warnings'};
536 foreach my $word (@_) {
537 if ($word eq 'FATAL') {
540 elsif ($catmask = $Bits{$word}) {
542 $mask |= $DeadBits{$word} if $fatal ;
545 { Croaker("Unknown warnings category '$word'")}
553 my $mask = ${^WARNING_BITS} ;
554 if (vec($mask, $Offsets{'all'}, 1)) {
555 $mask |= $Bits{'all'} ;
556 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
558 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
563 my $mask = ${^WARNING_BITS} ;
564 if (vec($mask, $Offsets{'all'}, 1)) {
565 $mask |= $Bits{'all'} ;
566 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
568 ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
578 # check the category supplied.
581 Croaker ("not an object")
582 if $category !~ /^([^=]+)=/ ;
586 $offset = $Offsets{$category};
587 Croaker("Unknown warnings category '$category'")
588 unless defined $offset;
591 $category = (caller(1))[0] ;
592 $offset = $Offsets{$category};
593 Croaker("package '$category' not registered for warnings")
594 unless defined $offset ;
597 my $this_pkg = (caller(1))[0] ;
602 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
603 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
608 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
609 last if $pkg ne $this_pkg ;
612 if !$pkg || $pkg eq $this_pkg ;
615 my $callers_bitmask = (caller($i))[9] ;
616 return ($callers_bitmask, $offset, $i) ;
621 Croaker("Usage: warnings::enabled([category])")
622 unless @_ == 1 || @_ == 0 ;
624 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
626 return 0 unless defined $callers_bitmask ;
627 return vec($callers_bitmask, $offset, 1) ||
628 vec($callers_bitmask, $Offsets{'all'}, 1) ;
634 Croaker("Usage: warnings::warn([category,] 'message')")
635 unless @_ == 2 || @_ == 1 ;
638 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
640 if vec($callers_bitmask, $offset+1, 1) ||
641 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
647 Croaker("Usage: warnings::warnif([category,] 'message')")
648 unless @_ == 2 || @_ == 1 ;
651 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
654 unless defined $callers_bitmask &&
655 (vec($callers_bitmask, $offset, 1) ||
656 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
659 if vec($callers_bitmask, $offset+1, 1) ||
660 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;