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