Commit | Line | Data |
---|---|---|
599cee73 PM |
1 | |
2 | # This file was created by warning.pl | |
3 | # Any changes made here will be lost. | |
4 | # | |
5 | ||
6 | package warning; | |
7 | ||
8 | =head1 NAME | |
9 | ||
6c67e1bb | 10 | warning - Perl pragma to control optional warnings |
599cee73 PM |
11 | |
12 | =head1 SYNOPSIS | |
13 | ||
14 | use warning; | |
0453d815 | 15 | no warning; |
599cee73 PM |
16 | |
17 | use warning "all"; | |
0453d815 | 18 | no warning "all"; |
599cee73 PM |
19 | |
20 | =head1 DESCRIPTION | |
21 | ||
0453d815 PM |
22 | If no import list is supplied, all possible warnings are either enabled |
23 | or disabled. | |
599cee73 | 24 | |
0453d815 | 25 | See L<perlmod/Pragmatic Modules> and L<perllexwarn>. |
599cee73 PM |
26 | |
27 | ||
28 | =cut | |
29 | ||
30 | use Carp ; | |
31 | ||
32 | %Bits = ( | |
0453d815 PM |
33 | 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..35] |
34 | 'ambiguous' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [16] | |
35 | 'closed' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [1] | |
627300f0 | 36 | 'closure' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [27] |
0453d815 PM |
37 | 'debugging' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [12] |
38 | 'deprecated' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [17] | |
627300f0 | 39 | 'digit' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [18] |
0453d815 PM |
40 | 'exec' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [2] |
41 | 'inplace' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [13] | |
42 | 'internal' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [14] | |
43 | 'io' => "\x55\x05\x00\x00\x00\x00\x00\x00\x00", # [0..5] | |
44 | 'misc' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [6] | |
45 | 'newline' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [3] | |
46 | 'numeric' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [7] | |
627300f0 | 47 | 'octal' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [19] |
0453d815 | 48 | 'once' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [8] |
627300f0 JH |
49 | 'overflow' => "\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [28] |
50 | 'parenthesis' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [20] | |
0453d815 | 51 | 'pipe' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [4] |
627300f0 JH |
52 | 'portable' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [29] |
53 | 'precedence' => "\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [21] | |
54 | 'printf' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [22] | |
0453d815 PM |
55 | 'recursion' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [9] |
56 | 'redefine' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [10] | |
627300f0 JH |
57 | 'reserved' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [23] |
58 | 'semicolon' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [24] | |
0453d815 | 59 | 'severe' => "\x00\x00\x40\x15\x00\x00\x00\x00\x00", # [11..14] |
627300f0 JH |
60 | 'signal' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [30] |
61 | 'substr' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [31] | |
62 | 'syntax' => "\x00\x00\x00\x40\x55\x55\x01\x00\x00", # [15..24] | |
63 | 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [32] | |
64 | 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [25] | |
0453d815 | 65 | 'unopened' => "\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [5] |
627300f0 JH |
66 | 'unsafe' => "\x00\x00\x00\x00\x00\x00\x50\x55\x15", # [26..34] |
67 | 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [33] | |
68 | 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [34] | |
69 | 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [35] | |
599cee73 PM |
70 | ); |
71 | ||
72 | %DeadBits = ( | |
0453d815 PM |
73 | 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..35] |
74 | 'ambiguous' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [16] | |
75 | 'closed' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [1] | |
627300f0 | 76 | 'closure' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [27] |
0453d815 PM |
77 | 'debugging' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [12] |
78 | 'deprecated' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [17] | |
627300f0 | 79 | 'digit' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [18] |
0453d815 PM |
80 | 'exec' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [2] |
81 | 'inplace' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [13] | |
82 | 'internal' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [14] | |
83 | 'io' => "\xaa\x0a\x00\x00\x00\x00\x00\x00\x00", # [0..5] | |
84 | 'misc' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [6] | |
85 | 'newline' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [3] | |
86 | 'numeric' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [7] | |
627300f0 | 87 | 'octal' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [19] |
0453d815 | 88 | 'once' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [8] |
627300f0 JH |
89 | 'overflow' => "\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [28] |
90 | 'parenthesis' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [20] | |
0453d815 | 91 | 'pipe' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [4] |
627300f0 JH |
92 | 'portable' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [29] |
93 | 'precedence' => "\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [21] | |
94 | 'printf' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [22] | |
0453d815 PM |
95 | 'recursion' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [9] |
96 | 'redefine' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [10] | |
627300f0 JH |
97 | 'reserved' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [23] |
98 | 'semicolon' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [24] | |
0453d815 | 99 | 'severe' => "\x00\x00\x80\x2a\x00\x00\x00\x00\x00", # [11..14] |
627300f0 JH |
100 | 'signal' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [30] |
101 | 'substr' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [31] | |
102 | 'syntax' => "\x00\x00\x00\x80\xaa\xaa\x02\x00\x00", # [15..24] | |
103 | 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [32] | |
104 | 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [25] | |
0453d815 | 105 | 'unopened' => "\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [5] |
627300f0 JH |
106 | 'unsafe' => "\x00\x00\x00\x00\x00\x00\xa0\xaa\x2a", # [26..34] |
107 | 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [33] | |
108 | 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [34] | |
109 | 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [35] | |
599cee73 PM |
110 | ); |
111 | ||
112 | ||
113 | sub bits { | |
114 | my $mask ; | |
115 | my $catmask ; | |
116 | my $fatal = 0 ; | |
117 | foreach my $word (@_) { | |
118 | if ($word eq 'FATAL') | |
119 | { $fatal = 1 } | |
120 | elsif ($catmask = $Bits{$word}) { | |
121 | $mask |= $catmask ; | |
122 | $mask |= $DeadBits{$word} if $fatal ; | |
123 | } | |
124 | else | |
125 | { croak "unknown warning category '$word'" } | |
126 | } | |
127 | ||
128 | return $mask ; | |
129 | } | |
130 | ||
131 | sub import { | |
132 | shift; | |
133 | $^B |= bits(@_ ? @_ : 'all') ; | |
134 | } | |
135 | ||
136 | sub unimport { | |
137 | shift; | |
138 | $^B &= ~ bits(@_ ? @_ : 'all') ; | |
139 | } | |
140 | ||
141 | ||
142 | sub make_fatal | |
143 | { | |
144 | my $self = shift ; | |
145 | my $bitmask = $self->bits(@_) ; | |
146 | $SIG{__WARN__} = | |
147 | sub | |
148 | { | |
149 | die @_ if $^B & $bitmask ; | |
150 | warn @_ | |
151 | } ; | |
152 | } | |
153 | ||
154 | sub bitmask | |
155 | { | |
156 | return $^B ; | |
157 | } | |
158 | ||
159 | sub enabled | |
160 | { | |
161 | my $string = shift ; | |
162 | ||
163 | return 1 | |
164 | if $bits{$string} && $^B & $bits{$string} ; | |
165 | ||
166 | return 0 ; | |
167 | } | |
168 | ||
169 | 1; |