source: trunk/third/perl/lib/warnings.pm @ 14545

Revision 14545, 11.7 KB checked in by ghudson, 24 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r14544, which included commits to RCS files with non-trunk default branches.
Line 
1
2# This file was created by warnings.pl
3# Any changes made here will be lost.
4#
5
6package warnings;
7
8=head1 NAME
9
10warnings - 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    use warnings::register;
21    if (warnings::enabled()) {
22        warnings::warn("some warning");
23    }
24
25    if (warnings::enabled("void")) {
26        warnings::warn("void", "some warning");
27    }
28
29=head1 DESCRIPTION
30
31If no import list is supplied, all possible warnings are either enabled
32or disabled.
33
34A number of functions are provided to assist module authors.
35
36=over 4
37
38=item use warnings::register
39
40Creates a new warnings category which has the same name as the module
41where the call to the pragma is used.
42
43=item warnings::enabled([$category])
44
45Returns TRUE if the warnings category C<$category> is enabled in the
46calling module.  Otherwise returns FALSE.
47
48If the parameter, C<$category>, isn't supplied, the current package name
49will be used.
50
51=item warnings::warn([$category,] $message)
52
53If the calling module has I<not> set C<$category> to "FATAL", print
54C<$message> to STDERR.
55If the calling module has set C<$category> to "FATAL", print C<$message>
56STDERR then die.
57
58If the parameter, C<$category>, isn't supplied, the current package name
59will be used.
60
61=back
62
63See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
64
65=cut
66
67use Carp ;
68
69%Offsets = (
70    'all'               => 0,
71    'chmod'             => 2,
72    'closure'           => 4,
73    'exiting'           => 6,
74    'glob'              => 8,
75    'io'                => 10,
76    'closed'            => 12,
77    'exec'              => 14,
78    'newline'           => 16,
79    'pipe'              => 18,
80    'unopened'          => 20,
81    'misc'              => 22,
82    'numeric'           => 24,
83    'once'              => 26,
84    'overflow'          => 28,
85    'pack'              => 30,
86    'portable'          => 32,
87    'recursion'         => 34,
88    'redefine'          => 36,
89    'regexp'            => 38,
90    'severe'            => 40,
91    'debugging'         => 42,
92    'inplace'           => 44,
93    'internal'          => 46,
94    'malloc'            => 48,
95    'signal'            => 50,
96    'substr'            => 52,
97    'syntax'            => 54,
98    'ambiguous'         => 56,
99    'bareword'          => 58,
100    'deprecated'        => 60,
101    'digit'             => 62,
102    'parenthesis'       => 64,
103    'precedence'        => 66,
104    'printf'            => 68,
105    'prototype'         => 70,
106    'qw'                => 72,
107    'reserved'          => 74,
108    'semicolon'         => 76,
109    'taint'             => 78,
110    'umask'             => 80,
111    'uninitialized'     => 82,
112    'unpack'            => 84,
113    'untie'             => 86,
114    'utf8'              => 88,
115    'void'              => 90,
116    'y2k'               => 92,
117  );
118
119%Bits = (
120    'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
121    'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28]
122    'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
123    'chmod'             => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
124    'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
125    'closure'           => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
126    'debugging'         => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21]
127    'deprecated'        => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
128    'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
129    'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
130    'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
131    'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
132    'inplace'           => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
133    'internal'          => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
134    'io'                => "\x00\x54\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
135    'malloc'            => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
136    'misc'              => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
137    'newline'           => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
138    'numeric'           => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
139    'once'              => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
140    'overflow'          => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
141    'pack'              => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
142    'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
143    'pipe'              => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
144    'portable'          => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
145    'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
146    'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
147    'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
148    'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
149    'recursion'         => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
150    'redefine'          => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
151    'regexp'            => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
152    'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
153    'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
154    'severe'            => "\x00\x00\x00\x00\x00\x55\x01\x00\x00\x00\x00\x00", # [20..24]
155    'signal'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
156    'substr'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
157    'syntax'            => "\x00\x00\x00\x00\x00\x00\x40\x55\x55\x15\x00\x00", # [27..38]
158    'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
159    'umask'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
160    'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
161    'unopened'          => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
162    'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
163    'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
164    'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
165    'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
166    'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
167  );
168
169%DeadBits = (
170    'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
171    'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28]
172    'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
173    'chmod'             => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
174    'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
175    'closure'           => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
176    'debugging'         => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21]
177    'deprecated'        => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
178    'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
179    'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
180    'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
181    'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
182    'inplace'           => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
183    'internal'          => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
184    'io'                => "\x00\xa8\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
185    'malloc'            => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
186    'misc'              => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
187    'newline'           => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
188    'numeric'           => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
189    'once'              => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
190    'overflow'          => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
191    'pack'              => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
192    'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
193    'pipe'              => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
194    'portable'          => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
195    'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
196    'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
197    'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
198    'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
199    'recursion'         => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
200    'redefine'          => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
201    'regexp'            => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
202    'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
203    'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
204    'severe'            => "\x00\x00\x00\x00\x00\xaa\x02\x00\x00\x00\x00\x00", # [20..24]
205    'signal'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
206    'substr'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
207    'syntax'            => "\x00\x00\x00\x00\x00\x00\x80\xaa\xaa\x2a\x00\x00", # [27..38]
208    'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
209    'umask'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
210    'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
211    'unopened'          => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
212    'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
213    'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
214    'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
215    'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
216    'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
217  );
218
219$NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
220$LAST_BIT = 94 ;
221$BYTES    = 12 ;
222
223$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
224
225sub bits {
226    my $mask ;
227    my $catmask ;
228    my $fatal = 0 ;
229    foreach my $word (@_) {
230        if  ($word eq 'FATAL') {
231            $fatal = 1;
232        }
233        elsif ($catmask = $Bits{$word}) {
234            $mask |= $catmask ;
235            $mask |= $DeadBits{$word} if $fatal ;
236        }
237        else
238          { croak("unknown warnings category '$word'")} 
239    }
240
241    return $mask ;
242}
243
244sub import {
245    shift;
246    ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
247}
248
249sub unimport {
250    shift;
251    my $mask = ${^WARNING_BITS} ;
252    if (vec($mask, $Offsets{'all'}, 1)) {
253        $mask = $Bits{'all'} ;
254        $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
255    }
256    ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
257}
258
259sub enabled
260{
261    croak("Usage: warnings::enabled([category])")
262        unless @_ == 1 || @_ == 0 ;
263    local $Carp::CarpLevel = 1 ;
264    my $category ;
265    my $offset ;
266    my $callers_bitmask = (caller(1))[9] ;
267    return 0 unless defined $callers_bitmask ;
268
269
270    if (@_) {
271        # check the category supplied.
272        $category = shift ;
273        $offset = $Offsets{$category};
274        croak("unknown warnings category '$category'")
275            unless defined $offset;
276    }
277    else {
278        $category = (caller(0))[0] ;
279        $offset = $Offsets{$category};
280        croak("package '$category' not registered for warnings")
281            unless defined $offset ;
282    }
283
284    return vec($callers_bitmask, $offset, 1) ||
285           vec($callers_bitmask, $Offsets{'all'}, 1) ;
286}
287
288
289sub warn
290{
291    croak("Usage: warnings::warn([category,] 'message')")
292        unless @_ == 2 || @_ == 1 ;
293    local $Carp::CarpLevel = 1 ;
294    my $category ;
295    my $offset ;
296    my $callers_bitmask = (caller(1))[9] ;
297
298    if (@_ == 2) {
299        $category = shift ;
300        $offset = $Offsets{$category};
301        croak("unknown warnings category '$category'")
302            unless defined $offset ;
303    }
304    else {
305        $category = (caller(0))[0] ;
306        $offset = $Offsets{$category};
307        croak("package '$category' not registered for warnings")
308            unless defined $offset ;
309    }
310
311    my $message = shift ;
312    croak($message)
313        if vec($callers_bitmask, $offset+1, 1) ||
314           vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
315    carp($message) ;
316}
317
3181;
Note: See TracBrowser for help on using the repository browser.