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