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 'deprecated' => 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,
41 'chmod' => DEFAULT_OFF,
42 'mkdir' => DEFAULT_OFF,
43 'umask' => DEFAULT_OFF,
45 'void' => DEFAULT_OFF,
46 'recursion' => DEFAULT_OFF,
47 'redefine' => DEFAULT_OFF,
48 'numeric' => DEFAULT_OFF,
49 'uninitialized' => DEFAULT_OFF,
50 'once' => DEFAULT_OFF,
51 'misc' => DEFAULT_OFF,
52 'regexp' => DEFAULT_OFF,
53 'glob' => DEFAULT_OFF,
55 'untie' => DEFAULT_OFF,
56 'substr' => DEFAULT_OFF,
57 'taint' => DEFAULT_OFF,
58 'signal' => DEFAULT_OFF,
59 'closure' => DEFAULT_OFF,
60 'overflow' => DEFAULT_OFF,
61 'portable' => DEFAULT_OFF,
62 'utf8' => DEFAULT_OFF,
63 'exiting' => DEFAULT_OFF,
64 'pack' => DEFAULT_OFF,
65 'unpack' => DEFAULT_OFF,
66 #'default' => DEFAULT_ON,
71 ###########################################################################
74 $t .= "\t" x ($l - (length($t) + 1) / 8);
78 ###########################################################################
90 foreach $k (sort keys %$tre) {
92 die "duplicate key $k\n" if defined $list{$k} ;
93 $Value{$index} = uc $k ;
94 push @{ $list{$k} }, $index ++ ;
96 { push (@{ $list{$k} }, walk ($v)) }
97 push @list, @{ $list{$k} } ;
103 ###########################################################################
112 for ($i = 1 ; $i < @a; ++ $i) {
114 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
117 my $out = join(",",@out);
119 $out =~ s/,(\.\.,)+/../g ;
123 ###########################################################################
131 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
133 $prefix .= " " x $indent ;
134 foreach $k (sort keys %$tre) {
136 print $prefix . "|\n" ;
137 print $prefix . "+- $k" ;
140 print " " . "-" x ($max - length $k ) . "+\n" ;
141 printTree ($v, $prefix . "|" , $max + $indent - 1)
149 ###########################################################################
154 my $mask = "\x00" x $max ;
158 vec($mask, $_, 1) = 1 ;
161 #$string = unpack("H$max", $mask) ;
162 #$string =~ s/(..)/\x$1/g;
163 foreach (unpack("C*", $mask)) {
164 $string .= '\x' . sprintf("%2.2x", $_) ;
169 ###########################################################################
171 if (@ARGV && $ARGV[0] eq "tree")
174 printTree($tree, " ", 4) ;
179 unlink "lib/warnings.pm";
180 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
181 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
184 /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
185 This file is built by warnings.pl
186 Any changes made here will be lost!
190 #define Off(x) ((x) / 8)
191 #define Bit(x) (1 << ((x) % 8))
192 #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
195 #define G_WARN_OFF 0 /* $^W == 0 */
196 #define G_WARN_ON 1 /* -w flag and $^W != 0 */
197 #define G_WARN_ALL_ON 2 /* -W flag */
198 #define G_WARN_ALL_OFF 4 /* -X flag */
199 #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
200 #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
202 #define pWARN_STD Nullsv
203 #define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
204 #define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
206 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
213 #@{ $list{"all"} } = walk ($tree) ;
218 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
221 foreach $k (sort { $a <=> $b } keys %Value) {
222 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
226 print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
227 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
228 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
229 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
233 #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
234 #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
235 #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
236 #define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
237 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
240 ( ! specialWARN(PL_curcop->cop_warnings) && \
241 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
242 isWARNf_on(PL_curcop->cop_warnings, x)))
245 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
246 (PL_curcop->cop_warnings == pWARN_ALL || \
247 isWARN_on(PL_curcop->cop_warnings, x) ) ) \
248 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
250 #define ckWARN2(x,y) \
251 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
252 (PL_curcop->cop_warnings == pWARN_ALL || \
253 isWARN_on(PL_curcop->cop_warnings, x) || \
254 isWARN_on(PL_curcop->cop_warnings, y) ) ) \
255 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
257 #define ckWARN_d(x) \
258 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
259 (PL_curcop->cop_warnings != pWARN_NONE && \
260 isWARN_on(PL_curcop->cop_warnings, x) ) )
262 #define ckWARN2_d(x,y) \
263 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
264 (PL_curcop->cop_warnings != pWARN_NONE && \
265 (isWARN_on(PL_curcop->cop_warnings, x) || \
266 isWARN_on(PL_curcop->cop_warnings, y) ) ) )
268 /* end of file warnings.h */
275 last if /^KEYWORDS$/ ;
279 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
281 #my %Keys = map {lc $Value{$_}, $_} keys %Value ;
283 print PM "%Offsets = (\n" ;
284 foreach my $k (sort { $a <=> $b } keys %Value) {
285 my $v = lc $Value{$k} ;
287 print PM tab(4, " '$v'"), "=> $k,\n" ;
292 print PM "%Bits = (\n" ;
293 foreach $k (sort keys %list) {
296 my @list = sort { $a <=> $b } @$v ;
298 print PM tab(4, " '$k'"), '=> "',
299 # mkHex($warn_size, @list),
300 mkHex($warn_size, map $_ * 2 , @list),
301 '", # [', mkRange(@list), "]\n" ;
306 print PM "%DeadBits = (\n" ;
307 foreach $k (sort keys %list) {
310 my @list = sort { $a <=> $b } @$v ;
312 print PM tab(4, " '$k'"), '=> "',
313 # mkHex($warn_size, @list),
314 mkHex($warn_size, map $_ * 2 + 1 , @list),
315 '", # [', mkRange(@list), "]\n" ;
319 print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
320 print PM '$LAST_BIT = ' . "$index ;\n" ;
321 print PM '$BYTES = ' . "$warn_size ;\n" ;
330 # This file was created by warnings.pl
331 # Any changes made here will be lost.
336 our $VERSION = '1.00';
340 warnings - Perl pragma to control optional warnings
350 use warnings::register;
351 if (warnings::enabled()) {
352 warnings::warn("some warning");
355 if (warnings::enabled("void")) {
356 warnings::warn("void", "some warning");
359 if (warnings::enabled($object)) {
360 warnings::warn($object, "some warning");
363 warnif("some warning");
364 warnif("void", "some warning");
365 warnif($object, "some warning");
369 If no import list is supplied, all possible warnings are either enabled
372 A number of functions are provided to assist module authors.
376 =item use warnings::register
378 Creates a new warnings category with the same name as the package where
379 the call to the pragma is used.
381 =item warnings::enabled()
383 Use the warnings category with the same name as the current package.
385 Return TRUE if that warnings category is enabled in the calling module.
386 Otherwise returns FALSE.
388 =item warnings::enabled($category)
390 Return TRUE if the warnings category, C<$category>, is enabled in the
392 Otherwise returns FALSE.
394 =item warnings::enabled($object)
396 Use the name of the class for the object reference, C<$object>, as the
399 Return TRUE if that warnings category is enabled in the first scope
400 where the object is used.
401 Otherwise returns FALSE.
403 =item warnings::warn($message)
405 Print C<$message> to STDERR.
407 Use the warnings category with the same name as the current package.
409 If that warnings category has been set to "FATAL" in the calling module
410 then die. Otherwise return.
412 =item warnings::warn($category, $message)
414 Print C<$message> to STDERR.
416 If the warnings category, C<$category>, has been set to "FATAL" in the
417 calling module then die. Otherwise return.
419 =item warnings::warn($object, $message)
421 Print C<$message> to STDERR.
423 Use the name of the class for the object reference, C<$object>, as the
426 If that warnings category has been set to "FATAL" in the scope where C<$object>
427 is first used then die. Otherwise return.
430 =item warnings::warnif($message)
434 if (warnings::enabled())
435 { warnings::warn($message) }
437 =item warnings::warnif($category, $message)
441 if (warnings::enabled($category))
442 { warnings::warn($category, $message) }
444 =item warnings::warnif($object, $message)
448 if (warnings::enabled($object))
449 { warnings::warn($object, $message) }
453 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
461 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
467 foreach my $word (@_) {
468 if ($word eq 'FATAL') {
471 elsif ($catmask = $Bits{$word}) {
473 $mask |= $DeadBits{$word} if $fatal ;
476 { croak("unknown warnings category '$word'")}
484 my $mask = ${^WARNING_BITS} ;
485 if (vec($mask, $Offsets{'all'}, 1)) {
486 $mask |= $Bits{'all'} ;
487 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
489 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
494 my $mask = ${^WARNING_BITS} ;
495 if (vec($mask, $Offsets{'all'}, 1)) {
496 $mask |= $Bits{'all'} ;
497 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
499 ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
509 # check the category supplied.
512 croak ("not an object")
513 if $category !~ /^([^=]+)=/ ;+
517 $offset = $Offsets{$category};
518 croak("unknown warnings category '$category'")
519 unless defined $offset;
522 $category = (caller(1))[0] ;
523 $offset = $Offsets{$category};
524 croak("package '$category' not registered for warnings")
525 unless defined $offset ;
528 my $this_pkg = (caller(1))[0] ;
533 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
534 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
539 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
540 last if $pkg ne $this_pkg ;
543 if !$pkg || $pkg eq $this_pkg ;
546 my $callers_bitmask = (caller($i))[9] ;
547 return ($callers_bitmask, $offset, $i) ;
552 croak("Usage: warnings::enabled([category])")
553 unless @_ == 1 || @_ == 0 ;
555 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
557 return 0 unless defined $callers_bitmask ;
558 return vec($callers_bitmask, $offset, 1) ||
559 vec($callers_bitmask, $Offsets{'all'}, 1) ;
565 croak("Usage: warnings::warn([category,] 'message')")
566 unless @_ == 2 || @_ == 1 ;
569 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
570 local $Carp::CarpLevel = $i ;
572 if vec($callers_bitmask, $offset+1, 1) ||
573 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
579 croak("Usage: warnings::warnif([category,] 'message')")
580 unless @_ == 2 || @_ == 1 ;
583 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
584 local $Carp::CarpLevel = $i ;
587 unless defined $callers_bitmask &&
588 (vec($callers_bitmask, $offset, 1) ||
589 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
592 if vec($callers_bitmask, $offset+1, 1) ||
593 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;