[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.09';

# 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,
    'illegalproto'	=> 94,
  );

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