This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
7d988cbd992f6ff9bc08fb1e8335f06d2ef13a49
[perl5.git] / lib / warnings.pm
1 # -*- buffer-read-only: t -*-
2 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
3 # This file is built by regen/warnings.pl.
4 # Any changes made here will be lost!
5
6 package warnings;
7
8 our $VERSION = '1.18';
9
10 # Verify that we're called correctly so that warnings will work.
11 # see also strict.pm.
12 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
13     my (undef, $f, $l) = caller;
14     die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
15 }
16
17 =head1 NAME
18
19 warnings - Perl pragma to control optional warnings
20
21 =head1 SYNOPSIS
22
23     use warnings;
24     no warnings;
25
26     use warnings "all";
27     no warnings "all";
28
29     use warnings::register;
30     if (warnings::enabled()) {
31         warnings::warn("some warning");
32     }
33
34     if (warnings::enabled("void")) {
35         warnings::warn("void", "some warning");
36     }
37
38     if (warnings::enabled($object)) {
39         warnings::warn($object, "some warning");
40     }
41
42     warnings::warnif("some warning");
43     warnings::warnif("void", "some warning");
44     warnings::warnif($object, "some warning");
45
46 =head1 DESCRIPTION
47
48 The C<warnings> pragma is a replacement for the command line flag C<-w>,
49 but the pragma is limited to the enclosing block, while the flag is global.
50 See L<perllexwarn> for more information and the list of built-in warning
51 categories.
52
53 If no import list is supplied, all possible warnings are either enabled
54 or disabled.
55
56 A number of functions are provided to assist module authors.
57
58 =over 4
59
60 =item use warnings::register
61
62 Creates a new warnings category with the same name as the package where
63 the call to the pragma is used.
64
65 =item warnings::enabled()
66
67 Use the warnings category with the same name as the current package.
68
69 Return TRUE if that warnings category is enabled in the calling module.
70 Otherwise returns FALSE.
71
72 =item warnings::enabled($category)
73
74 Return TRUE if the warnings category, C<$category>, is enabled in the
75 calling module.
76 Otherwise returns FALSE.
77
78 =item warnings::enabled($object)
79
80 Use the name of the class for the object reference, C<$object>, as the
81 warnings category.
82
83 Return TRUE if that warnings category is enabled in the first scope
84 where the object is used.
85 Otherwise returns FALSE.
86
87 =item warnings::fatal_enabled()
88
89 Return TRUE if the warnings category with the same name as the current
90 package has been set to FATAL in the calling module.
91 Otherwise returns FALSE.
92
93 =item warnings::fatal_enabled($category)
94
95 Return TRUE if the warnings category C<$category> has been set to FATAL in
96 the calling module.
97 Otherwise returns FALSE.
98
99 =item warnings::fatal_enabled($object)
100
101 Use the name of the class for the object reference, C<$object>, as the
102 warnings category.
103
104 Return TRUE if that warnings category has been set to FATAL in the first
105 scope where the object is used.
106 Otherwise returns FALSE.
107
108 =item warnings::warn($message)
109
110 Print C<$message> to STDERR.
111
112 Use the warnings category with the same name as the current package.
113
114 If that warnings category has been set to "FATAL" in the calling module
115 then die. Otherwise return.
116
117 =item warnings::warn($category, $message)
118
119 Print C<$message> to STDERR.
120
121 If the warnings category, C<$category>, has been set to "FATAL" in the
122 calling module then die. Otherwise return.
123
124 =item warnings::warn($object, $message)
125
126 Print C<$message> to STDERR.
127
128 Use the name of the class for the object reference, C<$object>, as the
129 warnings category.
130
131 If that warnings category has been set to "FATAL" in the scope where C<$object>
132 is first used then die. Otherwise return.
133
134
135 =item warnings::warnif($message)
136
137 Equivalent to:
138
139     if (warnings::enabled())
140       { warnings::warn($message) }
141
142 =item warnings::warnif($category, $message)
143
144 Equivalent to:
145
146     if (warnings::enabled($category))
147       { warnings::warn($category, $message) }
148
149 =item warnings::warnif($object, $message)
150
151 Equivalent to:
152
153     if (warnings::enabled($object))
154       { warnings::warn($object, $message) }
155
156 =item warnings::register_categories(@names)
157
158 This registers warning categories for the given names and is primarily for
159 use by the warnings::register pragma, for which see L<perllexwarn>.
160
161 =back
162
163 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
164
165 =cut
166
167 our %Offsets = (
168
169     # Warnings Categories added in Perl 5.008
170
171     'all'               => 0,
172     'closure'           => 2,
173     'deprecated'        => 4,
174     'exiting'           => 6,
175     'glob'              => 8,
176     'io'                => 10,
177     'closed'            => 12,
178     'exec'              => 14,
179     'layer'             => 16,
180     'newline'           => 18,
181     'pipe'              => 20,
182     'unopened'          => 22,
183     'misc'              => 24,
184     'numeric'           => 26,
185     'once'              => 28,
186     'overflow'          => 30,
187     'pack'              => 32,
188     'portable'          => 34,
189     'recursion'         => 36,
190     'redefine'          => 38,
191     'regexp'            => 40,
192     'severe'            => 42,
193     'debugging'         => 44,
194     'inplace'           => 46,
195     'internal'          => 48,
196     'malloc'            => 50,
197     'signal'            => 52,
198     'substr'            => 54,
199     'syntax'            => 56,
200     'ambiguous'         => 58,
201     'bareword'          => 60,
202     'digit'             => 62,
203     'parenthesis'       => 64,
204     'precedence'        => 66,
205     'printf'            => 68,
206     'prototype'         => 70,
207     'qw'                => 72,
208     'reserved'          => 74,
209     'semicolon'         => 76,
210     'taint'             => 78,
211     'threads'           => 80,
212     'uninitialized'     => 82,
213     'unpack'            => 84,
214     'untie'             => 86,
215     'utf8'              => 88,
216     'void'              => 90,
217
218     # Warnings Categories added in Perl 5.011
219
220     'imprecision'       => 92,
221     'illegalproto'      => 94,
222
223     # Warnings Categories added in Perl 5.013
224
225     'non_unicode'       => 96,
226     'nonchar'           => 98,
227     'surrogate'         => 100,
228
229     # Warnings Categories added in Perl 5.017
230
231     'experimental'      => 102,
232     'experimental::lexical_subs'=> 104,
233     'experimental::lexical_topic'=> 106,
234     'experimental::regex_sets'=> 108,
235     'experimental::smartmatch'=> 110,
236   );
237
238 our %Bits = (
239     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..55]
240     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [29]
241     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [30]
242     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
243     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
244     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
245     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
246     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [31]
247     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
248     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
249     'experimental'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55", # [51..55]
250     'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [52]
251     'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [53]
252     'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [54]
253     'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [55]
254     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
255     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [47]
256     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [46]
257     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
258     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [24]
259     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
260     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
261     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [25]
262     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
263     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
264     'non_unicode'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [48]
265     'nonchar'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [49]
266     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
267     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
268     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
269     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
270     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [32]
271     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
272     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
273     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [33]
274     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [34]
275     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [35]
276     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [36]
277     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
278     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
279     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
280     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [37]
281     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [38]
282     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00", # [21..25]
283     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [26]
284     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [27]
285     'surrogate'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [50]
286     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00", # [28..38,47]
287     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [39]
288     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [40]
289     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [41]
290     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
291     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [42]
292     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [43]
293     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00", # [44,48..50]
294     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [45]
295   );
296
297 our %DeadBits = (
298     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..55]
299     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [29]
300     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [30]
301     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
302     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
303     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
304     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
305     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [31]
306     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
307     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
308     'experimental'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa", # [51..55]
309     'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [52]
310     'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [53]
311     'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [54]
312     'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [55]
313     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
314     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [47]
315     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [46]
316     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
317     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [24]
318     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
319     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
320     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [25]
321     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
322     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
323     'non_unicode'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [48]
324     'nonchar'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [49]
325     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
326     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
327     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
328     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
329     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [32]
330     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
331     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
332     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [33]
333     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [34]
334     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [35]
335     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [36]
336     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
337     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
338     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
339     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [37]
340     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [38]
341     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00", # [21..25]
342     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [26]
343     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [27]
344     'surrogate'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [50]
345     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00", # [28..38,47]
346     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [39]
347     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [40]
348     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [41]
349     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
350     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [42]
351     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [43]
352     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00", # [44,48..50]
353     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [45]
354   );
355
356 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
357 $DEFAULT  = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55", # [2,52..55,4,22,23,25]
358 $LAST_BIT = 112 ;
359 $BYTES    = 14 ;
360
361 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
362
363 sub Croaker
364 {
365     require Carp; # this initializes %CarpInternal
366     local $Carp::CarpInternal{'warnings'};
367     delete $Carp::CarpInternal{'warnings'};
368     Carp::croak(@_);
369 }
370
371 sub _bits {
372     my $mask = shift ;
373     my $catmask ;
374     my $fatal = 0 ;
375     my $no_fatal = 0 ;
376
377     foreach my $word ( @_ ) {
378         if ($word eq 'FATAL') {
379             $fatal = 1;
380             $no_fatal = 0;
381         }
382         elsif ($word eq 'NONFATAL') {
383             $fatal = 0;
384             $no_fatal = 1;
385         }
386         elsif ($catmask = $Bits{$word}) {
387             $mask |= $catmask ;
388             $mask |= $DeadBits{$word} if $fatal ;
389             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
390         }
391         else
392           { Croaker("Unknown warnings category '$word'")}
393     }
394
395     return $mask ;
396 }
397
398 sub bits
399 {
400     # called from B::Deparse.pm
401     push @_, 'all' unless @_ ;
402     return _bits(undef, @_) ;
403 }
404
405 sub import 
406 {
407     shift;
408
409     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
410
411     if (vec($mask, $Offsets{'all'}, 1)) {
412         $mask |= $Bits{'all'} ;
413         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
414     }
415     
416     # Empty @_ is equivalent to @_ = 'all' ;
417     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
418 }
419
420 sub unimport 
421 {
422     shift;
423
424     my $catmask ;
425     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
426
427     if (vec($mask, $Offsets{'all'}, 1)) {
428         $mask |= $Bits{'all'} ;
429         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
430     }
431
432     push @_, 'all' unless @_;
433
434     foreach my $word ( @_ ) {
435         if ($word eq 'FATAL') {
436             next; 
437         }
438         elsif ($catmask = $Bits{$word}) {
439             $mask &= ~($catmask | $DeadBits{$word} | $All);
440         }
441         else
442           { Croaker("Unknown warnings category '$word'")}
443     }
444
445     ${^WARNING_BITS} = $mask ;
446 }
447
448 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
449
450 sub MESSAGE () { 4 };
451 sub FATAL () { 2 };
452 sub NORMAL () { 1 };
453
454 sub __chk
455 {
456     my $category ;
457     my $offset ;
458     my $isobj = 0 ;
459     my $wanted = shift;
460     my $has_message = $wanted & MESSAGE;
461
462     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
463         my $sub = (caller 1)[3];
464         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
465         Croaker("Usage: $sub($syntax)");
466     }
467
468     my $message = pop if $has_message;
469
470     if (@_) {
471         # check the category supplied.
472         $category = shift ;
473         if (my $type = ref $category) {
474             Croaker("not an object")
475                 if exists $builtin_type{$type};
476             $category = $type;
477             $isobj = 1 ;
478         }
479         $offset = $Offsets{$category};
480         Croaker("Unknown warnings category '$category'")
481             unless defined $offset;
482     }
483     else {
484         $category = (caller(1))[0] ;
485         $offset = $Offsets{$category};
486         Croaker("package '$category' not registered for warnings")
487             unless defined $offset ;
488     }
489
490     my $i;
491
492     if ($isobj) {
493         my $pkg;
494         $i = 2;
495         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
496             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
497         }
498         $i -= 2 ;
499     }
500     else {
501         $i = _error_loc(); # see where Carp will allocate the error
502     }
503
504     # Default to 0 if caller returns nothing.  Default to $DEFAULT if it
505     # explicitly returns undef.
506     my(@callers_bitmask) = (caller($i))[9] ;
507     my $callers_bitmask =
508          @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
509
510     my @results;
511     foreach my $type (FATAL, NORMAL) {
512         next unless $wanted & $type;
513
514         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
515                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
516     }
517
518     # &enabled and &fatal_enabled
519     return $results[0] unless $has_message;
520
521     # &warnif, and the category is neither enabled as warning nor as fatal
522     return if $wanted == (NORMAL | FATAL | MESSAGE)
523         && !($results[0] || $results[1]);
524
525     require Carp;
526     Carp::croak($message) if $results[0];
527     # will always get here for &warn. will only get here for &warnif if the
528     # category is enabled
529     Carp::carp($message);
530 }
531
532 sub _mkMask
533 {
534     my ($bit) = @_;
535     my $mask = "";
536
537     vec($mask, $bit, 1) = 1;
538     return $mask;
539 }
540
541 sub register_categories
542 {
543     my @names = @_;
544
545     for my $name (@names) {
546         if (! defined $Bits{$name}) {
547             $Bits{$name}     = _mkMask($LAST_BIT);
548             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
549             $Offsets{$name}  = $LAST_BIT ++;
550             foreach my $k (keys %Bits) {
551                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
552             }
553             $DeadBits{$name} = _mkMask($LAST_BIT);
554             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
555         }
556     }
557 }
558
559 sub _error_loc {
560     require Carp;
561     goto &Carp::short_error_loc; # don't introduce another stack frame
562 }
563
564 sub enabled
565 {
566     return __chk(NORMAL, @_);
567 }
568
569 sub fatal_enabled
570 {
571     return __chk(FATAL, @_);
572 }
573
574 sub warn
575 {
576     return __chk(FATAL | MESSAGE, @_);
577 }
578
579 sub warnif
580 {
581     return __chk(NORMAL | FATAL | MESSAGE, @_);
582 }
583
584 # These are not part of any public interface, so we can delete them to save
585 # space.
586 delete @warnings::{qw(NORMAL FATAL MESSAGE)};
587
588 1;
589
590 # ex: set ro: