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