[perl5.git] / warnings.pl

#!/usr/bin/perl


$VERSION = '1.00';

BEGIN {
  push @INC, './lib';
}
use strict ;

sub DEFAULT_ON  () { 1 }
sub DEFAULT_OFF () { 2 }

my $tree = {

'all' => {
       	'io'  		=> { 	'pipe' 		=> DEFAULT_OFF,
       				'unopened'	=> DEFAULT_OFF,
       				'closed'	=> DEFAULT_OFF,
       				'newline'	=> DEFAULT_OFF,
       				'exec'		=> DEFAULT_OFF,
       				'layer'		=> DEFAULT_OFF,
			   },
       	'syntax'	=> { 	'ambiguous'	=> DEFAULT_OFF,
			     	'semicolon'	=> DEFAULT_OFF,
			     	'precedence'	=> DEFAULT_OFF,
			     	'bareword'	=> DEFAULT_OFF,
			     	'reserved'	=> DEFAULT_OFF,
				'digit'		=> DEFAULT_OFF,
			     	'parenthesis'	=> DEFAULT_OFF,
       	 			'printf'	=> DEFAULT_OFF,
       	 			'prototype'	=> DEFAULT_OFF,
       	 			'qw'		=> DEFAULT_OFF,
			   },
       	'severe'	=> { 	'inplace'	=> DEFAULT_ON,
	 			'internal'	=> DEFAULT_ON,
         			'debugging'	=> DEFAULT_ON,
         			'malloc'	=> DEFAULT_ON,
	 		   },
        'deprecated'	=> DEFAULT_OFF,
       	'void'		=> DEFAULT_OFF,
       	'recursion'	=> DEFAULT_OFF,
       	'redefine'	=> DEFAULT_OFF,
       	'numeric'	=> DEFAULT_OFF,
        'uninitialized'	=> DEFAULT_OFF,
       	'once'		=> DEFAULT_OFF,
       	'misc'		=> DEFAULT_OFF,
       	'regexp'	=> DEFAULT_OFF,
       	'glob'		=> DEFAULT_OFF,
       	'y2k'		=> DEFAULT_OFF,
       	'untie'		=> DEFAULT_OFF,
	'substr'	=> DEFAULT_OFF,
	'taint'		=> DEFAULT_OFF,
	'signal'	=> DEFAULT_OFF,
	'closure'	=> DEFAULT_OFF,
	'overflow'	=> DEFAULT_OFF,
	'portable'	=> DEFAULT_OFF,
	'utf8'		=> DEFAULT_OFF,
       	'exiting'	=> DEFAULT_OFF,
       	'pack'		=> DEFAULT_OFF,
       	'unpack'	=> DEFAULT_OFF,
       	 #'default'	=> DEFAULT_ON,
  	}
} ;


###########################################################################
sub tab {
    my($l, $t) = @_;
    $t .= "\t" x ($l - (length($t) + 1) / 8);
    $t;
}

###########################################################################

my %list ;
my %Value ;
my $index ;

sub walk
{
    my $tre = shift ;
    my @list = () ;
    my ($k, $v) ;

    foreach $k (sort keys %$tre) {
	$v = $tre->{$k};
	die "duplicate key $k\n" if defined $list{$k} ;
	$Value{$index} = uc $k ;
        push @{ $list{$k} }, $index ++ ;
	if (ref $v)
	  { push (@{ $list{$k} }, walk ($v)) }
	push @list, @{ $list{$k} } ;
    }

   return @list ;
}

###########################################################################

sub mkRange
{
    my @a = @_ ;
    my @out = @a ;
    my $i ;


    for ($i = 1 ; $i < @a; ++ $i) {
      	$out[$i] = ".."
          if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
    }

    my $out = join(",",@out);

    $out =~ s/,(\.\.,)+/../g ;
    return $out;
}

###########################################################################
sub printTree
{
    my $tre = shift ;
    my $prefix = shift ;
    my $indent = shift ;
    my ($k, $v) ;

    my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;

    $prefix .= " " x $indent ;
    foreach $k (sort keys %$tre) {
	$v = $tre->{$k};
	print $prefix . "|\n" ;
	print $prefix . "+- $k" ;
	if (ref $v)
	{
	    print " " . "-" x ($max - length $k ) . "+\n" ;
	    printTree ($v, $prefix . "|" , $max + $indent - 1)
	}
	else
	  { print "\n" }
    }

}

###########################################################################

sub mkHexOct
{
    my ($f, $max, @a) = @_ ;
    my $mask = "\x00" x $max ;
    my $string = "" ;

    foreach (@a) {
	vec($mask, $_, 1) = 1 ;
    }

    foreach (unpack("C*", $mask)) {
        if ($f eq 'x') {
            $string .= '\x' . sprintf("%2.2x", $_)
        }
        else {
            $string .= '\\' . sprintf("%o", $_)
        }
    }
    return $string ;
}

