This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Convert Math::BigInt tests from Test to Test::More.
[perl5.git] / lib / warnings.pm
CommitLineData
37442d52 1# -*- buffer-read-only: t -*-
38875929 2# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 3# This file was created by warnings.pl
599cee73
PM
4# Any changes made here will be lost.
5#
6
4438c4b7 7package warnings;
599cee73 8
8452af9f 9our $VERSION = '1.10';
f2c3e829
RGS
10
11# Verify that we're called correctly so that warnings will work.
12# see also strict.pm.
5108dc18 13unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
f2c3e829 14 my (undef, $f, $l) = caller;
5108dc18 15 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
f2c3e829 16}
0ca4541c 17
599cee73
PM
18=head1 NAME
19
4438c4b7 20warnings - Perl pragma to control optional warnings
599cee73
PM
21
22=head1 SYNOPSIS
23
4438c4b7
JH
24 use warnings;
25 no warnings;
599cee73 26
4438c4b7
JH
27 use warnings "all";
28 no warnings "all";
599cee73 29
d3a7d8c7
GS
30 use warnings::register;
31 if (warnings::enabled()) {
32 warnings::warn("some warning");
33 }
34
35 if (warnings::enabled("void")) {
e476b1b5
GS
36 warnings::warn("void", "some warning");
37 }
38
7e6d00f8
PM
39 if (warnings::enabled($object)) {
40 warnings::warn($object, "some warning");
41 }
42
721f911b
PM
43 warnings::warnif("some warning");
44 warnings::warnif("void", "some warning");
45 warnings::warnif($object, "some warning");
7e6d00f8 46
599cee73
PM
47=head1 DESCRIPTION
48
fe2e802c
EM
49The C<warnings> pragma is a replacement for the command line flag C<-w>,
50but the pragma is limited to the enclosing block, while the flag is global.
51See L<perllexwarn> for more information.
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
e476b1b5
GS
156=back
157
749f83fa 158See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
159
160=cut
161
53c33732 162our %Offsets = (
0d658bf5
PM
163
164 # Warnings Categories added in Perl 5.008
165
d3a7d8c7 166 'all' => 0,
3eae5ce4 167 'closure' => 2,
12bcd1a6
PM
168 'deprecated' => 4,
169 'exiting' => 6,
170 'glob' => 8,
171 'io' => 10,
172 'closed' => 12,
173 'exec' => 14,
99ef548b
PM
174 'layer' => 16,
175 'newline' => 18,
176 'pipe' => 20,
177 'unopened' => 22,
178 'misc' => 24,
179 'numeric' => 26,
180 'once' => 28,
181 'overflow' => 30,
182 'pack' => 32,
183 'portable' => 34,
184 'recursion' => 36,
185 'redefine' => 38,
186 'regexp' => 40,
187 'severe' => 42,
188 'debugging' => 44,
189 'inplace' => 46,
190 'internal' => 48,
191 'malloc' => 50,
192 'signal' => 52,
193 'substr' => 54,
194 'syntax' => 56,
195 'ambiguous' => 58,
196 'bareword' => 60,
197 'digit' => 62,
198 'parenthesis' => 64,
199 'precedence' => 66,
200 'printf' => 68,
201 'prototype' => 70,
202 'qw' => 72,
203 'reserved' => 74,
204 'semicolon' => 76,
205 'taint' => 78,
38875929
DM
206 'threads' => 80,
207 'uninitialized' => 82,
208 'unpack' => 84,
209 'untie' => 86,
210 'utf8' => 88,
211 'void' => 90,
b88df990
NC
212
213 # Warnings Categories added in Perl 5.011
214
215 'imprecision' => 92,
197afce1 216 'illegalproto' => 94,
d3a7d8c7
GS
217 );
218
53c33732 219our %Bits = (
197afce1 220 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
99ef548b
PM
221 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
222 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
12bcd1a6 223 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
3eae5ce4 224 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
99ef548b 225 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
12bcd1a6 226 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
99ef548b 227 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
12bcd1a6
PM
228 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
229 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
230 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
197afce1 231 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [47]
b88df990 232 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
99ef548b
PM
233 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
234 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
235 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
236 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
237 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
238 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
239 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
240 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
241 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
242 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
243 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
244 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
245 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
246 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
247 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
248 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
249 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
250 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
251 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
252 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
253 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
254 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
255 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
256 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
257 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
258 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
197afce1 259 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40", # [28..38,47]
99ef548b 260 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
38875929
DM
261 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
262 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
99ef548b 263 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
38875929
DM
264 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
265 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
266 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
267 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
599cee73
PM
268 );
269
53c33732 270our %DeadBits = (
197afce1 271 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
99ef548b
PM
272 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
273 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
12bcd1a6 274 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
3eae5ce4 275 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
99ef548b 276 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
12bcd1a6 277 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
99ef548b 278 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
12bcd1a6
PM
279 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
280 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
281 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
197afce1 282 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [47]
b88df990 283 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
99ef548b
PM
284 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
285 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
286 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
287 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
288 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
289 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
290 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
291 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
292 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
293 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
294 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
295 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
296 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
297 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
298 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
299 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
300 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
301 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
302 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
303 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
304 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
305 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
306 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
307 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
308 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
309 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
197afce1 310 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80", # [28..38,47]
99ef548b 311 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
38875929
DM
312 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
313 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
99ef548b 314 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
38875929
DM
315 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
316 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
317 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
318 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
599cee73
PM
319 );
320
a86a20aa 321$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
197afce1 322$LAST_BIT = 96 ;
a86a20aa 323$BYTES = 12 ;
d3a7d8c7
GS
324
325$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
599cee73 326
c3186b65
PM
327sub Croaker
328{
4dd71923 329 require Carp; # this initializes %CarpInternal
dbab294c 330 local $Carp::CarpInternal{'warnings'};
c3186b65 331 delete $Carp::CarpInternal{'warnings'};
8becbb3b 332 Carp::croak(@_);
c3186b65
PM
333}
334
4c02ac93
NC
335sub _bits {
336 my $mask = shift ;
599cee73
PM
337 my $catmask ;
338 my $fatal = 0 ;
6e9af7e4
PM
339 my $no_fatal = 0 ;
340
341 foreach my $word ( @_ ) {
342 if ($word eq 'FATAL') {
327afb7f 343 $fatal = 1;
6e9af7e4
PM
344 $no_fatal = 0;
345 }
346 elsif ($word eq 'NONFATAL') {
347 $fatal = 0;
348 $no_fatal = 1;
327afb7f 349 }
d3a7d8c7
GS
350 elsif ($catmask = $Bits{$word}) {
351 $mask |= $catmask ;
352 $mask |= $DeadBits{$word} if $fatal ;
6e9af7e4 353 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
599cee73 354 }
d3a7d8c7 355 else
c3186b65 356 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
357 }
358
359 return $mask ;
360}
361
4c02ac93
NC
362sub bits
363{
364 # called from B::Deparse.pm
365 push @_, 'all' unless @_ ;
366 return _bits(undef, @_) ;
367}
368
6e9af7e4
PM
369sub import
370{
599cee73 371 shift;
6e9af7e4 372
f1f33818 373 my $mask = ${^WARNING_BITS} ;
6e9af7e4 374
f1f33818
PM
375 if (vec($mask, $Offsets{'all'}, 1)) {
376 $mask |= $Bits{'all'} ;
377 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
378 }
6e9af7e4 379
4c02ac93
NC
380 # Empty @_ is equivalent to @_ = 'all' ;
381 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
599cee73
PM
382}
383
6e9af7e4
PM
384sub unimport
385{
599cee73 386 shift;
6e9af7e4
PM
387
388 my $catmask ;
d3a7d8c7 389 my $mask = ${^WARNING_BITS} ;
6e9af7e4 390
d3a7d8c7 391 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 392 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
393 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
394 }
6e9af7e4
PM
395
396 push @_, 'all' unless @_;
397
398 foreach my $word ( @_ ) {
399 if ($word eq 'FATAL') {
400 next;
401 }
402 elsif ($catmask = $Bits{$word}) {
403 $mask &= ~($catmask | $DeadBits{$word} | $All);
404 }
405 else
406 { Croaker("Unknown warnings category '$word'")}
407 }
408
409 ${^WARNING_BITS} = $mask ;
599cee73
PM
410}
411
9df0f64f 412my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
413
96183d25 414sub MESSAGE () { 4 };
8787a747
NC
415sub FATAL () { 2 };
416sub NORMAL () { 1 };
417
7e6d00f8 418sub __chk
599cee73 419{
d3a7d8c7
GS
420 my $category ;
421 my $offset ;
7e6d00f8 422 my $isobj = 0 ;
8787a747 423 my $wanted = shift;
96183d25
NC
424 my $has_message = $wanted & MESSAGE;
425
426 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
427 my $sub = (caller 1)[3];
428 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
429 Croaker("Usage: $sub($syntax)");
430 }
431
432 my $message = pop if $has_message;
d3a7d8c7
GS
433
434 if (@_) {
435 # check the category supplied.
436 $category = shift ;
9df0f64f 437 if (my $type = ref $category) {
438 Croaker("not an object")
439 if exists $builtin_type{$type};
440 $category = $type;
7e6d00f8
PM
441 $isobj = 1 ;
442 }
d3a7d8c7 443 $offset = $Offsets{$category};
c3186b65 444 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
445 unless defined $offset;
446 }
447 else {
0ca4541c 448 $category = (caller(1))[0] ;
d3a7d8c7 449 $offset = $Offsets{$category};
c3186b65 450 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
451 unless defined $offset ;
452 }
453
f0a8fd68 454 my $i;
7e6d00f8
PM
455
456 if ($isobj) {
f0a8fd68
NC
457 my $pkg;
458 $i = 2;
7e6d00f8
PM
459 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
460 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
461 }
462 $i -= 2 ;
463 }
464 else {
4f527b71 465 $i = _error_loc(); # see where Carp will allocate the error
7e6d00f8
PM
466 }
467
4e92cb89
NC
468 # Defaulting this to 0 reduces complexity in code paths below.
469 my $callers_bitmask = (caller($i))[9] || 0 ;
8787a747
NC
470
471 my @results;
96183d25 472 foreach my $type (FATAL, NORMAL) {
8787a747
NC
473 next unless $wanted & $type;
474
475 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
476 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
477 }
96183d25
NC
478
479 # &enabled and &fatal_enabled
480 return $results[0] unless $has_message;
481
482 # &warnif, and the category is neither enabled as warning nor as fatal
483 return if $wanted == (NORMAL | FATAL | MESSAGE)
484 && !($results[0] || $results[1]);
485
486 require Carp;
487 Carp::croak($message) if $results[0];
488 # will always get here for &warn. will only get here for &warnif if the
489 # category is enabled
490 Carp::carp($message);
7e6d00f8
PM
491}
492
4f527b71 493sub _error_loc {
4dd71923 494 require Carp;
4f527b71
AS
495 goto &Carp::short_error_loc; # don't introduce another stack frame
496}
497
7e6d00f8
PM
498sub enabled
499{
8787a747 500 return __chk(NORMAL, @_);
599cee73
PM
501}
502
789c4615
RGS
503sub fatal_enabled
504{
8787a747 505 return __chk(FATAL, @_);
789c4615 506}
d3a7d8c7 507
e476b1b5
GS
508sub warn
509{
96183d25 510 return __chk(FATAL | MESSAGE, @_);
e476b1b5
GS
511}
512
7e6d00f8
PM
513sub warnif
514{
96183d25 515 return __chk(NORMAL | FATAL | MESSAGE, @_);
7e6d00f8 516}
0d658bf5 517
8787a747
NC
518# These are not part of any public interface, so we can delete them to save
519# space.
96183d25 520delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
8787a747 521
599cee73 5221;
37442d52 523# ex: set ro: