This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH warnings, perldiag] document diagnostics
[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
35 warnif("some warning");
36 warnif("void", "some warning");
37 warnif($object, "some warning");
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
MJD
133 'closure' => 2,
134 'exiting' => 4,
135 'glob' => 6,
136 'io' => 8,
137 'closed' => 10,
138 'exec' => 12,
139 'newline' => 14,
140 'pipe' => 16,
141 'unopened' => 18,
142 'misc' => 20,
143 'numeric' => 22,
144 'once' => 24,
145 'overflow' => 26,
146 'pack' => 28,
147 'portable' => 30,
148 'recursion' => 32,
149 'redefine' => 34,
150 'regexp' => 36,
151 'severe' => 38,
152 'debugging' => 40,
153 'inplace' => 42,
154 'internal' => 44,
155 'malloc' => 46,
156 'signal' => 48,
157 'substr' => 50,
158 'syntax' => 52,
159 'ambiguous' => 54,
160 'bareword' => 56,
161 'deprecated' => 58,
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
MJD
180 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x01", # [0..44]
181 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
182 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28]
183 'closed' => "\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5]
184 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
185 'debugging' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
186 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
187 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
188 'exec' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
189 'exiting' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
190 'glob' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
191 'inplace' => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21]
192 'internal' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
193 'io' => "\x00\x55\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9]
194 'malloc' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
195 'misc' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
196 'newline' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
197 'numeric' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
198 'once' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
199 'overflow' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
200 'pack' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
201 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
202 'pipe' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
203 'portable' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
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]
208 'recursion' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
209 'redefine' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
210 'regexp' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
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]
213 'severe' => "\x00\x00\x00\x00\x40\x55\x00\x00\x00\x00\x00\x00", # [19..23]
214 'signal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
215 'substr' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
216 'syntax' => "\x00\x00\x00\x00\x00\x00\x50\x55\x55\x05\x00\x00", # [26..37]
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]
219 'unopened' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
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
MJD
228 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x02", # [0..44]
229 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
230 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28]
231 'closed' => "\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5]
232 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
233 'debugging' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
234 'deprecated' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
235 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
236 'exec' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
237 'exiting' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
238 'glob' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
239 'inplace' => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21]
240 'internal' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
241 'io' => "\x00\xaa\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9]
242 'malloc' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
243 'misc' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
244 'newline' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
245 'numeric' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
246 'once' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
247 'overflow' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
248 'pack' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
249 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
250 'pipe' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
251 'portable' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
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]
256 'recursion' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
257 'redefine' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
258 'regexp' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
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]
261 'severe' => "\x00\x00\x00\x00\x80\xaa\x00\x00\x00\x00\x00\x00", # [19..23]
262 'signal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
263 'substr' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
264 'syntax' => "\x00\x00\x00\x00\x00\x00\xa0\xaa\xaa\x0a\x00\x00", # [26..37]
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]
267 'unopened' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
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
PM
280
281sub bits {
282 my $mask ;
283 my $catmask ;
284 my $fatal = 0 ;
285 foreach my $word (@_) {
327afb7f
GS
286 if ($word eq 'FATAL') {
287 $fatal = 1;
288 }
d3a7d8c7
GS
289 elsif ($catmask = $Bits{$word}) {
290 $mask |= $catmask ;
291 $mask |= $DeadBits{$word} if $fatal ;
599cee73 292 }
d3a7d8c7 293 else
3d1a39c8 294 { croak("Unknown warnings category '$word'")}
599cee73
PM
295 }
296
297 return $mask ;
298}
299
300sub import {
301 shift;
f1f33818
PM
302 my $mask = ${^WARNING_BITS} ;
303 if (vec($mask, $Offsets{'all'}, 1)) {
304 $mask |= $Bits{'all'} ;
305 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
306 }
307 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
599cee73
PM
308}
309
310sub unimport {
311 shift;
d3a7d8c7
GS
312 my $mask = ${^WARNING_BITS} ;
313 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 314 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
315 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
316 }
08540116 317 ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
599cee73
PM
318}
319
7e6d00f8 320sub __chk
599cee73 321{
d3a7d8c7
GS
322 my $category ;
323 my $offset ;
7e6d00f8 324 my $isobj = 0 ;
d3a7d8c7
GS
325
326 if (@_) {
327 # check the category supplied.
328 $category = shift ;
7e6d00f8
PM
329 if (ref $category) {
330 croak ("not an object")
3d1a39c8 331 if $category !~ /^([^=]+)=/ ;
7e6d00f8
PM
332 $category = $1 ;
333 $isobj = 1 ;
334 }
d3a7d8c7 335 $offset = $Offsets{$category};
3d1a39c8 336 croak("Unknown warnings category '$category'")
d3a7d8c7
GS
337 unless defined $offset;
338 }
339 else {
0ca4541c 340 $category = (caller(1))[0] ;
d3a7d8c7
GS
341 $offset = $Offsets{$category};
342 croak("package '$category' not registered for warnings")
343 unless defined $offset ;
344 }
345
0ca4541c 346 my $this_pkg = (caller(1))[0] ;
7e6d00f8
PM
347 my $i = 2 ;
348 my $pkg ;
349
350 if ($isobj) {
351 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
352 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
353 }
354 $i -= 2 ;
355 }
356 else {
357 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
358 last if $pkg ne $this_pkg ;
359 }
0ca4541c 360 $i = 2
7e6d00f8
PM
361 if !$pkg || $pkg eq $this_pkg ;
362 }
363
0ca4541c 364 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8
PM
365 return ($callers_bitmask, $offset, $i) ;
366}
367
368sub enabled
369{
370 croak("Usage: warnings::enabled([category])")
371 unless @_ == 1 || @_ == 0 ;
372
373 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
374
375 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
376 return vec($callers_bitmask, $offset, 1) ||
377 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73
PM
378}
379
d3a7d8c7 380
e476b1b5
GS
381sub warn
382{
d3a7d8c7
GS
383 croak("Usage: warnings::warn([category,] 'message')")
384 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 385
7e6d00f8
PM
386 my $message = pop ;
387 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
388 local $Carp::CarpLevel = $i ;
0ca4541c 389 croak($message)
d3a7d8c7
GS
390 if vec($callers_bitmask, $offset+1, 1) ||
391 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5
GS
392 carp($message) ;
393}
394
7e6d00f8
PM
395sub warnif
396{
397 croak("Usage: warnings::warnif([category,] 'message')")
398 unless @_ == 2 || @_ == 1 ;
399
400 my $message = pop ;
401 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
402 local $Carp::CarpLevel = $i ;
403
0ca4541c 404 return
7e6d00f8
PM
405 unless defined $callers_bitmask &&
406 (vec($callers_bitmask, $offset, 1) ||
407 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
408
0ca4541c 409 croak($message)
7e6d00f8
PM
410 if vec($callers_bitmask, $offset+1, 1) ||
411 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
412
413 carp($message) ;
414}
599cee73 4151;