sub mkHex
{
    my($max, @a) = @_;
    return mkHexOct("x", $max, @a);
}

sub mkOct
{
    my($max, @a) = @_;
    return mkHexOct("o", $max, @a);
}

###########################################################################

if (@ARGV && $ARGV[0] eq "tree")
{
    #print "  all -+\n" ;
    printTree($tree, "   ", 4) ;
    exit ;
}

unlink "warnings.h";
unlink "lib/warnings.pm";
open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";

print WARN <<'EOM' ;
/* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
   This file is built by warnings.pl
   Any changes made here will be lost!
*/


#define Off(x)			((x) / 8)
#define Bit(x)			(1 << ((x) % 8))
#define IsSet(a, x)		((a)[Off(x)] & Bit(x))


#define G_WARN_OFF		0 	/* $^W == 0 */
#define G_WARN_ON		1	/* -w flag and $^W != 0 */
#define G_WARN_ALL_ON		2	/* -W flag */
#define G_WARN_ALL_OFF		4	/* -X flag */
#define G_WARN_ONCE		8	/* set if 'once' ever enabled */
#define G_WARN_ALL_MASK		(G_WARN_ALL_ON|G_WARN_ALL_OFF)

#define pWARN_STD		Nullsv
#define pWARN_ALL		(Nullsv+1)	/* use warnings 'all' */
#define pWARN_NONE		(Nullsv+2)	/* no  warnings 'all' */

#define specialWARN(x)		((x) == pWARN_STD || (x) == pWARN_ALL ||	\
				 (x) == pWARN_NONE)
EOM

my $offset = 0 ;

$index = $offset ;
#@{ $list{"all"} } = walk ($tree) ;
walk ($tree) ;

die <<EOM if $index > 255 ;
Too many warnings categories -- max is 255
    rewrite packWARN* & unpackWARN* macros 
EOM

$index *= 2 ;
my $warn_size = int($index / 8) + ($index % 8 != 0) ;

my $k ;
foreach $k (sort { $a <=> $b } keys %Value) {
    print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
}
print WARN "\n" ;

print WARN tab(5, '#define WARNsize'),	"$warn_size\n" ;
#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });

print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;

print WARN <<'EOM';

#define isLEXWARN_on 	(PL_curcop->cop_warnings != pWARN_STD)
#define isLEXWARN_off	(PL_curcop->cop_warnings == pWARN_STD)
#define isWARN_ONCE	(PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
#define isWARN_on(c,x)	(IsSet(SvPVX(c), 2*(x)))
#define isWARNf_on(c,x)	(IsSet(SvPVX(c), 2*(x)+1))

#define ckWARN(x)							\
	( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&	\
	      (PL_curcop->cop_warnings == pWARN_ALL ||			\
	       isWARN_on(PL_curcop->cop_warnings, x) ) )		\
	  || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )

#define ckWARN2(x,y)							\
	  ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&	\
	      (PL_curcop->cop_warnings == pWARN_ALL ||			\
	        isWARN_on(PL_curcop->cop_warnings, x)  ||		\
	        isWARN_on(PL_curcop->cop_warnings, y) ) ) 		\
	    ||	(isLEXWARN_off && PL_dowarn & G_WARN_ON) )

#define ckWARN3(x,y,z)							\
	  ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&	\
	      (PL_curcop->cop_warnings == pWARN_ALL ||			\
	        isWARN_on(PL_curcop->cop_warnings, x)  ||		\
	        isWARN_on(PL_curcop->cop_warnings, y)  ||		\
	        isWARN_on(PL_curcop->cop_warnings, z) ) ) 		\
	    ||	(isLEXWARN_off && PL_dowarn & G_WARN_ON) )

#define ckWARN4(x,y,z,t)						\
	  ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&	\
	      (PL_curcop->cop_warnings == pWARN_ALL ||			\
	        isWARN_on(PL_curcop->cop_warnings, x)  ||		\
	        isWARN_on(PL_curcop->cop_warnings, y)  ||		\
	        isWARN_on(PL_curcop->cop_warnings, z)  ||		\
	        isWARN_on(PL_curcop->cop_warnings, t) ) ) 		\
	    ||	(isLEXWARN_off && PL_dowarn & G_WARN_ON) )

#define ckWARN_d(x)							\
	  (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||	\
	     (PL_curcop->cop_warnings != pWARN_NONE &&			\
	      isWARN_on(PL_curcop->cop_warnings, x) ) )

#define ckWARN2_d(x,y)							\
	  (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||	\
	     (PL_curcop->cop_warnings != pWARN_NONE &&			\
	        (isWARN_on(PL_curcop->cop_warnings, x)  ||		\
	         isWARN_on(PL_curcop->cop_warnings, y) ) ) )

#define ckWARN3_d(x,y,z)						\
	  (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||	\
	     (PL_curcop->cop_warnings != pWARN_NONE &&			\
	        (isWARN_on(PL_curcop->cop_warnings, x)  ||		\
	         isWARN_on(PL_curcop->cop_warnings, y)  ||		\
	         isWARN_on(PL_curcop->cop_warnings, z) ) ) )

