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