Let's not assume how much memory has been allocated
[p5sagit/p5-mst-13.2.git] / warnings.pl
1 #!/usr/bin/perl
2
3
4 $VERSION = '1.00';
5
6 BEGIN {
7   push @INC, './lib';
8 }
9 use strict ;
10
11 sub DEFAULT_ON  () { 1 }
12 sub DEFAULT_OFF () { 2 }
13
14 my $tree = {
15
16 'all' => {
17         'io'            => {    'pipe'          => DEFAULT_OFF,
18                                 'unopened'      => DEFAULT_OFF,
19                                 'closed'        => DEFAULT_OFF,
20                                 'newline'       => DEFAULT_OFF,
21                                 'exec'          => DEFAULT_OFF,
22                            },
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,
33                                 'qw'            => DEFAULT_OFF,
34                            },
35         'severe'        => {    'inplace'       => DEFAULT_ON,
36                                 'internal'      => DEFAULT_ON,
37                                 'debugging'     => DEFAULT_ON,
38                                 'malloc'        => DEFAULT_ON,
39                            },
40         'void'          => DEFAULT_OFF,
41         'recursion'     => DEFAULT_OFF,
42         'redefine'      => DEFAULT_OFF,
43         'numeric'       => DEFAULT_OFF,
44         'uninitialized' => DEFAULT_OFF,
45         'once'          => DEFAULT_OFF,
46         'misc'          => DEFAULT_OFF,
47         'regexp'        => DEFAULT_OFF,
48         'glob'          => DEFAULT_OFF,
49         'y2k'           => DEFAULT_OFF,
50         'untie'         => DEFAULT_OFF,
51         'substr'        => DEFAULT_OFF,
52         'taint'         => DEFAULT_OFF,
53         'signal'        => DEFAULT_OFF,
54         'closure'       => DEFAULT_OFF,
55         'overflow'      => DEFAULT_OFF,
56         'portable'      => DEFAULT_OFF,
57         'utf8'          => DEFAULT_OFF,
58         'exiting'       => DEFAULT_OFF,
59         'pack'          => DEFAULT_OFF,
60         'unpack'        => DEFAULT_OFF,
61          #'default'     => DEFAULT_ON,
62         }
63 } ;
64
65
66 ###########################################################################
67 sub tab {
68     my($l, $t) = @_;
69     $t .= "\t" x ($l - (length($t) + 1) / 8);
70     $t;
71 }
72
73 ###########################################################################
74
75 my %list ;
76 my %Value ;
77 my $index ;
78
79 sub walk
80 {
81     my $tre = shift ;
82     my @list = () ;
83     my ($k, $v) ;
84
85     foreach $k (sort keys %$tre) {
86         $v = $tre->{$k};
87         die "duplicate key $k\n" if defined $list{$k} ;
88         $Value{$index} = uc $k ;
89         push @{ $list{$k} }, $index ++ ;
90         if (ref $v)
91           { push (@{ $list{$k} }, walk ($v)) }
92         push @list, @{ $list{$k} } ;
93     }
94
95    return @list ;
96 }
97
98 ###########################################################################
99
100 sub mkRange
101 {
102     my @a = @_ ;
103     my @out = @a ;
104     my $i ;
105
106
107     for ($i = 1 ; $i < @a; ++ $i) {
108         $out[$i] = ".."
109           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
110     }
111
112     my $out = join(",",@out);
113
114     $out =~ s/,(\.\.,)+/../g ;
115     return $out;
116 }
117
118 ###########################################################################
119 sub printTree
120 {
121     my $tre = shift ;
122     my $prefix = shift ;
123     my $indent = shift ;
124     my ($k, $v) ;
125
126     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
127
128     $prefix .= " " x $indent ;
129     foreach $k (sort keys %$tre) {
130         $v = $tre->{$k};
131         print $prefix . "|\n" ;
132         print $prefix . "+- $k" ;
133         if (ref $v)
134         {
135             print " " . "-" x ($max - length $k ) . "+\n" ;
136             printTree ($v, $prefix . "|" , $max + $indent - 1)
137         }
138         else
139           { print "\n" }
140     }
141
142 }
143
144 ###########################################################################
145
146 sub mkHex
147 {
148     my ($max, @a) = @_ ;
149     my $mask = "\x00" x $max ;
150     my $string = "" ;
151
152     foreach (@a) {
153         vec($mask, $_, 1) = 1 ;
154     }
155
156     #$string = unpack("H$max", $mask) ;
157     #$string =~ s/(..)/\x$1/g;
158     foreach (unpack("C*", $mask)) {
159         $string .= '\x' . sprintf("%2.2x", $_) ;
160     }
161     return $string ;
162 }
163
164 ###########################################################################
165
166 if (@ARGV && $ARGV[0] eq "tree")
167 {
168     #print "  all -+\n" ;
169     printTree($tree, "   ", 4) ;
170     exit ;
171 }
172
173 unlink "warnings.h";
174 unlink "lib/warnings.pm";
175 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
176 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
177
178 print WARN <<'EOM' ;
179 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
180    This file is built by warnings.pl
181    Any changes made here will be lost!
182 */
183
184
185 #define Off(x)                  ((x) / 8)
186 #define Bit(x)                  (1 << ((x) % 8))
187 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
188
189
190 #define G_WARN_OFF              0       /* $^W == 0 */
191 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
192 #define G_WARN_ALL_ON           2       /* -W flag */
193 #define G_WARN_ALL_OFF          4       /* -X flag */
194 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
195 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
196
197 #define pWARN_STD               Nullsv
198 #define pWARN_ALL               (Nullsv+1)      /* use warnings 'all' */
199 #define pWARN_NONE              (Nullsv+2)      /* no  warnings 'all' */
200
201 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
202                                  (x) == pWARN_NONE)
203 EOM
204
205 my $offset = 0 ;
206
207 $index = $offset ;
208 #@{ $list{"all"} } = walk ($tree) ;
209 walk ($tree) ;
210
211
212 $index *= 2 ;
213 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
214
215 my $k ;
216 foreach $k (sort { $a <=> $b } keys %Value) {
217     print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
218 }
219 print WARN "\n" ;
220
221 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
222 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
223 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
224 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
225
226 print WARN <<'EOM';
227
228 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
229 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
230 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
231 #define isWARN_on(c,x)  (IsSet(SvPVX(c), 2*(x)))
232 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
233
234 #define ckDEAD(x)                                                       \
235            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
236             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
237               isWARNf_on(PL_curcop->cop_warnings, x)))
238
239 #define ckWARN(x)                                                       \
240         ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&     \
241               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
242                isWARN_on(PL_curcop->cop_warnings, x) ) )                \
243           || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
244
245 #define ckWARN2(x,y)                                                    \
246           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
247               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
248                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
249                 isWARN_on(PL_curcop->cop_warnings, y) ) )               \
250             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
251
252 #define ckWARN_d(x)                                                     \
253           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
254              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
255               isWARN_on(PL_curcop->cop_warnings, x) ) )
256
257 #define ckWARN2_d(x,y)                                                  \
258           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
259              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
260                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
261                  isWARN_on(PL_curcop->cop_warnings, y) ) ) )
262
263 /* end of file warnings.h */
264
265 EOM
266
267 close WARN ;
268
269 while (<DATA>) {
270     last if /^KEYWORDS$/ ;
271     print PM $_ ;
272 }
273
274 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
275
276 #my %Keys = map {lc $Value{$_}, $_} keys %Value ;
277
278 print PM "%Offsets = (\n" ;
279 foreach my $k (sort { $a <=> $b } keys %Value) {
280     my $v = lc $Value{$k} ;
281     $k *= 2 ;
282     print PM tab(4, "    '$v'"), "=> $k,\n" ;
283 }
284
285 print PM "  );\n\n" ;
286
287 print PM "%Bits = (\n" ;
288 foreach $k (sort keys  %list) {
289
290     my $v = $list{$k} ;
291     my @list = sort { $a <=> $b } @$v ;
292
293     print PM tab(4, "    '$k'"), '=> "',
294                 # mkHex($warn_size, @list),
295                 mkHex($warn_size, map $_ * 2 , @list),
296                 '", # [', mkRange(@list), "]\n" ;
297 }
298
299 print PM "  );\n\n" ;
300
301 print PM "%DeadBits = (\n" ;
302 foreach $k (sort keys  %list) {
303
304     my $v = $list{$k} ;
305     my @list = sort { $a <=> $b } @$v ;
306
307     print PM tab(4, "    '$k'"), '=> "',
308                 # mkHex($warn_size, @list),
309                 mkHex($warn_size, map $_ * 2 + 1 , @list),
310                 '", # [', mkRange(@list), "]\n" ;
311 }
312
313 print PM "  );\n\n" ;
314 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
315 print PM '$LAST_BIT = ' . "$index ;\n" ;
316 print PM '$BYTES    = ' . "$warn_size ;\n" ;
317 while (<DATA>) {
318     print PM $_ ;
319 }
320
321 close PM ;
322
323 __END__
324
325 # This file was created by warnings.pl
326 # Any changes made here will be lost.
327 #
328
329 package warnings;
330
331 our $VERSION = '1.00';
332
333 =head1 NAME
334
335 warnings - Perl pragma to control optional warnings
336
337 =head1 SYNOPSIS
338
339     use warnings;
340     no warnings;
341
342     use warnings "all";
343     no warnings "all";
344
345     use warnings::register;
346     if (warnings::enabled()) {
347         warnings::warn("some warning");
348     }
349
350     if (warnings::enabled("void")) {
351         warnings::warn("void", "some warning");
352     }
353
354     if (warnings::enabled($object)) {
355         warnings::warn($object, "some warning");
356     }
357
358     warnif("some warning");
359     warnif("void", "some warning");
360     warnif($object, "some warning");
361
362 =head1 DESCRIPTION
363
364 If no import list is supplied, all possible warnings are either enabled
365 or disabled.
366
367 A number of functions are provided to assist module authors.
368
369 =over 4
370
371 =item use warnings::register
372
373 Creates a new warnings category with the same name as the package where
374 the call to the pragma is used.
375
376 =item warnings::enabled()
377
378 Use the warnings category with the same name as the current package.
379
380 Return TRUE if that warnings category is enabled in the calling module.
381 Otherwise returns FALSE.
382
383 =item warnings::enabled($category)
384
385 Return TRUE if the warnings category, C<$category>, is enabled in the
386 calling module.
387 Otherwise returns FALSE.
388
389 =item warnings::enabled($object)
390
391 Use the name of the class for the object reference, C<$object>, as the
392 warnings category.
393
394 Return TRUE if that warnings category is enabled in the first scope
395 where the object is used.
396 Otherwise returns FALSE.
397
398 =item warnings::warn($message)
399
400 Print C<$message> to STDERR.
401
402 Use the warnings category with the same name as the current package.
403
404 If that warnings category has been set to "FATAL" in the calling module
405 then die. Otherwise return.
406
407 =item warnings::warn($category, $message)
408
409 Print C<$message> to STDERR.
410
411 If the warnings category, C<$category>, has been set to "FATAL" in the
412 calling module then die. Otherwise return.
413
414 =item warnings::warn($object, $message)
415
416 Print C<$message> to STDERR.
417
418 Use the name of the class for the object reference, C<$object>, as the
419 warnings category.
420
421 If that warnings category has been set to "FATAL" in the scope where C<$object>
422 is first used then die. Otherwise return.
423
424
425 =item warnings::warnif($message)
426
427 Equivalent to:
428
429     if (warnings::enabled())
430       { warnings::warn($message) }
431
432 =item warnings::warnif($category, $message)
433
434 Equivalent to:
435
436     if (warnings::enabled($category))
437       { warnings::warn($category, $message) }
438
439 =item warnings::warnif($object, $message)
440
441 Equivalent to:
442
443     if (warnings::enabled($object))
444       { warnings::warn($object, $message) }
445
446 =back
447
448 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
449
450 =cut
451
452 use Carp ;
453
454 KEYWORDS
455
456 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
457
458 sub bits {
459     my $mask ;
460     my $catmask ;
461     my $fatal = 0 ;
462     foreach my $word (@_) {
463         if  ($word eq 'FATAL') {
464             $fatal = 1;
465         }
466         elsif ($catmask = $Bits{$word}) {
467             $mask |= $catmask ;
468             $mask |= $DeadBits{$word} if $fatal ;
469         }
470         else
471           { croak("unknown warnings category '$word'")}
472     }
473
474     return $mask ;
475 }
476
477 sub import {
478     shift;
479     my $mask = ${^WARNING_BITS} ;
480     if (vec($mask, $Offsets{'all'}, 1)) {
481         $mask |= $Bits{'all'} ;
482         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
483     }
484     ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
485 }
486
487 sub unimport {
488     shift;
489     my $mask = ${^WARNING_BITS} ;
490     if (vec($mask, $Offsets{'all'}, 1)) {
491         $mask |= $Bits{'all'} ;
492         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
493     }
494     ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
495 }
496
497 sub __chk
498 {
499     my $category ;
500     my $offset ;
501     my $isobj = 0 ;
502
503     if (@_) {
504         # check the category supplied.
505         $category = shift ;
506         if (ref $category) {
507             croak ("not an object")
508                 if $category !~ /^([^=]+)=/ ;+
509             $category = $1 ;
510             $isobj = 1 ;
511         }
512         $offset = $Offsets{$category};
513         croak("unknown warnings category '$category'")
514             unless defined $offset;
515     }
516     else {
517         $category = (caller(1))[0] ;
518         $offset = $Offsets{$category};
519         croak("package '$category' not registered for warnings")
520             unless defined $offset ;
521     }
522
523     my $this_pkg = (caller(1))[0] ;
524     my $i = 2 ;
525     my $pkg ;
526
527     if ($isobj) {
528         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
529             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
530         }
531         $i -= 2 ;
532     }
533     else {
534         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
535             last if $pkg ne $this_pkg ;
536         }
537         $i = 2
538             if !$pkg || $pkg eq $this_pkg ;
539     }
540
541     my $callers_bitmask = (caller($i))[9] ;
542     return ($callers_bitmask, $offset, $i) ;
543 }
544
545 sub enabled
546 {
547     croak("Usage: warnings::enabled([category])")
548         unless @_ == 1 || @_ == 0 ;
549
550     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
551
552     return 0 unless defined $callers_bitmask ;
553     return vec($callers_bitmask, $offset, 1) ||
554            vec($callers_bitmask, $Offsets{'all'}, 1) ;
555 }
556
557
558 sub warn
559 {
560     croak("Usage: warnings::warn([category,] 'message')")
561         unless @_ == 2 || @_ == 1 ;
562
563     my $message = pop ;
564     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
565     local $Carp::CarpLevel = $i ;
566     croak($message)
567         if vec($callers_bitmask, $offset+1, 1) ||
568            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
569     carp($message) ;
570 }
571
572 sub warnif
573 {
574     croak("Usage: warnings::warnif([category,] 'message')")
575         unless @_ == 2 || @_ == 1 ;
576
577     my $message = pop ;
578     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
579     local $Carp::CarpLevel = $i ;
580
581     return
582         unless defined $callers_bitmask &&
583                 (vec($callers_bitmask, $offset, 1) ||
584                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
585
586     croak($message)
587         if vec($callers_bitmask, $offset+1, 1) ||
588            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
589
590     carp($message) ;
591 }
592 1;