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