This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
warnings::import() can exit quickly and efficiently if @_ is empty.
[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
6e9af7e4
PM
335sub bits
336{
337 # called from B::Deparse.pm
338
339 push @_, 'all' unless @_;
340
341 my $mask;
599cee73
PM
342 my $catmask ;
343 my $fatal = 0 ;
6e9af7e4
PM
344 my $no_fatal = 0 ;
345
346 foreach my $word ( @_ ) {
347 if ($word eq 'FATAL') {
327afb7f 348 $fatal = 1;
6e9af7e4
PM
349 $no_fatal = 0;
350 }
351 elsif ($word eq 'NONFATAL') {
352 $fatal = 0;
353 $no_fatal = 1;
327afb7f 354 }
d3a7d8c7
GS
355 elsif ($catmask = $Bits{$word}) {
356 $mask |= $catmask ;
357 $mask |= $DeadBits{$word} if $fatal ;
6e9af7e4 358 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
599cee73 359 }
d3a7d8c7 360 else
c3186b65 361 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
362 }
363
364 return $mask ;
365}
366
6e9af7e4
PM
367sub import
368{
599cee73 369 shift;
6e9af7e4 370
f1f33818 371 my $mask = ${^WARNING_BITS} ;
6e9af7e4 372
f1f33818
PM
373 if (vec($mask, $Offsets{'all'}, 1)) {
374 $mask |= $Bits{'all'} ;
375 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
376 }
6e9af7e4 377
8452af9f
NC
378 unless (@_) {
379 # This is equivalent to @_ = 'all' ;
380 return ${^WARNING_BITS} = $mask | $Bits{all} ;
381 }
382
383 my $catmask ;
384 my $fatal = 0 ;
385 my $no_fatal = 0 ;
6e9af7e4
PM
386
387 foreach my $word ( @_ ) {
388 if ($word eq 'FATAL') {
389 $fatal = 1;
390 $no_fatal = 0;
391 }
392 elsif ($word eq 'NONFATAL') {
393 $fatal = 0;
394 $no_fatal = 1;
395 }
396 elsif ($catmask = $Bits{$word}) {
397 $mask |= $catmask ;
398 $mask |= $DeadBits{$word} if $fatal ;
399 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
400 }
401 else
402 { Croaker("Unknown warnings category '$word'")}
403 }
404
405 ${^WARNING_BITS} = $mask ;
599cee73
PM
406}
407
6e9af7e4
PM
408sub unimport
409{
599cee73 410 shift;
6e9af7e4
PM
411
412 my $catmask ;
d3a7d8c7 413 my $mask = ${^WARNING_BITS} ;
6e9af7e4 414
d3a7d8c7 415 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 416 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
417 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
418 }
6e9af7e4
PM
419
420 push @_, 'all' unless @_;
421
422 foreach my $word ( @_ ) {
423 if ($word eq 'FATAL') {
424 next;
425 }
426 elsif ($catmask = $Bits{$word}) {
427 $mask &= ~($catmask | $DeadBits{$word} | $All);
428 }
429 else
430 { Croaker("Unknown warnings category '$word'")}
431 }
432
433 ${^WARNING_BITS} = $mask ;
599cee73
PM
434}
435
9df0f64f 436my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
437
7e6d00f8 438sub __chk
599cee73 439{
d3a7d8c7
GS
440 my $category ;
441 my $offset ;
7e6d00f8 442 my $isobj = 0 ;
d3a7d8c7
GS
443
444 if (@_) {
445 # check the category supplied.
446 $category = shift ;
9df0f64f 447 if (my $type = ref $category) {
448 Croaker("not an object")
449 if exists $builtin_type{$type};
450 $category = $type;
7e6d00f8
PM
451 $isobj = 1 ;
452 }
d3a7d8c7 453 $offset = $Offsets{$category};
c3186b65 454 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
455 unless defined $offset;
456 }
457 else {
0ca4541c 458 $category = (caller(1))[0] ;
d3a7d8c7 459 $offset = $Offsets{$category};
c3186b65 460 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
461 unless defined $offset ;
462 }
463
f0a8fd68 464 my $i;
7e6d00f8
PM
465
466 if ($isobj) {
f0a8fd68
NC
467 my $pkg;
468 $i = 2;
7e6d00f8
PM
469 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
470 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
471 }
472 $i -= 2 ;
473 }
474 else {
4f527b71 475 $i = _error_loc(); # see where Carp will allocate the error
7e6d00f8
PM
476 }
477
0ca4541c 478 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8
PM
479 return ($callers_bitmask, $offset, $i) ;
480}
481
4f527b71 482sub _error_loc {
4dd71923 483 require Carp;
4f527b71
AS
484 goto &Carp::short_error_loc; # don't introduce another stack frame
485}
486
7e6d00f8
PM
487sub enabled
488{
c3186b65 489 Croaker("Usage: warnings::enabled([category])")
7e6d00f8
PM
490 unless @_ == 1 || @_ == 0 ;
491
492 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
493
494 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
495 return vec($callers_bitmask, $offset, 1) ||
496 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73
PM
497}
498
789c4615
RGS
499sub fatal_enabled
500{
501 Croaker("Usage: warnings::fatal_enabled([category])")
502 unless @_ == 1 || @_ == 0 ;
503
504 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
505
506 return 0 unless defined $callers_bitmask;
507 return vec($callers_bitmask, $offset + 1, 1) ||
508 vec($callers_bitmask, $Offsets{'all'} + 1, 1) ;
509}
d3a7d8c7 510
e476b1b5
GS
511sub warn
512{
c3186b65 513 Croaker("Usage: warnings::warn([category,] 'message')")
d3a7d8c7 514 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 515
7e6d00f8
PM
516 my $message = pop ;
517 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
09e96b99 518 require Carp;
8becbb3b 519 Carp::croak($message)
d3a7d8c7
GS
520 if vec($callers_bitmask, $offset+1, 1) ||
521 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
8becbb3b 522 Carp::carp($message) ;
e476b1b5
GS
523}
524
7e6d00f8
PM
525sub warnif
526{
c3186b65 527 Croaker("Usage: warnings::warnif([category,] 'message')")
7e6d00f8
PM
528 unless @_ == 2 || @_ == 1 ;
529
530 my $message = pop ;
531 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
7e6d00f8 532
0ca4541c 533 return
7e6d00f8
PM
534 unless defined $callers_bitmask &&
535 (vec($callers_bitmask, $offset, 1) ||
536 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
537
09e96b99 538 require Carp;
8becbb3b 539 Carp::croak($message)
7e6d00f8
PM
540 if vec($callers_bitmask, $offset+1, 1) ||
541 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
542
8becbb3b 543 Carp::carp($message) ;
7e6d00f8 544}
0d658bf5 545
599cee73 5461;
37442d52 547# ex: set ro: