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