[perl5.git] / lib / warnings.pm


# This file was created by warnings.pl
# Any changes made here will be lost.
#

package warnings;

our $VERSION = '1.00';

=head1 NAME

warnings - Perl pragma to control optional warnings

=head1 SYNOPSIS

    use warnings;
    no warnings;

    use warnings "all";
    no warnings "all";

    use warnings::register;
    if (warnings::enabled()) {
        warnings::warn("some warning");
    }

    if (warnings::enabled("void")) {
        warnings::warn("void", "some warning");
    }

    if (warnings::enabled($object)) {
        warnings::warn($object, "some warning");
    }

    warnings::warnif("some warning");
    warnings::warnif("void", "some warning");
    warnings::warnif($object, "some warning");

=head1 DESCRIPTION

If no import list is supplied, all possible warnings are either enabled
or disabled.

A number of functions are provided to assist module authors.

=over 4

=item use warnings::register

Creates a new warnings category with the same name as the package where
the call to the pragma is used.

=item warnings::enabled()

Use the warnings category with the same name as the current package.

Return TRUE if that warnings category is enabled in the calling module.
Otherwise returns FALSE.

=item warnings::enabled($category)

Return TRUE if the warnings category, C<$category>, is enabled in the
calling module.
Otherwise returns FALSE.

=item warnings::enabled($object)

Use the name of the class for the object reference, C<$object>, as the
warnings category.

Return TRUE if that warnings category is enabled in the first scope
where the object is used.
Otherwise returns FALSE.

=item warnings::warn($message)

Print C<$message> to STDERR.

Use the warnings category with the same name as the current package.

If that warnings category has been set to "FATAL" in the calling module
then die. Otherwise return.

=item warnings::warn($category, $message)

Print C<$message> to STDERR.

If the warnings category, C<$category>, has been set to "FATAL" in the
calling module then die. Otherwise return.

=item warnings::warn($object, $message)

Print C<$message> to STDERR.

Use the name of the class for the object reference, C<$object>, as the
warnings category.

If that warnings category has been set to "FATAL" in the scope where C<$object>
is first used then die. Otherwise return.


=item warnings::warnif($message)

Equivalent to:

    if (warnings::enabled())
      { warnings::warn($message) }

=item warnings::warnif($category, $message)

Equivalent to:

    if (warnings::enabled($category))
      { warnings::warn($category, $message) }

=item warnings::warnif($object, $message)

Equivalent to:

    if (warnings::enabled($object))
      { warnings::warn($object, $message) }

=back

See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.

=cut

use Carp ;

%Offsets = (
    'all'		=> 0,
    'closure'		=> 2,
    'deprecated'	=> 4,
    'exiting'		=> 6,
    'glob'		=> 8,
    'io'		=> 10,
    'closed'		=> 12,
    'exec'		=> 14,
    'newline'		=> 16,
    'pipe'		=> 18,
    'unopened'		=> 20,
    'misc'		=> 22,
    'numeric'		=> 24,
    'once'		=> 26,
    'overflow'		=> 28,
    'pack'		=> 30,
    'portable'		=> 32,
    'recursion'		=> 34,
    'redefine'		=> 36,
    'regexp'		=> 38,
    'severe'		=> 40,
    'debugging'		=> 42,
    'inplace'		=> 44,
    'internal'		=> 46,
    'malloc'		=> 48,
    'signal'		=> 50,
    'substr'		=> 52,
    'syntax'		=> 54,
    'ambiguous'		=> 56,
    'bareword'		=> 58,
    'digit'		=> 60,
    'parenthesis'	=> 62,
    'precedence'	=> 64,
    'printf'		=> 66,
    'prototype'		=> 68,
    'qw'		=> 70,
    'reserved'		=> 72,
    'semicolon'		=> 74,
    'taint'		=> 76,
    'uninitialized'	=> 78,
    'unpack'		=> 80,
    'untie'		=> 82,
    'utf8'		=> 84,
    'void'		=> 86,
    'y2k'		=> 88,
  );

%Bits = (
    'all'		=> "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x01", # [0..44]
    'ambiguous'		=> "\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [28]
    'bareword'		=> "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
    'closed'		=> "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
    'closure'		=> "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
    'debugging'		=> "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21]
    'deprecated'	=> "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
    'digit'		=> "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
    'exec'		=> "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
    'exiting'		=> "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
    'glob'		=> "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
    'inplace'		=> "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
    'internal'		=> "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
    'io'		=> "\x00\x54\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
    'malloc'		=> "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
    'misc'		=> "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
    'newline'		=> "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
    'numeric'		=> "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
    'once'		=> "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
    'overflow'		=> "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
    'pack'		=> "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
    'parenthesis'	=> "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
    'pipe'		=> "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
    'portable'		=> "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
    'precedence'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
    'printf'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
    'prototype'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
    'qw'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
    'recursion'		=> "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
    'redefine'		=> "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
    'regexp'		=> "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
    'reserved'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
    'semicolon'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
    'severe'		=> "\x00\x00\x00\x00\x00\x55\x01\x00\x00\x00\x00\x00", # [20..24]
    'signal'		=> "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
    'substr'		=> "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
    'syntax'		=> "\x00\x00\x00\x00\x00\x00\x40\x55\x55\x05\x00\x00", # [27..37]
    'taint'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
    'uninitialized'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
    'unopened'		=> "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
    'unpack'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
    'untie'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
    'utf8'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
    'void'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
    'y2k'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
  );

