[p5sagit/p5-mst-13.2.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.08';

# 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::fatal_enabled()

Return TRUE if the warnings category with the same name as the current
package has been set to FATAL in the calling module.
Otherwise returns FALSE.

=item warnings::fatal_enabled($category)

Return TRUE if the warnings category C<$category> has been set to FATAL in
the calling module.
Otherwise returns FALSE.

=item warnings::fatal_enabled($object)

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

Return TRUE if that warnings category has been set to FATAL 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; # 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;
    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 fatal_enabled
{
    Croaker("Usage: warnings::fatal_enabled([category])")
  unless @_ == 1 || @_ == 0 ;

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

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