10 sub DEFAULT_ON () { 1 }
11 sub DEFAULT_OFF () { 2 }
16 'io' => { 'pipe' => DEFAULT_OFF,
17 'unopened' => DEFAULT_OFF,
18 'closed' => DEFAULT_OFF,
19 'newline' => DEFAULT_OFF,
20 'exec' => DEFAULT_OFF,
22 'syntax' => { 'ambiguous' => DEFAULT_OFF,
23 'semicolon' => DEFAULT_OFF,
24 'precedence' => DEFAULT_OFF,
25 'bareword' => DEFAULT_OFF,
26 'reserved' => DEFAULT_OFF,
27 'digit' => DEFAULT_OFF,
28 'parenthesis' => DEFAULT_OFF,
29 'deprecated' => 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 'void' => DEFAULT_OFF,
40 'recursion' => DEFAULT_OFF,
41 'redefine' => DEFAULT_OFF,
42 'numeric' => DEFAULT_OFF,
43 'uninitialized' => DEFAULT_OFF,
44 'once' => DEFAULT_OFF,
45 'misc' => DEFAULT_OFF,
46 'regexp' => DEFAULT_OFF,
47 'glob' => DEFAULT_OFF,
49 'chmod' => DEFAULT_OFF,
50 'umask' => 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 ###########################################################################
150 my $mask = "\x00" x $max ;
154 vec($mask, $_, 1) = 1 ;
157 #$string = unpack("H$max", $mask) ;
158 #$string =~ s/(..)/\x$1/g;
159 foreach (unpack("C*", $mask)) {
160 $string .= '\x' . sprintf("%2.2x", $_) ;
165 ###########################################################################
167 if (@ARGV && $ARGV[0] eq "tree")
170 printTree($tree, " ", 4) ;
174 #unlink "warnings.h";
175 #unlink "lib/warnings.pm";
176 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
177 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
180 /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
181 This file is built by warnings.pl
182 Any changes made here will be lost!
186 #define Off(x) ((x) / 8)
187 #define Bit(x) (1 << ((x) % 8))
188 #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
191 #define G_WARN_OFF 0 /* $^W == 0 */
192 #define G_WARN_ON 1 /* -w flag and $^W != 0 */
193 #define G_WARN_ALL_ON 2 /* -W flag */
194 #define G_WARN_ALL_OFF 4 /* -X flag */
195 #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
196 #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
198 #define pWARN_STD Nullsv
199 #define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
200 #define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
202 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
209 #@{ $list{"all"} } = walk ($tree) ;
214 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
217 foreach $k (sort { $a <=> $b } keys %Value) {
218 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
222 print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
223 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
224 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
225 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
229 #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
230 #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
231 #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
232 #define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
233 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
236 ( ! specialWARN(PL_curcop->cop_warnings) && \
237 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
238 isWARNf_on(PL_curcop->cop_warnings, x)))
241 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
242 (PL_curcop->cop_warnings == pWARN_ALL || \
243 isWARN_on(PL_curcop->cop_warnings, x) ) ) \
244 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
246 #define ckWARN2(x,y) \
247 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
248 (PL_curcop->cop_warnings == pWARN_ALL || \
249 isWARN_on(PL_curcop->cop_warnings, x) || \
250 isWARN_on(PL_curcop->cop_warnings, y) ) ) \
251 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
253 #define ckWARN_d(x) \
254 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
255 (PL_curcop->cop_warnings != pWARN_NONE && \
256 isWARN_on(PL_curcop->cop_warnings, x) ) )
258 #define ckWARN2_d(x,y) \
259 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
260 (PL_curcop->cop_warnings != pWARN_NONE && \
261 (isWARN_on(PL_curcop->cop_warnings, x) || \
262 isWARN_on(PL_curcop->cop_warnings, y) ) ) )
264 /* end of file warnings.h */
271 last if /^KEYWORDS$/ ;
275 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
277 #my %Keys = map {lc $Value{$_}, $_} keys %Value ;
279 print PM "%Offsets = (\n" ;
280 foreach my $k (sort { $a <=> $b } keys %Value) {
281 my $v = lc $Value{$k} ;
283 print PM tab(4, " '$v'"), "=> $k,\n" ;
288 print PM "%Bits = (\n" ;
289 foreach $k (sort keys %list) {
292 my @list = sort { $a <=> $b } @$v ;
294 print PM tab(4, " '$k'"), '=> "',
295 # mkHex($warn_size, @list),
296 mkHex($warn_size, map $_ * 2 , @list),
297 '", # [', mkRange(@list), "]\n" ;
302 print PM "%DeadBits = (\n" ;
303 foreach $k (sort keys %list) {
306 my @list = sort { $a <=> $b } @$v ;
308 print PM tab(4, " '$k'"), '=> "',
309 # mkHex($warn_size, @list),
310 mkHex($warn_size, map $_ * 2 + 1 , @list),
311 '", # [', mkRange(@list), "]\n" ;
315 print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
316 print PM '$LAST_BIT = ' . "$index ;\n" ;
317 print PM '$BYTES = ' . "$warn_size ;\n" ;
326 # This file was created by warnings.pl
327 # Any changes made here will be lost.
332 our $VERSION = '1.00';
336 warnings - Perl pragma to control optional warnings
346 use warnings::register;
347 if (warnings::enabled()) {
348 warnings::warn("some warning");
351 if (warnings::enabled("void")) {
352 warnings::warn("void", "some warning");
355 if (warnings::enabled($object)) {
356 warnings::warn($object, "some warning");
359 warnif("some warning");
360 warnif("void", "some warning");
361 warnif($object, "some warning");
365 If no import list is supplied, all possible warnings are either enabled
368 A number of functions are provided to assist module authors.
372 =item use warnings::register
374 Creates a new warnings category with the same name as the package where
375 the call to the pragma is used.
377 =item warnings::enabled()
379 Use the warnings category with the same name as the current package.
381 Return TRUE if that warnings category is enabled in the calling module.
382 Otherwise returns FALSE.
384 =item warnings::enabled($category)
386 Return TRUE if the warnings category, C<$category>, is enabled in the
388 Otherwise returns FALSE.
390 =item warnings::enabled($object)
392 Use the name of the class for the object reference, C<$object>, as the
395 Return TRUE if that warnings category is enabled in the first scope
396 where the object is used.
397 Otherwise returns FALSE.
399 =item warnings::warn($message)
401 Print C<$message> to STDERR.
403 Use the warnings category with the same name as the current package.
405 If that warnings category has been set to "FATAL" in the calling module
406 then die. Otherwise return.
408 =item warnings::warn($category, $message)
410 Print C<$message> to STDERR.
412 If the warnings category, C<$category>, has been set to "FATAL" in the
413 calling module then die. Otherwise return.
415 =item warnings::warn($object, $message)
417 Print C<$message> to STDERR.
419 Use the name of the class for the object reference, C<$object>, as the
422 If that warnings category has been set to "FATAL" in the scope where C<$object>
423 is first used then die. Otherwise return.
426 =item warnings::warnif($message)
430 if (warnings::enabled())
431 { warnings::warn($message) }
433 =item warnings::warnif($category, $message)
437 if (warnings::enabled($category))
438 { warnings::warn($category, $message) }
440 =item warnings::warnif($object, $message)
444 if (warnings::enabled($object))
445 { warnings::warn($object, $message) }
449 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
457 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
463 foreach my $word (@_) {
464 if ($word eq 'FATAL') {
467 elsif ($catmask = $Bits{$word}) {
469 $mask |= $DeadBits{$word} if $fatal ;
472 { croak("unknown warnings category '$word'")}
480 my $mask = ${^WARNING_BITS} ;
481 if (vec($mask, $Offsets{'all'}, 1)) {
482 $mask |= $Bits{'all'} ;
483 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
485 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
490 my $mask = ${^WARNING_BITS} ;
491 if (vec($mask, $Offsets{'all'}, 1)) {
492 $mask |= $Bits{'all'} ;
493 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
495 ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
505 # check the category supplied.
508 croak ("not an object")
509 if $category !~ /^([^=]+)=/ ;+
513 $offset = $Offsets{$category};
514 croak("unknown warnings category '$category'")
515 unless defined $offset;
518 $category = (caller(1))[0] ;
519 $offset = $Offsets{$category};
520 croak("package '$category' not registered for warnings")
521 unless defined $offset ;
524 my $this_pkg = (caller(1))[0] ;
529 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
530 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
535 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
536 last if $pkg ne $this_pkg ;
539 if !$pkg || $pkg eq $this_pkg ;
542 my $callers_bitmask = (caller($i))[9] ;
543 return ($callers_bitmask, $offset, $i) ;
548 croak("Usage: warnings::enabled([category])")
549 unless @_ == 1 || @_ == 0 ;
551 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
553 return 0 unless defined $callers_bitmask ;
554 return vec($callers_bitmask, $offset, 1) ||
555 vec($callers_bitmask, $Offsets{'all'}, 1) ;
561 croak("Usage: warnings::warn([category,] 'message')")
562 unless @_ == 2 || @_ == 1 ;
565 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
566 local $Carp::CarpLevel = $i ;
568 if vec($callers_bitmask, $offset+1, 1) ||
569 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
575 croak("Usage: warnings::warnif([category,] 'message')")
576 unless @_ == 2 || @_ == 1 ;
579 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
580 local $Carp::CarpLevel = $i ;
583 unless defined $callers_bitmask &&
584 (vec($callers_bitmask, $offset, 1) ||
585 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
588 if vec($callers_bitmask, $offset+1, 1) ||
589 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;