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