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