[p5sagit/p5-mst-13.2.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,
			   },
       	'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 ;

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


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

#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 ckDEAD(x)							\
	   ( ! specialWARN(PL_curcop->cop_warnings) &&			\
	    ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || 		\
	      isWARNf_on(PL_curcop->cop_warnings, x)))

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

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

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

=head1 DESCRIPTION

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

A number of functions are provided to assist module authors.

=over 4

=item use warnings::register

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

=item warnings::enabled()

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

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

=item warnings::enabled($category)

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

=item warnings::enabled($object)

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

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

=item warnings::warn($message)

Print C<$message> to STDERR.

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

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

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

Print C<$message> to STDERR.

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

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

Print C<$message> to STDERR.

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

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


=item warnings::warnif($message)

Equivalent to:

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

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

Equivalent to:

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

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

Equivalent to:

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

=back

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

=cut

use Carp ;

KEYWORDS

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

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

    return $mask ;
}

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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