Remove Encode::Tcl::Extended, suggested by
[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                                 'printf'        => DEFAULT_OFF,
31                                 'prototype'     => DEFAULT_OFF,
32                                 'qw'            => DEFAULT_OFF,
33                            },
34         'severe'        => {    'inplace'       => DEFAULT_ON,
35                                 'internal'      => DEFAULT_ON,
36                                 'debugging'     => DEFAULT_ON,
37                                 'malloc'        => DEFAULT_ON,
38                            },
39         'deprecated'    => DEFAULT_OFF,
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 mkHexOct
147 {
148     my ($f, $max, @a) = @_ ;
149     my $mask = "\x00" x $max ;
150     my $string = "" ;
151
152     foreach (@a) {
153         vec($mask, $_, 1) = 1 ;
154     }
155
156     foreach (unpack("C*", $mask)) {
157         if ($f eq 'x') {
158             $string .= '\x' . sprintf("%2.2x", $_)
159         }
160         else {
161             $string .= '\\' . sprintf("%o", $_)
162         }
163     }
164     return $string ;
165 }
166
167 sub mkHex
168 {
169     my($max, @a) = @_;
170     return mkHexOct("x", $max, @a);
171 }
172
173 sub mkOct
174 {
175     my($max, @a) = @_;
176     return mkHexOct("o", $max, @a);
177 }
178
179 ###########################################################################
180
181 if (@ARGV && $ARGV[0] eq "tree")
182 {
183     #print "  all -+\n" ;
184     printTree($tree, "   ", 4) ;
185     exit ;
186 }
187
188 unlink "warnings.h";
189 unlink "lib/warnings.pm";
190 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
191 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
192
193 print WARN <<'EOM' ;
194 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
195    This file is built by warnings.pl
196    Any changes made here will be lost!
197 */
198
199
200 #define Off(x)                  ((x) / 8)
201 #define Bit(x)                  (1 << ((x) % 8))
202 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
203
204
205 #define G_WARN_OFF              0       /* $^W == 0 */
206 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
207 #define G_WARN_ALL_ON           2       /* -W flag */
208 #define G_WARN_ALL_OFF          4       /* -X flag */
209 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
210 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
211
212 #define pWARN_STD               Nullsv
213 #define pWARN_ALL               (Nullsv+1)      /* use warnings 'all' */
214 #define pWARN_NONE              (Nullsv+2)      /* no  warnings 'all' */
215
216 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
217                                  (x) == pWARN_NONE)
218 EOM
219
220 my $offset = 0 ;
221
222 $index = $offset ;
223 #@{ $list{"all"} } = walk ($tree) ;
224 walk ($tree) ;
225
226 die <<EOM if $index > 255 ;
227 Too many warnings categories -- max is 255
228     rewrite packWARN* & unpackWARN* macros 
229 EOM
230
231 $index *= 2 ;
232 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
233
234 my $k ;
235 foreach $k (sort { $a <=> $b } keys %Value) {
236     print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
237 }
238 print WARN "\n" ;
239
240 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
241 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
242 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
243 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
244 my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
245
246 print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
247
248 print WARN <<'EOM';
249
250 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
251 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
252 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
253 #define isWARN_on(c,x)  (IsSet(SvPVX(c), 2*(x)))
254 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
255
256 #define ckWARN(x)                                                       \
257         ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&     \
258               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
259                isWARN_on(PL_curcop->cop_warnings, x) ) )                \
260           || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
261
262 #define ckWARN2(x,y)                                                    \
263           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
264               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
265                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
266                 isWARN_on(PL_curcop->cop_warnings, y) ) )               \
267             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
268
269 #define ckWARN3(x,y,z)                                                  \
270           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
271               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
272                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
273                 isWARN_on(PL_curcop->cop_warnings, y)  ||               \
274                 isWARN_on(PL_curcop->cop_warnings, z) ) )               \
275             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
276
277 #define ckWARN4(x,y,z,t)                                                \
278           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
279               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
280                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
281                 isWARN_on(PL_curcop->cop_warnings, y)  ||               \
282                 isWARN_on(PL_curcop->cop_warnings, z)  ||               \
283                 isWARN_on(PL_curcop->cop_warnings, t) ) )               \
284             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
285
286 #define ckWARN_d(x)                                                     \
287           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
288              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
289               isWARN_on(PL_curcop->cop_warnings, x) ) )
290
291 #define ckWARN2_d(x,y)                                                  \
292           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
293              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
294                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
295                  isWARN_on(PL_curcop->cop_warnings, y) ) ) )
296
297 #define ckWARN3_d(x,y,z)                                                \
298           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
299              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
300                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
301                  isWARN_on(PL_curcop->cop_warnings, y)  ||              \
302                  isWARN_on(PL_curcop->cop_warnings, z) ) ) )
303
304 #define ckWARN4_d(x,y,z,t)                                              \
305           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
306              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
307                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
308                  isWARN_on(PL_curcop->cop_warnings, y)  ||              \
309                  isWARN_on(PL_curcop->cop_warnings, z)  ||              \
310                  isWARN_on(PL_curcop->cop_warnings, t) ) ) )
311
312 #define packWARN(a)             (a                                 )
313 #define packWARN2(a,b)          ((a) | (b)<<8                      )
314 #define packWARN3(a,b,c)        ((a) | (b)<<8 | (c) <<16           )
315 #define packWARN4(a,b,c,d)      ((a) | (b)<<8 | (c) <<16 | (d) <<24)
316
317 #define unpackWARN1(x)          ((x)        & 0xFF)
318 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
319 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
320 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
321
322 #define ckDEAD(x)                                                       \
323            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
324             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
325               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
326               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
327               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
328               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
329
330 /* end of file warnings.h */
331
332 EOM
333
334 close WARN ;
335
336 while (<DATA>) {
337     last if /^KEYWORDS$/ ;
338     print PM $_ ;
339 }
340
341 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
342
343 #my %Keys = map {lc $Value{$_}, $_} keys %Value ;
344
345 print PM "%Offsets = (\n" ;
346 foreach my $k (sort { $a <=> $b } keys %Value) {
347     my $v = lc $Value{$k} ;
348     $k *= 2 ;
349     print PM tab(4, "    '$v'"), "=> $k,\n" ;
350 }
351
352 print PM "  );\n\n" ;
353
354 print PM "%Bits = (\n" ;
355 foreach $k (sort keys  %list) {
356
357     my $v = $list{$k} ;
358     my @list = sort { $a <=> $b } @$v ;
359
360     print PM tab(4, "    '$k'"), '=> "',
361                 # mkHex($warn_size, @list),
362                 mkHex($warn_size, map $_ * 2 , @list),
363                 '", # [', mkRange(@list), "]\n" ;
364 }
365
366 print PM "  );\n\n" ;
367
368 print PM "%DeadBits = (\n" ;
369 foreach $k (sort keys  %list) {
370
371     my $v = $list{$k} ;
372     my @list = sort { $a <=> $b } @$v ;
373
374     print PM tab(4, "    '$k'"), '=> "',
375                 # mkHex($warn_size, @list),
376                 mkHex($warn_size, map $_ * 2 + 1 , @list),
377                 '", # [', mkRange(@list), "]\n" ;
378 }
379
380 print PM "  );\n\n" ;
381 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
382 print PM '$LAST_BIT = ' . "$index ;\n" ;
383 print PM '$BYTES    = ' . "$warn_size ;\n" ;
384 while (<DATA>) {
385     print PM $_ ;
386 }
387
388 close PM ;
389
390 __END__
391
392 # This file was created by warnings.pl
393 # Any changes made here will be lost.
394 #
395
396 package warnings;
397
398 our $VERSION = '1.00';
399
400 =head1 NAME
401
402 warnings - Perl pragma to control optional warnings
403
404 =head1 SYNOPSIS
405
406     use warnings;
407     no warnings;
408
409     use warnings "all";
410     no warnings "all";
411
412     use warnings::register;
413     if (warnings::enabled()) {
414         warnings::warn("some warning");
415     }
416
417     if (warnings::enabled("void")) {
418         warnings::warn("void", "some warning");
419     }
420
421     if (warnings::enabled($object)) {
422         warnings::warn($object, "some warning");
423     }
424
425     warnings::warnif("some warning");
426     warnings::warnif("void", "some warning");
427     warnings::warnif($object, "some warning");
428
429 =head1 DESCRIPTION
430
431 If no import list is supplied, all possible warnings are either enabled
432 or disabled.
433
434 A number of functions are provided to assist module authors.
435
436 =over 4
437
438 =item use warnings::register
439
440 Creates a new warnings category with the same name as the package where
441 the call to the pragma is used.
442
443 =item warnings::enabled()
444
445 Use the warnings category with the same name as the current package.
446
447 Return TRUE if that warnings category is enabled in the calling module.
448 Otherwise returns FALSE.
449
450 =item warnings::enabled($category)
451
452 Return TRUE if the warnings category, C<$category>, is enabled in the
453 calling module.
454 Otherwise returns FALSE.
455
456 =item warnings::enabled($object)
457
458 Use the name of the class for the object reference, C<$object>, as the
459 warnings category.
460
461 Return TRUE if that warnings category is enabled in the first scope
462 where the object is used.
463 Otherwise returns FALSE.
464
465 =item warnings::warn($message)
466
467 Print C<$message> to STDERR.
468
469 Use the warnings category with the same name as the current package.
470
471 If that warnings category has been set to "FATAL" in the calling module
472 then die. Otherwise return.
473
474 =item warnings::warn($category, $message)
475
476 Print C<$message> to STDERR.
477
478 If the warnings category, C<$category>, has been set to "FATAL" in the
479 calling module then die. Otherwise return.
480
481 =item warnings::warn($object, $message)
482
483 Print C<$message> to STDERR.
484
485 Use the name of the class for the object reference, C<$object>, as the
486 warnings category.
487
488 If that warnings category has been set to "FATAL" in the scope where C<$object>
489 is first used then die. Otherwise return.
490
491
492 =item warnings::warnif($message)
493
494 Equivalent to:
495
496     if (warnings::enabled())
497       { warnings::warn($message) }
498
499 =item warnings::warnif($category, $message)
500
501 Equivalent to:
502
503     if (warnings::enabled($category))
504       { warnings::warn($category, $message) }
505
506 =item warnings::warnif($object, $message)
507
508 Equivalent to:
509
510     if (warnings::enabled($object))
511       { warnings::warn($object, $message) }
512
513 =back
514
515 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
516
517 =cut
518
519 use Carp ;
520
521 KEYWORDS
522
523 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
524
525 sub bits {
526     my $mask ;
527     my $catmask ;
528     my $fatal = 0 ;
529     foreach my $word (@_) {
530         if  ($word eq 'FATAL') {
531             $fatal = 1;
532         }
533         elsif ($catmask = $Bits{$word}) {
534             $mask |= $catmask ;
535             $mask |= $DeadBits{$word} if $fatal ;
536         }
537         else
538           { croak("Unknown warnings category '$word'")}
539     }
540
541     return $mask ;
542 }
543
544 sub import {
545     shift;
546     my $mask = ${^WARNING_BITS} ;
547     if (vec($mask, $Offsets{'all'}, 1)) {
548         $mask |= $Bits{'all'} ;
549         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
550     }
551     ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
552 }
553
554 sub unimport {
555     shift;
556     my $mask = ${^WARNING_BITS} ;
557     if (vec($mask, $Offsets{'all'}, 1)) {
558         $mask |= $Bits{'all'} ;
559         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
560     }
561     ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
562 }
563
564 sub __chk
565 {
566     my $category ;
567     my $offset ;
568     my $isobj = 0 ;
569
570     if (@_) {
571         # check the category supplied.
572         $category = shift ;
573         if (ref $category) {
574             croak ("not an object")
575                 if $category !~ /^([^=]+)=/ ;
576             $category = $1 ;
577             $isobj = 1 ;
578         }
579         $offset = $Offsets{$category};
580         croak("Unknown warnings category '$category'")
581             unless defined $offset;
582     }
583     else {
584         $category = (caller(1))[0] ;
585         $offset = $Offsets{$category};
586         croak("package '$category' not registered for warnings")
587             unless defined $offset ;
588     }
589
590     my $this_pkg = (caller(1))[0] ;
591     my $i = 2 ;
592     my $pkg ;
593
594     if ($isobj) {
595         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
596             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
597         }
598         $i -= 2 ;
599     }
600     else {
601         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
602             last if $pkg ne $this_pkg ;
603         }
604         $i = 2
605             if !$pkg || $pkg eq $this_pkg ;
606     }
607
608     my $callers_bitmask = (caller($i))[9] ;
609     return ($callers_bitmask, $offset, $i) ;
610 }
611
612 sub enabled
613 {
614     croak("Usage: warnings::enabled([category])")
615         unless @_ == 1 || @_ == 0 ;
616
617     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
618
619     return 0 unless defined $callers_bitmask ;
620     return vec($callers_bitmask, $offset, 1) ||
621            vec($callers_bitmask, $Offsets{'all'}, 1) ;
622 }
623
624
625 sub warn
626 {
627     croak("Usage: warnings::warn([category,] 'message')")
628         unless @_ == 2 || @_ == 1 ;
629
630     my $message = pop ;
631     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
632     local $Carp::CarpLevel = $i ;
633     croak($message)
634         if vec($callers_bitmask, $offset+1, 1) ||
635            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
636     carp($message) ;
637 }
638
639 sub warnif
640 {
641     croak("Usage: warnings::warnif([category,] 'message')")
642         unless @_ == 2 || @_ == 1 ;
643
644     my $message = pop ;
645     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
646     local $Carp::CarpLevel = $i ;
647
648     return
649         unless defined $callers_bitmask &&
650                 (vec($callers_bitmask, $offset, 1) ||
651                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
652
653     croak($message)
654         if vec($callers_bitmask, $offset+1, 1) ||
655            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
656
657     carp($message) ;
658 }
659 1;