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