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