I don't think trying to bracket the hires time with lores
[p5sagit/p5-mst-13.2.git] / lib / warnings.pm
CommitLineData
599cee73 1
4438c4b7 2# This file was created by warnings.pl
599cee73 3# Any changes made here will be lost.
4#
5
4438c4b7 6package warnings;
599cee73 7
0ca4541c 8our $VERSION = '1.00';
9
599cee73 10=head1 NAME
11
4438c4b7 12warnings - Perl pragma to control optional warnings
599cee73 13
14=head1 SYNOPSIS
15
4438c4b7 16 use warnings;
17 no warnings;
599cee73 18
4438c4b7 19 use warnings "all";
20 no warnings "all";
599cee73 21
d3a7d8c7 22 use warnings::register;
23 if (warnings::enabled()) {
24 warnings::warn("some warning");
25 }
26
27 if (warnings::enabled("void")) {
e476b1b5 28 warnings::warn("void", "some warning");
29 }
30
7e6d00f8 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 39=head1 DESCRIPTION
40
0453d815 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 45
46=over 4
47
d3a7d8c7 48=item use warnings::register
49
7e6d00f8 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 95Use the name of the class for the object reference, C<$object>, as the
96warnings category.
d3a7d8c7 97
7e6d00f8 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 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 123=back
124
749f83fa 125See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73 126
127=cut
128
129use Carp ;
130
d3a7d8c7 131%Offsets = (
132 'all' => 0,
3eae5ce4 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 177 );
178
599cee73 179%Bits = (
3eae5ce4 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 225 );
226
227%DeadBits = (
3eae5ce4 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 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 278
279$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
599cee73 280
281sub bits {
282 my $mask ;
283 my $catmask ;
284 my $fatal = 0 ;
285 foreach my $word (@_) {
327afb7f 286 if ($word eq 'FATAL') {
287 $fatal = 1;
288 }
d3a7d8c7 289 elsif ($catmask = $Bits{$word}) {
290 $mask |= $catmask ;
291 $mask |= $DeadBits{$word} if $fatal ;
599cee73 292 }
d3a7d8c7 293 else
0ca4541c 294 { croak("unknown warnings category '$word'")}
599cee73 295 }
296
297 return $mask ;
298}
299
300sub import {
301 shift;
f1f33818 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 308}
309
310sub unimport {
311 shift;
d3a7d8c7 312 my $mask = ${^WARNING_BITS} ;
313 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 314 $mask |= $Bits{'all'} ;
d3a7d8c7 315 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
316 }
08540116 317 ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
599cee73 318}
319
7e6d00f8 320sub __chk
599cee73 321{
d3a7d8c7 322 my $category ;
323 my $offset ;
7e6d00f8 324 my $isobj = 0 ;
d3a7d8c7 325
326 if (@_) {
327 # check the category supplied.
328 $category = shift ;
7e6d00f8 329 if (ref $category) {
330 croak ("not an object")
331 if $category !~ /^([^=]+)=/ ;+
332 $category = $1 ;
333 $isobj = 1 ;
334 }
d3a7d8c7 335 $offset = $Offsets{$category};
336 croak("unknown warnings category '$category'")
337 unless defined $offset;
338 }
339 else {
0ca4541c 340 $category = (caller(1))[0] ;
d3a7d8c7 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 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 361 if !$pkg || $pkg eq $this_pkg ;
362 }
363
0ca4541c 364 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8 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 376 return vec($callers_bitmask, $offset, 1) ||
377 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73 378}
379
d3a7d8c7 380
e476b1b5 381sub warn
382{
d3a7d8c7 383 croak("Usage: warnings::warn([category,] 'message')")
384 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 385
7e6d00f8 386 my $message = pop ;
387 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
388 local $Carp::CarpLevel = $i ;
0ca4541c 389 croak($message)
d3a7d8c7 390 if vec($callers_bitmask, $offset+1, 1) ||
391 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5 392 carp($message) ;
393}
394
7e6d00f8 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 405 unless defined $callers_bitmask &&
406 (vec($callers_bitmask, $offset, 1) ||
407 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
408
0ca4541c 409 croak($message)
7e6d00f8 410 if vec($callers_bitmask, $offset+1, 1) ||
411 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
412
413 carp($message) ;
414}
599cee73 4151;