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


# 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");
    }

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

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

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

$NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0\0";
$LAST_BIT = 98 ;
$BYTES    = 13 ;

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

sub bits {
    my $mask ;
    my $catmask ;
    my $fatal = 0 ;
    foreach my $word (@_) {
	if  ($word eq 'FATAL') {
	    $fatal = 1;
	}
	elsif ($catmask = $Bits{$word}) {
	    $mask |= $catmask ;
	    $mask |= $DeadBits{$word} if $fatal ;
	}
	else
          { croak("unknown warnings category '$word'")}
    }

    return $mask ;
}

sub import {
    shift;
    my $mask = ${^WARNING_BITS} ;
    if (vec($mask, $Offsets{'all'}, 1)) {
        $mask |= $Bits{'all'} ;
        $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
    }
    ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
}

sub unimport {
    shift;
    my $mask = ${^WARNING_BITS} ;
    if (vec($mask, $Offsets{'all'}, 1)) {
        $mask |= $Bits{'all'} ;
        $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
    }
    ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
}

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

    if (@_) {
        # check the category supplied.
        $category = shift ;
        if (ref $category) {
            croak ("not an object")
                if $category !~ /^([^=]+)=/ ;+
	    $category = $1 ;
            $isobj = 1 ;
        }
        $offset = $Offsets{$category};
        croak("unknown warnings category '$category'")
	    unless defined $offset;
    }
    else {
        $category = (caller(1))[0] ;
        $offset = $Offsets{$category};
        croak("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
{
    croak("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
{
    croak("Usage: warnings::warn([category,] 'message')")
	unless @_ == 2 || @_ == 1 ;

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

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

    my $message = pop ;
    my ($callers_bitmask, $offset, $i) = __chk(@_) ;
    local $Carp::CarpLevel = $i ;

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