#define ckWARN4_d(x,y,z,t)						\
	  (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||	\
	     (PL_curcop->cop_warnings != pWARN_NONE &&			\
	        (isWARN_on(PL_curcop->cop_warnings, x)  ||		\
	         isWARN_on(PL_curcop->cop_warnings, y)  ||		\
	         isWARN_on(PL_curcop->cop_warnings, z)  ||		\
	         isWARN_on(PL_curcop->cop_warnings, t) ) ) )

#define packWARN(a)		(a                                 )
#define packWARN2(a,b)		((a) | (b)<<8                      )
#define packWARN3(a,b,c)	((a) | (b)<<8 | (c) <<16           )
#define packWARN4(a,b,c,d)	((a) | (b)<<8 | (c) <<16 | (d) <<24)

#define unpackWARN1(x)		((x)        & 0xFF)
#define unpackWARN2(x)		(((x) >>8)  & 0xFF)
#define unpackWARN3(x)		(((x) >>16) & 0xFF)
#define unpackWARN4(x)		(((x) >>24) & 0xFF)

#define ckDEAD(x)							\
	   ( ! specialWARN(PL_curcop->cop_warnings) &&			\
	    ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || 		\
	      isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||	\
	      isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||	\
	      isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||	\
	      isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))

/* end of file warnings.h */

EOM

close WARN ;

while (<DATA>) {
    last if /^KEYWORDS$/ ;
    print PM $_ ;
}

#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;

#my %Keys = map {lc $Value{$_}, $_} keys %Value ;

print PM "%Offsets = (\n" ;
foreach my $k (sort { $a <=> $b } keys %Value) {
    my $v = lc $Value{$k} ;
    $k *= 2 ;
    print PM tab(4, "    '$v'"), "=> $k,\n" ;
}

print PM "  );\n\n" ;

print PM "%Bits = (\n" ;
foreach $k (sort keys  %list) {

    my $v = $list{$k} ;
    my @list = sort { $a <=> $b } @$v ;

    print PM tab(4, "    '$k'"), '=> "',
		# mkHex($warn_size, @list),
		mkHex($warn_size, map $_ * 2 , @list),
		'", # [', mkRange(@list), "]\n" ;
}

print PM "  );\n\n" ;

print PM "%DeadBits = (\n" ;
foreach $k (sort keys  %list) {

    my $v = $list{$k} ;
    my @list = sort { $a <=> $b } @$v ;

    print PM tab(4, "    '$k'"), '=> "',
		# mkHex($warn_size, @list),
		mkHex($warn_size, map $_ * 2 + 1 , @list),
		'", # [', mkRange(@list), "]\n" ;
}

print PM "  );\n\n" ;
print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
print PM '$LAST_BIT = ' . "$index ;\n" ;
print PM '$BYTES    = ' . "$warn_size ;\n" ;
while (<DATA>) {
    print PM $_ ;
}

close PM ;

__END__

# 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 ;

KEYWORDS

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

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

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
          { Croaker("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('FATAL' => (@_ ? @_ : 'all')) | $All) ;
}

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 PM	1	#!/usr/bin/perl
599cee73 PM	2
0ca4541c NIS	3
0ca4541c NIS	4	$VERSION = '1.00';
b75c8c73	5
73f0cc2d GS	6	BEGIN {
	7	push @INC, './lib';
	8	}
599cee73 PM	9	use strict ;
	10
	11	sub DEFAULT_ON () { 1 }
	12	sub DEFAULT_OFF () { 2 }
	13
	14	my $tree = {
d3a7d8c7 GS	15
d3a7d8c7 GS	16	'all' => {
e476b1b5	17	'io' => { 'pipe' => DEFAULT_OFF,
599cee73 PM	18	'unopened' => DEFAULT_OFF,
	19	'closed' => DEFAULT_OFF,
	20	'newline' => DEFAULT_OFF,
	21	'exec' => DEFAULT_OFF,
99ef548b	22	'layer' => DEFAULT_OFF,
599cee73	23	},
e476b1b5	24	'syntax' => { 'ambiguous' => DEFAULT_OFF,
599cee73	25	'semicolon' => DEFAULT_OFF,
e476b1b5	26	'precedence' => DEFAULT_OFF,
4673fc70	27	'bareword' => DEFAULT_OFF,
599cee73	28	'reserved' => DEFAULT_OFF,
627300f0	29	'digit' => DEFAULT_OFF,
599cee73	30	'parenthesis' => DEFAULT_OFF,
599cee73	31	'printf' => DEFAULT_OFF,
e476b1b5 GS	32	'prototype' => DEFAULT_OFF,
e476b1b5 GS	33	'qw' => DEFAULT_OFF,
599cee73	34	},
e476b1b5	35	'severe' => { 'inplace' => DEFAULT_ON,
0453d815 PM	36	'internal' => DEFAULT_ON,
0453d815 PM	37	'debugging' => DEFAULT_ON,
e476b1b5	38	'malloc' => DEFAULT_ON,
0453d815	39	},
12bcd1a6	40	'deprecated' => DEFAULT_OFF,
e476b1b5 GS	41	'void' => DEFAULT_OFF,
	42	'recursion' => DEFAULT_OFF,
	43	'redefine' => DEFAULT_OFF,
	44	'numeric' => DEFAULT_OFF,
	45	'uninitialized' => DEFAULT_OFF,
	46	'once' => DEFAULT_OFF,
	47	'misc' => DEFAULT_OFF,
	48	'regexp' => DEFAULT_OFF,
	49	'glob' => DEFAULT_OFF,
	50	'y2k' => DEFAULT_OFF,
e476b1b5 GS	51	'untie' => DEFAULT_OFF,
	52	'substr' => DEFAULT_OFF,
	53	'taint' => DEFAULT_OFF,
	54	'signal' => DEFAULT_OFF,
	55	'closure' => DEFAULT_OFF,
	56	'overflow' => DEFAULT_OFF,
	57	'portable' => DEFAULT_OFF,
	58	'utf8' => DEFAULT_OFF,
	59	'exiting' => DEFAULT_OFF,
	60	'pack' => DEFAULT_OFF,
	61	'unpack' => DEFAULT_OFF,
0453d815	62	#'default' => DEFAULT_ON,
d3a7d8c7 GS	63	}
d3a7d8c7 GS	64	} ;
599cee73 PM	65
	66
	67	###########################################################################
	68	sub tab {
	69	my($l, $t) = @_;
	70	$t .= "\t" x ($l - (length($t) + 1) / 8);
	71	$t;
	72	}
	73
	74	###########################################################################
	75
	76	my %list ;
	77	my %Value ;
d3a7d8c7	78	my $index ;
599cee73 PM	79
	80	sub walk
	81	{
	82	my $tre = shift ;
	83	my @list = () ;
	84	my ($k, $v) ;
	85
95dfd3ab GS	86	foreach $k (sort keys %$tre) {
95dfd3ab GS	87	$v = $tre->{$k};
599cee73 PM	88	die "duplicate key $k\n" if defined $list{$k} ;
	89	$Value{$index} = uc $k ;
	90	push @{ $list{$k} }, $index ++ ;
	91	if (ref $v)
	92	{ push (@{ $list{$k} }, walk ($v)) }
	93	push @list, @{ $list{$k} } ;
	94	}
	95
	96	return @list ;
599cee73 PM	97	}
	98
	99	###########################################################################
	100
	101	sub mkRange
	102	{
	103	my @a = @_ ;
	104	my @out = @a ;
	105	my $i ;
	106
	107
	108	for ($i = 1 ; $i < @a; ++ $i) {
0ca4541c	109	$out[$i] = ".."
599cee73 PM	110	if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
	111	}
	112
	113	my $out = join(",",@out);
	114
	115	$out =~ s/,(\.\.,)+/../g ;
	116	return $out;
	117	}
	118
	119	###########################################################################
e476b1b5 GS	120	sub printTree
	121	{
	122	my $tre = shift ;
	123	my $prefix = shift ;
	124	my $indent = shift ;
	125	my ($k, $v) ;
	126
	127	my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
	128
	129	$prefix .= " " x $indent ;
	130	foreach $k (sort keys %$tre) {
	131	$v = $tre->{$k};
	132	print $prefix . "\|\n" ;
	133	print $prefix . "+- $k" ;
	134	if (ref $v)
0ca4541c	135	{
e476b1b5	136	print " " . "-" x ($max - length $k ) . "+\n" ;
0ca4541c	137	printTree ($v, $prefix . "\|" , $max + $indent - 1)
e476b1b5 GS	138	}
	139	else
	140	{ print "\n" }
	141	}
	142
	143	}
	144
	145	###########################################################################
599cee73	146
317ea90d	147	sub mkHexOct
599cee73	148	{
317ea90d	149	my ($f, $max, @a) = @_ ;
599cee73 PM	150	my $mask = "\x00" x $max ;
	151	my $string = "" ;
	152
	153	foreach (@a) {
	154	vec($mask, $_, 1) = 1 ;
	155	}
	156
599cee73	157	foreach (unpack("C*", $mask)) {
317ea90d MS	158	if ($f eq 'x') {
	159	$string .= '\x' . sprintf("%2.2x", $_)
	160	}
	161	else {
	162	$string .= '\\' . sprintf("%o", $_)
	163	}
599cee73 PM	164	}
	165	return $string ;
	166	}
	167
317ea90d MS	168	sub mkHex
	169	{
	170	my($max, @a) = @_;
	171	return mkHexOct("x", $max, @a);
	172	}
	173
	174	sub mkOct
	175	{
	176	my($max, @a) = @_;
	177	return mkHexOct("o", $max, @a);
	178	}
	179
599cee73 PM	180	###########################################################################
599cee73 PM	181
e476b1b5 GS	182	if (@ARGV && $ARGV[0] eq "tree")
e476b1b5 GS	183	{
d3a7d8c7	184	#print " all -+\n" ;
e476b1b5 GS	185	printTree($tree, " ", 4) ;
	186	exit ;
	187	}
599cee73	188
918426be NC	189	unlink "warnings.h";
918426be NC	190	unlink "lib/warnings.pm";
4438c4b7 JH	191	open(WARN, ">warnings.h") \|\| die "Can't create warnings.h: $!\n";
4438c4b7 JH	192	open(PM, ">lib/warnings.pm") \|\| die "Can't create lib/warnings.pm: $!\n";
599cee73 PM	193
	194	print WARN <<'EOM' ;
	195	/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7	196	This file is built by warnings.pl
599cee73 PM	197	Any changes made here will be lost!
	198	*/
	199
	200
0453d815 PM	201	#define Off(x) ((x) / 8)
0453d815 PM	202	#define Bit(x) (1 << ((x) % 8))
599cee73 PM	203	#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
599cee73 PM	204
0453d815	205
599cee73	206	#define G_WARN_OFF 0 /* $^W == 0 */
0453d815	207	#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73 PM	208	#define G_WARN_ALL_ON 2 /* -W flag */
599cee73 PM	209	#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815	210	#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73 PM	211	#define G_WARN_ALL_MASK (G_WARN_ALL_ON\|G_WARN_ALL_OFF)
599cee73 PM	212
d3a7d8c7 GS	213	#define pWARN_STD Nullsv
	214	#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
	215	#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
599cee73	216
d3a7d8c7 GS	217	#define specialWARN(x) ((x) == pWARN_STD \|\| (x) == pWARN_ALL \|\| \
d3a7d8c7 GS	218	(x) == pWARN_NONE)
599cee73 PM	219	EOM
599cee73 PM	220
d3a7d8c7 GS	221	my $offset = 0 ;
	222
	223	$index = $offset ;
	224	#@{ $list{"all"} } = walk ($tree) ;
	225	walk ($tree) ;
