This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
11fd5b0718623ca592115465a7d6e3479124506f
[perl5.git] / lib / warnings.pm
1
2 # This file was created by warnings.pl
3 # Any changes made here will be lost.
4 #
5
6 package warnings;
7
8 =head1 NAME
9
10 warnings - Perl pragma to control optional warnings
11
12 =head1 SYNOPSIS
13
14     use warnings;
15     no warnings;
16
17     use warnings "all";
18     no warnings "all";
19
20     if (warnings::enabled("void") {
21         warnings::warn("void", "some warning");
22     }
23
24 =head1 DESCRIPTION
25
26 If no import list is supplied, all possible warnings are either enabled
27 or disabled.
28
29 Two functions are provided to assist module authors.
30
31 =over 4
32
33 =item warnings::enabled($category)
34
35 Returns TRUE if the warnings category in C<$category> is enabled in the
36 calling module. Otherwise returns FALSE.
37
38
39 =item warnings::warn($category, $message)
40
41 If the calling module has I<not> set C<$category> to "FATAL", print
42 C<$message> to STDERR.
43 If the calling module has set C<$category> to "FATAL", print C<$message>
44 STDERR then die.
45
46 =back
47
48 See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
49
50 =cut
51
52 use Carp ;
53
54 %Bits = (
55     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
56     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
57     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28]
58     'chmod'             => "\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [0]
59     'closed'            => "\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5]
60     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
61     'debugging'         => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
62     'deprecated'        => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
63     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
64     'exec'              => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
65     'exiting'           => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
66     'glob'              => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
67     'inplace'           => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21]
68     'internal'          => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
69     'io'                => "\x00\x55\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9]
70     'malloc'            => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
71     'misc'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
72     'newline'           => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
73     'numeric'           => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
74     'once'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
75     'overflow'          => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
76     'pack'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
77     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
78     'pipe'              => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
79     'portable'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
80     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
81     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
82     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
83     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
84     'recursion'         => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
85     'redefine'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
86     'regexp'            => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
87     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
88     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
89     'severe'            => "\x00\x00\x00\x00\x40\x55\x00\x00\x00\x00\x00\x00", # [19..23]
90     'signal'            => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
91     'substr'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
92     'syntax'            => "\x00\x00\x00\x00\x00\x00\x50\x55\x55\x05\x00\x00", # [26..37]
93     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
94     'umask'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
95     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
96     'unopened'          => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
97     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
98     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
99     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
100     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
101     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
102   );
103
104 %DeadBits = (
105     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
106     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
107     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28]
108     'chmod'             => "\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [0]
109     'closed'            => "\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5]
110     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
111     'debugging'         => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
112     'deprecated'        => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
113     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
114     'exec'              => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
115     'exiting'           => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
116     'glob'              => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
117     'inplace'           => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21]
118     'internal'          => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
119     'io'                => "\x00\xaa\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4..9]
120     'malloc'            => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
121     'misc'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
122     'newline'           => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
123     'numeric'           => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
124     'once'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
125     'overflow'          => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
126     'pack'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
127     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
128     'pipe'              => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
129     'portable'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
130     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
131     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
132     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
133     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
134     'recursion'         => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
135     'redefine'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
136     'regexp'            => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
137     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
138     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
139     'severe'            => "\x00\x00\x00\x00\x80\xaa\x00\x00\x00\x00\x00\x00", # [19..23]
140     'signal'            => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
141     'substr'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
142     'syntax'            => "\x00\x00\x00\x00\x00\x00\xa0\xaa\xaa\x0a\x00\x00", # [26..37]
143     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
144     'umask'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
145     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
146     'unopened'          => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
147     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
148     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
149     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
150     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
151     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
152   );
153
154 $NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
155
156 sub bits {
157     my $mask ;
158     my $catmask ;
159     my $fatal = 0 ;
160     foreach my $word (@_) {
161         if  ($word eq 'FATAL') {
162             $fatal = 1;
163         }
164         else {
165             if ($catmask = $Bits{$word}) {
166                 $mask |= $catmask ;
167                 $mask |= $DeadBits{$word} if $fatal ;
168             }
169         }
170     }
171
172     return $mask ;
173 }
174
175 sub import {
176     shift;
177     ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
178 }
179
180 sub unimport {
181     shift;
182     ${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ;
183 }
184
185 sub enabled
186 {
187     # If no parameters, check for any lexical warnings enabled
188     # in the users scope.
189     my $callers_bitmask = (caller(1))[9] ; 
190     return ($callers_bitmask ne $NONE) if @_ == 0 ;
191
192     # otherwise check for the category supplied.
193     my $category = shift ;
194     return 0
195         unless $Bits{$category} ;
196     return 0 unless defined $callers_bitmask ;
197     return 1
198         if ($callers_bitmask & $Bits{$category}) ne $NONE ;
199    
200     return 0 ; 
201 }
202
203 sub warn
204 {
205     croak "Usage: warnings::warn('category', 'message')"
206         unless @_ == 2 ;
207     my $category = shift ;
208     my $message = shift ;
209     local $Carp::CarpLevel = 1 ;
210     my $callers_bitmask = (caller(1))[9] ; 
211     croak($message) 
212         if defined $callers_bitmask &&
213            ($callers_bitmask & $DeadBits{$category}) ne $NONE ;
214     carp($message) ;
215 }
216
217 1;