[p5sagit/p5-mst-13.2.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 Croaker
{
    delete $Carp::CarpInternal{'warnings'};
    croak @_ ;
}

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
          { Croaker("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) {
            Croaker ("not an object")
                if $category !~ /^([^=]+)=/ ;
	    $category = $1 ;
            $isobj = 1 ;
        }
        $offset = $Offsets{$category};
        Croaker("Unknown warnings category '$category'")
	    unless defined $offset;
    }
    else {
        $category = (caller(1))[0] ;
        $offset = $Offsets{$category};
        Croaker("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
{
    Croaker("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
{
    Croaker("Usage: warnings::warn([category,] 'message')")
	unless @_ == 2 || @_ == 1 ;

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

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

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

    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	3	# Any changes made here will be lost.
	4	#
	5
4438c4b7	6	package warnings;
599cee73	7
0ca4541c	8	our $VERSION = '1.00';
0ca4541c	9
599cee73	10	=head1 NAME
599cee73	11
4438c4b7	12	warnings - Perl pragma to control optional warnings
599cee73	13
	14	=head1 SYNOPSIS
	15
4438c4b7	16	use warnings;
4438c4b7	17	no warnings;
599cee73	18
4438c4b7	19	use warnings "all";
4438c4b7	20	no warnings "all";
599cee73	21
d3a7d8c7	22	use warnings::register;
	23	if (warnings::enabled()) {
	24	warnings::warn("some warning");
	25	}
	26
	27	if (warnings::enabled("void")) {
e476b1b5	28	warnings::warn("void", "some warning");
	29	}
	30
7e6d00f8	31	if (warnings::enabled($object)) {
	32	warnings::warn($object, "some warning");
	33	}
	34
721f911b	35	warnings::warnif("some warning");
	36	warnings::warnif("void", "some warning");
	37	warnings::warnif($object, "some warning");
7e6d00f8	38
599cee73	39	=head1 DESCRIPTION
599cee73	40
0453d815	41	If no import list is supplied, all possible warnings are either enabled
0453d815	42	or disabled.
599cee73	43
0ca4541c	44	A number of functions are provided to assist module authors.
e476b1b5	45
	46	=over 4
	47
d3a7d8c7	48	=item use warnings::register
d3a7d8c7	49
7e6d00f8	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	95	Use the name of the class for the object reference, C<$object>, as the
7e6d00f8	96	warnings category.
d3a7d8c7	97
7e6d00f8	98	If that warnings category has been set to "FATAL" in the scope where C<$object>
7e6d00f8	99	is first used then die. Otherwise return.
599cee73	100
e476b1b5	101
7e6d00f8	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	123	=back
e476b1b5	124
749f83fa	125	See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73	126
	127	=cut
	128
	129	use Carp ;
	130
d3a7d8c7	131	%Offsets = (
d3a7d8c7	132	'all' => 0,
3eae5ce4	133	'closure' => 2,
12bcd1a6	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	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	177	);
d3a7d8c7	178
599cee73	179	%Bits = (
3eae5ce4	180	'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x01", # [0..44]
12bcd1a6	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	185	'debugging' => "\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [21]
12bcd1a6	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	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	202	'pipe' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
12bcd1a6	203	'portable' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
3eae5ce4	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	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	211	'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
3eae5ce4	212	'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
12bcd1a6	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	217	'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
3eae5ce4	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	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	225	);
	226
	227	%DeadBits = (
3eae5ce4	228	'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x02", # [0..44]
12bcd1a6	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	233	'debugging' => "\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [21]
12bcd1a6	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	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	250	'pipe' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
12bcd1a6	251	'portable' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
3eae5ce4	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	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	259	'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
3eae5ce4	260	'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
12bcd1a6	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	265	'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
3eae5ce4	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	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	273	);
599cee73	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	278
d3a7d8c7	279	$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
599cee73	280
c3186b65	281	sub Croaker
	282	{
	283	delete $Carp::CarpInternal{'warnings'};
	284	croak @_ ;
	285	}
	286
599cee73	287	sub bits {
	288	my $mask ;
	289	my $catmask ;
	290	my $fatal = 0 ;
	291	foreach my $word (@_) {
327afb7f	292	if ($word eq 'FATAL') {
	293	$fatal = 1;
	294	}
d3a7d8c7	295	elsif ($catmask = $Bits{$word}) {
	296	$mask \|= $catmask ;
	297	$mask \|= $DeadBits{$word} if $fatal ;
599cee73	298	}
d3a7d8c7	299	else
c3186b65	300	{ Croaker("Unknown warnings category '$word'")}
599cee73	301	}
	302
	303	return $mask ;
	304	}
	305
	306	sub import {
	307	shift;
f1f33818	308	my $mask = ${^WARNING_BITS} ;
	309	if (vec($mask, $Offsets{'all'}, 1)) {
	310	$mask \|= $Bits{'all'} ;
	311	$mask \|= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
	312	}
	313	${^WARNING_BITS} = $mask \| bits(@_ ? @_ : 'all') ;
599cee73	314	}
	315
	316	sub unimport {
	317	shift;
d3a7d8c7	318	my $mask = ${^WARNING_BITS} ;
d3a7d8c7	319	if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818	320	$mask \|= $Bits{'all'} ;
d3a7d8c7	321	$mask \|= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
d3a7d8c7	322	}
08540116	323	${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) \| $All) ;
599cee73	324	}
599cee73	325
7e6d00f8	326	sub __chk
599cee73	327	{
d3a7d8c7	328	my $category ;
d3a7d8c7	329	my $offset ;
7e6d00f8	330	my $isobj = 0 ;
d3a7d8c7	331
	332	if (@_) {
	333	# check the category supplied.
	334	$category = shift ;
7e6d00f8	335	if (ref $category) {
c3186b65	336	Croaker ("not an object")
3d1a39c8	337	if $category !~ /^([^=]+)=/ ;
7e6d00f8	338	$category = $1 ;
	339	$isobj = 1 ;
	340	}
d3a7d8c7	341	$offset = $Offsets{$category};
c3186b65	342	Croaker("Unknown warnings category '$category'")
d3a7d8c7	343	unless defined $offset;
	344	}
	345	else {
0ca4541c	346	$category = (caller(1))[0] ;
d3a7d8c7	347	$offset = $Offsets{$category};
c3186b65	348	Croaker("package '$category' not registered for warnings")
d3a7d8c7	349	unless defined $offset ;
	350	}
	351
0ca4541c	352	my $this_pkg = (caller(1))[0] ;
7e6d00f8	353	my $i = 2 ;
	354	my $pkg ;
	355
	356	if ($isobj) {
	357	while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
	358	last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
	359	}
	360	$i -= 2 ;
	361	}
	362	else {
	363	for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
	364	last if $pkg ne $this_pkg ;
	365	}
0ca4541c	366	$i = 2
7e6d00f8	367	if !$pkg \|\| $pkg eq $this_pkg ;
	368	}
	369
0ca4541c	370	my $callers_bitmask = (caller($i))[9] ;
7e6d00f8	371	return ($callers_bitmask, $offset, $i) ;
	372	}
	373
	374	sub enabled
	375	{
c3186b65	376	Croaker("Usage: warnings::enabled([category])")
7e6d00f8	377	unless @_ == 1 \|\| @_ == 0 ;
	378
	379	my ($callers_bitmask, $offset, $i) = __chk(@_) ;
	380
	381	return 0 unless defined $callers_bitmask ;
d3a7d8c7	382	return vec($callers_bitmask, $offset, 1) \|\|
d3a7d8c7	383	vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73	384	}
599cee73	385
d3a7d8c7	386
e476b1b5	387	sub warn
e476b1b5	388	{
c3186b65	389	Croaker("Usage: warnings::warn([category,] 'message')")
d3a7d8c7	390	unless @_ == 2 \|\| @_ == 1 ;
d3a7d8c7	391
7e6d00f8	392	my $message = pop ;
7e6d00f8	393	my ($callers_bitmask, $offset, $i) = __chk(@_) ;
0ca4541c	394	croak($message)
d3a7d8c7	395	if vec($callers_bitmask, $offset+1, 1) \|\|
d3a7d8c7	396	vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5	397	carp($message) ;
	398	}
	399
7e6d00f8	400	sub warnif
7e6d00f8	401	{
c3186b65	402	Croaker("Usage: warnings::warnif([category,] 'message')")
7e6d00f8	403	unless @_ == 2 \|\| @_ == 1 ;
	404
	405	my $message = pop ;
	406	my ($callers_bitmask, $offset, $i) = __chk(@_) ;
7e6d00f8	407
0ca4541c	408	return
7e6d00f8	409	unless defined $callers_bitmask &&
	410	(vec($callers_bitmask, $offset, 1) \|\|
	411	vec($callers_bitmask, $Offsets{'all'}, 1)) ;
	412
0ca4541c	413	croak($message)
7e6d00f8	414	if vec($callers_bitmask, $offset+1, 1) \|\|
	415	vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
	416
	417	carp($message) ;
	418	}
599cee73	419	1;