This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: perl v5.8.0 17303 on VMS_VAX V7.2
[perl5.git] / lib / warnings.pm
CommitLineData
599cee73 1
38875929 2# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 3# This file was created by warnings.pl
599cee73
PM
4# Any changes made here will be lost.
5#
6
4438c4b7 7package warnings;
599cee73 8
0ca4541c
NIS
9our $VERSION = '1.00';
10
599cee73
PM
11=head1 NAME
12
4438c4b7 13warnings - Perl pragma to control optional warnings
599cee73
PM
14
15=head1 SYNOPSIS
16
4438c4b7
JH
17 use warnings;
18 no warnings;
599cee73 19
4438c4b7
JH
20 use warnings "all";
21 no warnings "all";
599cee73 22
d3a7d8c7
GS
23 use warnings::register;
24 if (warnings::enabled()) {
25 warnings::warn("some warning");
26 }
27
28 if (warnings::enabled("void")) {
e476b1b5
GS
29 warnings::warn("void", "some warning");
30 }
31
7e6d00f8
PM
32 if (warnings::enabled($object)) {
33 warnings::warn($object, "some warning");
34 }
35
721f911b
PM
36 warnings::warnif("some warning");
37 warnings::warnif("void", "some warning");
38 warnings::warnif($object, "some warning");
7e6d00f8 39
599cee73
PM
40=head1 DESCRIPTION
41
0453d815
PM
42If no import list is supplied, all possible warnings are either enabled
43or disabled.
599cee73 44
0ca4541c 45A number of functions are provided to assist module authors.
e476b1b5
GS
46
47=over 4
48
d3a7d8c7
GS
49=item use warnings::register
50
7e6d00f8
PM
51Creates a new warnings category with the same name as the package where
52the call to the pragma is used.
53
54=item warnings::enabled()
55
56Use the warnings category with the same name as the current package.
57
58Return TRUE if that warnings category is enabled in the calling module.
59Otherwise returns FALSE.
60
61=item warnings::enabled($category)
62
63Return TRUE if the warnings category, C<$category>, is enabled in the
64calling module.
65Otherwise returns FALSE.
66
67=item warnings::enabled($object)
68
69Use the name of the class for the object reference, C<$object>, as the
70warnings category.
71
72Return TRUE if that warnings category is enabled in the first scope
73where the object is used.
74Otherwise returns FALSE.
75
76=item warnings::warn($message)
77
78Print C<$message> to STDERR.
79
80Use the warnings category with the same name as the current package.
81
82If that warnings category has been set to "FATAL" in the calling module
83then die. Otherwise return.
84
85=item warnings::warn($category, $message)
86
87Print C<$message> to STDERR.
88
89If the warnings category, C<$category>, has been set to "FATAL" in the
90calling module then die. Otherwise return.
e476b1b5 91
7e6d00f8 92=item warnings::warn($object, $message)
e476b1b5 93
7e6d00f8 94Print C<$message> to STDERR.
e476b1b5 95
7e6d00f8
PM
96Use the name of the class for the object reference, C<$object>, as the
97warnings category.
d3a7d8c7 98
7e6d00f8
PM
99If that warnings category has been set to "FATAL" in the scope where C<$object>
100is first used then die. Otherwise return.
599cee73 101
e476b1b5 102
7e6d00f8
PM
103=item warnings::warnif($message)
104
105Equivalent to:
106
107 if (warnings::enabled())
108 { warnings::warn($message) }
109
110=item warnings::warnif($category, $message)
111
112Equivalent to:
113
114 if (warnings::enabled($category))
115 { warnings::warn($category, $message) }
116
117=item warnings::warnif($object, $message)
118
119Equivalent to:
120
121 if (warnings::enabled($object))
122 { warnings::warn($object, $message) }
d3a7d8c7 123
e476b1b5
GS
124=back
125
749f83fa 126See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
127
128=cut
129
130use Carp ;
131
d3a7d8c7 132%Offsets = (
0d658bf5
PM
133
134 # Warnings Categories added in Perl 5.008
135
d3a7d8c7 136 'all' => 0,
3eae5ce4 137 'closure' => 2,
12bcd1a6
PM
138 'deprecated' => 4,
139 'exiting' => 6,
140 'glob' => 8,
141 'io' => 10,
142 'closed' => 12,
143 'exec' => 14,
99ef548b
PM
144 'layer' => 16,
145 'newline' => 18,
146 'pipe' => 20,
147 'unopened' => 22,
148 'misc' => 24,
149 'numeric' => 26,
150 'once' => 28,
151 'overflow' => 30,
152 'pack' => 32,
153 'portable' => 34,
154 'recursion' => 36,
155 'redefine' => 38,
156 'regexp' => 40,
157 'severe' => 42,
158 'debugging' => 44,
159 'inplace' => 46,
160 'internal' => 48,
161 'malloc' => 50,
162 'signal' => 52,
163 'substr' => 54,
164 'syntax' => 56,
165 'ambiguous' => 58,
166 'bareword' => 60,
167 'digit' => 62,
168 'parenthesis' => 64,
169 'precedence' => 66,
170 'printf' => 68,
171 'prototype' => 70,
172 'qw' => 72,
173 'reserved' => 74,
174 'semicolon' => 76,
175 'taint' => 78,
38875929
DM
176 'threads' => 80,
177 'uninitialized' => 82,
178 'unpack' => 84,
179 'untie' => 86,
180 'utf8' => 88,
181 'void' => 90,
182 'y2k' => 92,
d3a7d8c7
GS
183 );
184
599cee73 185%Bits = (
38875929 186 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
99ef548b
PM
187 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
188 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
12bcd1a6 189 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
3eae5ce4 190 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
99ef548b 191 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
12bcd1a6 192 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
99ef548b 193 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
12bcd1a6
PM
194 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
195 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
196 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
99ef548b
PM
197 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
198 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
199 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
200 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
201 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
202 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
203 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
204 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
205 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
206 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
207 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
208 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
209 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
210 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
211 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
212 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
213 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
214 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
215 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
216 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
217 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
218 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
219 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
220 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
221 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
222 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
223 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
224 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
38875929
DM
225 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
226 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
99ef548b 227 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
38875929
DM
228 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
229 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
230 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
231 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
232 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
599cee73
PM
233 );
234
235%DeadBits = (
38875929 236 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
99ef548b
PM
237 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
238 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
12bcd1a6 239 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
3eae5ce4 240 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
99ef548b 241 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
12bcd1a6 242 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
99ef548b 243 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
12bcd1a6
PM
244 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
245 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
246 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
99ef548b
PM
247 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
248 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
249 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
250 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
251 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
252 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
253 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
254 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
255 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
256 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
257 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
258 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
259 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
260 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
261 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
262 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
263 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
264 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
265 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
266 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
267 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
268 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
269 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
270 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
271 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
272 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
273 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
274 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
38875929
DM
275 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
276 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
99ef548b 277 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
38875929
DM
278 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
279 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
280 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
281 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
282 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
599cee73
PM
283 );
284
a86a20aa 285$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
38875929 286$LAST_BIT = 94 ;
a86a20aa 287$BYTES = 12 ;
d3a7d8c7
GS
288
289$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
599cee73 290
c3186b65
PM
291sub Croaker
292{
293 delete $Carp::CarpInternal{'warnings'};
294 croak @_ ;
295}
296
599cee73
PM
297sub bits {
298 my $mask ;
299 my $catmask ;
300 my $fatal = 0 ;
301 foreach my $word (@_) {
327afb7f
GS
302 if ($word eq 'FATAL') {
303 $fatal = 1;
304 }
d3a7d8c7
GS
305 elsif ($catmask = $Bits{$word}) {
306 $mask |= $catmask ;
307 $mask |= $DeadBits{$word} if $fatal ;
599cee73 308 }
d3a7d8c7 309 else
c3186b65 310 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
311 }
312
313 return $mask ;
314}
315
316sub import {
317 shift;
f1f33818
PM
318 my $mask = ${^WARNING_BITS} ;
319 if (vec($mask, $Offsets{'all'}, 1)) {
320 $mask |= $Bits{'all'} ;
321 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
322 }
323 ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
599cee73
PM
324}
325
326sub unimport {
327 shift;
d3a7d8c7
GS
328 my $mask = ${^WARNING_BITS} ;
329 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 330 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
331 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
332 }
08540116 333 ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
599cee73
PM
334}
335
7e6d00f8 336sub __chk
599cee73 337{
d3a7d8c7
GS
338 my $category ;
339 my $offset ;
7e6d00f8 340 my $isobj = 0 ;
d3a7d8c7
GS
341
342 if (@_) {
343 # check the category supplied.
344 $category = shift ;
7e6d00f8 345 if (ref $category) {
c3186b65 346 Croaker ("not an object")
3d1a39c8 347 if $category !~ /^([^=]+)=/ ;
7e6d00f8
PM
348 $category = $1 ;
349 $isobj = 1 ;
350 }
d3a7d8c7 351 $offset = $Offsets{$category};
c3186b65 352 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
353 unless defined $offset;
354 }
355 else {
0ca4541c 356 $category = (caller(1))[0] ;
d3a7d8c7 357 $offset = $Offsets{$category};
c3186b65 358 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
359 unless defined $offset ;
360 }
361
0ca4541c 362 my $this_pkg = (caller(1))[0] ;
7e6d00f8
PM
363 my $i = 2 ;
364 my $pkg ;
365
366 if ($isobj) {
367 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
368 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
369 }
370 $i -= 2 ;
371 }
372 else {
373 for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
374 last if $pkg ne $this_pkg ;
375 }
0ca4541c 376 $i = 2
7e6d00f8
PM
377 if !$pkg || $pkg eq $this_pkg ;
378 }
379
0ca4541c 380 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8
PM
381 return ($callers_bitmask, $offset, $i) ;
382}
383
384sub enabled
385{
c3186b65 386 Croaker("Usage: warnings::enabled([category])")
7e6d00f8
PM
387 unless @_ == 1 || @_ == 0 ;
388
389 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
390
391 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
392 return vec($callers_bitmask, $offset, 1) ||
393 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73
PM
394}
395
d3a7d8c7 396
e476b1b5
GS
397sub warn
398{
c3186b65 399 Croaker("Usage: warnings::warn([category,] 'message')")
d3a7d8c7 400 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 401
7e6d00f8
PM
402 my $message = pop ;
403 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
0ca4541c 404 croak($message)
d3a7d8c7
GS
405 if vec($callers_bitmask, $offset+1, 1) ||
406 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5
GS
407 carp($message) ;
408}
409
7e6d00f8
PM
410sub warnif
411{
c3186b65 412 Croaker("Usage: warnings::warnif([category,] 'message')")
7e6d00f8
PM
413 unless @_ == 2 || @_ == 1 ;
414
415 my $message = pop ;
416 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
7e6d00f8 417
0ca4541c 418 return
7e6d00f8
PM
419 unless defined $callers_bitmask &&
420 (vec($callers_bitmask, $offset, 1) ||
421 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
422
0ca4541c 423 croak($message)
7e6d00f8
PM
424 if vec($callers_bitmask, $offset+1, 1) ||
425 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
426
427 carp($message) ;
428}
0d658bf5 429
599cee73 4301;