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