[perl5.git] / lib / warnings.pm

# -*- buffer-read-only: t -*-
# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
# This file was created by warnings.pl
# Any changes made here will be lost.
#

package warnings;

our $VERSION = '1.06';

# Verify that we're called correctly so that warnings will work.
# see also strict.pm.
unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
    my (undef, $f, $l) = caller;
    die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
}

=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

The C<warnings> pragma is a replacement for the command line flag C<-w>,
but the pragma is limited to the enclosing block, while the flag is global.
See L<perllexwarn> for more information.

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

our %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,

    # Warnings Categories added in Perl 5.011

    'imprecision'	=> 92,
  );

our %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]
    'imprecision'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
    '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]
  );

our %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]
    'imprecision'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
    '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]
  );

$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
{
    require Carp::Heavy; # this initializes %CarpInternal
    local $Carp::CarpInternal{'warnings'};
    delete $Carp::CarpInternal{'warnings'};
    Carp::croak(@_);
}

sub bits
{
    # called from B::Deparse.pm

    push @_, 'all' unless @_;

    my $mask;
    my $catmask ;
    my $fatal = 0 ;
    my $no_fatal = 0 ;

    foreach my $word ( @_ ) {
	if ($word eq 'FATAL') {
	    $fatal = 1;
	    $no_fatal = 0;
	}
	elsif ($word eq 'NONFATAL') {
	    $fatal = 0;
	    $no_fatal = 1;
	}
	elsif ($catmask = $Bits{$word}) {
	    $mask |= $catmask ;
	    $mask |= $DeadBits{$word} if $fatal ;
	    $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
	}
	else
          { Croaker("Unknown warnings category '$word'")}
    }

    return $mask ;
}

sub import 
{
    shift;

    my $catmask ;
    my $fatal = 0 ;
    my $no_fatal = 0 ;

    my $mask = ${^WARNING_BITS} ;

    if (vec($mask, $Offsets{'all'}, 1)) {
        $mask |= $Bits{'all'} ;
        $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
    }
    
    push @_, 'all' unless @_;

    foreach my $word ( @_ ) {
	if ($word eq 'FATAL') {
	    $fatal = 1;
	    $no_fatal = 0;
	}
	elsif ($word eq 'NONFATAL') {
	    $fatal = 0;
	    $no_fatal = 1;
	}
	elsif ($catmask = $Bits{$word}) {
	    $mask |= $catmask ;
	    $mask |= $DeadBits{$word} if $fatal ;
	    $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
	}
	else
          { Croaker("Unknown warnings category '$word'")}
    }

    ${^WARNING_BITS} = $mask ;
}

sub unimport 
{
    shift;

    my $catmask ;
    my $mask = ${^WARNING_BITS} ;

    if (vec($mask, $Offsets{'all'}, 1)) {
        $mask |= $Bits{'all'} ;
        $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
    }

    push @_, 'all' unless @_;

    foreach my $word ( @_ ) {
	if ($word eq 'FATAL') {
	    next; 
	}
	elsif ($catmask = $Bits{$word}) {
	    $mask &= ~($catmask | $DeadBits{$word} | $All);
	}
	else
          { Croaker("Unknown warnings category '$word'")}
    }

    ${^WARNING_BITS} = $mask ;
}

my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();

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

    if (@_) {
        # check the category supplied.
        $category = shift ;
        if (my $type = ref $category) {
            Croaker("not an object")
                if exists $builtin_type{$type};
	    $category = $type;
            $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 {
        $i = _error_loc(); # see where Carp will allocate the error
    }

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

sub _error_loc {
    require Carp::Heavy;
    goto &Carp::short_error_loc; # don't introduce another stack frame
}                                                             

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(@_) ;
    require Carp;
    Carp::croak($message)
	if vec($callers_bitmask, $offset+1, 1) ||
	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
    Carp::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)) ;

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

    Carp::carp($message) ;
}

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