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