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 my $mask = ${^WARNING_BITS} ;
477 if (vec($mask, $Offsets{'all'}, 1)) {
478 $mask |= $Bits{'all'} ;
479 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
481 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
486 my $mask = ${^WARNING_BITS} ;
487 if (vec($mask, $Offsets{'all'}, 1)) {
488 $mask |= $Bits{'all'} ;
489 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
491 ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
501 # check the category supplied.
504 croak ("not an object")
505 if $category !~ /^([^=]+)=/ ;+
509 $offset = $Offsets{$category};
510 croak("unknown warnings category '$category'")
511 unless defined $offset;
514 $category = (caller(1))[0] ;
515 $offset = $Offsets{$category};
516 croak("package '$category' not registered for warnings")
517 unless defined $offset ;
520 my $this_pkg = (caller(1))[0] ;
525 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
526 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
531 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
532 last if $pkg ne $this_pkg ;
535 if !$pkg || $pkg eq $this_pkg ;
538 my $callers_bitmask = (caller($i))[9] ;
539 return ($callers_bitmask, $offset, $i) ;
544 croak("Usage: warnings::enabled([category])")
545 unless @_ == 1 || @_ == 0 ;
547 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
549 return 0 unless defined $callers_bitmask ;
550 return vec($callers_bitmask, $offset, 1) ||
551 vec($callers_bitmask, $Offsets{'all'}, 1) ;
557 croak("Usage: warnings::warn([category,] 'message')")
558 unless @_ == 2 || @_ == 1 ;
561 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
562 local $Carp::CarpLevel = $i ;
564 if vec($callers_bitmask, $offset+1, 1) ||
565 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
571 croak("Usage: warnings::warnif([category,] 'message')")
572 unless @_ == 2 || @_ == 1 ;
575 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
576 local $Carp::CarpLevel = $i ;
579 unless defined $callers_bitmask &&
580 (vec($callers_bitmask, $offset, 1) ||
581 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
584 if vec($callers_bitmask, $offset+1, 1) ||
585 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;