599cee73	226
12bcd1a6 PM	227	die <<EOM if $index > 255 ;
	228	Too many warnings categories -- max is 255
	229	rewrite packWARN* & unpackWARN* macros
	230	EOM
599cee73 PM	231
	232	$index *= 2 ;
	233	my $warn_size = int($index / 8) + ($index % 8 != 0) ;
	234
	235	my $k ;
	236	foreach $k (sort { $a <=> $b } keys %Value) {
	237	print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
	238	}
	239	print WARN "\n" ;
	240
	241	print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
	242	#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
	243	print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
	244	print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
317ea90d MS	245	my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
	246
	247	print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
599cee73 PM	248
	249	print WARN <<'EOM';
	250
d5a71f30 GS	251	#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
	252	#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
	253	#define isWARN_ONCE (PL_dowarn & (G_WARN_ON\|G_WARN_ONCE))
	254	#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
	255	#define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
	256
d5a71f30 GS	257	#define ckWARN(x) \
	258	( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
	259	(PL_curcop->cop_warnings == pWARN_ALL \|\| \
	260	isWARN_on(PL_curcop->cop_warnings, x) ) ) \
	261	\|\| (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
	262
	263	#define ckWARN2(x,y) \
	264	( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
	265	(PL_curcop->cop_warnings == pWARN_ALL \|\| \
	266	isWARN_on(PL_curcop->cop_warnings, x) \|\| \
	267	isWARN_on(PL_curcop->cop_warnings, y) ) ) \
	268	\|\| (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
	269
12bcd1a6 PM	270	#define ckWARN3(x,y,z) \
	271	( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
	272	(PL_curcop->cop_warnings == pWARN_ALL \|\| \
	273	isWARN_on(PL_curcop->cop_warnings, x) \|\| \
	274	isWARN_on(PL_curcop->cop_warnings, y) \|\| \
	275	isWARN_on(PL_curcop->cop_warnings, z) ) ) \
	276	\|\| (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
	277
	278	#define ckWARN4(x,y,z,t) \
	279	( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \
	280	(PL_curcop->cop_warnings == pWARN_ALL \|\| \
	281	isWARN_on(PL_curcop->cop_warnings, x) \|\| \
	282	isWARN_on(PL_curcop->cop_warnings, y) \|\| \
	283	isWARN_on(PL_curcop->cop_warnings, z) \|\| \
	284	isWARN_on(PL_curcop->cop_warnings, t) ) ) \
	285	\|\| (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
	286
d5a71f30 GS	287	#define ckWARN_d(x) \
	288	(isLEXWARN_off \|\| PL_curcop->cop_warnings == pWARN_ALL \|\| \
	289	(PL_curcop->cop_warnings != pWARN_NONE && \
	290	isWARN_on(PL_curcop->cop_warnings, x) ) )
	291
	292	#define ckWARN2_d(x,y) \
	293	(isLEXWARN_off \|\| PL_curcop->cop_warnings == pWARN_ALL \|\| \
	294	(PL_curcop->cop_warnings != pWARN_NONE && \
	295	(isWARN_on(PL_curcop->cop_warnings, x) \|\| \
	296	isWARN_on(PL_curcop->cop_warnings, y) ) ) )
	297
12bcd1a6 PM	298	#define ckWARN3_d(x,y,z) \
	299	(isLEXWARN_off \|\| PL_curcop->cop_warnings == pWARN_ALL \|\| \
	300	(PL_curcop->cop_warnings != pWARN_NONE && \
	301	(isWARN_on(PL_curcop->cop_warnings, x) \|\| \
	302	isWARN_on(PL_curcop->cop_warnings, y) \|\| \
	303	isWARN_on(PL_curcop->cop_warnings, z) ) ) )
	304
	305	#define ckWARN4_d(x,y,z,t) \
	306	(isLEXWARN_off \|\| PL_curcop->cop_warnings == pWARN_ALL \|\| \
	307	(PL_curcop->cop_warnings != pWARN_NONE && \
	308	(isWARN_on(PL_curcop->cop_warnings, x) \|\| \
	309	isWARN_on(PL_curcop->cop_warnings, y) \|\| \
	310	isWARN_on(PL_curcop->cop_warnings, z) \|\| \
	311	isWARN_on(PL_curcop->cop_warnings, t) ) ) )
	312
	313	#define packWARN(a) (a )
	314	#define packWARN2(a,b) ((a) \| (b)<<8 )
	315	#define packWARN3(a,b,c) ((a) \| (b)<<8 \| (c) <<16 )
	316	#define packWARN4(a,b,c,d) ((a) \| (b)<<8 \| (c) <<16 \| (d) <<24)
	317
	318	#define unpackWARN1(x) ((x) & 0xFF)
	319	#define unpackWARN2(x) (((x) >>8) & 0xFF)
	320	#define unpackWARN3(x) (((x) >>16) & 0xFF)
	321	#define unpackWARN4(x) (((x) >>24) & 0xFF)
	322
	323	#define ckDEAD(x) \
	324	( ! specialWARN(PL_curcop->cop_warnings) && \
	325	( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) \|\| \
	326	isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) \|\| \
	327	isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) \|\| \
	328	isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) \|\| \
	329	isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
	330
4438c4b7	331	/* end of file warnings.h */
599cee73 PM	332
	333	EOM
	334
	335	close WARN ;
	336
	337	while (<DATA>) {
	338	last if /^KEYWORDS$/ ;
	339	print PM $_ ;
	340	}
	341
d3a7d8c7 GS	342	#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
	343
	344	#my %Keys = map {lc $Value{$_}, $_} keys %Value ;
	345
	346	print PM "%Offsets = (\n" ;
	347	foreach my $k (sort { $a <=> $b } keys %Value) {
	348	my $v = lc $Value{$k} ;
	349	$k *= 2 ;
	350	print PM tab(4, " '$v'"), "=> $k,\n" ;
	351	}
	352
	353	print PM " );\n\n" ;
	354
599cee73 PM	355	print PM "%Bits = (\n" ;
	356	foreach $k (sort keys %list) {
	357
	358	my $v = $list{$k} ;
	359	my @list = sort { $a <=> $b } @$v ;
	360
0ca4541c NIS	361	print PM tab(4, " '$k'"), '=> "',
	362	# mkHex($warn_size, @list),
	363	mkHex($warn_size, map $_ * 2 , @list),
599cee73 PM	364	'", # [', mkRange(@list), "]\n" ;
	365	}
	366
	367	print PM " );\n\n" ;
	368
	369	print PM "%DeadBits = (\n" ;
	370	foreach $k (sort keys %list) {
	371
	372	my $v = $list{$k} ;
	373	my @list = sort { $a <=> $b } @$v ;
	374
0ca4541c NIS	375	print PM tab(4, " '$k'"), '=> "',
	376	# mkHex($warn_size, @list),
	377	mkHex($warn_size, map $_ * 2 + 1 , @list),
599cee73 PM	378	'", # [', mkRange(@list), "]\n" ;
	379	}
	380
	381	print PM " );\n\n" ;
d3a7d8c7 GS	382	print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
	383	print PM '$LAST_BIT = ' . "$index ;\n" ;
	384	print PM '$BYTES = ' . "$warn_size ;\n" ;
599cee73 PM	385	while (<DATA>) {
	386	print PM $_ ;
	387	}
	388
	389	close PM ;
	390
	391	__END__
	392
4438c4b7	393	# This file was created by warnings.pl
599cee73 PM	394	# Any changes made here will be lost.
	395	#
	396
4438c4b7	397	package warnings;
599cee73	398
b75c8c73 MS	399	our $VERSION = '1.00';
b75c8c73 MS	400
599cee73 PM	401	=head1 NAME
599cee73 PM	402
4438c4b7	403	warnings - Perl pragma to control optional warnings
599cee73 PM	404
	405	=head1 SYNOPSIS
	406
4438c4b7 JH	407	use warnings;
4438c4b7 JH	408	no warnings;
599cee73	409
4438c4b7 JH	410	use warnings "all";
4438c4b7 JH	411	no warnings "all";
599cee73	412
d3a7d8c7 GS	413	use warnings::register;
	414	if (warnings::enabled()) {
	415	warnings::warn("some warning");
	416	}
	417
	418	if (warnings::enabled("void")) {
e476b1b5 GS	419	warnings::warn("void", "some warning");
	420	}
	421
7e6d00f8 PM	422	if (warnings::enabled($object)) {
	423	warnings::warn($object, "some warning");
	424	}
	425
721f911b PM	426	warnings::warnif("some warning");
	427	warnings::warnif("void", "some warning");
	428	warnings::warnif($object, "some warning");
7e6d00f8	429
599cee73 PM	430	=head1 DESCRIPTION
599cee73 PM	431
0453d815 PM	432	If no import list is supplied, all possible warnings are either enabled
0453d815 PM	433	or disabled.
599cee73	434
0ca4541c	435	A number of functions are provided to assist module authors.
e476b1b5 GS	436
	437	=over 4
	438
d3a7d8c7 GS	439	=item use warnings::register
d3a7d8c7 GS	440
7e6d00f8 PM	441	Creates a new warnings category with the same name as the package where
	442	the call to the pragma is used.
	443
	444	=item warnings::enabled()
	445
	446	Use the warnings category with the same name as the current package.
	447
	448	Return TRUE if that warnings category is enabled in the calling module.
	449	Otherwise returns FALSE.
	450
	451	=item warnings::enabled($category)
	452
	453	Return TRUE if the warnings category, C<$category>, is enabled in the
	454	calling module.
	455	Otherwise returns FALSE.
	456
	457	=item warnings::enabled($object)
	458
	459	Use the name of the class for the object reference, C<$object>, as the
	460	warnings category.
	461
	462	Return TRUE if that warnings category is enabled in the first scope
	463	where the object is used.
	464	Otherwise returns FALSE.
	465
	466	=item warnings::warn($message)
	467
	468	Print C<$message> to STDERR.
	469
	470	Use the warnings category with the same name as the current package.
	471
	472	If that warnings category has been set to "FATAL" in the calling module
	473	then die. Otherwise return.
	474
	475	=item warnings::warn($category, $message)
	476
	477	Print C<$message> to STDERR.
	478
	479	If the warnings category, C<$category>, has been set to "FATAL" in the
	480	calling module then die. Otherwise return.
d3a7d8c7	481
7e6d00f8	482	=item warnings::warn($object, $message)
e476b1b5	483
7e6d00f8	484	Print C<$message> to STDERR.
e476b1b5	485
7e6d00f8 PM	486	Use the name of the class for the object reference, C<$object>, as the
7e6d00f8 PM	487	warnings category.
e476b1b5	488
7e6d00f8 PM	489	If that warnings category has been set to "FATAL" in the scope where C<$object>
7e6d00f8 PM	490	is first used then die. Otherwise return.
599cee73	491
e476b1b5	492
7e6d00f8 PM	493	=item warnings::warnif($message)
	494
	495	Equivalent to:
	496
	497	if (warnings::enabled())
	498	{ warnings::warn($message) }
	499
	500	=item warnings::warnif($category, $message)
	501
	502	Equivalent to:
	503
	504	if (warnings::enabled($category))
	505	{ warnings::warn($category, $message) }
	506
	507	=item warnings::warnif($object, $message)
	508
	509	Equivalent to:
	510
	511	if (warnings::enabled($object))
	512	{ warnings::warn($object, $message) }
d3a7d8c7	513
e476b1b5 GS	514	=back
e476b1b5 GS	515
749f83fa	516	See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73 PM	517
	518	=cut
	519
	520	use Carp ;
	521
	522	KEYWORDS
	523
d3a7d8c7 GS	524	$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
d3a7d8c7 GS	525
c3186b65 PM	526	sub Croaker
	527	{
	528	delete $Carp::CarpInternal{'warnings'};
	529	croak @_ ;
	530	}
	531
599cee73 PM	532	sub bits {
	533	my $mask ;
	534	my $catmask ;
	535	my $fatal = 0 ;
	536	foreach my $word (@_) {
327afb7f GS	537	if ($word eq 'FATAL') {
	538	$fatal = 1;
	539	}
d3a7d8c7 GS	540	elsif ($catmask = $Bits{$word}) {
	541	$mask \|= $catmask ;
	542	$mask \|= $DeadBits{$word} if $fatal ;
599cee73	543	}
d3a7d8c7	544	else
c3186b65	545	{ Croaker("Unknown warnings category '$word'")}
599cee73 PM	546	}
	547
	548	return $mask ;
	549	}
	550
	551	sub import {
	552	shift;
f1f33818 PM	553	my $mask = ${^WARNING_BITS} ;
	554	if (vec($mask, $Offsets{'all'}, 1)) {
	555	$mask \|= $Bits{'all'} ;
	556	$mask \|= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
	557	}
	558	${^WARNING_BITS} = $mask \| bits(@_ ? @_ : 'all') ;
599cee73 PM	559	}
	560
	561	sub unimport {
	562	shift;
d3a7d8c7 GS	563	my $mask = ${^WARNING_BITS} ;
d3a7d8c7 GS	564	if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818	565	$mask \|= $Bits{'all'} ;
d3a7d8c7 GS	566	$mask \|= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
d3a7d8c7 GS	567	}
08540116	568	${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) \| $All) ;
599cee73 PM	569	}
599cee73 PM	570
7e6d00f8	571	sub __chk
599cee73	572	{
d3a7d8c7 GS	573	my $category ;
d3a7d8c7 GS	574	my $offset ;
7e6d00f8	575	my $isobj = 0 ;
d3a7d8c7 GS	576
	577	if (@_) {
	578	# check the category supplied.
	579	$category = shift ;
7e6d00f8	580	if (ref $category) {
c3186b65	581	Croaker ("not an object")
3d1a39c8	582	if $category !~ /^([^=]+)=/ ;
7e6d00f8 PM	583	$category = $1 ;
	584	$isobj = 1 ;
	585	}
d3a7d8c7	586	$offset = $Offsets{$category};
c3186b65	587	Croaker("Unknown warnings category '$category'")
d3a7d8c7 GS	588	unless defined $offset;
	589	}
	590	else {
0ca4541c	591	$category = (caller(1))[0] ;
d3a7d8c7	592	$offset = $Offsets{$category};
c3186b65	593	Croaker("package '$category' not registered for warnings")
d3a7d8c7 GS	594	unless defined $offset ;
	595	}
	596
0ca4541c	597	my $this_pkg = (caller(1))[0] ;
7e6d00f8 PM	598	my $i = 2 ;
	599	my $pkg ;
	600
	601	if ($isobj) {
	602	while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
	603	last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
	604	}
	605	$i -= 2 ;
	606	}
	607	else {
	608	for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
	609	last if $pkg ne $this_pkg ;
	610	}
