This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
put an experimental warning on lexical topic
[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.17';
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   );
236
237 our %Bits = (
238     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..54]
239     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [29]
240     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [30]
241     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
242     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
243     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
244     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
245     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [31]
246     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
247     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
248     'experimental'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x15", # [51..54]
249     'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [52]
250     'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [53]
251     'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [54]
252     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
253     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [47]
254     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [46]
255     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
256     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [24]
257     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
258     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
259     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [25]
260     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
261     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
262     'non_unicode'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [48]
263     'nonchar'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [49]
264     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
265     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
266     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
267     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
268     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [32]
269     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
270     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
271     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [33]
272     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [34]
273     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [35]
274     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [36]
275     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
276     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
277     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
278     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [37]
279     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [38]
280     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00", # [21..25]
281     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [26]
282     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [27]
283     'surrogate'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [50]
284     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00", # [28..38,47]
285     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [39]
286     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [40]
287     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [41]
288     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
289     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [42]
290     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [43]
291     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00", # [44,48..50]
292     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [45]
293   );
294
295 our %DeadBits = (
296     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..54]
297     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [29]
298     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [30]
299     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
300     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
301     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
302     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
303     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [31]
304     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
305     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
306     'experimental'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x2a", # [51..54]
307     'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [52]
308     'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [53]
309     'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [54]
310     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
311     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [47]
312     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [46]
313     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
314     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [24]
315     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
316     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
317     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [25]
318     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
319     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
320     'non_unicode'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [48]
321     'nonchar'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [49]
322     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
323     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
324     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
325     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
326     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [32]
327     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
328     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
329     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [33]
330     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [34]
331     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [35]
332     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [36]
333     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
334     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
335     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
336     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [37]
337     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [38]
338     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00", # [21..25]
339     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [26]
340     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [27]
341     'surrogate'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [50]
342     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00", # [28..38,47]
343     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [39]
344     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [40]
345     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [41]
346     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
347     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [42]
348     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [43]
349     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00", # [44,48..50]
350     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [45]
351   );
352
353 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
354 $DEFAULT  = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x15", # [2,52..54,4,22,23,25]
355 $LAST_BIT = 110 ;
356 $BYTES    = 14 ;
357
358 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
359
360 sub Croaker
361 {
362     require Carp; # this initializes %CarpInternal
363     local $Carp::CarpInternal{'warnings'};
364     delete $Carp::CarpInternal{'warnings'};
365     Carp::croak(@_);
366 }
367
368 sub _bits {
369     my $mask = shift ;
370     my $catmask ;
371     my $fatal = 0 ;
372     my $no_fatal = 0 ;
373
374     foreach my $word ( @_ ) {
375         if ($word eq 'FATAL') {
376             $fatal = 1;
377             $no_fatal = 0;
378         }
379         elsif ($word eq 'NONFATAL') {
380             $fatal = 0;
381             $no_fatal = 1;
382         }
383         elsif ($catmask = $Bits{$word}) {
384             $mask |= $catmask ;
385             $mask |= $DeadBits{$word} if $fatal ;
386             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
387         }
388         else
389           { Croaker("Unknown warnings category '$word'")}
390     }
391
392     return $mask ;
393 }
394
395 sub bits
396 {
397     # called from B::Deparse.pm
398     push @_, 'all' unless @_ ;
399     return _bits(undef, @_) ;
400 }
401
402 sub import 
403 {
404     shift;
405
406     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
407
408     if (vec($mask, $Offsets{'all'}, 1)) {
409         $mask |= $Bits{'all'} ;
410         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
411     }
412     
413     # Empty @_ is equivalent to @_ = 'all' ;
414     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
415 }
416
417 sub unimport 
418 {
419     shift;
420
421     my $catmask ;
422     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
423
424     if (vec($mask, $Offsets{'all'}, 1)) {
425         $mask |= $Bits{'all'} ;
426         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
427     }
428
429     push @_, 'all' unless @_;
430
431     foreach my $word ( @_ ) {
432         if ($word eq 'FATAL') {
433             next; 
434         }
435         elsif ($catmask = $Bits{$word}) {
436             $mask &= ~($catmask | $DeadBits{$word} | $All);
437         }
438         else
439           { Croaker("Unknown warnings category '$word'")}
440     }
441
442     ${^WARNING_BITS} = $mask ;
443 }
444
445 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
446
447 sub MESSAGE () { 4 };
448 sub FATAL () { 2 };
449 sub NORMAL () { 1 };
450
451 sub __chk
452 {
453     my $category ;
454     my $offset ;
455     my $isobj = 0 ;
456     my $wanted = shift;
457     my $has_message = $wanted & MESSAGE;
458
459     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
460         my $sub = (caller 1)[3];
461         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
462         Croaker("Usage: $sub($syntax)");
463     }
464
465     my $message = pop if $has_message;
466
467     if (@_) {
468         # check the category supplied.
469         $category = shift ;
470         if (my $type = ref $category) {
471             Croaker("not an object")
472                 if exists $builtin_type{$type};
473             $category = $type;
474             $isobj = 1 ;
475         }
476         $offset = $Offsets{$category};
477         Croaker("Unknown warnings category '$category'")
478             unless defined $offset;
479     }
480     else {
481         $category = (caller(1))[0] ;
482         $offset = $Offsets{$category};
483         Croaker("package '$category' not registered for warnings")
484             unless defined $offset ;
485     }
486
487     my $i;
488
489     if ($isobj) {
490         my $pkg;
491         $i = 2;
492         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
493             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
494         }
495         $i -= 2 ;
496     }
497     else {
498         $i = _error_loc(); # see where Carp will allocate the error
499     }
500
501     # Default to 0 if caller returns nothing.  Default to $DEFAULT if it
502     # explicitly returns undef.
503     my(@callers_bitmask) = (caller($i))[9] ;
504     my $callers_bitmask =
505          @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
506
507     my @results;
508     foreach my $type (FATAL, NORMAL) {
509         next unless $wanted & $type;
510
511         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
512                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
513     }
514
515     # &enabled and &fatal_enabled
516     return $results[0] unless $has_message;
517
518     # &warnif, and the category is neither enabled as warning nor as fatal
519     return if $wanted == (NORMAL | FATAL | MESSAGE)
520         && !($results[0] || $results[1]);
521
522     require Carp;
523     Carp::croak($message) if $results[0];
524     # will always get here for &warn. will only get here for &warnif if the
525     # category is enabled
526     Carp::carp($message);
527 }
528
529 sub _mkMask
530 {
531     my ($bit) = @_;
532     my $mask = "";
533
534     vec($mask, $bit, 1) = 1;
535     return $mask;
536 }
537
538 sub register_categories
539 {
540     my @names = @_;
541
542     for my $name (@names) {
543         if (! defined $Bits{$name}) {
544             $Bits{$name}     = _mkMask($LAST_BIT);
545             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
546             $Offsets{$name}  = $LAST_BIT ++;
547             foreach my $k (keys %Bits) {
548                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
549             }
550             $DeadBits{$name} = _mkMask($LAST_BIT);
551             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
552         }
553     }
554 }
555
556 sub _error_loc {
557     require Carp;
558     goto &Carp::short_error_loc; # don't introduce another stack frame
559 }
560
561 sub enabled
562 {
563     return __chk(NORMAL, @_);
564 }
565
566 sub fatal_enabled
567 {
568     return __chk(FATAL, @_);
569 }
570
571 sub warn
572 {
573     return __chk(FATAL | MESSAGE, @_);
574 }
575
576 sub warnif
577 {
578     return __chk(NORMAL | FATAL | MESSAGE, @_);
579 }
580
581 # These are not part of any public interface, so we can delete them to save
582 # space.
583 delete @warnings::{qw(NORMAL FATAL MESSAGE)};
584
585 1;
586
587 # ex: set ro: