our $TODO should be local $::TODO, revealing a bug in the de-commenting regexp.
[perl.git] / lib / warnings.pm
1 # -*- buffer-read-only: t -*-
2 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
3 # This file was created by warnings.pl
4 # Any changes made here will be lost.
5 #
6
7 package warnings;
8
9 our $VERSION = '1.06';
10
11 # Verify that we're called correctly so that warnings will work.
12 # see also strict.pm.
13 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
14     my (undef, $f, $l) = caller;
15     die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
16 }
17
18 =head1 NAME
19
20 warnings - Perl pragma to control optional warnings
21
22 =head1 SYNOPSIS
23
24     use warnings;
25     no warnings;
26
27     use warnings "all";
28     no warnings "all";
29
30     use warnings::register;
31     if (warnings::enabled()) {
32         warnings::warn("some warning");
33     }
34
35     if (warnings::enabled("void")) {
36         warnings::warn("void", "some warning");
37     }
38
39     if (warnings::enabled($object)) {
40         warnings::warn($object, "some warning");
41     }
42
43     warnings::warnif("some warning");
44     warnings::warnif("void", "some warning");
45     warnings::warnif($object, "some warning");
46
47 =head1 DESCRIPTION
48
49 The C<warnings> pragma is a replacement for the command line flag C<-w>,
50 but the pragma is limited to the enclosing block, while the flag is global.
51 See L<perllexwarn> for more information.
52
53 If no import list is supplied, all possible warnings are either enabled
54 or disabled.
55
56 A number of functions are provided to assist module authors.
57
58 =over 4
59
60 =item use warnings::register
61
62 Creates a new warnings category with the same name as the package where
63 the call to the pragma is used.
64
65 =item warnings::enabled()
66
67 Use the warnings category with the same name as the current package.
68
69 Return TRUE if that warnings category is enabled in the calling module.
70 Otherwise returns FALSE.
71
72 =item warnings::enabled($category)
73
74 Return TRUE if the warnings category, C<$category>, is enabled in the
75 calling module.
76 Otherwise returns FALSE.
77
78 =item warnings::enabled($object)
79
80 Use the name of the class for the object reference, C<$object>, as the
81 warnings category.
82
83 Return TRUE if that warnings category is enabled in the first scope
84 where the object is used.
85 Otherwise returns FALSE.
86
87 =item warnings::warn($message)
88
89 Print C<$message> to STDERR.
90
91 Use the warnings category with the same name as the current package.
92
93 If that warnings category has been set to "FATAL" in the calling module
94 then die. Otherwise return.
95
96 =item warnings::warn($category, $message)
97
98 Print C<$message> to STDERR.
99
100 If the warnings category, C<$category>, has been set to "FATAL" in the
101 calling module then die. Otherwise return.
102
103 =item warnings::warn($object, $message)
104
105 Print C<$message> to STDERR.
106
107 Use the name of the class for the object reference, C<$object>, as the
108 warnings category.
109
110 If that warnings category has been set to "FATAL" in the scope where C<$object>
111 is first used then die. Otherwise return.
112
113
114 =item warnings::warnif($message)
115
116 Equivalent to:
117
118     if (warnings::enabled())
119       { warnings::warn($message) }
120
121 =item warnings::warnif($category, $message)
122
123 Equivalent to:
124
125     if (warnings::enabled($category))
126       { warnings::warn($category, $message) }
127
128 =item warnings::warnif($object, $message)
129
130 Equivalent to:
131
132     if (warnings::enabled($object))
133       { warnings::warn($object, $message) }
134
135 =back
136
137 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
138
139 =cut
140
141 our %Offsets = (
142
143     # Warnings Categories added in Perl 5.008
144
145     'all'               => 0,
146     'closure'           => 2,
147     'deprecated'        => 4,
148     'exiting'           => 6,
149     'glob'              => 8,
150     'io'                => 10,
151     'closed'            => 12,
152     'exec'              => 14,
153     'layer'             => 16,
154     'newline'           => 18,
155     'pipe'              => 20,
156     'unopened'          => 22,
157     'misc'              => 24,
158     'numeric'           => 26,
159     'once'              => 28,
160     'overflow'          => 30,
161     'pack'              => 32,
162     'portable'          => 34,
163     'recursion'         => 36,
164     'redefine'          => 38,
165     'regexp'            => 40,
166     'severe'            => 42,
167     'debugging'         => 44,
168     'inplace'           => 46,
169     'internal'          => 48,
170     'malloc'            => 50,
171     'signal'            => 52,
172     'substr'            => 54,
173     'syntax'            => 56,
174     'ambiguous'         => 58,
175     'bareword'          => 60,
176     'digit'             => 62,
177     'parenthesis'       => 64,
178     'precedence'        => 66,
179     'printf'            => 68,
180     'prototype'         => 70,
181     'qw'                => 72,
182     'reserved'          => 74,
183     'semicolon'         => 76,
184     'taint'             => 78,
185     'threads'           => 80,
186     'uninitialized'     => 82,
187     'unpack'            => 84,
188     'untie'             => 86,
189     'utf8'              => 88,
190     'void'              => 90,
191
192     # Warnings Categories added in Perl 5.011
193
194     'imprecision'       => 92,
195   );
196
197 our %Bits = (
198     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
199     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
200     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
201     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
202     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
203     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
204     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
205     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
206     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
207     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
208     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
209     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
210     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
211     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
212     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
213     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
214     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
215     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
216     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
217     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
218     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
219     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
220     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
221     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
222     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
223     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
224     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
225     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
226     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
227     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
228     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
229     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
230     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
231     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
232     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
233     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
234     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
235     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
236     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
237     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
238     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
239     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
240     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
241     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
242     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
243     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
244     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
245   );
246
247 our %DeadBits = (
248     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
249     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
250     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
251     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
252     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
253     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
254     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
255     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
256     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
257     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
258     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
259     'imprecision'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
260     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
261     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
262     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
263     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
264     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
265     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
266     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
267     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
268     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
269     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
270     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
271     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
272     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
273     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
274     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
275     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
276     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
277     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
278     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
279     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
280     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
281     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
282     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
283     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
284     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
285     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
286     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
287     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
288     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
289     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
290     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
291     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
292     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
293     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
294     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
295   );
296
297 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
298 $LAST_BIT = 94 ;
299 $BYTES    = 12 ;
300
301 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
302
303 sub Croaker
304 {
305     require Carp::Heavy; # this initializes %CarpInternal
306     local $Carp::CarpInternal{'warnings'};
307     delete $Carp::CarpInternal{'warnings'};
308     Carp::croak(@_);
309 }
310
311 sub bits
312 {
313     # called from B::Deparse.pm
314
315     push @_, 'all' unless @_;
316
317     my $mask;
318     my $catmask ;
319     my $fatal = 0 ;
320     my $no_fatal = 0 ;
321
322     foreach my $word ( @_ ) {
323         if ($word eq 'FATAL') {
324             $fatal = 1;
325             $no_fatal = 0;
326         }
327         elsif ($word eq 'NONFATAL') {
328             $fatal = 0;
329             $no_fatal = 1;
330         }
331         elsif ($catmask = $Bits{$word}) {
332             $mask |= $catmask ;
333             $mask |= $DeadBits{$word} if $fatal ;
334             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
335         }
336         else
337           { Croaker("Unknown warnings category '$word'")}
338     }
339
340     return $mask ;
341 }
342
343 sub import 
344 {
345     shift;
346
347     my $catmask ;
348     my $fatal = 0 ;
349     my $no_fatal = 0 ;
350
351     my $mask = ${^WARNING_BITS} ;
352
353     if (vec($mask, $Offsets{'all'}, 1)) {
354         $mask |= $Bits{'all'} ;
355         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
356     }
357     
358     push @_, 'all' unless @_;
359
360     foreach my $word ( @_ ) {
361         if ($word eq 'FATAL') {
362             $fatal = 1;
363             $no_fatal = 0;
364         }
365         elsif ($word eq 'NONFATAL') {
366             $fatal = 0;
367             $no_fatal = 1;
368         }
369         elsif ($catmask = $Bits{$word}) {
370             $mask |= $catmask ;
371             $mask |= $DeadBits{$word} if $fatal ;
372             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
373         }
374         else
375           { Croaker("Unknown warnings category '$word'")}
376     }
377
378     ${^WARNING_BITS} = $mask ;
379 }
380
381 sub unimport 
382 {
383     shift;
384
385     my $catmask ;
386     my $mask = ${^WARNING_BITS} ;
387
388     if (vec($mask, $Offsets{'all'}, 1)) {
389         $mask |= $Bits{'all'} ;
390         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
391     }
392
393     push @_, 'all' unless @_;
394
395     foreach my $word ( @_ ) {
396         if ($word eq 'FATAL') {
397             next; 
398         }
399         elsif ($catmask = $Bits{$word}) {
400             $mask &= ~($catmask | $DeadBits{$word} | $All);
401         }
402         else
403           { Croaker("Unknown warnings category '$word'")}
404     }
405
406     ${^WARNING_BITS} = $mask ;
407 }
408
409 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
410
411 sub __chk
412 {
413     my $category ;
414     my $offset ;
415     my $isobj = 0 ;
416
417     if (@_) {
418         # check the category supplied.
419         $category = shift ;
420         if (my $type = ref $category) {
421             Croaker("not an object")
422                 if exists $builtin_type{$type};
423             $category = $type;
424             $isobj = 1 ;
425         }
426         $offset = $Offsets{$category};
427         Croaker("Unknown warnings category '$category'")
428             unless defined $offset;
429     }
430     else {
431         $category = (caller(1))[0] ;
432         $offset = $Offsets{$category};
433         Croaker("package '$category' not registered for warnings")
434             unless defined $offset ;
435     }
436
437     my $this_pkg = (caller(1))[0] ;
438     my $i = 2 ;
439     my $pkg ;
440
441     if ($isobj) {
442         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
443             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
444         }
445         $i -= 2 ;
446     }
447     else {
448         $i = _error_loc(); # see where Carp will allocate the error
449     }
450
451     my $callers_bitmask = (caller($i))[9] ;
452     return ($callers_bitmask, $offset, $i) ;
453 }
454
455 sub _error_loc {
456     require Carp::Heavy;
457     goto &Carp::short_error_loc; # don't introduce another stack frame
458 }                                                             
459
460 sub enabled
461 {
462     Croaker("Usage: warnings::enabled([category])")
463         unless @_ == 1 || @_ == 0 ;
464
465     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
466
467     return 0 unless defined $callers_bitmask ;
468     return vec($callers_bitmask, $offset, 1) ||
469            vec($callers_bitmask, $Offsets{'all'}, 1) ;
470 }
471
472
473 sub warn
474 {
475     Croaker("Usage: warnings::warn([category,] 'message')")
476         unless @_ == 2 || @_ == 1 ;
477
478     my $message = pop ;
479     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
480     require Carp;
481     Carp::croak($message)
482         if vec($callers_bitmask, $offset+1, 1) ||
483            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
484     Carp::carp($message) ;
485 }
486
487 sub warnif
488 {
489     Croaker("Usage: warnings::warnif([category,] 'message')")
490         unless @_ == 2 || @_ == 1 ;
491
492     my $message = pop ;
493     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
494
495     return
496         unless defined $callers_bitmask &&
497                 (vec($callers_bitmask, $offset, 1) ||
498                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
499
500     require Carp;
501     Carp::croak($message)
502         if vec($callers_bitmask, $offset+1, 1) ||
503            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
504
505     Carp::carp($message) ;
506 }
507
508 1;
509 # ex: set ro: