This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move the repeated vec logic into warnings::__chk.
[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
8787a747
NC
414sub FATAL () { 2 };
415sub NORMAL () { 1 };
416
7e6d00f8 417sub __chk
599cee73 418{
d3a7d8c7
GS
419 my $category ;
420 my $offset ;
7e6d00f8 421 my $isobj = 0 ;
8787a747 422 my $wanted = shift;
d3a7d8c7
GS
423
424 if (@_) {
425 # check the category supplied.
426 $category = shift ;
9df0f64f 427 if (my $type = ref $category) {
428 Croaker("not an object")
429 if exists $builtin_type{$type};
430 $category = $type;
7e6d00f8
PM
431 $isobj = 1 ;
432 }
d3a7d8c7 433 $offset = $Offsets{$category};
c3186b65 434 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
435 unless defined $offset;
436 }
437 else {
0ca4541c 438 $category = (caller(1))[0] ;
d3a7d8c7 439 $offset = $Offsets{$category};
c3186b65 440 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
441 unless defined $offset ;
442 }
443
f0a8fd68 444 my $i;
7e6d00f8
PM
445
446 if ($isobj) {
f0a8fd68
NC
447 my $pkg;
448 $i = 2;
7e6d00f8
PM
449 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
450 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
451 }
452 $i -= 2 ;
453 }
454 else {
4f527b71 455 $i = _error_loc(); # see where Carp will allocate the error
7e6d00f8
PM
456 }
457
4e92cb89
NC
458 # Defaulting this to 0 reduces complexity in code paths below.
459 my $callers_bitmask = (caller($i))[9] || 0 ;
8787a747
NC
460
461 my @results;
462 foreach my $type (NORMAL, FATAL) {
463 next unless $wanted & $type;
464
465 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
466 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
467 }
468 return $wanted == (NORMAL | FATAL) ? @results : $results[0];
7e6d00f8
PM
469}
470
4f527b71 471sub _error_loc {
4dd71923 472 require Carp;
4f527b71
AS
473 goto &Carp::short_error_loc; # don't introduce another stack frame
474}
475
7e6d00f8
PM
476sub enabled
477{
c3186b65 478 Croaker("Usage: warnings::enabled([category])")
7e6d00f8
PM
479 unless @_ == 1 || @_ == 0 ;
480
8787a747 481 return __chk(NORMAL, @_);
599cee73
PM
482}
483
789c4615
RGS
484sub fatal_enabled
485{
486 Croaker("Usage: warnings::fatal_enabled([category])")
487 unless @_ == 1 || @_ == 0 ;
488
8787a747 489 return __chk(FATAL, @_);
789c4615 490}
d3a7d8c7 491
e476b1b5
GS
492sub warn
493{
c3186b65 494 Croaker("Usage: warnings::warn([category,] 'message')")
d3a7d8c7 495 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 496
7e6d00f8 497 my $message = pop ;
09e96b99 498 require Carp;
8787a747 499 Carp::croak($message) if __chk(FATAL, @_);
8becbb3b 500 Carp::carp($message) ;
e476b1b5
GS
501}
502
7e6d00f8
PM
503sub warnif
504{
c3186b65 505 Croaker("Usage: warnings::warnif([category,] 'message')")
7e6d00f8
PM
506 unless @_ == 2 || @_ == 1 ;
507
508 my $message = pop ;
8787a747 509 my ($warn, $fatal) = __chk(NORMAL | FATAL, @_);
7e6d00f8 510
8787a747 511 return unless $warn or $fatal;
7e6d00f8 512
09e96b99 513 require Carp;
8787a747 514 Carp::croak($message) if $fatal;
8becbb3b 515 Carp::carp($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.
520delete $warnings::{$_} foreach qw(NORMAL FATAL);
521
599cee73 5221;
37442d52 523# ex: set ro: