This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
As verified by Doug MacEachern.
[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
GS
131%Offsets = (
132 'all' => 0,
3eae5ce4 133 'closure' => 2,
12bcd1a6
PM
134 'deprecated' => 4,
135 'exiting' => 6,
136 'glob' => 8,
137 'io' => 10,
138 'closed' => 12,
139 'exec' => 14,
140 'newline' => 16,
141 'pipe' => 18,
142 'unopened' => 20,
143 'misc' => 22,
144 'numeric' => 24,
145 'once' => 26,
146 'overflow' => 28,
147 'pack' => 30,
148 'portable' => 32,
149 'recursion' => 34,
150 'redefine' => 36,
151 'regexp' => 38,
152 'severe' => 40,
153 'debugging' => 42,
154 'inplace' => 44,
155 'internal' => 46,
156 'malloc' => 48,
157 'signal' => 50,
158 'substr' => 52,
159 'syntax' => 54,
160 'ambiguous' => 56,
161 'bareword' => 58,
3eae5ce4
MJD
162 'digit' => 60,
163 'parenthesis' => 62,
164 'precedence' => 64,
165 'printf' => 66,
166 'prototype' => 68,
167 'qw' => 70,
168 'reserved' => 72,
169 'semicolon' => 74,
170 'taint' => 76,
171 'uninitialized' => 78,
172 'unpack' => 80,
173 'untie' => 82,
174 'utf8' => 84,
175 'void' => 86,
176 'y2k' => 88,
d3a7d8c7
GS
177 );
178
599cee73 179%Bits = (
3eae5ce4 180 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x01", # [0..44]
12bcd1a6
PM
181 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28]
182 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
183 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
3eae5ce4 184 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
12bcd1a6
PM
185 'debugging' => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21]
186 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
3eae5ce4 187 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
12bcd1a6
PM
188 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
189 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
190 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
191 'inplace' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
192 'internal' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
193 'io' => "\x00\x54\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
194 'malloc' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
195 'misc' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
196 'newline' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
197 'numeric' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
198 'once' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
199 'overflow' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
200 'pack' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
3eae5ce4 201 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
12bcd1a6
PM
202 'pipe' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
203 'portable' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
3eae5ce4
MJD
204 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
205 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
206 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
207 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
12bcd1a6
PM
208 'recursion' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
209 'redefine' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
210 'regexp' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
3eae5ce4
MJD
211 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
212 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
12bcd1a6
PM
213 'severe' => "\x00\x00\x00\x00\x00\x55\x01\x00\x00\x00\x00\x00", # [20..24]
214 'signal' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
215 'substr' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
216 'syntax' => "\x00\x00\x00\x00\x00\x00\x40\x55\x55\x05\x00\x00", # [27..37]
3eae5ce4
MJD
217 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
218 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
12bcd1a6 219 'unopened' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
3eae5ce4
MJD
220 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
221 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
222 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
223 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
224 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
599cee73
PM
225 );
226
227%DeadBits = (
3eae5ce4 228 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x02", # [0..44]
12bcd1a6
PM
229 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28]
230 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
231 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
3eae5ce4 232 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
12bcd1a6
PM
233 'debugging' => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21]
234 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
3eae5ce4 235 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
12bcd1a6
PM
236 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
237 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
238 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
239 'inplace' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
240 'internal' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
241 'io' => "\x00\xa8\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
242 'malloc' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
243 'misc' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
244 'newline' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
245 'numeric' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
246 'once' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
247 'overflow' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
248 'pack' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
3eae5ce4 249 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
12bcd1a6
PM
250 'pipe' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
251 'portable' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
3eae5ce4
MJD
252 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
253 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
254 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
255 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
12bcd1a6
PM
256 'recursion' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
257 'redefine' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
258 'regexp' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
3eae5ce4
MJD
259 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
260 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
12bcd1a6
PM
261 'severe' => "\x00\x00\x00\x00\x00\xaa\x02\x00\x00\x00\x00\x00", # [20..24]
262 'signal' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
263 'substr' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
264 'syntax' => "\x00\x00\x00\x00\x00\x00\x80\xaa\xaa\x0a\x00\x00", # [27..37]
3eae5ce4
MJD
265 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
266 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
12bcd1a6 267 'unopened' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
3eae5ce4
MJD
268 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
269 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
270 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
271 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
272 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
599cee73
PM
273 );
274
a86a20aa 275$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
3eae5ce4 276$LAST_BIT = 90 ;
a86a20aa 277$BYTES = 12 ;
d3a7d8c7
GS
278
279$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
599cee73 280
c3186b65
PM
281sub Croaker
282{
283 delete $Carp::CarpInternal{'warnings'};
284 croak @_ ;
285}
286
599cee73
PM
287sub bits {
288 my $mask ;
289 my $catmask ;
290 my $fatal = 0 ;
291 foreach my $word (@_) {
327afb7f
GS
292 if ($word eq 'FATAL') {
293 $fatal = 1;
294 }
d3a7d8c7
GS
295 elsif ($catmask = $Bits{$word}) {
296 $mask |= $catmask ;
297 $mask |= $DeadBits{$word} if $fatal ;
599cee73 298 }
d3a7d8c7 299 else
c3186b65 300 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
301 }
302
303 return $mask ;
304}
305
306sub import {
307 shift;
f1f33818
PM
308 my $mask = ${^WARNING_BITS} ;
309 if (vec($mask, $Offsets{'all'}, 1)) {
310 $mask |= $Bits{'all'} ;
311 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
312 }
313 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
599cee73
PM
314}
315
316sub unimport {
317 shift;
d3a7d8c7
GS
318 my $mask = ${^WARNING_BITS} ;
319 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 320 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
321 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
322 }
08540116 323 ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
599cee73
PM
324}
325
7e6d00f8 326sub __chk
599cee73 327{
d3a7d8c7
GS
328 my $category ;
329 my $offset ;
7e6d00f8 330 my $isobj = 0 ;
d3a7d8c7
GS
331
332 if (@_) {
333 # check the category supplied.
334 $category = shift ;
7e6d00f8 335 if (ref $category) {
c3186b65 336 Croaker ("not an object")
3d1a39c8 337 if $category !~ /^([^=]+)=/ ;
7e6d00f8
PM
338 $category = $1 ;
339 $isobj = 1 ;
340 }
d3a7d8c7 341 $offset = $Offsets{$category};
c3186b65 342 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
343 unless defined $offset;
344 }
345 else {
0ca4541c 346 $category = (caller(1))[0] ;
d3a7d8c7 347 $offset = $Offsets{$category};
c3186b65 348 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
349 unless defined $offset ;
350 }
351
0ca4541c 352 my $this_pkg = (caller(1))[0] ;
7e6d00f8
PM
353 my $i = 2 ;
354 my $pkg ;
355
356 if ($isobj) {
357 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
358 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
359 }
360 $i -= 2 ;
361 }
362 else {
363 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
364 last if $pkg ne $this_pkg ;
365 }
0ca4541c 366 $i = 2
7e6d00f8
PM
367 if !$pkg || $pkg eq $this_pkg ;
368 }
369
0ca4541c 370 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8
PM
371 return ($callers_bitmask, $offset, $i) ;
372}
373
374sub enabled
375{
c3186b65 376 Croaker("Usage: warnings::enabled([category])")
7e6d00f8
PM
377 unless @_ == 1 || @_ == 0 ;
378
379 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
380
381 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
382 return vec($callers_bitmask, $offset, 1) ||
383 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73
PM
384}
385
d3a7d8c7 386
e476b1b5
GS
387sub warn
388{
c3186b65 389 Croaker("Usage: warnings::warn([category,] 'message')")
d3a7d8c7 390 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 391
7e6d00f8
PM
392 my $message = pop ;
393 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
0ca4541c 394 croak($message)
d3a7d8c7
GS
395 if vec($callers_bitmask, $offset+1, 1) ||
396 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5
GS
397 carp($message) ;
398}
399
7e6d00f8
PM
400sub warnif
401{
c3186b65 402 Croaker("Usage: warnings::warnif([category,] 'message')")
7e6d00f8
PM
403 unless @_ == 2 || @_ == 1 ;
404
405 my $message = pop ;
406 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
7e6d00f8 407
0ca4541c 408 return
7e6d00f8
PM
409 unless defined $callers_bitmask &&
410 (vec($callers_bitmask, $offset, 1) ||
411 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
412
0ca4541c 413 croak($message)
7e6d00f8
PM
414 if vec($callers_bitmask, $offset+1, 1) ||
415 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
416
417 carp($message) ;
418}
599cee73 4191;