This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
dquote_static.c: White-space only; no code changes
[perl5.git] / lib / warnings.pm
CommitLineData
37442d52 1# -*- buffer-read-only: t -*-
38875929 2# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
78102347
NC
3# This file is built by regen/warnings.pl.
4# Any changes made here will be lost!
599cee73 5
4438c4b7 6package warnings;
599cee73 7
7ae5d31c 8our $VERSION = '1.15';
f2c3e829
RGS
9
10# Verify that we're called correctly so that warnings will work.
11# see also strict.pm.
5108dc18 12unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
f2c3e829 13 my (undef, $f, $l) = caller;
5108dc18 14 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
f2c3e829 15}
0ca4541c 16
599cee73
PM
17=head1 NAME
18
4438c4b7 19warnings - Perl pragma to control optional warnings
599cee73
PM
20
21=head1 SYNOPSIS
22
4438c4b7
JH
23 use warnings;
24 no warnings;
599cee73 25
4438c4b7
JH
26 use warnings "all";
27 no warnings "all";
599cee73 28
d3a7d8c7
GS
29 use warnings::register;
30 if (warnings::enabled()) {
31 warnings::warn("some warning");
32 }
33
34 if (warnings::enabled("void")) {
e476b1b5
GS
35 warnings::warn("void", "some warning");
36 }
37
7e6d00f8
PM
38 if (warnings::enabled($object)) {
39 warnings::warn($object, "some warning");
40 }
41
721f911b
PM
42 warnings::warnif("some warning");
43 warnings::warnif("void", "some warning");
44 warnings::warnif($object, "some warning");
7e6d00f8 45
599cee73
PM
46=head1 DESCRIPTION
47
fe2e802c
EM
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.
28726416
DG
50See L<perllexwarn> for more information and the list of built-in warning
51categories.
fe2e802c 52
0453d815
PM
53If no import list is supplied, all possible warnings are either enabled
54or disabled.
599cee73 55
0ca4541c 56A number of functions are provided to assist module authors.
e476b1b5
GS
57
58=over 4
59
d3a7d8c7
GS
60=item use warnings::register
61
7e6d00f8
PM
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
789c4615
RGS
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
7e6d00f8
PM
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.
e476b1b5 123
7e6d00f8 124=item warnings::warn($object, $message)
e476b1b5 125
7e6d00f8 126Print C<$message> to STDERR.
e476b1b5 127
7e6d00f8
PM
128Use the name of the class for the object reference, C<$object>, as the
129warnings category.
d3a7d8c7 130
7e6d00f8
PM
131If that warnings category has been set to "FATAL" in the scope where C<$object>
132is first used then die. Otherwise return.
599cee73 133
e476b1b5 134
7e6d00f8
PM
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) }
d3a7d8c7 155
5e7ad92a 156=item warnings::register_categories(@names)
572bfd36
RS
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
e476b1b5
GS
161=back
162
749f83fa 163See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
164
165=cut
166
53c33732 167our %Offsets = (
0d658bf5
PM
168
169 # Warnings Categories added in Perl 5.008
170
d3a7d8c7 171 'all' => 0,
3eae5ce4 172 'closure' => 2,
12bcd1a6
PM
173 'deprecated' => 4,
174 'exiting' => 6,
175 'glob' => 8,
176 'io' => 10,
177 'closed' => 12,
178 'exec' => 14,
99ef548b
PM
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,
38875929
DM
211 'threads' => 80,
212 'uninitialized' => 82,
213 'unpack' => 84,
214 'untie' => 86,
215 'utf8' => 88,
216 'void' => 90,
b88df990
NC
217
218 # Warnings Categories added in Perl 5.011
219
220 'imprecision' => 92,
197afce1 221 'illegalproto' => 94,
8457b38f
KW
222
223 # Warnings Categories added in Perl 5.013
224
225 'non_unicode' => 96,
226 'nonchar' => 98,
227 'surrogate' => 100,
6f87cb12
FC
228
229 # Warnings Categories added in Perl 5.017
230
231 'experimental' => 102,
f1d34ca8 232 'experimental::lexical_subs'=> 104,
d3a7d8c7
GS
233 );
234
53c33732 235our %Bits = (
6f87cb12
FC
236 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x01", # [0..52]
237 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [29]
238 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [30]
239 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
240 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
241 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
242 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
243 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [31]
244 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
245 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
246 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01", # [51,52]
f1d34ca8 247 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [52]
6f87cb12
FC
248 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
249 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [47]
250 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [46]
251 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
252 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [24]
253 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
254 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
255 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [25]
256 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
257 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
258 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [48]
259 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [49]
260 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
261 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
262 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
263 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
264 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [32]
265 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
266 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
267 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [33]
268 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [34]
269 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [35]
270 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [36]
271 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
272 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
273 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
274 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [37]
275 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [38]
276 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00", # [21..25]
277 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [26]
278 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [27]
279 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [50]
280 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00", # [28..38,47]
281 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [39]
282 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [40]
283 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [41]
284 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
285 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [42]
286 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [43]
287 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00", # [44,48..50]
288 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [45]
599cee73
PM
289 );
290
53c33732 291our %DeadBits = (
6f87cb12
FC
292 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x02", # [0..52]
293 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [29]
294 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [30]
295 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
296 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
297 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
298 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
299 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [31]
300 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
301 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
302 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02", # [51,52]
f1d34ca8 303 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [52]
6f87cb12
FC
304 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
305 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [47]
306 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [46]
307 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
308 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [24]
309 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
310 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
311 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [25]
312 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
313 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
314 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [48]
315 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [49]
316 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
317 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
318 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
319 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
320 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [32]
321 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
322 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
323 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [33]
324 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [34]
325 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [35]
326 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [36]
327 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
328 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
329 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
330 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [37]
331 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [38]
332 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00", # [21..25]
333 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [26]
334 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [27]
335 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [50]
336 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00", # [28..38,47]
337 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [39]
338 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [40]
339 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [41]
340 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
341 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [42]
342 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [43]
343 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00", # [44,48..50]
344 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [45]
599cee73
PM
345 );
346
6f87cb12
FC
347$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
348$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x01", # [2,52,4,22,23,25]
349$LAST_BIT = 106 ;
350$BYTES = 14 ;
d3a7d8c7
GS
351
352$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
599cee73 353
c3186b65
PM
354sub Croaker
355{
4dd71923 356 require Carp; # this initializes %CarpInternal
dbab294c 357 local $Carp::CarpInternal{'warnings'};
c3186b65 358 delete $Carp::CarpInternal{'warnings'};
8becbb3b 359 Carp::croak(@_);
c3186b65
PM
360}
361
4c02ac93
NC
362sub _bits {
363 my $mask = shift ;
599cee73
PM
364 my $catmask ;
365 my $fatal = 0 ;
6e9af7e4
PM
366 my $no_fatal = 0 ;
367
368 foreach my $word ( @_ ) {
369 if ($word eq 'FATAL') {
327afb7f 370 $fatal = 1;
6e9af7e4
PM
371 $no_fatal = 0;
372 }
373 elsif ($word eq 'NONFATAL') {
374 $fatal = 0;
375 $no_fatal = 1;
327afb7f 376 }
d3a7d8c7
GS
377 elsif ($catmask = $Bits{$word}) {
378 $mask |= $catmask ;
379 $mask |= $DeadBits{$word} if $fatal ;
6e9af7e4 380 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
599cee73 381 }
d3a7d8c7 382 else
c3186b65 383 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
384 }
385
386 return $mask ;
387}
388
4c02ac93
NC
389sub bits
390{
391 # called from B::Deparse.pm
392 push @_, 'all' unless @_ ;
393 return _bits(undef, @_) ;
394}
395
6e9af7e4
PM
396sub import
397{
599cee73 398 shift;
6e9af7e4 399
7fc874e8 400 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
6e9af7e4 401
f1f33818
PM
402 if (vec($mask, $Offsets{'all'}, 1)) {
403 $mask |= $Bits{'all'} ;
404 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
405 }
6e9af7e4 406
4c02ac93
NC
407 # Empty @_ is equivalent to @_ = 'all' ;
408 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
599cee73
PM
409}
410
6e9af7e4
PM
411sub unimport
412{
599cee73 413 shift;
6e9af7e4
PM
414
415 my $catmask ;
7fc874e8 416 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
6e9af7e4 417
d3a7d8c7 418 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 419 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
420 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
421 }
6e9af7e4
PM
422
423 push @_, 'all' unless @_;
424
425 foreach my $word ( @_ ) {
426 if ($word eq 'FATAL') {
427 next;
428 }
429 elsif ($catmask = $Bits{$word}) {
430 $mask &= ~($catmask | $DeadBits{$word} | $All);
431 }
432 else
433 { Croaker("Unknown warnings category '$word'")}
434 }
435
436 ${^WARNING_BITS} = $mask ;
599cee73
PM
437}
438
9df0f64f 439my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
440
96183d25 441sub MESSAGE () { 4 };
8787a747
NC
442sub FATAL () { 2 };
443sub NORMAL () { 1 };
444
7e6d00f8 445sub __chk
599cee73 446{
d3a7d8c7
GS
447 my $category ;
448 my $offset ;
7e6d00f8 449 my $isobj = 0 ;
8787a747 450 my $wanted = shift;
96183d25
NC
451 my $has_message = $wanted & MESSAGE;
452
453 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
454 my $sub = (caller 1)[3];
455 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
456 Croaker("Usage: $sub($syntax)");
457 }
458
459 my $message = pop if $has_message;
d3a7d8c7
GS
460
461 if (@_) {
462 # check the category supplied.
463 $category = shift ;
9df0f64f 464 if (my $type = ref $category) {
465 Croaker("not an object")
466 if exists $builtin_type{$type};
467 $category = $type;
7e6d00f8
PM
468 $isobj = 1 ;
469 }
d3a7d8c7 470 $offset = $Offsets{$category};
c3186b65 471 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
472 unless defined $offset;
473 }
474 else {
0ca4541c 475 $category = (caller(1))[0] ;
d3a7d8c7 476 $offset = $Offsets{$category};
c3186b65 477 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
478 unless defined $offset ;
479 }
480
f0a8fd68 481 my $i;
7e6d00f8
PM
482
483 if ($isobj) {
f0a8fd68
NC
484 my $pkg;
485 $i = 2;
7e6d00f8
PM
486 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
487 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
488 }
489 $i -= 2 ;
490 }
491 else {
4f527b71 492 $i = _error_loc(); # see where Carp will allocate the error
7e6d00f8
PM
493 }
494
7fc874e8
FC
495 # Default to 0 if caller returns nothing. Default to $DEFAULT if it
496 # explicitly returns undef.
497 my(@callers_bitmask) = (caller($i))[9] ;
498 my $callers_bitmask =
499 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
8787a747
NC
500
501 my @results;
96183d25 502 foreach my $type (FATAL, NORMAL) {
8787a747
NC
503 next unless $wanted & $type;
504
505 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
506 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
507 }
96183d25
NC
508
509 # &enabled and &fatal_enabled
510 return $results[0] unless $has_message;
511
512 # &warnif, and the category is neither enabled as warning nor as fatal
513 return if $wanted == (NORMAL | FATAL | MESSAGE)
514 && !($results[0] || $results[1]);
515
516 require Carp;
517 Carp::croak($message) if $results[0];
518 # will always get here for &warn. will only get here for &warnif if the
519 # category is enabled
520 Carp::carp($message);
7e6d00f8
PM
521}
522
572bfd36
RS
523sub _mkMask
524{
525 my ($bit) = @_;
526 my $mask = "";
527
528 vec($mask, $bit, 1) = 1;
529 return $mask;
530}
531
5e7ad92a 532sub register_categories
572bfd36
RS
533{
534 my @names = @_;
535
536 for my $name (@names) {
537 if (! defined $Bits{$name}) {
538 $Bits{$name} = _mkMask($LAST_BIT);
539 vec($Bits{'all'}, $LAST_BIT, 1) = 1;
540 $Offsets{$name} = $LAST_BIT ++;
541 foreach my $k (keys %Bits) {
542 vec($Bits{$k}, $LAST_BIT, 1) = 0;
543 }
544 $DeadBits{$name} = _mkMask($LAST_BIT);
545 vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
546 }
547 }
548}
549
4f527b71 550sub _error_loc {
4dd71923 551 require Carp;
4f527b71 552 goto &Carp::short_error_loc; # don't introduce another stack frame
13781810 553}
4f527b71 554
7e6d00f8
PM
555sub enabled
556{
8787a747 557 return __chk(NORMAL, @_);
599cee73
PM
558}
559
789c4615
RGS
560sub fatal_enabled
561{
8787a747 562 return __chk(FATAL, @_);
789c4615 563}
d3a7d8c7 564
e476b1b5
GS
565sub warn
566{
96183d25 567 return __chk(FATAL | MESSAGE, @_);
e476b1b5
GS
568}
569
7e6d00f8
PM
570sub warnif
571{
96183d25 572 return __chk(NORMAL | FATAL | MESSAGE, @_);
7e6d00f8 573}
0d658bf5 574
8787a747
NC
575# These are not part of any public interface, so we can delete them to save
576# space.
96183d25 577delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
8787a747 578
599cee73 5791;
ce716c52 580
37442d52 581# ex: set ro: