[p5sagit/p5-mst-13.2.git] / lib / warnings.pm


# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
# 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 = (

    # Warnings Categories added in Perl 5.008

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

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

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

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