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