This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
-t without -w
[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                                 '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 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
227 $index *= 2 ;
228 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
229
230 my $k ;
231 foreach $k (sort { $a <=> $b } keys %Value) {
232     print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
233 }
234 print WARN "\n" ;
235
236 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
237 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
238 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
239 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
240 my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
241
242 print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
243
244 print WARN <<'EOM';
245
246 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
247 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
248 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
249 #define isWARN_on(c,x)  (IsSet(SvPVX(c), 2*(x)))
250 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
251
252 #define ckDEAD(x)                                                       \
253            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
254             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
255               isWARNf_on(PL_curcop->cop_warnings, x)))
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 ckWARN_d(x)                                                     \
271           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
272              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
273               isWARN_on(PL_curcop->cop_warnings, x) ) )
274
275 #define ckWARN2_d(x,y)                                                  \
276           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
277              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
278                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
279                  isWARN_on(PL_curcop->cop_warnings, y) ) ) )
280
281 /* end of file warnings.h */
282
283 EOM
284
285 close WARN ;
286
287 while (<DATA>) {
288     last if /^KEYWORDS$/ ;
289     print PM $_ ;
290 }
291
292 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
293
294 #my %Keys = map {lc $Value{$_}, $_} keys %Value ;
295
296 print PM "%Offsets = (\n" ;
297 foreach my $k (sort { $a <=> $b } keys %Value) {
298     my $v = lc $Value{$k} ;
299     $k *= 2 ;
300     print PM tab(4, "    '$v'"), "=> $k,\n" ;
301 }
302
303 print PM "  );\n\n" ;
304
305 print PM "%Bits = (\n" ;
306 foreach $k (sort keys  %list) {
307
308     my $v = $list{$k} ;
309     my @list = sort { $a <=> $b } @$v ;
310
311     print PM tab(4, "    '$k'"), '=> "',
312                 # mkHex($warn_size, @list),
313                 mkHex($warn_size, map $_ * 2 , @list),
314                 '", # [', mkRange(@list), "]\n" ;
315 }
316
317 print PM "  );\n\n" ;
318
319 print PM "%DeadBits = (\n" ;
320 foreach $k (sort keys  %list) {
321
322     my $v = $list{$k} ;
323     my @list = sort { $a <=> $b } @$v ;
324
325     print PM tab(4, "    '$k'"), '=> "',
326                 # mkHex($warn_size, @list),
327                 mkHex($warn_size, map $_ * 2 + 1 , @list),
328                 '", # [', mkRange(@list), "]\n" ;
329 }
330
331 print PM "  );\n\n" ;
332 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
333 print PM '$LAST_BIT = ' . "$index ;\n" ;
334 print PM '$BYTES    = ' . "$warn_size ;\n" ;
335 while (<DATA>) {
336     print PM $_ ;
337 }
338
339 close PM ;
340
341 __END__
342
343 # This file was created by warnings.pl
344 # Any changes made here will be lost.
345 #
346
347 package warnings;
348
349 our $VERSION = '1.00';
350
351 =head1 NAME
352
353 warnings - Perl pragma to control optional warnings
354
355 =head1 SYNOPSIS
356
357     use warnings;
358     no warnings;
359
360     use warnings "all";
361     no warnings "all";
362
363     use warnings::register;
364     if (warnings::enabled()) {
365         warnings::warn("some warning");
366     }
367
368     if (warnings::enabled("void")) {
369         warnings::warn("void", "some warning");
370     }
371
372     if (warnings::enabled($object)) {
373         warnings::warn($object, "some warning");
374     }
375
376     warnif("some warning");
377     warnif("void", "some warning");
378     warnif($object, "some warning");
379
380 =head1 DESCRIPTION
381
382 If no import list is supplied, all possible warnings are either enabled
383 or disabled.
384
385 A number of functions are provided to assist module authors.
386
387 =over 4
388
389 =item use warnings::register
390
391 Creates a new warnings category with the same name as the package where
392 the call to the pragma is used.
393
394 =item warnings::enabled()
395
396 Use the warnings category with the same name as the current package.
397
398 Return TRUE if that warnings category is enabled in the calling module.
399 Otherwise returns FALSE.
400
401 =item warnings::enabled($category)
402
403 Return TRUE if the warnings category, C<$category>, is enabled in the
404 calling module.
405 Otherwise returns FALSE.
406
407 =item warnings::enabled($object)
408
409 Use the name of the class for the object reference, C<$object>, as the
410 warnings category.
411
412 Return TRUE if that warnings category is enabled in the first scope
413 where the object is used.
414 Otherwise returns FALSE.
415
416 =item warnings::warn($message)
417
418 Print C<$message> to STDERR.
419
420 Use the warnings category with the same name as the current package.
421
422 If that warnings category has been set to "FATAL" in the calling module
423 then die. Otherwise return.
424
425 =item warnings::warn($category, $message)
426
427 Print C<$message> to STDERR.
428
429 If the warnings category, C<$category>, has been set to "FATAL" in the
430 calling module then die. Otherwise return.
431
432 =item warnings::warn($object, $message)
433
434 Print C<$message> to STDERR.
435
436 Use the name of the class for the object reference, C<$object>, as the
437 warnings category.
438
439 If that warnings category has been set to "FATAL" in the scope where C<$object>
440 is first used then die. Otherwise return.
441
442
443 =item warnings::warnif($message)
444
445 Equivalent to:
446
447     if (warnings::enabled())
448       { warnings::warn($message) }
449
450 =item warnings::warnif($category, $message)
451
452 Equivalent to:
453
454     if (warnings::enabled($category))
455       { warnings::warn($category, $message) }
456
457 =item warnings::warnif($object, $message)
458
459 Equivalent to:
460
461     if (warnings::enabled($object))
462       { warnings::warn($object, $message) }
463
464 =back
465
466 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
467
468 =cut
469
470 use Carp ;
471
472 KEYWORDS
473
474 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
475
476 sub bits {
477     my $mask ;
478     my $catmask ;
479     my $fatal = 0 ;
480     foreach my $word (@_) {
481         if  ($word eq 'FATAL') {
482             $fatal = 1;
483         }
484         elsif ($catmask = $Bits{$word}) {
485             $mask |= $catmask ;
486             $mask |= $DeadBits{$word} if $fatal ;
487         }
488         else
489           { croak("unknown warnings category '$word'")}
490     }
491
492     return $mask ;
493 }
494
495 sub import {
496     shift;
497     my $mask = ${^WARNING_BITS} ;
498     if (vec($mask, $Offsets{'all'}, 1)) {
499         $mask |= $Bits{'all'} ;
500         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
501     }
502     ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
503 }
504
505 sub unimport {
506     shift;
507     my $mask = ${^WARNING_BITS} ;
508     if (vec($mask, $Offsets{'all'}, 1)) {
509         $mask |= $Bits{'all'} ;
510         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
511     }
512     ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
513 }
514
515 sub __chk
516 {
517     my $category ;
518     my $offset ;
519     my $isobj = 0 ;
520
521     if (@_) {
522         # check the category supplied.
523         $category = shift ;
524         if (ref $category) {
525             croak ("not an object")
526                 if $category !~ /^([^=]+)=/ ;+
527             $category = $1 ;
528             $isobj = 1 ;
529         }
530         $offset = $Offsets{$category};
531         croak("unknown warnings category '$category'")
532             unless defined $offset;
533     }
534     else {
535         $category = (caller(1))[0] ;
536         $offset = $Offsets{$category};
537         croak("package '$category' not registered for warnings")
538             unless defined $offset ;
539     }
540
541     my $this_pkg = (caller(1))[0] ;
542     my $i = 2 ;
543     my $pkg ;
544
545     if ($isobj) {
546         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
547             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
548         }
549         $i -= 2 ;
550     }
551     else {
552         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
553             last if $pkg ne $this_pkg ;
554         }
555         $i = 2
556             if !$pkg || $pkg eq $this_pkg ;
557     }
558
559     my $callers_bitmask = (caller($i))[9] ;
560     return ($callers_bitmask, $offset, $i) ;
561 }
562
563 sub enabled
564 {
565     croak("Usage: warnings::enabled([category])")
566         unless @_ == 1 || @_ == 0 ;
567
568     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
569
570     return 0 unless defined $callers_bitmask ;
571     return vec($callers_bitmask, $offset, 1) ||
572            vec($callers_bitmask, $Offsets{'all'}, 1) ;
573 }
574
575
576 sub warn
577 {
578     croak("Usage: warnings::warn([category,] 'message')")
579         unless @_ == 2 || @_ == 1 ;
580
581     my $message = pop ;
582     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
583     local $Carp::CarpLevel = $i ;
584     croak($message)
585         if vec($callers_bitmask, $offset+1, 1) ||
586            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
587     carp($message) ;
588 }
589
590 sub warnif
591 {
592     croak("Usage: warnings::warnif([category,] 'message')")
593         unless @_ == 2 || @_ == 1 ;
594
595     my $message = pop ;
596     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
597     local $Carp::CarpLevel = $i ;
598
599     return
600         unless defined $callers_bitmask &&
601                 (vec($callers_bitmask, $offset, 1) ||
602                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
603
604     croak($message)
605         if vec($callers_bitmask, $offset+1, 1) ||
606            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
607
608     carp($message) ;
609 }
610 1;