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