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