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.05';
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    local $Carp::CarpInternal{'warnings'};
298    delete $Carp::CarpInternal{'warnings'};
299    Carp::croak(@_);
300}
301
302sub bits
303{
304    # called from B::Deparse.pm
305
306    push @_, 'all' unless @_;
307
308    my $mask;
309    my $catmask ;
310    my $fatal = 0 ;
311    my $no_fatal = 0 ;
312
313    foreach my $word ( @_ ) {
314	if ($word eq 'FATAL') {
315	    $fatal = 1;
316	    $no_fatal = 0;
317	}
318	elsif ($word eq 'NONFATAL') {
319	    $fatal = 0;
320	    $no_fatal = 1;
321	}
322	elsif ($catmask = $Bits{$word}) {
323	    $mask |= $catmask ;
324	    $mask |= $DeadBits{$word} if $fatal ;
325	    $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
326	}
327	else
328          { Croaker("Unknown warnings category '$word'")}
329    }
330
331    return $mask ;
332}
333
334sub import
335{
336    shift;
337
338    my $catmask ;
339    my $fatal = 0 ;
340    my $no_fatal = 0 ;
341
342    my $mask = ${^WARNING_BITS} ;
343
344    if (vec($mask, $Offsets{'all'}, 1)) {
345        $mask |= $Bits{'all'} ;
346        $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
347    }
348
349    push @_, 'all' unless @_;
350
351    foreach my $word ( @_ ) {
352	if ($word eq 'FATAL') {
353	    $fatal = 1;
354	    $no_fatal = 0;
355	}
356	elsif ($word eq 'NONFATAL') {
357	    $fatal = 0;
358	    $no_fatal = 1;
359	}
360	elsif ($catmask = $Bits{$word}) {
361	    $mask |= $catmask ;
362	    $mask |= $DeadBits{$word} if $fatal ;
363	    $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
364	}
365	else
366          { Croaker("Unknown warnings category '$word'")}
367    }
368
369    ${^WARNING_BITS} = $mask ;
370}
371
372sub unimport
373{
374    shift;
375
376    my $catmask ;
377    my $mask = ${^WARNING_BITS} ;
378
379    if (vec($mask, $Offsets{'all'}, 1)) {
380        $mask |= $Bits{'all'} ;
381        $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
382    }
383
384    push @_, 'all' unless @_;
385
386    foreach my $word ( @_ ) {
387	if ($word eq 'FATAL') {
388	    next;
389	}
390	elsif ($catmask = $Bits{$word}) {
391	    $mask &= ~($catmask | $DeadBits{$word} | $All);
392	}
393	else
394          { Croaker("Unknown warnings category '$word'")}
395    }
396
397    ${^WARNING_BITS} = $mask ;
398}
399
400my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
401
402sub __chk
403{
404    my $category ;
405    my $offset ;
406    my $isobj = 0 ;
407
408    if (@_) {
409        # check the category supplied.
410        $category = shift ;
411        if (my $type = ref $category) {
412            Croaker("not an object")
413                if exists $builtin_type{$type};
414	    $category = $type;
415            $isobj = 1 ;
416        }
417        $offset = $Offsets{$category};
418        Croaker("Unknown warnings category '$category'")
419	    unless defined $offset;
420    }
421    else {
422        $category = (caller(1))[0] ;
423        $offset = $Offsets{$category};
424        Croaker("package '$category' not registered for warnings")
425	    unless defined $offset ;
426    }
427
428    my $this_pkg = (caller(1))[0] ;
429    my $i = 2 ;
430    my $pkg ;
431
432    if ($isobj) {
433        while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
434            last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
435        }
436	$i -= 2 ;
437    }
438    else {
439        for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
440            last if $pkg ne $this_pkg ;
441        }
442        $i = 2
443            if !$pkg || $pkg eq $this_pkg ;
444    }
445
446    my $callers_bitmask = (caller($i))[9] ;
447    return ($callers_bitmask, $offset, $i) ;
448}
449
450sub enabled
451{
452    Croaker("Usage: warnings::enabled([category])")
453	unless @_ == 1 || @_ == 0 ;
454
455    my ($callers_bitmask, $offset, $i) = __chk(@_) ;
456
457    return 0 unless defined $callers_bitmask ;
458    return vec($callers_bitmask, $offset, 1) ||
459           vec($callers_bitmask, $Offsets{'all'}, 1) ;
460}
461
462
463sub warn
464{
465    Croaker("Usage: warnings::warn([category,] 'message')")
466	unless @_ == 2 || @_ == 1 ;
467
468    my $message = pop ;
469    my ($callers_bitmask, $offset, $i) = __chk(@_) ;
470    Carp::croak($message)
471	if vec($callers_bitmask, $offset+1, 1) ||
472	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
473    Carp::carp($message) ;
474}
475
476sub warnif
477{
478    Croaker("Usage: warnings::warnif([category,] 'message')")
479	unless @_ == 2 || @_ == 1 ;
480
481    my $message = pop ;
482    my ($callers_bitmask, $offset, $i) = __chk(@_) ;
483
484    return
485        unless defined $callers_bitmask &&
486            	(vec($callers_bitmask, $offset, 1) ||
487            	vec($callers_bitmask, $Offsets{'all'}, 1)) ;
488
489    Carp::croak($message)
490	if vec($callers_bitmask, $offset+1, 1) ||
491	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
492
493    Carp::carp($message) ;
494}
495
4961;
497# ex: set ro:
498