[p5sagit/p5-mst-13.2.git] / warnings.pl

#!/usr/bin/perl

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

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

my $tree = {
       	'io'  		=> { 	'pipe' 		=> DEFAULT_OFF,
       				'unopened'	=> DEFAULT_OFF,
       				'closed'	=> DEFAULT_OFF,
       				'newline'	=> DEFAULT_OFF,
       				'exec'		=> DEFAULT_OFF,
			   },
       	'syntax'	=> { 	'ambiguous'	=> DEFAULT_OFF,
			     	'semicolon'	=> DEFAULT_OFF,
			     	'precedence'	=> DEFAULT_OFF,
			     	'bareword'	=> DEFAULT_OFF,
			     	'reserved'	=> DEFAULT_OFF,
				'digit'		=> DEFAULT_OFF,
			     	'parenthesis'	=> DEFAULT_OFF,
       	 			'deprecated'	=> DEFAULT_OFF,
       	 			'printf'	=> DEFAULT_OFF,
       	 			'prototype'	=> DEFAULT_OFF,
       	 			'qw'		=> DEFAULT_OFF,
			   },
       	'severe'	=> { 	'inplace'	=> DEFAULT_ON,
	 			'internal'	=> DEFAULT_ON,
         			'debugging'	=> DEFAULT_ON,
         			'malloc'	=> DEFAULT_ON,
	 		   },
       	'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,
       	'chmod'		=> DEFAULT_OFF,
       	'umask'		=> 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 = 0 ;

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 mkHex
{
    my ($max, @a) = @_ ;
    my $mask = "\x00" x $max ;
    my $string = "" ;

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

    #$string = unpack("H$max", $mask) ;
    #$string =~ s/(..)/\x$1/g;
    foreach (unpack("C*", $mask)) {
	$string .= '\x' . sprintf("%2.2x", $_) ;
    }
    return $string ;
}

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

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 WARN_STD		Nullsv
#define WARN_ALL		(Nullsv+1)	/* use warnings 'all' */
#define WARN_NONE		(Nullsv+2)	/* no  warnings 'all' */

#define specialWARN(x)		((x) == WARN_STD || (x) == WARN_ALL ||	\
				 (x) == WARN_NONE)

#define ckDEAD(x)							\
	   ( ! specialWARN(PL_curcop->cop_warnings) &&			\
	    IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))