%DeadBits = (
    'all'		=> "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x02", # [0..44]
    'ambiguous'		=> "\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [28]
    'bareword'		=> "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
    'closed'		=> "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
    'closure'		=> "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
    'debugging'		=> "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21]
    'deprecated'	=> "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
    'digit'		=> "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
    'exec'		=> "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
    'exiting'		=> "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
    'glob'		=> "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
    'inplace'		=> "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
    'internal'		=> "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
    'io'		=> "\x00\xa8\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..10]
    'malloc'		=> "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
    'misc'		=> "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
    'newline'		=> "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
    'numeric'		=> "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
    'once'		=> "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
    'overflow'		=> "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
    'pack'		=> "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
    'parenthesis'	=> "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
    'pipe'		=> "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
    'portable'		=> "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
    'precedence'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
    'printf'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
    'prototype'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
    'qw'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
    'recursion'		=> "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
    'redefine'		=> "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
    'regexp'		=> "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
    'reserved'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
    'semicolon'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
    'severe'		=> "\x00\x00\x00\x00\x00\xaa\x02\x00\x00\x00\x00\x00", # [20..24]
    'signal'		=> "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
    'substr'		=> "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
    'syntax'		=> "\x00\x00\x00\x00\x00\x00\x80\xaa\xaa\x0a\x00\x00", # [27..37]
    'taint'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
    'uninitialized'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
    'unopened'		=> "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
    'unpack'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
    'untie'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
    'utf8'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
    'void'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
    'y2k'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
  );

$NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
$LAST_BIT = 90 ;
$BYTES    = 12 ;

$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;

sub bits {
    my $mask ;
    my $catmask ;
    my $fatal = 0 ;
    foreach my $word (@_) {
	if  ($word eq 'FATAL') {
	    $fatal = 1;
	}
	elsif ($catmask = $Bits{$word}) {
	    $mask |= $catmask ;
	    $mask |= $DeadBits{$word} if $fatal ;
	}
	else
          { croak("Unknown warnings category '$word'")}
    }

    return $mask ;
}

sub import {
    shift;
    my $mask = ${^WARNING_BITS} ;
    if (vec($mask, $Offsets{'all'}, 1)) {
        $mask |= $Bits{'all'} ;
        $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
    }
    ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
}

sub unimport {
    shift;
    my $mask = ${^WARNING_BITS} ;
    if (vec($mask, $Offsets{'all'}, 1)) {
        $mask |= $Bits{'all'} ;
        $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
    }
    ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
}

sub __chk
{
    my $category ;
    my $offset ;
    my $isobj = 0 ;

    if (@_) {
        # check the category supplied.
        $category = shift ;
        if (ref $category) {
            croak ("not an object")
                if $category !~ /^([^=]+)=/ ;
	    $category = $1 ;
            $isobj = 1 ;
        }
        $offset = $Offsets{$category};
        croak("Unknown warnings category '$category'")
	    unless defined $offset;
    }
    else {
        $category = (caller(1))[0] ;
        $offset = $Offsets{$category};
        croak("package '$category' not registered for warnings")
	    unless defined $offset ;
    }

    my $this_pkg = (caller(1))[0] ;
    my $i = 2 ;
    my $pkg ;

    if ($isobj) {
        while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
            last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
        }
	$i -= 2 ;
    }
    else {
        for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
            last if $pkg ne $this_pkg ;
        }
        $i = 2
            if !$pkg || $pkg eq $this_pkg ;
    }

    my $callers_bitmask = (caller($i))[9] ;
    return ($callers_bitmask, $offset, $i) ;
}

sub enabled
{
    croak("Usage: warnings::enabled([category])")
	unless @_ == 1 || @_ == 0 ;

    my ($callers_bitmask, $offset, $i) = __chk(@_) ;

    return 0 unless defined $callers_bitmask ;
    return vec($callers_bitmask, $offset, 1) ||
           vec($callers_bitmask, $Offsets{'all'}, 1) ;
}


sub warn
{
    croak("Usage: warnings::warn([category,] 'message')")
	unless @_ == 2 || @_ == 1 ;

    my $message = pop ;
    my ($callers_bitmask, $offset, $i) = __chk(@_) ;
    local $Carp::CarpLevel = $i ;
    croak($message)
	if vec($callers_bitmask, $offset+1, 1) ||
	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
    carp($message) ;
}

sub warnif
{
    croak("Usage: warnings::warnif([category,] 'message')")
	unless @_ == 2 || @_ == 1 ;

    my $message = pop ;
    my ($callers_bitmask, $offset, $i) = __chk(@_) ;
    local $Carp::CarpLevel = $i ;

    return
        unless defined $callers_bitmask &&
            	(vec($callers_bitmask, $offset, 1) ||
            	vec($callers_bitmask, $Offsets{'all'}, 1)) ;

    croak($message)
	if vec($callers_bitmask, $offset+1, 1) ||
	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;

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