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


# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
# This file was created by warnings.pl
# Any changes made here will be lost.
#

package warnings;

our $VERSION = '1.00';

=head1 NAME

warnings - Perl pragma to control optional warnings

=head1 SYNOPSIS

    use warnings;
    no warnings;

    use warnings "all";
    no warnings "all";

    use warnings::register;
    if (warnings::enabled()) {
        warnings::warn("some warning");
    }

    if (warnings::enabled("void")) {
        warnings::warn("void", "some warning");
    }

    if (warnings::enabled($object)) {
        warnings::warn($object, "some warning");
    }

    warnings::warnif("some warning");
    warnings::warnif("void", "some warning");
    warnings::warnif($object, "some warning");

=head1 DESCRIPTION

If no import list is supplied, all possible warnings are either enabled
or disabled.

A number of functions are provided to assist module authors.

=over 4

=item use warnings::register

Creates a new warnings category with the same name as the package where
the call to the pragma is used.

=item warnings::enabled()

Use the warnings category with the same name as the current package.

Return TRUE if that warnings category is enabled in the calling module.
Otherwise returns FALSE.

=item warnings::enabled($category)

Return TRUE if the warnings category, C<$category>, is enabled in the
calling module.
Otherwise returns FALSE.

=item warnings::enabled($object)

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

Return TRUE if that warnings category is enabled in the first scope
where the object is used.
Otherwise returns FALSE.

=item warnings::warn($message)

Print C<$message> to STDERR.

Use the warnings category with the same name as the current package.

If that warnings category has been set to "FATAL" in the calling module
then die. Otherwise return.

=item warnings::warn($category, $message)

Print C<$message> to STDERR.

If the warnings category, C<$category>, has been set to "FATAL" in the
calling module then die. Otherwise return.

=item warnings::warn($object, $message)

Print C<$message> to STDERR.

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

If that warnings category has been set to "FATAL" in the scope where C<$object>
is first used then die. Otherwise return.


=item warnings::warnif($message)

Equivalent to:

    if (warnings::enabled())
      { warnings::warn($message) }

=item warnings::warnif($category, $message)

Equivalent to:

    if (warnings::enabled($category))
      { warnings::warn($category, $message) }

=item warnings::warnif($object, $message)

Equivalent to:

    if (warnings::enabled($object))
      { warnings::warn($object, $message) }

=back

See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.

=cut

use Carp ;

%Offsets = (

    # Warnings Categories added in Perl 5.008

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

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

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

$NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
$LAST_BIT = 94 ;
$BYTES    = 12 ;

$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;

sub Croaker
{
    delete $Carp::CarpInternal{'warnings'};
    croak(@_);
}

sub bits
{
    # 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 ;
}

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

    if (@_) {
        # check the category supplied.
        $category = shift ;
        if (ref $category) {
            Croaker ("not an object")
                if $category !~ /^([^=]+)=/ ;
	    $category = $1 ;
            $isobj = 1 ;
        }
        $offset = $Offsets{$category};
        Croaker("Unknown warnings category '$category'")
	    unless defined $offset;
    }
    else {
        $category = (caller(1))[0] ;
        $offset = $Offsets{$category};
        Croaker("package '$category' not registered for warnings")
	    unless defined $offset ;
    }

    my $this_pkg = (caller(1))[0] ;
    my $i = 2 ;
    my $pkg ;

    if ($isobj) {
        while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
            last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
        }
	$i -= 2 ;
    }
    else {
        for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
            last if $pkg ne $this_pkg ;
        }
        $i = 2
            if !$pkg || $pkg eq $this_pkg ;
    }

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

sub enabled
{
    Croaker("Usage: warnings::enabled([category])")
	unless @_ == 1 || @_ == 0 ;

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

    return 0 unless defined $callers_bitmask ;
    return vec($callers_bitmask, $offset, 1) ||
           vec($callers_bitmask, $Offsets{'all'}, 1) ;
}


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

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

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

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

    return
        unless defined $callers_bitmask &&
            	(vec($callers_bitmask, $offset, 1) ||
            	vec($callers_bitmask, $Offsets{'all'}, 1)) ;

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

    carp($message) ;
}

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