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