0ca4541c	611	$i = 2
7e6d00f8 PM	612	if !$pkg \|\| $pkg eq $this_pkg ;
	613	}
	614
0ca4541c	615	my $callers_bitmask = (caller($i))[9] ;
7e6d00f8 PM	616	return ($callers_bitmask, $offset, $i) ;
	617	}
	618
	619	sub enabled
	620	{
c3186b65	621	Croaker("Usage: warnings::enabled([category])")
7e6d00f8 PM	622	unless @_ == 1 \|\| @_ == 0 ;
	623
	624	my ($callers_bitmask, $offset, $i) = __chk(@_) ;
	625
	626	return 0 unless defined $callers_bitmask ;
d3a7d8c7 GS	627	return vec($callers_bitmask, $offset, 1) \|\|
d3a7d8c7 GS	628	vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73 PM	629	}
599cee73 PM	630
d3a7d8c7	631
e476b1b5 GS	632	sub warn
e476b1b5 GS	633	{
c3186b65	634	Croaker("Usage: warnings::warn([category,] 'message')")
d3a7d8c7	635	unless @_ == 2 \|\| @_ == 1 ;
d3a7d8c7	636
7e6d00f8 PM	637	my $message = pop ;
7e6d00f8 PM	638	my ($callers_bitmask, $offset, $i) = __chk(@_) ;
0ca4541c	639	croak($message)
d3a7d8c7 GS	640	if vec($callers_bitmask, $offset+1, 1) \|\|
d3a7d8c7 GS	641	vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5 GS	642	carp($message) ;
	643	}
	644
7e6d00f8 PM	645	sub warnif
7e6d00f8 PM	646	{
c3186b65	647	Croaker("Usage: warnings::warnif([category,] 'message')")
7e6d00f8 PM	648	unless @_ == 2 \|\| @_ == 1 ;
	649
	650	my $message = pop ;
	651	my ($callers_bitmask, $offset, $i) = __chk(@_) ;
7e6d00f8	652
0ca4541c	653	return
7e6d00f8 PM	654	unless defined $callers_bitmask &&
	655	(vec($callers_bitmask, $offset, 1) \|\|
	656	vec($callers_bitmask, $Offsets{'all'}, 1)) ;
	657
0ca4541c	658	croak($message)
7e6d00f8 PM	659	if vec($callers_bitmask, $offset+1, 1) \|\|
	660	vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
	661
	662	carp($message) ;
	663	}
599cee73	664	1;