8 sub DEFAULT_ON () { 1 }
9 sub DEFAULT_OFF () { 2 }
14 'io' => { 'pipe' => DEFAULT_OFF,
15 'unopened' => DEFAULT_OFF,
16 'closed' => DEFAULT_OFF,
17 'newline' => DEFAULT_OFF,
18 'exec' => DEFAULT_OFF,
20 'syntax' => { 'ambiguous' => DEFAULT_OFF,
21 'semicolon' => DEFAULT_OFF,
22 'precedence' => DEFAULT_OFF,
23 'bareword' => DEFAULT_OFF,
24 'reserved' => DEFAULT_OFF,
25 'digit' => DEFAULT_OFF,
26 'parenthesis' => DEFAULT_OFF,
27 'deprecated' => DEFAULT_OFF,
28 'printf' => DEFAULT_OFF,
29 'prototype' => DEFAULT_OFF,
32 'severe' => { 'inplace' => DEFAULT_ON,
33 'internal' => DEFAULT_ON,
34 'debugging' => DEFAULT_ON,
35 'malloc' => DEFAULT_ON,
37 'void' => DEFAULT_OFF,
38 'recursion' => DEFAULT_OFF,
39 'redefine' => DEFAULT_OFF,
40 'numeric' => DEFAULT_OFF,
41 'uninitialized' => DEFAULT_OFF,
42 'once' => DEFAULT_OFF,
43 'misc' => DEFAULT_OFF,
44 'regexp' => DEFAULT_OFF,
45 'glob' => DEFAULT_OFF,
47 'chmod' => DEFAULT_OFF,
48 'umask' => DEFAULT_OFF,
49 'untie' => DEFAULT_OFF,
50 'substr' => DEFAULT_OFF,
51 'taint' => DEFAULT_OFF,
52 'signal' => DEFAULT_OFF,
53 'closure' => DEFAULT_OFF,
54 'overflow' => DEFAULT_OFF,
55 'portable' => DEFAULT_OFF,
56 'utf8' => DEFAULT_OFF,
57 'exiting' => DEFAULT_OFF,
58 'pack' => DEFAULT_OFF,
59 'unpack' => DEFAULT_OFF,
60 #'default' => DEFAULT_ON,
65 ###########################################################################
68 $t .= "\t" x ($l - (length($t) + 1) / 8);
72 ###########################################################################
84 foreach $k (sort keys %$tre) {
86 die "duplicate key $k\n" if defined $list{$k} ;
87 $Value{$index} = uc $k ;
88 push @{ $list{$k} }, $index ++ ;
90 { push (@{ $list{$k} }, walk ($v)) }
91 push @list, @{ $list{$k} } ;
97 ###########################################################################
106 for ($i = 1 ; $i < @a; ++ $i) {
108 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
111 my $out = join(",",@out);
113 $out =~ s/,(\.\.,)+/../g ;
117 ###########################################################################
125 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
127 $prefix .= " " x $indent ;
128 foreach $k (sort keys %$tre) {
130 print $prefix . "|\n" ;
131 print $prefix . "+- $k" ;
134 print " " . "-" x ($max - length $k ) . "+\n" ;
135 printTree ($v, $prefix . "|" , $max + $indent - 1)
143 ###########################################################################
148 my $mask = "\x00" x $max ;
152 vec($mask, $_, 1) = 1 ;
155 #$string = unpack("H$max", $mask) ;
156 #$string =~ s/(..)/\x$1/g;
157 foreach (unpack("C*", $mask)) {
158 $string .= '\x' . sprintf("%2.2x", $_) ;
163 ###########################################################################
165 if (@ARGV && $ARGV[0] eq "tree")
168 printTree($tree, " ", 4) ;
172 #unlink "warnings.h";
173 #unlink "lib/warnings.pm";
174 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
175 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
178 /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
179 This file is built by warnings.pl
180 Any changes made here will be lost!
184 #define Off(x) ((x) / 8)
185 #define Bit(x) (1 << ((x) % 8))
186 #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
189 #define G_WARN_OFF 0 /* $^W == 0 */
190 #define G_WARN_ON 1 /* -w flag and $^W != 0 */
191 #define G_WARN_ALL_ON 2 /* -W flag */
192 #define G_WARN_ALL_OFF 4 /* -X flag */
193 #define G_WARN_ONCE 8 /* set if 'once' ever enabled */
194 #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
196 #define pWARN_STD Nullsv
197 #define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
198 #define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
200 #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
207 #@{ $list{"all"} } = walk ($tree) ;
212 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
215 foreach $k (sort { $a <=> $b } keys %Value) {
216 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
220 print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
221 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
222 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
223 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
227 #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
228 #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
229 #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
230 #define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
231 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
234 ( ! specialWARN(PL_curcop->cop_warnings) && \
235 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
236 isWARNf_on(PL_curcop->cop_warnings, x)))
239 ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
240 (PL_curcop->cop_warnings == pWARN_ALL || \
241 isWARN_on(PL_curcop->cop_warnings, x) ) ) \
242 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
244 #define ckWARN2(x,y) \
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 isWARN_on(PL_curcop->cop_warnings, y) ) ) \
249 || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
251 #define ckWARN_d(x) \
252 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
253 (PL_curcop->cop_warnings != pWARN_NONE && \
254 isWARN_on(PL_curcop->cop_warnings, x) ) )
256 #define ckWARN2_d(x,y) \
257 (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \
258 (PL_curcop->cop_warnings != pWARN_NONE && \
259 (isWARN_on(PL_curcop->cop_warnings, x) || \
260 isWARN_on(PL_curcop->cop_warnings, y) ) ) )
262 /* end of file warnings.h */
269 last if /^KEYWORDS$/ ;
273 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
275 #my %Keys = map {lc $Value{$_}, $_} keys %Value ;
277 print PM "%Offsets = (\n" ;
278 foreach my $k (sort { $a <=> $b } keys %Value) {
279 my $v = lc $Value{$k} ;
281 print PM tab(4, " '$v'"), "=> $k,\n" ;
286 print PM "%Bits = (\n" ;
287 foreach $k (sort keys %list) {
290 my @list = sort { $a <=> $b } @$v ;
292 print PM tab(4, " '$k'"), '=> "',
293 # mkHex($warn_size, @list),
294 mkHex($warn_size, map $_ * 2 , @list),
295 '", # [', mkRange(@list), "]\n" ;
300 print PM "%DeadBits = (\n" ;
301 foreach $k (sort keys %list) {
304 my @list = sort { $a <=> $b } @$v ;
306 print PM tab(4, " '$k'"), '=> "',
307 # mkHex($warn_size, @list),
308 mkHex($warn_size, map $_ * 2 + 1 , @list),
309 '", # [', mkRange(@list), "]\n" ;
313 print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
314 print PM '$LAST_BIT = ' . "$index ;\n" ;
315 print PM '$BYTES = ' . "$warn_size ;\n" ;
324 # This file was created by warnings.pl
325 # Any changes made here will be lost.
332 warnings - Perl pragma to control optional warnings
342 use warnings::register;
343 if (warnings::enabled()) {
344 warnings::warn("some warning");
347 if (warnings::enabled("void")) {
348 warnings::warn("void", "some warning");
351 if (warnings::enabled($object)) {
352 warnings::warn($object, "some warning");
355 warnif("some warning");
356 warnif("void", "some warning");
357 warnif($object, "some warning");
361 If no import list is supplied, all possible warnings are either enabled
364 A number of functions are provided to assist module authors.
368 =item use warnings::register
370 Creates a new warnings category with the same name as the package where
371 the call to the pragma is used.
373 =item warnings::enabled()
375 Use the warnings category with the same name as the current package.
377 Return TRUE if that warnings category is enabled in the calling module.
378 Otherwise returns FALSE.
380 =item warnings::enabled($category)
382 Return TRUE if the warnings category, C<$category>, is enabled in the
384 Otherwise returns FALSE.
386 =item warnings::enabled($object)
388 Use the name of the class for the object reference, C<$object>, as the
391 Return TRUE if that warnings category is enabled in the first scope
392 where the object is used.
393 Otherwise returns FALSE.
395 =item warnings::warn($message)
397 Print C<$message> to STDERR.
399 Use the warnings category with the same name as the current package.
401 If that warnings category has been set to "FATAL" in the calling module
402 then die. Otherwise return.
404 =item warnings::warn($category, $message)
406 Print C<$message> to STDERR.
408 If the warnings category, C<$category>, has been set to "FATAL" in the
409 calling module then die. Otherwise return.
411 =item warnings::warn($object, $message)
413 Print C<$message> to STDERR.
415 Use the name of the class for the object reference, C<$object>, as the
418 If that warnings category has been set to "FATAL" in the scope where C<$object>
419 is first used then die. Otherwise return.
422 =item warnings::warnif($message)
426 if (warnings::enabled())
427 { warnings::warn($message) }
429 =item warnings::warnif($category, $message)
433 if (warnings::enabled($category))
434 { warnings::warn($category, $message) }
436 =item warnings::warnif($object, $message)
440 if (warnings::enabled($object))
441 { warnings::warn($object, $message) }
445 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
453 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
459 foreach my $word (@_) {
460 if ($word eq 'FATAL') {
463 elsif ($catmask = $Bits{$word}) {
465 $mask |= $DeadBits{$word} if $fatal ;
468 { croak("unknown warnings category '$word'")}
476 ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
481 my $mask = ${^WARNING_BITS} ;
482 if (vec($mask, $Offsets{'all'}, 1)) {
483 $mask = $Bits{'all'} ;
484 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
486 ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
496 # check the category supplied.
499 croak ("not an object")
500 if $category !~ /^([^=]+)=/ ;+
504 $offset = $Offsets{$category};
505 croak("unknown warnings category '$category'")
506 unless defined $offset;
509 $category = (caller(1))[0] ;
510 $offset = $Offsets{$category};
511 croak("package '$category' not registered for warnings")
512 unless defined $offset ;
515 my $this_pkg = (caller(1))[0] ;
520 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
521 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
526 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
527 last if $pkg ne $this_pkg ;
530 if !$pkg || $pkg eq $this_pkg ;
533 my $callers_bitmask = (caller($i))[9] ;
534 return ($callers_bitmask, $offset, $i) ;
539 croak("Usage: warnings::enabled([category])")
540 unless @_ == 1 || @_ == 0 ;
542 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
544 return 0 unless defined $callers_bitmask ;
545 return vec($callers_bitmask, $offset, 1) ||
546 vec($callers_bitmask, $Offsets{'all'}, 1) ;
552 croak("Usage: warnings::warn([category,] 'message')")
553 unless @_ == 2 || @_ == 1 ;
556 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
557 local $Carp::CarpLevel = $i ;
559 if vec($callers_bitmask, $offset+1, 1) ||
560 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
566 croak("Usage: warnings::warnif([category,] 'message')")
567 unless @_ == 2 || @_ == 1 ;
570 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
571 local $Carp::CarpLevel = $i ;
574 unless defined $callers_bitmask &&
575 (vec($callers_bitmask, $offset, 1) ||
576 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
579 if vec($callers_bitmask, $offset+1, 1) ||
580 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;