#define ckWARN(x)							\
	( (PL_curcop->cop_warnings != WARN_STD &&			\
	   PL_curcop->cop_warnings != WARN_NONE &&			\
	      (PL_curcop->cop_warnings == WARN_ALL ||			\
	       IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )		\
	  || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )

#define ckWARN2(x,y)							\
	  ( (PL_curcop->cop_warnings != WARN_STD  &&			\
	     PL_curcop->cop_warnings != WARN_NONE &&			\
	      (PL_curcop->cop_warnings == WARN_ALL ||			\
	        IsSet(SvPVX(PL_curcop->cop_warnings), 2*x)  ||		\
	        IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) 		\
	    ||	(PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )

#define ckWARN_d(x)							\
	  (PL_curcop->cop_warnings == WARN_STD ||			\
	   PL_curcop->cop_warnings == WARN_ALL ||			\
	     (PL_curcop->cop_warnings != WARN_NONE &&			\
	      IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )

#define ckWARN2_d(x,y)							\
	  (PL_curcop->cop_warnings == WARN_STD ||			\
	   PL_curcop->cop_warnings == WARN_ALL ||			\
	     (PL_curcop->cop_warnings != WARN_NONE &&			\
	        (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x)  ||		\
	         IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) )


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

EOM


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

$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" ;

print WARN <<'EOM';

/* end of file warnings.h */

EOM

close WARN ;

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

$list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
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" ;
while (<DATA>) {
    print PM $_ ;
}

close PM ;

__END__

# This file was created by warnings.pl
# Any changes made here will be lost.
#

package warnings;

=head1 NAME

warnings - Perl pragma to control optional warnings

=head1 SYNOPSIS

    use warnings;
    no warnings;

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

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

=head1 DESCRIPTION

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

Two functions are provided to assist module authors.

=over 4

=item warnings::enabled($category)

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


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

If the calling module has I<not> set C<$category> to "FATAL", print
C<$message> to STDERR.
If the calling module has set C<$category> to "FATAL", print C<$message>
STDERR then die.

=back

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

=cut

use Carp ;

KEYWORDS

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

    return $mask ;
}

sub import {
    shift;
    ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
}

sub unimport {
    shift;
    ${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ;
}

sub enabled
{
    # If no parameters, check for any lexical warnings enabled
    # in the users scope.
    my $callers_bitmask = (caller(1))[9] ; 
    return ($callers_bitmask ne $NONE) if @_ == 0 ;

    # otherwise check for the category supplied.
    my $category = shift ;
    return 0
	unless $Bits{$category} ;
    return 0 unless defined $callers_bitmask ;
    return 1
	if ($callers_bitmask & $Bits{$category}) ne $NONE ;
   
    return 0 ; 
}

sub warn
{
    croak "Usage: warnings::warn('category', 'message')"
	unless @_ == 2 ;
    my $category = shift ;
    my $message = shift ;
    local $Carp::CarpLevel = 1 ;
    my $callers_bitmask = (caller(1))[9] ; 
    croak($message) 
	if defined $callers_bitmask &&
           ($callers_bitmask & $DeadBits{$category}) ne $NONE ;
    carp($message) ;
}

1;
Commit	Line	Data
599cee73	1	#!/usr/bin/perl
599cee73	2
73f0cc2d	3	BEGIN {
	4	push @INC, './lib';
	5	}
599cee73	6	use strict ;
	7
	8	sub DEFAULT_ON () { 1 }
	9	sub DEFAULT_OFF () { 2 }
	10
	11	my $tree = {
e476b1b5	12	'io' => { 'pipe' => DEFAULT_OFF,
599cee73	13	'unopened' => DEFAULT_OFF,
	14	'closed' => DEFAULT_OFF,
	15	'newline' => DEFAULT_OFF,
	16	'exec' => DEFAULT_OFF,
599cee73	17	},
e476b1b5	18	'syntax' => { 'ambiguous' => DEFAULT_OFF,
599cee73	19	'semicolon' => DEFAULT_OFF,
e476b1b5	20	'precedence' => DEFAULT_OFF,
4673fc70	21	'bareword' => DEFAULT_OFF,
599cee73	22	'reserved' => DEFAULT_OFF,
627300f0	23	'digit' => DEFAULT_OFF,
599cee73	24	'parenthesis' => DEFAULT_OFF,
	25	'deprecated' => DEFAULT_OFF,
	26	'printf' => DEFAULT_OFF,
e476b1b5	27	'prototype' => DEFAULT_OFF,
e476b1b5	28	'qw' => DEFAULT_OFF,
599cee73	29	},
e476b1b5	30	'severe' => { 'inplace' => DEFAULT_ON,
0453d815	31	'internal' => DEFAULT_ON,
0453d815	32	'debugging' => DEFAULT_ON,
e476b1b5	33	'malloc' => DEFAULT_ON,
0453d815	34	},
e476b1b5	35	'void' => DEFAULT_OFF,
	36	'recursion' => DEFAULT_OFF,
	37	'redefine' => DEFAULT_OFF,
	38	'numeric' => DEFAULT_OFF,
	39	'uninitialized' => DEFAULT_OFF,
	40	'once' => DEFAULT_OFF,
	41	'misc' => DEFAULT_OFF,
	42	'regexp' => DEFAULT_OFF,
	43	'glob' => DEFAULT_OFF,
	44	'y2k' => DEFAULT_OFF,
	45	'chmod' => DEFAULT_OFF,
	46	'umask' => DEFAULT_OFF,
	47	'untie' => DEFAULT_OFF,
	48	'substr' => DEFAULT_OFF,
	49	'taint' => DEFAULT_OFF,
	50	'signal' => DEFAULT_OFF,
	51	'closure' => DEFAULT_OFF,
	52	'overflow' => DEFAULT_OFF,
	53	'portable' => DEFAULT_OFF,
	54	'utf8' => DEFAULT_OFF,
	55	'exiting' => DEFAULT_OFF,
	56	'pack' => DEFAULT_OFF,
	57	'unpack' => DEFAULT_OFF,
0453d815	58	#'default' => DEFAULT_ON,
599cee73	59	} ;
	60
	61
	62	###########################################################################
	63	sub tab {
	64	my($l, $t) = @_;
	65	$t .= "\t" x ($l - (length($t) + 1) / 8);
	66	$t;
	67	}
	68
	69	###########################################################################
	70
	71	my %list ;
	72	my %Value ;
	73	my $index = 0 ;
	74
	75	sub walk
	76	{
	77	my $tre = shift ;
	78	my @list = () ;
	79	my ($k, $v) ;
	80
95dfd3ab	81	foreach $k (sort keys %$tre) {
95dfd3ab	82	$v = $tre->{$k};
599cee73	83	die "duplicate key $k\n" if defined $list{$k} ;
	84	$Value{$index} = uc $k ;
	85	push @{ $list{$k} }, $index ++ ;
	86	if (ref $v)
	87	{ push (@{ $list{$k} }, walk ($v)) }
	88	push @list, @{ $list{$k} } ;
	89	}
	90
	91	return @list ;
599cee73	92	}
	93
	94	###########################################################################
	95
	96	sub mkRange
	97	{
	98	my @a = @_ ;
	99	my @out = @a ;
	100	my $i ;
	101
	102
	103	for ($i = 1 ; $i < @a; ++ $i) {
	104	$out[$i] = ".."
	105	if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
	106	}
	107
	108	my $out = join(",",@out);
	109
	110	$out =~ s/,(\.\.,)+/../g ;
	111	return $out;
	112	}
	113
	114	###########################################################################
e476b1b5	115	sub printTree
	116	{
	117	my $tre = shift ;
	118	my $prefix = shift ;
	119	my $indent = shift ;
	120	my ($k, $v) ;
	121
	122	my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
	123
	124	$prefix .= " " x $indent ;
	125	foreach $k (sort keys %$tre) {
	126	$v = $tre->{$k};
	127	print $prefix . "\|\n" ;
	128	print $prefix . "+- $k" ;
	129	if (ref $v)
	130	{
	131	print " " . "-" x ($max - length $k ) . "+\n" ;
	132	printTree ($v, $prefix . "\|" , $max + $indent - 1)
	133	}
	134	else
	135	{ print "\n" }
	136	}
	137
	138	}
	139
	140	###########################################################################
599cee73	141
	142	sub mkHex
	143	{
	144	my ($max, @a) = @_ ;
	145	my $mask = "\x00" x $max ;
	146	my $string = "" ;
	147
	148	foreach (@a) {
	149	vec($mask, $_, 1) = 1 ;
	150	}
	151
	152	#$string = unpack("H$max", $mask) ;
	153	#$string =~ s/(..)/\x$1/g;
	154	foreach (unpack("C*", $mask)) {
	155	$string .= '\x' . sprintf("%2.2x", $_) ;
	156	}
	157	return $string ;
	158	}
	159
	160	###########################################################################
	161
e476b1b5	162	if (@ARGV && $ARGV[0] eq "tree")
	163	{
	164	print " all -+\n" ;
	165	printTree($tree, " ", 4) ;
	166	exit ;
	167	}
599cee73	168
4438c4b7	169	#unlink "warnings.h";
	170	#unlink "lib/warnings.pm";
	171	open(WARN, ">warnings.h") \|\| die "Can't create warnings.h: $!\n";
	172	open(PM, ">lib/warnings.pm") \|\| die "Can't create lib/warnings.pm: $!\n";
599cee73	173
	174	print WARN <<'EOM' ;
	175	/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7	176	This file is built by warnings.pl
599cee73	177	Any changes made here will be lost!
	178	*/
	179
	180
0453d815	181	#define Off(x) ((x) / 8)
0453d815	182	#define Bit(x) (1 << ((x) % 8))
599cee73	183	#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
599cee73	184
0453d815	185
599cee73	186	#define G_WARN_OFF 0 /* $^W == 0 */
0453d815	187	#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73	188	#define G_WARN_ALL_ON 2 /* -W flag */
599cee73	189	#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815	190	#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73	191	#define G_WARN_ALL_MASK (G_WARN_ALL_ON\|G_WARN_ALL_OFF)
599cee73	192
0453d815	193	#define WARN_STD Nullsv
971a9dd3	194	#define WARN_ALL (Nullsv+1) /* use warnings 'all' */
971a9dd3	195	#define WARN_NONE (Nullsv+2) /* no warnings 'all' */
599cee73	196
0453d815	197	#define specialWARN(x) ((x) == WARN_STD \|\| (x) == WARN_ALL \|\| \
0453d815	198	(x) == WARN_NONE)
599cee73	199
599cee73	200	#define ckDEAD(x) \
0453d815	201	( ! specialWARN(PL_curcop->cop_warnings) && \
e24b16f9	202	IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
599cee73	203
599cee73	204	#define ckWARN(x) \
0453d815	205	( (PL_curcop->cop_warnings != WARN_STD && \
0453d815	206	PL_curcop->cop_warnings != WARN_NONE && \
e24b16f9	207	(PL_curcop->cop_warnings == WARN_ALL \|\| \
e24b16f9	208	IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \
0453d815	209	\|\| (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
599cee73	210
599cee73	211	#define ckWARN2(x,y) \
0453d815	212	( (PL_curcop->cop_warnings != WARN_STD && \
0453d815	213	PL_curcop->cop_warnings != WARN_NONE && \
e24b16f9	214	(PL_curcop->cop_warnings == WARN_ALL \|\| \
	215	IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) \|\| \
	216	IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \
0453d815	217	\|\| (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
599cee73	218
0453d815	219	#define ckWARN_d(x) \
	220	(PL_curcop->cop_warnings == WARN_STD \|\| \
	221	PL_curcop->cop_warnings == WARN_ALL \|\| \
	222	(PL_curcop->cop_warnings != WARN_NONE && \
	223	IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )
599cee73	224
0453d815	225	#define ckWARN2_d(x,y) \
	226	(PL_curcop->cop_warnings == WARN_STD \|\| \
	227	PL_curcop->cop_warnings == WARN_ALL \|\| \
	228	(PL_curcop->cop_warnings != WARN_NONE && \
	229	(IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) \|\| \
	230	IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) )
599cee73	231
599cee73	232
0453d815	233	#define isLEXWARN_on (PL_curcop->cop_warnings != WARN_STD)
	234	#define isLEXWARN_off (PL_curcop->cop_warnings == WARN_STD)
	235	#define isWARN_ONCE (PL_dowarn & (G_WARN_ON\|G_WARN_ONCE))
	236	#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
599cee73	237
	238	EOM
	239
	240
	241	$index = 0 ;
	242	@{ $list{"all"} } = walk ($tree) ;
	243
	244	$index *= 2 ;
	245	my $warn_size = int($index / 8) + ($index % 8 != 0) ;
	246
	247	my $k ;
	248	foreach $k (sort { $a <=> $b } keys %Value) {
	249	print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
	250	}
	251	print WARN "\n" ;
	252
	253	print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
	254	#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
	255	print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
	256	print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
	257
	258	print WARN <<'EOM';
	259
4438c4b7	260	/* end of file warnings.h */
599cee73	261
	262	EOM
	263
	264	close WARN ;
	265
	266	while (<DATA>) {
	267	last if /^KEYWORDS$/ ;
	268	print PM $_ ;
	269	}
	270
	271	$list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
	272	print PM "%Bits = (\n" ;
	273	foreach $k (sort keys %list) {
	274
	275	my $v = $list{$k} ;
	276	my @list = sort { $a <=> $b } @$v ;
	277
	278	print PM tab(4, " '$k'"), '=> "',
	279	# mkHex($warn_size, @list),
	280	mkHex($warn_size, map $_ * 2 , @list),
	281	'", # [', mkRange(@list), "]\n" ;
	282	}
	283
	284	print PM " );\n\n" ;
	285
	286	print PM "%DeadBits = (\n" ;
	287	foreach $k (sort keys %list) {
	288
	289	my $v = $list{$k} ;
	290	my @list = sort { $a <=> $b } @$v ;
	291
	292	print PM tab(4, " '$k'"), '=> "',
	293	# mkHex($warn_size, @list),
	294	mkHex($warn_size, map $_ * 2 + 1 , @list),
	295	'", # [', mkRange(@list), "]\n" ;
	296	}
	297
	298	print PM " );\n\n" ;
e476b1b5	299	print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
599cee73	300	while (<DATA>) {
	301	print PM $_ ;
	302	}
	303
	304	close PM ;
	305
	306	__END__
	307
4438c4b7	308	# This file was created by warnings.pl
599cee73	309	# Any changes made here will be lost.
	310	#
	311
4438c4b7	312	package warnings;
599cee73	313
	314	=head1 NAME
	315
4438c4b7	316	warnings - Perl pragma to control optional warnings
599cee73	317
	318	=head1 SYNOPSIS
	319
4438c4b7	320	use warnings;
4438c4b7	321	no warnings;
599cee73	322
4438c4b7	323	use warnings "all";
4438c4b7	324	no warnings "all";
599cee73	325
e476b1b5	326	if (warnings::enabled("void") {
	327	warnings::warn("void", "some warning");
	328	}
	329
599cee73	330	=head1 DESCRIPTION
599cee73	331
0453d815	332	If no import list is supplied, all possible warnings are either enabled
0453d815	333	or disabled.
599cee73	334
e476b1b5	335	Two functions are provided to assist module authors.
	336
	337	=over 4
	338
	339	=item warnings::enabled($category)
	340
	341	Returns TRUE if the warnings category in C<$category> is enabled in the
	342	calling module. Otherwise returns FALSE.
	343
	344
	345	=item warnings::warn($category, $message)
599cee73	346
e476b1b5	347	If the calling module has I<not> set C<$category> to "FATAL", print
	348	C<$message> to STDERR.
	349	If the calling module has set C<$category> to "FATAL", print C<$message>
	350	STDERR then die.
	351
	352	=back
	353
	354	See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
599cee73	355
	356	=cut
	357
	358	use Carp ;
	359
	360	KEYWORDS
	361
	362	sub bits {
	363	my $mask ;
	364	my $catmask ;
	365	my $fatal = 0 ;
	366	foreach my $word (@_) {
327afb7f	367	if ($word eq 'FATAL') {
	368	$fatal = 1;
	369	}
	370	else {
	371	if ($catmask = $Bits{$word}) {
	372	$mask \|= $catmask ;
	373	$mask \|= $DeadBits{$word} if $fatal ;
	374	}
599cee73	375	}
599cee73	376	}
	377
	378	return $mask ;
	379	}
	380
	381	sub import {
	382	shift;
6a818117	383	${^WARNING_BITS} \|= bits(@_ ? @_ : 'all') ;
599cee73	384	}
	385
	386	sub unimport {
	387	shift;
6a818117	388	${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ;
599cee73	389	}
	390
	391	sub enabled
	392	{
e476b1b5	393	# If no parameters, check for any lexical warnings enabled
	394	# in the users scope.
	395	my $callers_bitmask = (caller(1))[9] ;
	396	return ($callers_bitmask ne $NONE) if @_ == 0 ;
	397
	398	# otherwise check for the category supplied.
	399	my $category = shift ;
	400	return 0
	401	unless $Bits{$category} ;
	402	return 0 unless defined $callers_bitmask ;
599cee73	403	return 1
e476b1b5	404	if ($callers_bitmask & $Bits{$category}) ne $NONE ;
599cee73	405
	406	return 0 ;
	407	}
	408
e476b1b5	409	sub warn
	410	{
	411	croak "Usage: warnings::warn('category', 'message')"
	412	unless @_ == 2 ;
	413	my $category = shift ;
	414	my $message = shift ;
	415	local $Carp::CarpLevel = 1 ;
	416	my $callers_bitmask = (caller(1))[9] ;
	417	croak($message)
	418	if defined $callers_bitmask &&
	419	($callers_bitmask & $DeadBits{$category}) ne $NONE ;
	420	carp($message) ;
	421	}
	422
599cee73	423	1;