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
don't depend on threads to do a watchdog when testing threads
[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
78102347 8our $VERSION = '1.12';
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.
50See L<perllexwarn> for more information.
51
0453d815
PM		 52If no import list is supplied, all possible warnings are either enabled
53or disabled.
599cee73 54
0ca4541c 55A number of functions are provided to assist module authors.
e476b1b5
GS		 56
57=over 4
58
d3a7d8c7
GS		 59=item use warnings::register
60
7e6d00f8
PM		 61Creates a new warnings category with the same name as the package where
62the call to the pragma is used.
63
64=item warnings::enabled()
65
66Use the warnings category with the same name as the current package.
67
68Return TRUE if that warnings category is enabled in the calling module.
69Otherwise returns FALSE.
70
71=item warnings::enabled($category)
72
73Return TRUE if the warnings category, C<$category>, is enabled in the
74calling module.
75Otherwise returns FALSE.
76
77=item warnings::enabled($object)
78
79Use the name of the class for the object reference, C<$object>, as the
80warnings category.
81
82Return TRUE if that warnings category is enabled in the first scope
83where the object is used.
84Otherwise returns FALSE.
85
789c4615
RGS		 86=item warnings::fatal_enabled()
87
88Return TRUE if the warnings category with the same name as the current
89package has been set to FATAL in the calling module.
90Otherwise returns FALSE.
91
92=item warnings::fatal_enabled($category)
93
94Return TRUE if the warnings category C<$category> has been set to FATAL in
95the calling module.
96Otherwise returns FALSE.
97
98=item warnings::fatal_enabled($object)
99
100Use the name of the class for the object reference, C<$object>, as the
101warnings category.
102
103Return TRUE if that warnings category has been set to FATAL in the first
104scope where the object is used.
105Otherwise returns FALSE.
106
7e6d00f8
PM		 107=item warnings::warn($message)
108
109Print C<$message> to STDERR.
110
111Use the warnings category with the same name as the current package.
112
113If that warnings category has been set to "FATAL" in the calling module
114then die. Otherwise return.
115
116=item warnings::warn($category, $message)
117
118Print C<$message> to STDERR.
119
120If the warnings category, C<$category>, has been set to "FATAL" in the
121calling module then die. Otherwise return.
e476b1b5 122
7e6d00f8 123=item warnings::warn($object, $message)
e476b1b5 124
7e6d00f8 125Print C<$message> to STDERR.
e476b1b5 126
7e6d00f8
PM		 127Use the name of the class for the object reference, C<$object>, as the
128warnings category.
d3a7d8c7 129
7e6d00f8
PM		 130If that warnings category has been set to "FATAL" in the scope where C<$object>
131is first used then die. Otherwise return.
599cee73 132
e476b1b5 133
7e6d00f8
PM		 134=item warnings::warnif($message)
135
136Equivalent to:
137
138 if (warnings::enabled())
139 { warnings::warn($message) }
140
141=item warnings::warnif($category, $message)
142
143Equivalent to:
144
145 if (warnings::enabled($category))
146 { warnings::warn($category, $message) }
147
148=item warnings::warnif($object, $message)
149
150Equivalent to:
151
152 if (warnings::enabled($object))
153 { warnings::warn($object, $message) }
d3a7d8c7 154
5e7ad92a 155=item warnings::register_categories(@names)
572bfd36
RS		 156
157This registers warning categories for the given names and is primarily for
158use by the warnings::register pragma, for which see L<perllexwarn>.
159
e476b1b5
GS		 160=back
161
749f83fa 162See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM		 163
164=cut
165
53c33732 166our %Offsets = (
0d658bf5
PM		 167
168 # Warnings Categories added in Perl 5.008
169
d3a7d8c7 170 'all' => 0,
3eae5ce4 171 'closure' => 2,
12bcd1a6
PM		 172 'deprecated' => 4,
173 'exiting' => 6,
174 'glob' => 8,
175 'io' => 10,
176 'closed' => 12,
177 'exec' => 14,
99ef548b
PM		 178 'layer' => 16,
179 'newline' => 18,
180 'pipe' => 20,
181 'unopened' => 22,
182 'misc' => 24,
183 'numeric' => 26,
184 'once' => 28,
185 'overflow' => 30,
186 'pack' => 32,
187 'portable' => 34,
188 'recursion' => 36,
189 'redefine' => 38,
190 'regexp' => 40,
191 'severe' => 42,
192 'debugging' => 44,
193 'inplace' => 46,
194 'internal' => 48,
195 'malloc' => 50,
196 'signal' => 52,
197 'substr' => 54,
198 'syntax' => 56,
199 'ambiguous' => 58,
200 'bareword' => 60,
201 'digit' => 62,
202 'parenthesis' => 64,
203 'precedence' => 66,
204 'printf' => 68,
205 'prototype' => 70,
206 'qw' => 72,
207 'reserved' => 74,
208 'semicolon' => 76,
209 'taint' => 78,
38875929
DM		 210 'threads' => 80,
211 'uninitialized' => 82,
212 'unpack' => 84,
213 'untie' => 86,
214 'utf8' => 88,
215 'void' => 90,
b88df990
NC		 216
217 # Warnings Categories added in Perl 5.011
218
219 'imprecision' => 92,
197afce1 220 'illegalproto' => 94,
8457b38f
KW		 221
222 # Warnings Categories added in Perl 5.013
223
224 'non_unicode' => 96,
225 'nonchar' => 98,
226 'surrogate' => 100,
d3a7d8c7
GS		 227 );
228
53c33732 229our %Bits = (
8457b38f
KW		 230 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..50]
231 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [29]
232 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [30]
233 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
234 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
235 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [22]
236 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
237 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [31]
238 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
239 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
240 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
241 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [47]
242 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [46]
243 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [23]
244 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [24]
245 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
246 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
247 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [25]
248 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
249 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
250 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [48]
251 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [49]
252 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
253 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
254 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
255 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
256 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [32]
257 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
258 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
259 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [33]
260 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [34]
261 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [35]
262 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [36]
263 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
264 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
265 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [20]
266 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [37]
267 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [38]
268 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00", # [21..25]
269 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [26]
270 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [27]
271 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [50]
272 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00", # [28..38,47]
273 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [39]
274 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [40]
275 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [41]
276 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
277 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [42]
278 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [43]
279 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15", # [44,48..50]
280 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [45]
599cee73
PM		 281 );
282
53c33732 283our %DeadBits = (
8457b38f
KW		 284 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..50]
285 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [29]
286 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [30]
287 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
288 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
289 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [22]
290 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
291 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [31]
292 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
293 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
294 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
295 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [47]
296 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [46]
297 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [23]
298 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [24]
299 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
300 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
301 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [25]
302 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
303 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
304 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [48]
305 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [49]
306 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
307 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
308 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
309 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
310 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [32]
311 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
312 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
313 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [33]
314 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [34]
315 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [35]
316 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [36]
317 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
318 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
319 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [20]
320 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [37]
321 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [38]
322 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00", # [21..25]
323 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [26]
324 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [27]
325 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [50]
326 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00", # [28..38,47]
327 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [39]
328 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [40]
329 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [41]
330 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
331 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [42]
332 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [43]
333 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a", # [44,48..50]
334 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [45]
599cee73
PM		 335 );
336
8457b38f
KW		 337$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0";
338$LAST_BIT = 102 ;
339$BYTES = 13 ;
d3a7d8c7
GS		 340
341$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
599cee73 342
c3186b65
PM		 343sub Croaker
344{
4dd71923 345 require Carp; # this initializes %CarpInternal
dbab294c 346 local $Carp::CarpInternal{'warnings'};
c3186b65 347 delete $Carp::CarpInternal{'warnings'};
8becbb3b 348 Carp::croak(@_);
c3186b65
PM		 349}
350
4c02ac93
NC		 351sub _bits {
352 my $mask = shift ;
599cee73
PM		 353 my $catmask ;
354 my $fatal = 0 ;
6e9af7e4
PM		 355 my $no_fatal = 0 ;
356
357 foreach my $word ( @_ ) {
358 if ($word eq 'FATAL') {
327afb7f 359 $fatal = 1;
6e9af7e4
PM		 360 $no_fatal = 0;
361 }
362 elsif ($word eq 'NONFATAL') {
363 $fatal = 0;
364 $no_fatal = 1;
327afb7f 365 }
d3a7d8c7
GS		 366 elsif ($catmask = $Bits{$word}) {
367 $mask |= $catmask ;
368 $mask |= $DeadBits{$word} if $fatal ;
6e9af7e4 369 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
599cee73 370 }
d3a7d8c7 371 else
c3186b65 372 { Croaker("Unknown warnings category '$word'")}
599cee73
PM		 373 }
374
375 return $mask ;
376}
377
4c02ac93
NC		 378sub bits
379{
380 # called from B::Deparse.pm
381 push @_, 'all' unless @_ ;
382 return _bits(undef, @_) ;
383}
384
6e9af7e4
PM		 385sub import
386{
599cee73 387 shift;
6e9af7e4 388
f1f33818 389 my $mask = ${^WARNING_BITS} ;
6e9af7e4 390
f1f33818
PM		 391 if (vec($mask, $Offsets{'all'}, 1)) {
392 $mask |= $Bits{'all'} ;
393 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
394 }
6e9af7e4 395
4c02ac93
NC		 396 # Empty @_ is equivalent to @_ = 'all' ;
397 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
599cee73
PM		 398}
399
6e9af7e4
PM		 400sub unimport
401{
599cee73 402 shift;
6e9af7e4
PM		 403
404 my $catmask ;
d3a7d8c7 405 my $mask = ${^WARNING_BITS} ;
6e9af7e4 406
d3a7d8c7 407 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 408 $mask |= $Bits{'all'} ;
d3a7d8c7
GS		 409 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
410 }
6e9af7e4
PM		 411
412 push @_, 'all' unless @_;
413
414 foreach my $word ( @_ ) {
415 if ($word eq 'FATAL') {
416 next;
417 }
418 elsif ($catmask = $Bits{$word}) {
419 $mask &= ~($catmask | $DeadBits{$word} | $All);
420 }
421 else
422 { Croaker("Unknown warnings category '$word'")}
423 }
424
425 ${^WARNING_BITS} = $mask ;
599cee73
PM		 426}
427
9df0f64f
MK		 428my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
429
96183d25 430sub MESSAGE () { 4 };
8787a747
NC		 431sub FATAL () { 2 };
432sub NORMAL () { 1 };
433
7e6d00f8 434sub __chk
599cee73 435{
d3a7d8c7
GS		 436 my $category ;
437 my $offset ;
7e6d00f8 438 my $isobj = 0 ;
8787a747 439 my $wanted = shift;
96183d25
NC		 440 my $has_message = $wanted & MESSAGE;
441
442 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
443 my $sub = (caller 1)[3];
444 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
445 Croaker("Usage: $sub($syntax)");
446 }
447
448 my $message = pop if $has_message;
d3a7d8c7
GS		 449
450 if (@_) {
451 # check the category supplied.
452 $category = shift ;
9df0f64f
MK		 453 if (my $type = ref $category) {
454 Croaker("not an object")
455 if exists $builtin_type{$type};
456 $category = $type;
7e6d00f8
PM		 457 $isobj = 1 ;
458 }
d3a7d8c7 459 $offset = $Offsets{$category};
c3186b65 460 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS		 461 unless defined $offset;
462 }
463 else {
0ca4541c 464 $category = (caller(1))[0] ;
d3a7d8c7 465 $offset = $Offsets{$category};
c3186b65 466 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS		 467 unless defined $offset ;
468 }
469
f0a8fd68 470 my $i;
7e6d00f8
PM		 471
472 if ($isobj) {
f0a8fd68
NC		 473 my $pkg;
474 $i = 2;
7e6d00f8
PM		 475 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
476 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
477 }
478 $i -= 2 ;
479 }
480 else {
4f527b71 481 $i = _error_loc(); # see where Carp will allocate the error
7e6d00f8
PM		 482 }
483
4e92cb89
NC		 484 # Defaulting this to 0 reduces complexity in code paths below.
485 my $callers_bitmask = (caller($i))[9] || 0 ;
8787a747
NC		 486
487 my @results;
96183d25 488 foreach my $type (FATAL, NORMAL) {
8787a747
NC		 489 next unless $wanted & $type;
490
491 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
492 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
493 }
96183d25
NC		 494
495 # &enabled and &fatal_enabled
496 return $results[0] unless $has_message;
497
498 # &warnif, and the category is neither enabled as warning nor as fatal
499 return if $wanted == (NORMAL | FATAL | MESSAGE)
500 && !($results[0] || $results[1]);
501
502 require Carp;
503 Carp::croak($message) if $results[0];
504 # will always get here for &warn. will only get here for &warnif if the
505 # category is enabled
506 Carp::carp($message);
7e6d00f8
PM		 507}
508
572bfd36
RS		 509sub _mkMask
510{
511 my ($bit) = @_;
512 my $mask = "";
513
514 vec($mask, $bit, 1) = 1;
515 return $mask;
516}
517
5e7ad92a 518sub register_categories
572bfd36
RS		 519{
520 my @names = @_;
521
522 for my $name (@names) {
523 if (! defined $Bits{$name}) {
524 $Bits{$name} = _mkMask($LAST_BIT);
525 vec($Bits{'all'}, $LAST_BIT, 1) = 1;
526 $Offsets{$name} = $LAST_BIT ++;
527 foreach my $k (keys %Bits) {
528 vec($Bits{$k}, $LAST_BIT, 1) = 0;
529 }
530 $DeadBits{$name} = _mkMask($LAST_BIT);
531 vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
532 }
533 }
534}
535
4f527b71 536sub _error_loc {
4dd71923 537 require Carp;
4f527b71 538 goto &Carp::short_error_loc; # don't introduce another stack frame
13781810 539}
4f527b71 540
7e6d00f8
PM		 541sub enabled
542{
8787a747 543 return __chk(NORMAL, @_);
599cee73
PM		 544}
545
789c4615
RGS		 546sub fatal_enabled
547{
8787a747 548 return __chk(FATAL, @_);
789c4615 549}
d3a7d8c7 550
e476b1b5
GS		 551sub warn
552{
96183d25 553 return __chk(FATAL | MESSAGE, @_);
e476b1b5
GS		 554}
555
7e6d00f8
PM		 556sub warnif
557{
96183d25 558 return __chk(NORMAL | FATAL | MESSAGE, @_);
7e6d00f8 559}
0d658bf5 560
8787a747
NC		 561# These are not part of any public interface, so we can delete them to save
562# space.
96183d25 563delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
8787a747 564
599cee73 5651;
ce716c52 566
37442d52 567# ex: set ro:
Unnamed repository; edit this file 'description' to name the repository.