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