This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Storable status tweak.
[perl5.git] / lib / warnings.pm
CommitLineData
599cee73 1
4438c4b7 2# This file was created by warnings.pl
599cee73
PM
3# Any changes made here will be lost.
4#
5
4438c4b7 6package warnings;
599cee73 7
0ca4541c
NIS
8our $VERSION = '1.00';
9
599cee73
PM
10=head1 NAME
11
4438c4b7 12warnings - Perl pragma to control optional warnings
599cee73
PM
13
14=head1 SYNOPSIS
15
4438c4b7
JH
16 use warnings;
17 no warnings;
599cee73 18
4438c4b7
JH
19 use warnings "all";
20 no warnings "all";
599cee73 21
d3a7d8c7
GS
22 use warnings::register;
23 if (warnings::enabled()) {
24 warnings::warn("some warning");
25 }
26
27 if (warnings::enabled("void")) {
e476b1b5
GS
28 warnings::warn("void", "some warning");
29 }
30
7e6d00f8
PM
31 if (warnings::enabled($object)) {
32 warnings::warn($object, "some warning");
33 }
34
721f911b
PM
35 warnings::warnif("some warning");
36 warnings::warnif("void", "some warning");
37 warnings::warnif($object, "some warning");
7e6d00f8 38
599cee73
PM
39=head1 DESCRIPTION
40
0453d815
PM
41If no import list is supplied, all possible warnings are either enabled
42or disabled.
599cee73 43
0ca4541c 44A number of functions are provided to assist module authors.
e476b1b5
GS
45
46=over 4
47
d3a7d8c7
GS
48=item use warnings::register
49
7e6d00f8
PM
50Creates a new warnings category with the same name as the package where
51the call to the pragma is used.
52
53=item warnings::enabled()
54
55Use the warnings category with the same name as the current package.
56
57Return TRUE if that warnings category is enabled in the calling module.
58Otherwise returns FALSE.
59
60=item warnings::enabled($category)
61
62Return TRUE if the warnings category, C<$category>, is enabled in the
63calling module.
64Otherwise returns FALSE.
65
66=item warnings::enabled($object)
67
68Use the name of the class for the object reference, C<$object>, as the
69warnings category.
70
71Return TRUE if that warnings category is enabled in the first scope
72where the object is used.
73Otherwise returns FALSE.
74
75=item warnings::warn($message)
76
77Print C<$message> to STDERR.
78
79Use the warnings category with the same name as the current package.
80
81If that warnings category has been set to "FATAL" in the calling module
82then die. Otherwise return.
83
84=item warnings::warn($category, $message)
85
86Print C<$message> to STDERR.
87
88If the warnings category, C<$category>, has been set to "FATAL" in the
89calling module then die. Otherwise return.
e476b1b5 90
7e6d00f8 91=item warnings::warn($object, $message)
e476b1b5 92
7e6d00f8 93Print C<$message> to STDERR.
e476b1b5 94
7e6d00f8
PM
95Use the name of the class for the object reference, C<$object>, as the
96warnings category.
d3a7d8c7 97
7e6d00f8
PM
98If that warnings category has been set to "FATAL" in the scope where C<$object>
99is first used then die. Otherwise return.
599cee73 100
e476b1b5 101
7e6d00f8
PM
102=item warnings::warnif($message)
103
104Equivalent to:
105
106 if (warnings::enabled())
107 { warnings::warn($message) }
108
109=item warnings::warnif($category, $message)
110
111Equivalent to:
112
113 if (warnings::enabled($category))
114 { warnings::warn($category, $message) }
115
116=item warnings::warnif($object, $message)
117
118Equivalent to:
119
120 if (warnings::enabled($object))
121 { warnings::warn($object, $message) }
d3a7d8c7 122
e476b1b5
GS
123=back
124
749f83fa 125See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
126
127=cut
128
129use Carp ;
130
d3a7d8c7 131%Offsets = (
0d658bf5
PM
132
133 # Warnings Categories added in Perl 5.008
134
d3a7d8c7 135 'all' => 0,
3eae5ce4 136 'closure' => 2,
12bcd1a6
PM
137 'deprecated' => 4,
138 'exiting' => 6,
139 'glob' => 8,
140 'io' => 10,
141 'closed' => 12,
142 'exec' => 14,
99ef548b
PM
143 'layer' => 16,
144 'newline' => 18,
145 'pipe' => 20,
146 'unopened' => 22,
147 'misc' => 24,
148 'numeric' => 26,
149 'once' => 28,
150 'overflow' => 30,
151 'pack' => 32,
152 'portable' => 34,
153 'recursion' => 36,
154 'redefine' => 38,
155 'regexp' => 40,
156 'severe' => 42,
157 'debugging' => 44,
158 'inplace' => 46,
159 'internal' => 48,
160 'malloc' => 50,
161 'signal' => 52,
162 'substr' => 54,
163 'syntax' => 56,
164 'ambiguous' => 58,
165 'bareword' => 60,
166 'digit' => 62,
167 'parenthesis' => 64,
168 'precedence' => 66,
169 'printf' => 68,
170 'prototype' => 70,
171 'qw' => 72,
172 'reserved' => 74,
173 'semicolon' => 76,
174 'taint' => 78,
175 'uninitialized' => 80,
176 'unpack' => 82,
177 'untie' => 84,
178 'utf8' => 86,
179 'void' => 88,
180 'y2k' => 90,
d3a7d8c7
GS
181 );
182
599cee73 183%Bits = (
99ef548b
PM
184 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x05", # [0..45]
185 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
186 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
12bcd1a6 187 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
3eae5ce4 188 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
99ef548b 189 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
12bcd1a6 190 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
99ef548b 191 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
12bcd1a6
PM
192 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
193 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
194 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
99ef548b
PM
195 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
196 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
197 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
198 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
199 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
200 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
201 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
202 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
203 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
204 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
205 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
206 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
207 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
208 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
209 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
210 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
211 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
212 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
213 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
214 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
215 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
216 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
217 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
218 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
219 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
220 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
221 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
222 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
223 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
224 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
225 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
226 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
227 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
228 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
229 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
599cee73
PM
230 );
231
232%DeadBits = (
99ef548b
PM
233 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x0a", # [0..45]
234 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
235 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
12bcd1a6 236 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
3eae5ce4 237 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
99ef548b 238 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
12bcd1a6 239 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
99ef548b 240 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
12bcd1a6
PM
241 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
242 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
243 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
99ef548b
PM
244 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
245 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
246 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
247 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
248 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
249 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
250 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
251 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
252 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
253 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
254 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
255 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
256 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
257 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
258 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
259 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
260 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
261 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
262 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
263 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
264 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
265 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
266 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
267 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
268 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
269 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
270 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
271 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
272 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
273 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
274 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
275 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
276 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
277 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
278 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
599cee73
PM
279 );
280
a86a20aa 281$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
99ef548b 282$LAST_BIT = 92 ;
a86a20aa 283$BYTES = 12 ;
d3a7d8c7
GS
284
285$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
599cee73 286
c3186b65
PM
287sub Croaker
288{
289 delete $Carp::CarpInternal{'warnings'};
290 croak @_ ;
291}
292
599cee73
PM
293sub bits {
294 my $mask ;
295 my $catmask ;
296 my $fatal = 0 ;
297 foreach my $word (@_) {
327afb7f
GS
298 if ($word eq 'FATAL') {
299 $fatal = 1;
300 }
d3a7d8c7
GS
301 elsif ($catmask = $Bits{$word}) {
302 $mask |= $catmask ;
303 $mask |= $DeadBits{$word} if $fatal ;
599cee73 304 }
d3a7d8c7 305 else
c3186b65 306 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
307 }
308
309 return $mask ;
310}
311
312sub import {
313 shift;
f1f33818
PM
314 my $mask = ${^WARNING_BITS} ;
315 if (vec($mask, $Offsets{'all'}, 1)) {
316 $mask |= $Bits{'all'} ;
317 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
318 }
319 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
599cee73
PM
320}
321
322sub unimport {
323 shift;
d3a7d8c7
GS
324 my $mask = ${^WARNING_BITS} ;
325 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 326 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
327 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
328 }
08540116 329 ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
599cee73
PM
330}
331
7e6d00f8 332sub __chk
599cee73 333{
d3a7d8c7
GS
334 my $category ;
335 my $offset ;
7e6d00f8 336 my $isobj = 0 ;
d3a7d8c7
GS
337
338 if (@_) {
339 # check the category supplied.
340 $category = shift ;
7e6d00f8 341 if (ref $category) {
c3186b65 342 Croaker ("not an object")
3d1a39c8 343 if $category !~ /^([^=]+)=/ ;
7e6d00f8
PM
344 $category = $1 ;
345 $isobj = 1 ;
346 }
d3a7d8c7 347 $offset = $Offsets{$category};
c3186b65 348 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
349 unless defined $offset;
350 }
351 else {
0ca4541c 352 $category = (caller(1))[0] ;
d3a7d8c7 353 $offset = $Offsets{$category};
c3186b65 354 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
355 unless defined $offset ;
356 }
357
0ca4541c 358 my $this_pkg = (caller(1))[0] ;
7e6d00f8
PM
359 my $i = 2 ;
360 my $pkg ;
361
362 if ($isobj) {
363 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
364 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
365 }
366 $i -= 2 ;
367 }
368 else {
369 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
370 last if $pkg ne $this_pkg ;
371 }
0ca4541c 372 $i = 2
7e6d00f8
PM
373 if !$pkg || $pkg eq $this_pkg ;
374 }
375
0ca4541c 376 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8
PM
377 return ($callers_bitmask, $offset, $i) ;
378}
379
380sub enabled
381{
c3186b65 382 Croaker("Usage: warnings::enabled([category])")
7e6d00f8
PM
383 unless @_ == 1 || @_ == 0 ;
384
385 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
386
387 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
388 return vec($callers_bitmask, $offset, 1) ||
389 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73
PM
390}
391
d3a7d8c7 392
e476b1b5
GS
393sub warn
394{
c3186b65 395 Croaker("Usage: warnings::warn([category,] 'message')")
d3a7d8c7 396 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 397
7e6d00f8
PM
398 my $message = pop ;
399 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
0ca4541c 400 croak($message)
d3a7d8c7
GS
401 if vec($callers_bitmask, $offset+1, 1) ||
402 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5
GS
403 carp($message) ;
404}
405
7e6d00f8
PM
406sub warnif
407{
c3186b65 408 Croaker("Usage: warnings::warnif([category,] 'message')")
7e6d00f8
PM
409 unless @_ == 2 || @_ == 1 ;
410
411 my $message = pop ;
412 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
7e6d00f8 413
0ca4541c 414 return
7e6d00f8
PM
415 unless defined $callers_bitmask &&
416 (vec($callers_bitmask, $offset, 1) ||
417 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
418
0ca4541c 419 croak($message)
7e6d00f8
PM
420 if vec($callers_bitmask, $offset+1, 1) ||
421 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
422
423 carp($message) ;
424}
0d658bf5 425
599cee73 4261;