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 || \
204 ( ! specialWARN(PL_curcop->cop_warnings) && \
205 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
208 ( (PL_curcop->cop_warnings != pWARN_STD && \
209 PL_curcop->cop_warnings != pWARN_NONE && \
210 (PL_curcop->cop_warnings == pWARN_ALL || \
211 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \
212 || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) )
214 #define ckWARN2(x,y) \
215 ( (PL_curcop->cop_warnings != pWARN_STD && \
216 PL_curcop->cop_warnings != pWARN_NONE && \
217 (PL_curcop->cop_warnings == pWARN_ALL || \
218 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \
219 IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \
220 || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) )
222 #define ckWARN_d(x) \
223 (PL_curcop->cop_warnings == pWARN_STD || \
224 PL_curcop->cop_warnings == pWARN_ALL || \
225 (PL_curcop->cop_warnings != pWARN_NONE && \
226 IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )
228 #define ckWARN2_d(x,y) \
229 (PL_curcop->cop_warnings == pWARN_STD || \
230 PL_curcop->cop_warnings == pWARN_ALL || \
231 (PL_curcop->cop_warnings != pWARN_NONE && \
232 (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \
233 IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) )
236 #define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
237 #define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
238 #define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
239 #define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
246 #@{ $list{"all"} } = walk ($tree) ;
251 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
254 foreach $k (sort { $a <=> $b } keys %Value) {
255 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
259 print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
260 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
261 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
262 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
266 /* end of file warnings.h */
273 last if /^KEYWORDS$/ ;
277 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
279 #my %Keys = map {lc $Value{$_}, $_} keys %Value ;
281 print PM "%Offsets = (\n" ;
282 foreach my $k (sort { $a <=> $b } keys %Value) {
283 my $v = lc $Value{$k} ;
285 print PM tab(4, " '$v'"), "=> $k,\n" ;
290 print PM "%Bits = (\n" ;
291 foreach $k (sort keys %list) {
294 my @list = sort { $a <=> $b } @$v ;
296 print PM tab(4, " '$k'"), '=> "',
297 # mkHex($warn_size, @list),
298 mkHex($warn_size, map $_ * 2 , @list),
299 '", # [', mkRange(@list), "]\n" ;
304 print PM "%DeadBits = (\n" ;
305 foreach $k (sort keys %list) {
308 my @list = sort { $a <=> $b } @$v ;
310 print PM tab(4, " '$k'"), '=> "',
311 # mkHex($warn_size, @list),
312 mkHex($warn_size, map $_ * 2 + 1 , @list),
313 '", # [', mkRange(@list), "]\n" ;
317 print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
318 print PM '$LAST_BIT = ' . "$index ;\n" ;
319 print PM '$BYTES = ' . "$warn_size ;\n" ;
328 # This file was created by warnings.pl
329 # Any changes made here will be lost.
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");
357 If no import list is supplied, all possible warnings are either enabled
360 A number of functions are provided to assist module authors.
364 =item use warnings::register
366 Creates a new warnings category which has the same name as the module
367 where the call to the pragma is used.
369 =item warnings::enabled([$category])
371 Returns TRUE if the warnings category C<$category> is enabled in the
372 calling module. Otherwise returns FALSE.
374 If the parameter, C<$category>, isn't supplied, the current package name
377 =item warnings::warn([$category,] $message)
379 If the calling module has I<not> set C<$category> to "FATAL", print
380 C<$message> to STDERR.
381 If the calling module has set C<$category> to "FATAL", print C<$message>
384 If the parameter, C<$category>, isn't supplied, the current package name
389 See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
397 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
403 foreach my $word (@_) {
404 if ($word eq 'FATAL') {
407 elsif ($catmask = $Bits{$word}) {
409 $mask |= $DeadBits{$word} if $fatal ;
412 { croak("unknown warnings category '$word'")}
420 ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
425 my $mask = ${^WARNING_BITS} ;
426 if (vec($mask, $Offsets{'all'}, 1)) {
427 $mask = $Bits{'all'} ;
428 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
430 ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
435 croak("Usage: warnings::enabled([category])")
436 unless @_ == 1 || @_ == 0 ;
437 local $Carp::CarpLevel = 1 ;
440 my $callers_bitmask = (caller(1))[9] ;
441 return 0 unless defined $callers_bitmask ;
445 # check the category supplied.
447 $offset = $Offsets{$category};
448 croak("unknown warnings category '$category'")
449 unless defined $offset;
452 $category = (caller(0))[0] ;
453 $offset = $Offsets{$category};
454 croak("package '$category' not registered for warnings")
455 unless defined $offset ;
458 return vec($callers_bitmask, $offset, 1) ||
459 vec($callers_bitmask, $Offsets{'all'}, 1) ;
465 croak("Usage: warnings::warn([category,] 'message')")
466 unless @_ == 2 || @_ == 1 ;
467 local $Carp::CarpLevel = 1 ;
470 my $callers_bitmask = (caller(1))[9] ;
474 $offset = $Offsets{$category};
475 croak("unknown warnings category '$category'")
476 unless defined $offset ;
479 $category = (caller(0))[0] ;
480 $offset = $Offsets{$category};
481 croak("package '$category' not registered for warnings")
482 unless defined $offset ;
485 my $message = shift ;
487 if vec($callers_bitmask, $offset+1, 1) ||
488 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;