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