This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
c86ea68f7b18f6f2723808bc3eabf8a8308b268c
[perl5.git] / lib / warnings.pm
1 # -*- buffer-read-only: t -*-
2 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
3 # This file was created by warnings.pl
4 # Any changes made here will be lost.
5 #
6
7 package warnings;
8
9 our $VERSION = '1.10';
10
11 # Verify that we're called correctly so that warnings will work.
12 # see also strict.pm.
13 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
14     my (undef, $f, $l) = caller;
15     die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
16 }
17
18 =head1 NAME
19
20 warnings - Perl pragma to control optional warnings
21
22 =head1 SYNOPSIS
23
24     use warnings;
25     no warnings;
26
27     use warnings "all";
28     no warnings "all";
29
30     use warnings::register;
31     if (warnings::enabled()) {
32         warnings::warn("some warning");
33     }
34
35     if (warnings::enabled("void")) {
36         warnings::warn("void", "some warning");
37     }
38
39     if (warnings::enabled($object)) {
40         warnings::warn($object, "some warning");
41     }
42
43     warnings::warnif("some warning");
44     warnings::warnif("void", "some warning");
45     warnings::warnif($object, "some warning");
46
47 =head1 DESCRIPTION
48
49 The C<warnings> pragma is a replacement for the command line flag C<-w>,
50 but the pragma is limited to the enclosing block, while the flag is global.
51 See L<perllexwarn> for more information.
52
53 If no import list is supplied, all possible warnings are either enabled
54 or disabled.
55
56 A number of functions are provided to assist module authors.
57
58 =over 4
59
60 =item use warnings::register
61
62 Creates a new warnings category with the same name as the package where
63 the call to the pragma is used.
64
65 =item warnings::enabled()
66
67 Use the warnings category with the same name as the current package.
68
69 Return TRUE if that warnings category is enabled in the calling module.
70 Otherwise returns FALSE.
71
72 =item warnings::enabled($category)
73
74 Return TRUE if the warnings category, C<$category>, is enabled in the
75 calling module.
76 Otherwise returns FALSE.
77
78 =item warnings::enabled($object)
79
80 Use the name of the class for the object reference, C<$object>, as the
81 warnings category.
82
83 Return TRUE if that warnings category is enabled in the first scope
84 where the object is used.
85 Otherwise returns FALSE.
86
87 =item warnings::fatal_enabled()
88
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.
92
93 =item warnings::fatal_enabled($category)
94
95 Return TRUE if the warnings category C<$category> has been set to FATAL in
96 the calling module.
97 Otherwise returns FALSE.
98
99 =item warnings::fatal_enabled($object)
100
101 Use the name of the class for the object reference, C<$object>, as the
102 warnings category.
103
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.
107
108 =item warnings::warn($message)
109
110 Print C<$message> to STDERR.
111
112 Use the warnings category with the same name as the current package.
113
114 If that warnings category has been set to "FATAL" in the calling module
115 then die. Otherwise return.
116
117 =item warnings::warn($category, $message)
118
119 Print C<$message> to STDERR.
120
121 If the warnings category, C<$category>, has been set to "FATAL" in the
122 calling module then die. Otherwise return.
123
124 =item warnings::warn($object, $message)
125
126 Print C<$message> to STDERR.
127
128 Use the name of the class for the object reference, C<$object>, as the
129 warnings category.
130
131 If that warnings category has been set to "FATAL" in the scope where C<$object>
132 is first used then die. Otherwise return.
133
134
135 =item warnings::warnif($message)
136
137 Equivalent to:
138
139     if (warnings::enabled())
140       { warnings::warn($message) }
141
142 =item warnings::warnif($category, $message)
143
144 Equivalent to:
145
146     if (warnings::enabled($category))
147       { warnings::warn($category, $message) }
148
149 =item warnings::warnif($object, $message)
150
151 Equivalent to:
152
153     if (warnings::enabled($object))
154       { warnings::warn($object, $message) }
155
156 =back
157
158 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
159
160 =cut
161
162 our %Offsets = (
163
164     # Warnings Categories added in Perl 5.008
165
166     'all'               => 0,
167     'closure'           => 2,
168     'deprecated'        => 4,
169     'exiting'           => 6,
170     'glob'              => 8,
171     'io'                => 10,
172     'closed'            => 12,
173     'exec'              => 14,
174     'layer'             => 16,
175     'newline'           => 18,
176     'pipe'              => 20,
177     'unopened'          => 22,
178     'misc'              => 24,
179     'numeric'           => 26,
180     'once'              => 28,
181     'overflow'          => 30,
182     'pack'              => 32,
183     'portable'          => 34,
184     'recursion'         => 36,
185     'redefine'          => 38,
186     'regexp'            => 40,
187     'severe'            => 42,
188     'debugging'         => 44,
189     'inplace'           => 46,
190     'internal'          => 48,
191     'malloc'            => 50,
192     'signal'            => 52,
193     'substr'            => 54,
194     'syntax'            => 56,
195     'ambiguous'         => 58,
196     'bareword'          => 60,
197     'digit'             => 62,
198     'parenthesis'       => 64,
199     'precedence'        => 66,
200     'printf'            => 68,
201     'prototype'         => 70,
202     'qw'                => 72,
203     'reserved'          => 74,
204     'semicolon'         => 76,
205     'taint'             => 78,
206     'threads'           => 80,
207     'uninitialized'     => 82,
208     'unpack'            => 84,
209     'untie'             => 86,
210     'utf8'              => 88,
211     'void'              => 90,
212
213     # Warnings Categories added in Perl 5.011
214
215     'imprecision'       => 92,
216     'illegalproto'      => 94,
217   );
218
219 our %Bits = (
220     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
221     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
222     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
223     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
224     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
225     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
226     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
227     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
228     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
229     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
230     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
231     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [47]
232     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
233     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
234     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
235     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
236     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
237     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
238     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
239     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
240     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
241     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
242     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
243     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
244     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
245     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
246     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
247     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
248     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
249     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
250     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
251     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
252     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
253     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
254     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
255     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
256     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
257     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
258     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
259     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40", # [28..38,47]
260     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
261     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
262     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
263     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
264     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
265     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
266     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
267     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
268   );
269
270 our %DeadBits = (
271     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
272     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
273     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
274     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
275     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
276     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
277     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
278     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
279     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
280     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
281     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
282     'illegalproto'      => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [47]
283     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
284     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
285     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
286     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
287     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
288     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
289     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
290     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
291     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
292     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
293     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
294     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
295     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
296     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
297     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
298     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
299     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
300     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
301     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
302     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
303     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
304     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
305     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
306     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
307     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
308     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
309     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
310     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80", # [28..38,47]
311     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
312     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
313     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
314     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
315     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
316     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
317     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
318     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
319   );
320
321 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
322 $LAST_BIT = 96 ;
323 $BYTES    = 12 ;
324
325 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
326
327 sub Croaker
328 {
329     require Carp; # this initializes %CarpInternal
330     local $Carp::CarpInternal{'warnings'};
331     delete $Carp::CarpInternal{'warnings'};
332     Carp::croak(@_);
333 }
334
335 sub _bits {
336     my $mask = shift ;
337     my $catmask ;
338     my $fatal = 0 ;
339     my $no_fatal = 0 ;
340
341     foreach my $word ( @_ ) {
342         if ($word eq 'FATAL') {
343             $fatal = 1;
344             $no_fatal = 0;
345         }
346         elsif ($word eq 'NONFATAL') {
347             $fatal = 0;
348             $no_fatal = 1;
349         }
350         elsif ($catmask = $Bits{$word}) {
351             $mask |= $catmask ;
352             $mask |= $DeadBits{$word} if $fatal ;
353             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
354         }
355         else
356           { Croaker("Unknown warnings category '$word'")}
357     }
358
359     return $mask ;
360 }
361
362 sub bits
363 {
364     # called from B::Deparse.pm
365     push @_, 'all' unless @_ ;
366     return _bits(undef, @_) ;
367 }
368
369 sub import 
370 {
371     shift;
372
373     my $mask = ${^WARNING_BITS} ;
374
375     if (vec($mask, $Offsets{'all'}, 1)) {
376         $mask |= $Bits{'all'} ;
377         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
378     }
379     
380     # Empty @_ is equivalent to @_ = 'all' ;
381     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
382 }
383
384 sub unimport 
385 {
386     shift;
387
388     my $catmask ;
389     my $mask = ${^WARNING_BITS} ;
390
391     if (vec($mask, $Offsets{'all'}, 1)) {
392         $mask |= $Bits{'all'} ;
393         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
394     }
395
396     push @_, 'all' unless @_;
397
398     foreach my $word ( @_ ) {
399         if ($word eq 'FATAL') {
400             next; 
401         }
402         elsif ($catmask = $Bits{$word}) {
403             $mask &= ~($catmask | $DeadBits{$word} | $All);
404         }
405         else
406           { Croaker("Unknown warnings category '$word'")}
407     }
408
409     ${^WARNING_BITS} = $mask ;
410 }
411
412 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
413
414 sub FATAL () { 2 };
415 sub NORMAL () { 1 };
416
417 sub __chk
418 {
419     my $category ;
420     my $offset ;
421     my $isobj = 0 ;
422     my $wanted = shift;
423
424     if (@_) {
425         # check the category supplied.
426         $category = shift ;
427         if (my $type = ref $category) {
428             Croaker("not an object")
429                 if exists $builtin_type{$type};
430             $category = $type;
431             $isobj = 1 ;
432         }
433         $offset = $Offsets{$category};
434         Croaker("Unknown warnings category '$category'")
435             unless defined $offset;
436     }
437     else {
438         $category = (caller(1))[0] ;
439         $offset = $Offsets{$category};
440         Croaker("package '$category' not registered for warnings")
441             unless defined $offset ;
442     }
443
444     my $i;
445
446     if ($isobj) {
447         my $pkg;
448         $i = 2;
449         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
450             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
451         }
452         $i -= 2 ;
453     }
454     else {
455         $i = _error_loc(); # see where Carp will allocate the error
456     }
457
458     # Defaulting this to 0 reduces complexity in code paths below.
459     my $callers_bitmask = (caller($i))[9] || 0 ;
460
461     my @results;
462     foreach my $type (NORMAL, FATAL) {
463         next unless $wanted & $type;
464
465         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
466                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
467     }
468     return $wanted == (NORMAL | FATAL) ? @results : $results[0];
469 }
470
471 sub _error_loc {
472     require Carp;
473     goto &Carp::short_error_loc; # don't introduce another stack frame
474 }                                                             
475
476 sub enabled
477 {
478     Croaker("Usage: warnings::enabled([category])")
479         unless @_ == 1 || @_ == 0 ;
480
481     return __chk(NORMAL, @_);
482 }
483
484 sub fatal_enabled
485 {
486     Croaker("Usage: warnings::fatal_enabled([category])")
487   unless @_ == 1 || @_ == 0 ;
488
489     return __chk(FATAL, @_);
490 }
491
492 sub warn
493 {
494     Croaker("Usage: warnings::warn([category,] 'message')")
495         unless @_ == 2 || @_ == 1 ;
496
497     my $message = pop ;
498     require Carp;
499     Carp::croak($message) if __chk(FATAL, @_);
500     Carp::carp($message) ;
501 }
502
503 sub warnif
504 {
505     Croaker("Usage: warnings::warnif([category,] 'message')")
506         unless @_ == 2 || @_ == 1 ;
507
508     my $message = pop ;
509     my ($warn, $fatal) = __chk(NORMAL | FATAL, @_);
510
511     return unless $warn or $fatal;
512
513     require Carp;
514     Carp::croak($message) if $fatal;
515     Carp::carp($message) ;
516 }
517
518 # These are not part of any public interface, so we can delete them to save
519 # space.
520 delete $warnings::{$_} foreach qw(NORMAL FATAL);
521
522 1;
523 # ex: set ro: