This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
9149f691949cd5fe6bb0743b5b9509c65eafc98e
[perl5.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 Croaker
526 {
527     delete $Carp::CarpInternal{'warnings'};
528     croak @_ ;
529 }
530
531 sub bits {
532     my $mask ;
533     my $catmask ;
534     my $fatal = 0 ;
535     foreach my $word (@_) {
536         if  ($word eq 'FATAL') {
537             $fatal = 1;
538         }
539         elsif ($catmask = $Bits{$word}) {
540             $mask |= $catmask ;
541             $mask |= $DeadBits{$word} if $fatal ;
542         }
543         else
544           { Croaker("Unknown warnings category '$word'")}
545     }
546
547     return $mask ;
548 }
549
550 sub import {
551     shift;
552     my $mask = ${^WARNING_BITS} ;
553     if (vec($mask, $Offsets{'all'}, 1)) {
554         $mask |= $Bits{'all'} ;
555         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
556     }
557     ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
558 }
559
560 sub unimport {
561     shift;
562     my $mask = ${^WARNING_BITS} ;
563     if (vec($mask, $Offsets{'all'}, 1)) {
564         $mask |= $Bits{'all'} ;
565         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
566     }
567     ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
568 }
569
570 sub __chk
571 {
572     my $category ;
573     my $offset ;
574     my $isobj = 0 ;
575
576     if (@_) {
577         # check the category supplied.
578         $category = shift ;
579         if (ref $category) {
580             Croaker ("not an object")
581                 if $category !~ /^([^=]+)=/ ;
582             $category = $1 ;
583             $isobj = 1 ;
584         }
585         $offset = $Offsets{$category};
586         Croaker("Unknown warnings category '$category'")
587             unless defined $offset;
588     }
589     else {
590         $category = (caller(1))[0] ;
591         $offset = $Offsets{$category};
592         Croaker("package '$category' not registered for warnings")
593             unless defined $offset ;
594     }
595
596     my $this_pkg = (caller(1))[0] ;
597     my $i = 2 ;
598     my $pkg ;
599
600     if ($isobj) {
601         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
602             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
603         }
604         $i -= 2 ;
605     }
606     else {
607         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
608             last if $pkg ne $this_pkg ;
609         }
610         $i = 2
611             if !$pkg || $pkg eq $this_pkg ;
612     }
613
614     my $callers_bitmask = (caller($i))[9] ;
615     return ($callers_bitmask, $offset, $i) ;
616 }
617
618 sub enabled
619 {
620     Croaker("Usage: warnings::enabled([category])")
621         unless @_ == 1 || @_ == 0 ;
622
623     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
624
625     return 0 unless defined $callers_bitmask ;
626     return vec($callers_bitmask, $offset, 1) ||
627            vec($callers_bitmask, $Offsets{'all'}, 1) ;
628 }
629
630
631 sub warn
632 {
633     Croaker("Usage: warnings::warn([category,] 'message')")
634         unless @_ == 2 || @_ == 1 ;
635
636     my $message = pop ;
637     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
638     croak($message)
639         if vec($callers_bitmask, $offset+1, 1) ||
640            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
641     carp($message) ;
642 }
643
644 sub warnif
645 {
646     Croaker("Usage: warnings::warnif([category,] 'message')")
647         unless @_ == 2 || @_ == 1 ;
648
649     my $message = pop ;
650     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
651
652     return
653         unless defined $callers_bitmask &&
654                 (vec($callers_bitmask, $offset, 1) ||
655                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
656
657     croak($message)
658         if vec($callers_bitmask, $offset+1, 1) ||
659            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
660
661     carp($message) ;
662 }
663 1;