xref: /openbsd-src/gnu/usr.bin/perl/lib/warnings.pm (revision 47911bd667ac77dc523b8a13ef40b012dbffa741) 
1
2# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
3# This file was created by warnings.pl
4# Any changes made here will be lost.
5#
6
7package warnings;
8
9our $VERSION = '1.00';
10
11=head1 NAME
12
13warnings - 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
42If no import list is supplied, all possible warnings are either enabled
43or disabled.
44
45A number of functions are provided to assist module authors.
46
47=over 4
48
49=item use warnings::register
50
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.
91
92=item warnings::warn($object, $message)
93
94Print C<$message> to STDERR.
95
96Use the name of the class for the object reference, C<$object>, as the
97warnings category.
98
99If that warnings category has been set to "FATAL" in the scope where C<$object>
100is first used then die. Otherwise return.
101
102
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) }
123
124=back
125
126See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
127
128=cut
129
130use Carp ;
131
132%Offsets = (
133
134    # Warnings Categories added in Perl 5.008
135
136    'all'		=> 0,
137    'closure'		=> 2,
138    'deprecated'	=> 4,
139    'exiting'		=> 6,
140    'glob'		=> 8,
141    'io'		=> 10,
142    'closed'		=> 12,
143    'exec'		=> 14,
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,
176    'threads'		=> 80,
177    'uninitialized'	=> 82,
178    'unpack'		=> 84,
179    'untie'		=> 86,
180    'utf8'		=> 88,
181    'void'		=> 90,
182    'y2k'		=> 92,
183  );
184
185%Bits = (
186    'all'		=> "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
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]
189    'closed'		=> "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
190    'closure'		=> "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
191    'debugging'		=> "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
192    'deprecated'	=> "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
193    'digit'		=> "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
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]
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]
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]
227    'unopened'		=> "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
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]
233  );
234
235%DeadBits = (
236    'all'		=> "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
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]
239    'closed'		=> "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
240    'closure'		=> "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
241    'debugging'		=> "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
242    'deprecated'	=> "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
243    'digit'		=> "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
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]
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]
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]
277    'unopened'		=> "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
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]
283  );
284
285$NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
286$LAST_BIT = 94 ;
287$BYTES    = 12 ;
288
289$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
290
291sub Croaker
292{
293    delete $Carp::CarpInternal{'warnings'};
294    croak @_ ;
295}
296
297sub bits
298{
299    # called from B::Deparse.pm
300
301    push @_, 'all' unless @_;
302
303    my $mask;
304    my $catmask ;
305    my $fatal = 0 ;
306    my $no_fatal = 0 ;
307
308    foreach my $word ( @_ ) {
309	if ($word eq 'FATAL') {
310	    $fatal = 1;
311	    $no_fatal = 0;
312	}
313	elsif ($word eq 'NONFATAL') {
314	    $fatal = 0;
315	    $no_fatal = 1;
316	}
317	elsif ($catmask = $Bits{$word}) {
318	    $mask |= $catmask ;
319	    $mask |= $DeadBits{$word} if $fatal ;
320	    $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
321	}
322	else
323          { Croaker("Unknown warnings category '$word'")}
324    }
325
326    return $mask ;
327}
328
329sub import
330{
331    shift;
332
333    my $catmask ;
334    my $fatal = 0 ;
335    my $no_fatal = 0 ;
336
337    my $mask = ${^WARNING_BITS} ;
338
339    if (vec($mask, $Offsets{'all'}, 1)) {
340        $mask |= $Bits{'all'} ;
341        $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
342    }
343
344    push @_, 'all' unless @_;
345
346    foreach my $word ( @_ ) {
347	if ($word eq 'FATAL') {
348	    $fatal = 1;
349	    $no_fatal = 0;
350	}
351	elsif ($word eq 'NONFATAL') {
352	    $fatal = 0;
353	    $no_fatal = 1;
354	}
355	elsif ($catmask = $Bits{$word}) {
356	    $mask |= $catmask ;
357	    $mask |= $DeadBits{$word} if $fatal ;
358	    $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
359	}
360	else
361          { Croaker("Unknown warnings category '$word'")}
362    }
363
364    ${^WARNING_BITS} = $mask ;
365}
366
367sub unimport
368{
369    shift;
370
371    my $catmask ;
372    my $mask = ${^WARNING_BITS} ;
373
374    if (vec($mask, $Offsets{'all'}, 1)) {
375        $mask |= $Bits{'all'} ;
376        $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
377    }
378
379    push @_, 'all' unless @_;
380
381    foreach my $word ( @_ ) {
382	if ($word eq 'FATAL') {
383	    next;
384	}
385	elsif ($catmask = $Bits{$word}) {
386	    $mask &= ~($catmask | $DeadBits{$word} | $All);
387	}
388	else
389          { Croaker("Unknown warnings category '$word'")}
390    }
391
392    ${^WARNING_BITS} = $mask ;
393}
394
395sub __chk
396{
397    my $category ;
398    my $offset ;
399    my $isobj = 0 ;
400
401    if (@_) {
402        # check the category supplied.
403        $category = shift ;
404        if (ref $category) {
405            Croaker ("not an object")
406                if $category !~ /^([^=]+)=/ ;
407	    $category = $1 ;
408            $isobj = 1 ;
409        }
410        $offset = $Offsets{$category};
411        Croaker("Unknown warnings category '$category'")
412	    unless defined $offset;
413    }
414    else {
415        $category = (caller(1))[0] ;
416        $offset = $Offsets{$category};
417        Croaker("package '$category' not registered for warnings")
418	    unless defined $offset ;
419    }
420
421    my $this_pkg = (caller(1))[0] ;
422    my $i = 2 ;
423    my $pkg ;
424
425    if ($isobj) {
426        while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
427            last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
428        }
429	$i -= 2 ;
430    }
431    else {
432        for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
433            last if $pkg ne $this_pkg ;
434        }
435        $i = 2
436            if !$pkg || $pkg eq $this_pkg ;
437    }
438
439    my $callers_bitmask = (caller($i))[9] ;
440    return ($callers_bitmask, $offset, $i) ;
441}
442
443sub enabled
444{
445    Croaker("Usage: warnings::enabled([category])")
446	unless @_ == 1 || @_ == 0 ;
447
448    my ($callers_bitmask, $offset, $i) = __chk(@_) ;
449
450    return 0 unless defined $callers_bitmask ;
451    return vec($callers_bitmask, $offset, 1) ||
452           vec($callers_bitmask, $Offsets{'all'}, 1) ;
453}
454
455
456sub warn
457{
458    Croaker("Usage: warnings::warn([category,] 'message')")
459	unless @_ == 2 || @_ == 1 ;
460
461    my $message = pop ;
462    my ($callers_bitmask, $offset, $i) = __chk(@_) ;
463    croak($message)
464	if vec($callers_bitmask, $offset+1, 1) ||
465	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
466    carp($message) ;
467}
468
469sub warnif
470{
471    Croaker("Usage: warnings::warnif([category,] 'message')")
472	unless @_ == 2 || @_ == 1 ;
473
474    my $message = pop ;
475    my ($callers_bitmask, $offset, $i) = __chk(@_) ;
476
477    return
478        unless defined $callers_bitmask &&
479            	(vec($callers_bitmask, $offset, 1) ||
480            	vec($callers_bitmask, $Offsets{'all'}, 1)) ;
481
482    croak($message)
483	if vec($callers_bitmask, $offset+1, 1) ||
484	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
485
486    carp($message) ;
487}
488
4891;
490