perl/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.03';

=head1 NAME

warnings - Perl pragma to control optional warnings

=head1 SYNOPSIS

    use warnings;
    no warnings;

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

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

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

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

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

=head1 DESCRIPTION

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

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

A number of functions are provided to assist module authors.

=over 4

=item use warnings::register

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

=item warnings::enabled()

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

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

=item warnings::enabled($category)

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

=item warnings::enabled($object)

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

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

=item warnings::warn($message)

Print C<$message> to STDERR.

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

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

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

Print C<$message> to STDERR.

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

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

Print C<$message> to STDERR.

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

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


=item warnings::warnif($message)

Equivalent to:

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

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

Equivalent to:

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

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

Equivalent to:

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

=back

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

=cut

use Carp ();

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,
    'y2k'               => 92,
  );

our %Bits = (
    'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
    'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
    'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
    'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
    'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
    'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
    'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
    'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
    'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
    'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
    'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
    '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]
  );

our %DeadBits = (
    'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
    'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
    'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
    'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
    'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
    'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
    'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
    'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
    'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
    'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
    'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
    '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'};
    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 {
        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(@_) ;
    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)) ;

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

    Carp::carp($message) ;
}

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