This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
regcomp.c: Make comment more accurate
[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
41ac5f6f 8our $VERSION = '1.13';
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
KW		 338$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0";
339$LAST_BIT = 102 ;
340$BYTES = 13 ;
d3a7d8c7
GS		 341
342$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
599cee73 343
c3186b65
PM		 344sub Croaker
345{
4dd71923 346 require Carp; # this initializes %CarpInternal
dbab294c 347 local $Carp::CarpInternal{'warnings'};
c3186b65 348 delete $Carp::CarpInternal{'warnings'};
8becbb3b 349 Carp::croak(@_);
c3186b65
PM		 350}
351
4c02ac93
NC		 352sub _bits {
353 my $mask = shift ;
599cee73
PM		 354 my $catmask ;
355 my $fatal = 0 ;
6e9af7e4
PM		 356 my $no_fatal = 0 ;
357
358 foreach my $word ( @_ ) {
359 if ($word eq 'FATAL') {
327afb7f 360 $fatal = 1;
6e9af7e4
PM		 361 $no_fatal = 0;
362 }
363 elsif ($word eq 'NONFATAL') {
364 $fatal = 0;
365 $no_fatal = 1;
327afb7f 366 }
d3a7d8c7
GS		 367 elsif ($catmask = $Bits{$word}) {
368 $mask |= $catmask ;
369 $mask |= $DeadBits{$word} if $fatal ;
6e9af7e4 370 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
599cee73 371 }
d3a7d8c7 372 else
c3186b65 373 { Croaker("Unknown warnings category '$word'")}
599cee73
PM		 374 }
375
376 return $mask ;
377}
378
4c02ac93
NC		 379sub bits
380{
381 # called from B::Deparse.pm
382 push @_, 'all' unless @_ ;
383 return _bits(undef, @_) ;
384}
385
6e9af7e4
PM		 386sub import
387{
599cee73 388 shift;
6e9af7e4 389
7e4f0450 390 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
6e9af7e4 391
f1f33818
PM		 392 if (vec($mask, $Offsets{'all'}, 1)) {
393 $mask |= $Bits{'all'} ;
394 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
395 }
6e9af7e4 396
4c02ac93
NC		 397 # Empty @_ is equivalent to @_ = 'all' ;
398 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
599cee73
PM		 399}
400
6e9af7e4
PM		 401sub unimport
402{
599cee73 403 shift;
6e9af7e4
PM		 404
405 my $catmask ;
7e4f0450 406 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
6e9af7e4 407
d3a7d8c7 408 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 409 $mask |= $Bits{'all'} ;
d3a7d8c7
GS		 410 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
411 }
6e9af7e4
PM		 412
413 push @_, 'all' unless @_;
414
415 foreach my $word ( @_ ) {
416 if ($word eq 'FATAL') {
417 next;
418 }
419 elsif ($catmask = $Bits{$word}) {
420 $mask &= ~($catmask | $DeadBits{$word} | $All);
421 }
422 else
423 { Croaker("Unknown warnings category '$word'")}
424 }
425
426 ${^WARNING_BITS} = $mask ;
599cee73
PM		 427}
428
9df0f64f
MK		 429my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
430
96183d25 431sub MESSAGE () { 4 };
8787a747
NC		 432sub FATAL () { 2 };
433sub NORMAL () { 1 };
434
7e6d00f8 435sub __chk
599cee73 436{
d3a7d8c7
GS		 437 my $category ;
438 my $offset ;
7e6d00f8 439 my $isobj = 0 ;
8787a747 440 my $wanted = shift;
96183d25
NC		 441 my $has_message = $wanted & MESSAGE;
442
443 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
444 my $sub = (caller 1)[3];
445 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
446 Croaker("Usage: $sub($syntax)");
447 }
448
449 my $message = pop if $has_message;
d3a7d8c7
GS		 450
451 if (@_) {
452 # check the category supplied.
453 $category = shift ;
9df0f64f
MK		 454 if (my $type = ref $category) {
455 Croaker("not an object")
456 if exists $builtin_type{$type};
457 $category = $type;
7e6d00f8
PM		 458 $isobj = 1 ;
459 }
d3a7d8c7 460 $offset = $Offsets{$category};
c3186b65 461 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS		 462 unless defined $offset;
463 }
464 else {
0ca4541c 465 $category = (caller(1))[0] ;
d3a7d8c7 466 $offset = $Offsets{$category};
c3186b65 467 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS		 468 unless defined $offset ;
469 }
470
f0a8fd68 471 my $i;
7e6d00f8
PM		 472
473 if ($isobj) {
f0a8fd68
NC		 474 my $pkg;
475 $i = 2;
7e6d00f8
PM		 476 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
477 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
478 }
479 $i -= 2 ;
480 }
481 else {
4f527b71 482 $i = _error_loc(); # see where Carp will allocate the error
7e6d00f8
PM		 483 }
484
4e92cb89
NC		 485 # Defaulting this to 0 reduces complexity in code paths below.
486 my $callers_bitmask = (caller($i))[9] || 0 ;
8787a747
NC		 487
488 my @results;
96183d25 489 foreach my $type (FATAL, NORMAL) {
8787a747
NC		 490 next unless $wanted & $type;
491
492 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
493 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
494 }
96183d25
NC		 495
496 # &enabled and &fatal_enabled
497 return $results[0] unless $has_message;
498
499 # &warnif, and the category is neither enabled as warning nor as fatal
500 return if $wanted == (NORMAL | FATAL | MESSAGE)
501 && !($results[0] || $results[1]);
502
503 require Carp;
504 Carp::croak($message) if $results[0];
505 # will always get here for &warn. will only get here for &warnif if the
506 # category is enabled
507 Carp::carp($message);
7e6d00f8
PM		 508}
509
572bfd36
RS		 510sub _mkMask
511{
512 my ($bit) = @_;
513 my $mask = "";
514
515 vec($mask, $bit, 1) = 1;
516 return $mask;
517}
518
5e7ad92a 519sub register_categories
572bfd36
RS		 520{
521 my @names = @_;
522
523 for my $name (@names) {
524 if (! defined $Bits{$name}) {
525 $Bits{$name} = _mkMask($LAST_BIT);
526 vec($Bits{'all'}, $LAST_BIT, 1) = 1;
527 $Offsets{$name} = $LAST_BIT ++;
528 foreach my $k (keys %Bits) {
529 vec($Bits{$k}, $LAST_BIT, 1) = 0;
530 }
531 $DeadBits{$name} = _mkMask($LAST_BIT);
532 vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
533 }
534 }
535}
536
4f527b71 537sub _error_loc {
4dd71923 538 require Carp;
4f527b71 539 goto &Carp::short_error_loc; # don't introduce another stack frame
13781810 540}
4f527b71 541
7e6d00f8
PM		 542sub enabled
543{
8787a747 544 return __chk(NORMAL, @_);
599cee73
PM		 545}
546
789c4615
RGS		 547sub fatal_enabled
548{
8787a747 549 return __chk(FATAL, @_);
789c4615 550}
d3a7d8c7 551
e476b1b5
GS		 552sub warn
553{
96183d25 554 return __chk(FATAL | MESSAGE, @_);
e476b1b5
GS		 555}
556
7e6d00f8
PM		 557sub warnif
558{
96183d25 559 return __chk(NORMAL | FATAL | MESSAGE, @_);
7e6d00f8 560}
0d658bf5 561
8787a747
NC		 562# These are not part of any public interface, so we can delete them to save
563# space.
96183d25 564delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
8787a747 565
599cee73 5661;
ce716c52 567
37442d52 568# ex: set ro:
Unnamed repository; edit this file 'description' to name the repository.