1 # -*- buffer-read-only: t -*-
2 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
3 # This file is built by regen/warnings.pl.
4 # Any changes made here will be lost!
10 # Verify that we're called correctly so that warnings will work.
12 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
13 my (undef, $f, $l) = caller;
14 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
19 warnings - Perl pragma to control optional warnings
29 use warnings::register;
30 if (warnings::enabled()) {
31 warnings::warn("some warning");
34 if (warnings::enabled("void")) {
35 warnings::warn("void", "some warning");
38 if (warnings::enabled($object)) {
39 warnings::warn($object, "some warning");
42 warnings::warnif("some warning");
43 warnings::warnif("void", "some warning");
44 warnings::warnif($object, "some warning");
48 The C<warnings> pragma is a replacement for the command line flag C<-w>,
49 but the pragma is limited to the enclosing block, while the flag is global.
50 See L<perllexwarn> for more information and the list of built-in warning
53 If no import list is supplied, all possible warnings are either enabled
56 A number of functions are provided to assist module authors.
60 =item use warnings::register
62 Creates a new warnings category with the same name as the package where
63 the call to the pragma is used.
65 =item warnings::enabled()
67 Use the warnings category with the same name as the current package.
69 Return TRUE if that warnings category is enabled in the calling module.
70 Otherwise returns FALSE.
72 =item warnings::enabled($category)
74 Return TRUE if the warnings category, C<$category>, is enabled in the
76 Otherwise returns FALSE.
78 =item warnings::enabled($object)
80 Use the name of the class for the object reference, C<$object>, as the
83 Return TRUE if that warnings category is enabled in the first scope
84 where the object is used.
85 Otherwise returns FALSE.
87 =item warnings::fatal_enabled()
89 Return TRUE if the warnings category with the same name as the current
90 package has been set to FATAL in the calling module.
91 Otherwise returns FALSE.
93 =item warnings::fatal_enabled($category)
95 Return TRUE if the warnings category C<$category> has been set to FATAL in
97 Otherwise returns FALSE.
99 =item warnings::fatal_enabled($object)
101 Use the name of the class for the object reference, C<$object>, as the
104 Return TRUE if that warnings category has been set to FATAL in the first
105 scope where the object is used.
106 Otherwise returns FALSE.
108 =item warnings::warn($message)
110 Print C<$message> to STDERR.
112 Use the warnings category with the same name as the current package.
114 If that warnings category has been set to "FATAL" in the calling module
115 then die. Otherwise return.
117 =item warnings::warn($category, $message)
119 Print C<$message> to STDERR.
121 If the warnings category, C<$category>, has been set to "FATAL" in the
122 calling module then die. Otherwise return.
124 =item warnings::warn($object, $message)
126 Print C<$message> to STDERR.
128 Use the name of the class for the object reference, C<$object>, as the
131 If that warnings category has been set to "FATAL" in the scope where C<$object>
132 is first used then die. Otherwise return.
135 =item warnings::warnif($message)
139 if (warnings::enabled())
140 { warnings::warn($message) }
142 =item warnings::warnif($category, $message)
146 if (warnings::enabled($category))
147 { warnings::warn($category, $message) }
149 =item warnings::warnif($object, $message)
153 if (warnings::enabled($object))
154 { warnings::warn($object, $message) }
156 =item warnings::register_categories(@names)
158 This registers warning categories for the given names and is primarily for
159 use by the warnings::register pragma, for which see L<perllexwarn>.
163 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
169 # Warnings Categories added in Perl 5.008
212 'uninitialized' => 82,
218 # Warnings Categories added in Perl 5.011
221 'illegalproto' => 94,
223 # Warnings Categories added in Perl 5.013
229 # Warnings Categories added in Perl 5.017
231 'experimental' => 102,
232 'experimental::lexical_subs'=> 104,
236 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x01", # [0..52]
237 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [29]
238 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [30]
239 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
240 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
241 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
242 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
243 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [31]
244 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
245 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
246 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01", # [51,52]
247 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [52]
248 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
249 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [47]
250 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [46]
251 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
252 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [24]
253 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
254 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
255 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [25]
256 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
257 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
258 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [48]
259 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [49]
260 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
261 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
262 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
263 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
264 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [32]
265 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
266 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
267 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [33]
268 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [34]
269 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [35]
270 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [36]
271 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
272 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
273 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
274 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [37]
275 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [38]
276 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00", # [21..25]
277 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [26]
278 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [27]
279 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [50]
280 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00", # [28..38,47]
281 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [39]
282 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [40]
283 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [41]
284 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
285 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [42]
286 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [43]
287 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00", # [44,48..50]
288 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [45]
292 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x02", # [0..52]
293 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [29]
294 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [30]
295 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
296 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
297 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
298 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
299 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [31]
300 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
301 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
302 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02", # [51,52]
303 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [52]
304 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
305 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [47]
306 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [46]
307 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
308 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [24]
309 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
310 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
311 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [25]
312 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
313 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
314 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [48]
315 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [49]
316 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
317 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
318 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
319 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
320 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [32]
321 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
322 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
323 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [33]
324 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [34]
325 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [35]
326 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [36]
327 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
328 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
329 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
330 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [37]
331 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [38]
332 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00", # [21..25]
333 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [26]
334 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [27]
335 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [50]
336 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00", # [28..38,47]
337 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [39]
338 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [40]
339 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [41]
340 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
341 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [42]
342 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [43]
343 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00", # [44,48..50]
344 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [45]
347 $NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
348 $DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x01", # [2,52,4,22,23,25]
352 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
356 require Carp; # this initializes %CarpInternal
357 local $Carp::CarpInternal{'warnings'};
358 delete $Carp::CarpInternal{'warnings'};
368 foreach my $word ( @_ ) {
369 if ($word eq 'FATAL') {
373 elsif ($word eq 'NONFATAL') {
377 elsif ($catmask = $Bits{$word}) {
379 $mask |= $DeadBits{$word} if $fatal ;
380 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
383 { Croaker("Unknown warnings category '$word'")}
391 # called from B::Deparse.pm
392 push @_, 'all' unless @_ ;
393 return _bits(undef, @_) ;
400 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
402 if (vec($mask, $Offsets{'all'}, 1)) {
403 $mask |= $Bits{'all'} ;
404 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
407 # Empty @_ is equivalent to @_ = 'all' ;
408 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
416 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
418 if (vec($mask, $Offsets{'all'}, 1)) {
419 $mask |= $Bits{'all'} ;
420 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
423 push @_, 'all' unless @_;
425 foreach my $word ( @_ ) {
426 if ($word eq 'FATAL') {
429 elsif ($catmask = $Bits{$word}) {
430 $mask &= ~($catmask | $DeadBits{$word} | $All);
433 { Croaker("Unknown warnings category '$word'")}
436 ${^WARNING_BITS} = $mask ;
439 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
441 sub MESSAGE () { 4 };
451 my $has_message = $wanted & MESSAGE;
453 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
454 my $sub = (caller 1)[3];
455 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
456 Croaker("Usage: $sub($syntax)");
459 my $message = pop if $has_message;
462 # check the category supplied.
464 if (my $type = ref $category) {
465 Croaker("not an object")
466 if exists $builtin_type{$type};
470 $offset = $Offsets{$category};
471 Croaker("Unknown warnings category '$category'")
472 unless defined $offset;
475 $category = (caller(1))[0] ;
476 $offset = $Offsets{$category};
477 Croaker("package '$category' not registered for warnings")
478 unless defined $offset ;
486 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
487 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
492 $i = _error_loc(); # see where Carp will allocate the error
495 # Default to 0 if caller returns nothing. Default to $DEFAULT if it
496 # explicitly returns undef.
497 my(@callers_bitmask) = (caller($i))[9] ;
498 my $callers_bitmask =
499 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
502 foreach my $type (FATAL, NORMAL) {
503 next unless $wanted & $type;
505 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
506 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
509 # &enabled and &fatal_enabled
510 return $results[0] unless $has_message;
512 # &warnif, and the category is neither enabled as warning nor as fatal
513 return if $wanted == (NORMAL | FATAL | MESSAGE)
514 && !($results[0] || $results[1]);
517 Carp::croak($message) if $results[0];
518 # will always get here for &warn. will only get here for &warnif if the
519 # category is enabled
520 Carp::carp($message);
528 vec($mask, $bit, 1) = 1;
532 sub register_categories
536 for my $name (@names) {
537 if (! defined $Bits{$name}) {
538 $Bits{$name} = _mkMask($LAST_BIT);
539 vec($Bits{'all'}, $LAST_BIT, 1) = 1;
540 $Offsets{$name} = $LAST_BIT ++;
541 foreach my $k (keys %Bits) {
542 vec($Bits{$k}, $LAST_BIT, 1) = 0;
544 $DeadBits{$name} = _mkMask($LAST_BIT);
545 vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
552 goto &Carp::short_error_loc; # don't introduce another stack frame
557 return __chk(NORMAL, @_);
562 return __chk(FATAL, @_);
567 return __chk(FATAL | MESSAGE, @_);
572 return __chk(NORMAL | FATAL | MESSAGE, @_);
575 # These are not part of any public interface, so we can delete them to save
577 delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);