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