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