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,
23 'syntax' => { 'ambiguous' => DEFAULT_OFF,
24 'semicolon' => DEFAULT_OFF,
25 'precedence' => DEFAULT_OFF,
26 'bareword' => DEFAULT_OFF,
27 'reserved' => DEFAULT_OFF,
28 'digit' => DEFAULT_OFF,
29 'parenthesis' => DEFAULT_OFF,
30 'printf' => DEFAULT_OFF,
31 'prototype' => DEFAULT_OFF,
34 'severe' => { 'inplace' => DEFAULT_ON,
35 'internal' => DEFAULT_ON,
36 'debugging' => DEFAULT_ON,
37 'malloc' => DEFAULT_ON,
39 'deprecated' => DEFAULT_OFF,
40 'void' => DEFAULT_OFF,
41 'recursion' => DEFAULT_OFF,
42 'redefine' => DEFAULT_OFF,
43 'numeric' => DEFAULT_OFF,
44 'uninitialized' => DEFAULT_OFF,
45 'once' => DEFAULT_OFF,
46 'misc' => DEFAULT_OFF,
47 'regexp' => DEFAULT_OFF,
48 'glob' => DEFAULT_OFF,
50 'untie' => DEFAULT_OFF,
51 'substr' => DEFAULT_OFF,
52 'taint' => DEFAULT_OFF,
53 'signal' => DEFAULT_OFF,
54 'closure' => DEFAULT_OFF,
55 'overflow' => DEFAULT_OFF,
56 'portable' => DEFAULT_OFF,
57 'utf8' => DEFAULT_OFF,
58 'exiting' => DEFAULT_OFF,
59 'pack' => DEFAULT_OFF,
60 'unpack' => DEFAULT_OFF,
61 #'default' => DEFAULT_ON,
66 ###########################################################################
69 $t .= "\t" x ($l - (length($t) + 1) / 8);
73 ###########################################################################
85 foreach $k (sort keys %$tre) {
87 die "duplicate key $k\n" if defined $list{$k} ;
88 $Value{$index} = uc $k ;
89 push @{ $list{$k} }, $index ++ ;
91 { push (@{ $list{$k} }, walk ($v)) }
92 push @list, @{ $list{$k} } ;
98 ###########################################################################
107 for ($i = 1 ; $i < @a; ++ $i) {
109 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
112 my $out = join(",",@out);
114 $out =~ s/,(\.\.,)+/../g ;
118 ###########################################################################
126 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
128 $prefix .= " " x $indent ;
129 foreach $k (sort keys %$tre) {
131 print $prefix . "|\n" ;
132 print $prefix . "+- $k" ;
135 print " " . "-" x ($max - length $k ) . "+\n" ;
136 printTree ($v, $prefix . "|" , $max + $indent - 1)
144 ###########################################################################
148 my ($f, $max, @a) = @_ ;
149 my $mask = "\x00" x $max ;
153 vec($mask, $_, 1) = 1 ;
156 foreach (unpack("C*", $mask)) {
158 $string .= '\x' . sprintf("%2.2x", $_)
161 $string .= '\\' . sprintf("%o", $_)
170 return mkHexOct("x", $max, @a);
176 return mkHexOct("o", $max, @a);
179 ###########################################################################
181 if (@ARGV && $ARGV[0] eq "tree")
184 printTree($tree, " ", 4) ;
189 unlink "lib/warnings.pm";
190 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
191 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
194 /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
195 This file is built by warnings.pl
196 Any changes made here will be lost!
200 #define Off(x) ((x) / 8)
201 #define Bit(x) (1 << ((x) % 8))
202 #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
205 #define G_WARN_OFF 0 /* $^W == 0 */
206 #define G_WARN_ON 1 /* -w flag and $^W != 0 */
207 #define G_WARN_ALL_ON 2 /* -W flag */
208 #define G_WARN_ALL_OFF 4 /* -X flag */
209 #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
210 #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
212 #define pWARN_STD Nullsv
213 #define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
214 #define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
216 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
223 #@{ $list{"all"} } = walk ($tree) ;
226 die <<EOM if $index > 255 ;
227 Too many warnings categories -- max is 255
228 rewrite packWARN* & unpackWARN* macros
232 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
235 foreach $k (sort { $a <=> $b } keys %Value) {
236 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
240 print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
241 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
242 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
243 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
244 my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
246 print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
250 #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
251 #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
252 #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
253 #define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
254 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
257 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
258 (PL_curcop->cop_warnings == pWARN_ALL || \
259 isWARN_on(PL_curcop->cop_warnings, x) ) ) \
260 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
262 #define ckWARN2(x,y) \
263 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
264 (PL_curcop->cop_warnings == pWARN_ALL || \
265 isWARN_on(PL_curcop->cop_warnings, x) || \
266 isWARN_on(PL_curcop->cop_warnings, y) ) ) \
267 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
269 #define ckWARN3(x,y,z) \
270 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
271 (PL_curcop->cop_warnings == pWARN_ALL || \
272 isWARN_on(PL_curcop->cop_warnings, x) || \
273 isWARN_on(PL_curcop->cop_warnings, y) || \
274 isWARN_on(PL_curcop->cop_warnings, z) ) ) \
275 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
277 #define ckWARN4(x,y,z,t) \
278 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
279 (PL_curcop->cop_warnings == pWARN_ALL || \
280 isWARN_on(PL_curcop->cop_warnings, x) || \
281 isWARN_on(PL_curcop->cop_warnings, y) || \
282 isWARN_on(PL_curcop->cop_warnings, z) || \
283 isWARN_on(PL_curcop->cop_warnings, t) ) ) \
284 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
286 #define ckWARN_d(x) \
287 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
288 (PL_curcop->cop_warnings != pWARN_NONE && \
289 isWARN_on(PL_curcop->cop_warnings, x) ) )
291 #define ckWARN2_d(x,y) \
292 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
293 (PL_curcop->cop_warnings != pWARN_NONE && \
294 (isWARN_on(PL_curcop->cop_warnings, x) || \
295 isWARN_on(PL_curcop->cop_warnings, y) ) ) )
297 #define ckWARN3_d(x,y,z) \
298 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
299 (PL_curcop->cop_warnings != pWARN_NONE && \
300 (isWARN_on(PL_curcop->cop_warnings, x) || \
301 isWARN_on(PL_curcop->cop_warnings, y) || \
302 isWARN_on(PL_curcop->cop_warnings, z) ) ) )
304 #define ckWARN4_d(x,y,z,t) \
305 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
306 (PL_curcop->cop_warnings != pWARN_NONE && \
307 (isWARN_on(PL_curcop->cop_warnings, x) || \
308 isWARN_on(PL_curcop->cop_warnings, y) || \
309 isWARN_on(PL_curcop->cop_warnings, z) || \
310 isWARN_on(PL_curcop->cop_warnings, t) ) ) )
312 #define packWARN(a) (a )
313 #define packWARN2(a,b) ((a) | (b)<<8 )
314 #define packWARN3(a,b,c) ((a) | (b)<<8 | (c) <<16 )
315 #define packWARN4(a,b,c,d) ((a) | (b)<<8 | (c) <<16 | (d) <<24)
317 #define unpackWARN1(x) ((x) & 0xFF)
318 #define unpackWARN2(x) (((x) >>8) & 0xFF)
319 #define unpackWARN3(x) (((x) >>16) & 0xFF)
320 #define unpackWARN4(x) (((x) >>24) & 0xFF)
323 ( ! specialWARN(PL_curcop->cop_warnings) && \
324 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
325 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
326 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
327 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
328 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
330 /* end of file warnings.h */
337 last if /^KEYWORDS$/ ;
341 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
343 #my %Keys = map {lc $Value{$_}, $_} keys %Value ;
345 print PM "%Offsets = (\n" ;
346 foreach my $k (sort { $a <=> $b } keys %Value) {
347 my $v = lc $Value{$k} ;
349 print PM tab(4, " '$v'"), "=> $k,\n" ;
354 print PM "%Bits = (\n" ;
355 foreach $k (sort keys %list) {
358 my @list = sort { $a <=> $b } @$v ;
360 print PM tab(4, " '$k'"), '=> "',
361 # mkHex($warn_size, @list),
362 mkHex($warn_size, map $_ * 2 , @list),
363 '", # [', mkRange(@list), "]\n" ;
368 print PM "%DeadBits = (\n" ;
369 foreach $k (sort keys %list) {
372 my @list = sort { $a <=> $b } @$v ;
374 print PM tab(4, " '$k'"), '=> "',
375 # mkHex($warn_size, @list),
376 mkHex($warn_size, map $_ * 2 + 1 , @list),
377 '", # [', mkRange(@list), "]\n" ;
381 print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
382 print PM '$LAST_BIT = ' . "$index ;\n" ;
383 print PM '$BYTES = ' . "$warn_size ;\n" ;
392 # This file was created by warnings.pl
393 # Any changes made here will be lost.
398 our $VERSION = '1.00';
402 warnings - Perl pragma to control optional warnings
412 use warnings::register;
413 if (warnings::enabled()) {
414 warnings::warn("some warning");
417 if (warnings::enabled("void")) {
418 warnings::warn("void", "some warning");
421 if (warnings::enabled($object)) {
422 warnings::warn($object, "some warning");
425 warnings::warnif("some warning");
426 warnings::warnif("void", "some warning");
427 warnings::warnif($object, "some warning");
431 If no import list is supplied, all possible warnings are either enabled
434 A number of functions are provided to assist module authors.
438 =item use warnings::register
440 Creates a new warnings category with the same name as the package where
441 the call to the pragma is used.
443 =item warnings::enabled()
445 Use the warnings category with the same name as the current package.
447 Return TRUE if that warnings category is enabled in the calling module.
448 Otherwise returns FALSE.
450 =item warnings::enabled($category)
452 Return TRUE if the warnings category, C<$category>, is enabled in the
454 Otherwise returns FALSE.
456 =item warnings::enabled($object)
458 Use the name of the class for the object reference, C<$object>, as the
461 Return TRUE if that warnings category is enabled in the first scope
462 where the object is used.
463 Otherwise returns FALSE.
465 =item warnings::warn($message)
467 Print C<$message> to STDERR.
469 Use the warnings category with the same name as the current package.
471 If that warnings category has been set to "FATAL" in the calling module
472 then die. Otherwise return.
474 =item warnings::warn($category, $message)
476 Print C<$message> to STDERR.
478 If the warnings category, C<$category>, has been set to "FATAL" in the
479 calling module then die. Otherwise return.
481 =item warnings::warn($object, $message)
483 Print C<$message> to STDERR.
485 Use the name of the class for the object reference, C<$object>, as the
488 If that warnings category has been set to "FATAL" in the scope where C<$object>
489 is first used then die. Otherwise return.
492 =item warnings::warnif($message)
496 if (warnings::enabled())
497 { warnings::warn($message) }
499 =item warnings::warnif($category, $message)
503 if (warnings::enabled($category))
504 { warnings::warn($category, $message) }
506 =item warnings::warnif($object, $message)
510 if (warnings::enabled($object))
511 { warnings::warn($object, $message) }
515 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
523 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
527 delete $Carp::CarpInternal{'warnings'};
535 foreach my $word (@_) {
536 if ($word eq 'FATAL') {
539 elsif ($catmask = $Bits{$word}) {
541 $mask |= $DeadBits{$word} if $fatal ;
544 { Croaker("Unknown warnings category '$word'")}
552 my $mask = ${^WARNING_BITS} ;
553 if (vec($mask, $Offsets{'all'}, 1)) {
554 $mask |= $Bits{'all'} ;
555 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
557 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
562 my $mask = ${^WARNING_BITS} ;
563 if (vec($mask, $Offsets{'all'}, 1)) {
564 $mask |= $Bits{'all'} ;
565 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
567 ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
577 # check the category supplied.
580 Croaker ("not an object")
581 if $category !~ /^([^=]+)=/ ;
585 $offset = $Offsets{$category};
586 Croaker("Unknown warnings category '$category'")
587 unless defined $offset;
590 $category = (caller(1))[0] ;
591 $offset = $Offsets{$category};
592 Croaker("package '$category' not registered for warnings")
593 unless defined $offset ;
596 my $this_pkg = (caller(1))[0] ;
601 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
602 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
607 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
608 last if $pkg ne $this_pkg ;
611 if !$pkg || $pkg eq $this_pkg ;
614 my $callers_bitmask = (caller($i))[9] ;
615 return ($callers_bitmask, $offset, $i) ;
620 Croaker("Usage: warnings::enabled([category])")
621 unless @_ == 1 || @_ == 0 ;
623 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
625 return 0 unless defined $callers_bitmask ;
626 return vec($callers_bitmask, $offset, 1) ||
627 vec($callers_bitmask, $Offsets{'all'}, 1) ;
633 Croaker("Usage: warnings::warn([category,] 'message')")
634 unless @_ == 2 || @_ == 1 ;
637 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
639 if vec($callers_bitmask, $offset+1, 1) ||
640 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
646 Croaker("Usage: warnings::warnif([category,] 'message')")
647 unless @_ == 2 || @_ == 1 ;
650 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
653 unless defined $callers_bitmask &&
654 (vec($callers_bitmask, $offset, 1) ||
655 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
658 if vec($callers_bitmask, $offset+1, 1) ||
659 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;