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