[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,
			   },
       	'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,
       	'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) ;


$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 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('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 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,
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 PM	29	'parenthesis' => DEFAULT_OFF,
	30	'deprecated' => DEFAULT_OFF,
	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	},
e476b1b5 GS	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 GS	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 GS	62	}
d3a7d8c7 GS	63	} ;
599cee73 PM	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 PM	78
	79	sub walk
	80	{
	81	my $tre = shift ;
	82	my @list = () ;
	83	my ($k, $v) ;
	84
95dfd3ab GS	85	foreach $k (sort keys %$tre) {
95dfd3ab GS	86	$v = $tre->{$k};
599cee73 PM	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 PM	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 PM	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 GS	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 GS	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 PM	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 MS	157	if ($f eq 'x') {
	158	$string .= '\x' . sprintf("%2.2x", $_)
	159	}
	160	else {
	161	$string .= '\\' . sprintf("%o", $_)
	162	}
599cee73 PM	163	}
	164	return $string ;
	165	}
	166
317ea90d MS	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 PM	179	###########################################################################
599cee73 PM	180
e476b1b5 GS	181	if (@ARGV && $ARGV[0] eq "tree")
e476b1b5 GS	182	{
d3a7d8c7	183	#print " all -+\n" ;
e476b1b5 GS	184	printTree($tree, " ", 4) ;
	185	exit ;
	186	}
599cee73	187
918426be NC	188	unlink "warnings.h";
918426be NC	189	unlink "lib/warnings.pm";
4438c4b7 JH	190	open(WARN, ">warnings.h") \|\| die "Can't create warnings.h: $!\n";
4438c4b7 JH	191	open(PM, ">lib/warnings.pm") \|\| die "Can't create lib/warnings.pm: $!\n";
599cee73 PM	192
	193	print WARN <<'EOM' ;
	194	/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7	195	This file is built by warnings.pl
599cee73 PM	196	Any changes made here will be lost!
	197	*/
	198
	199
0453d815 PM	200	#define Off(x) ((x) / 8)
0453d815 PM	201	#define Bit(x) (1 << ((x) % 8))
599cee73 PM	202	#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
599cee73 PM	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 PM	207	#define G_WARN_ALL_ON 2 /* -W flag */
599cee73 PM	208	#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815	209	#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73 PM	210	#define G_WARN_ALL_MASK (G_WARN_ALL_ON\|G_WARN_ALL_OFF)
599cee73 PM	211
d3a7d8c7 GS	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 GS	216	#define specialWARN(x) ((x) == pWARN_STD \|\| (x) == pWARN_ALL \|\| \
d3a7d8c7 GS	217	(x) == pWARN_NONE)
599cee73 PM	218	EOM
599cee73 PM	219
d3a7d8c7 GS	220	my $offset = 0 ;
	221
	222	$index = $offset ;
	223	#@{ $list{"all"} } = walk ($tree) ;
	224	walk ($tree) ;
599cee73	225
599cee73 PM	226
	227	$index *= 2 ;
	228	my $warn_size = int($index / 8) + ($index % 8 != 0) ;
	229
	230	my $k ;
	231	foreach $k (sort { $a <=> $b } keys %Value) {
	232	print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
	233	}
	234	print WARN "\n" ;
	235
	236	print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
	237	#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
	238	print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
	239	print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
317ea90d MS	240	my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
	241
	242	print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
599cee73 PM	243
	244	print WARN <<'EOM';
	245
d5a71f30 GS	246	#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
	247	#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
	248	#define isWARN_ONCE (PL_dowarn & (G_WARN_ON\|G_WARN_ONCE))
	249	#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x)))
	250	#define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
	251
	252	#define ckDEAD(x) \
	253	( ! specialWARN(PL_curcop->cop_warnings) && \
	254	( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) \|\| \
	255	isWARNf_on(PL_curcop->cop_warnings, x)))
	256
	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
	270	#define ckWARN_d(x) \
	271	(isLEXWARN_off \|\| PL_curcop->cop_warnings == pWARN_ALL \|\| \
	272	(PL_curcop->cop_warnings != pWARN_NONE && \
	273	isWARN_on(PL_curcop->cop_warnings, x) ) )
	274
	275	#define ckWARN2_d(x,y) \
	276	(isLEXWARN_off \|\| PL_curcop->cop_warnings == pWARN_ALL \|\| \
	277	(PL_curcop->cop_warnings != pWARN_NONE && \
	278	(isWARN_on(PL_curcop->cop_warnings, x) \|\| \
	279	isWARN_on(PL_curcop->cop_warnings, y) ) ) )
	280
4438c4b7	281	/* end of file warnings.h */
599cee73 PM	282
	283	EOM
	284
	285	close WARN ;
	286
	287	while (<DATA>) {
	288	last if /^KEYWORDS$/ ;
	289	print PM $_ ;
	290	}
	291
d3a7d8c7 GS	292	#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
	293
	294	#my %Keys = map {lc $Value{$_}, $_} keys %Value ;
	295
	296	print PM "%Offsets = (\n" ;
	297	foreach my $k (sort { $a <=> $b } keys %Value) {
	298	my $v = lc $Value{$k} ;
	299	$k *= 2 ;
	300	print PM tab(4, " '$v'"), "=> $k,\n" ;
	301	}
	302
	303	print PM " );\n\n" ;
	304
599cee73 PM	305	print PM "%Bits = (\n" ;
	306	foreach $k (sort keys %list) {
	307
	308	my $v = $list{$k} ;
	309	my @list = sort { $a <=> $b } @$v ;
	310
0ca4541c NIS	311	print PM tab(4, " '$k'"), '=> "',
	312	# mkHex($warn_size, @list),
	313	mkHex($warn_size, map $_ * 2 , @list),
599cee73 PM	314	'", # [', mkRange(@list), "]\n" ;
	315	}
	316
	317	print PM " );\n\n" ;
	318
	319	print PM "%DeadBits = (\n" ;
	320	foreach $k (sort keys %list) {
	321
	322	my $v = $list{$k} ;
	323	my @list = sort { $a <=> $b } @$v ;
	324
0ca4541c NIS	325	print PM tab(4, " '$k'"), '=> "',
	326	# mkHex($warn_size, @list),
	327	mkHex($warn_size, map $_ * 2 + 1 , @list),
599cee73 PM	328	'", # [', mkRange(@list), "]\n" ;
	329	}
	330
	331	print PM " );\n\n" ;
d3a7d8c7 GS	332	print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
	333	print PM '$LAST_BIT = ' . "$index ;\n" ;
	334	print PM '$BYTES = ' . "$warn_size ;\n" ;
599cee73 PM	335	while (<DATA>) {
	336	print PM $_ ;
	337	}
	338
	339	close PM ;
	340
	341	__END__
	342
4438c4b7	343	# This file was created by warnings.pl
599cee73 PM	344	# Any changes made here will be lost.
	345	#
	346
4438c4b7	347	package warnings;
599cee73	348
b75c8c73 MS	349	our $VERSION = '1.00';
b75c8c73 MS	350
599cee73 PM	351	=head1 NAME
599cee73 PM	352
4438c4b7	353	warnings - Perl pragma to control optional warnings
599cee73 PM	354
	355	=head1 SYNOPSIS
	356
4438c4b7 JH	357	use warnings;
4438c4b7 JH	358	no warnings;
599cee73	359
4438c4b7 JH	360	use warnings "all";
4438c4b7 JH	361	no warnings "all";
599cee73	362
d3a7d8c7 GS	363	use warnings::register;
	364	if (warnings::enabled()) {
	365	warnings::warn("some warning");
	366	}
	367
	368	if (warnings::enabled("void")) {
e476b1b5 GS	369	warnings::warn("void", "some warning");
	370	}
	371
7e6d00f8 PM	372	if (warnings::enabled($object)) {
	373	warnings::warn($object, "some warning");
	374	}
	375
	376	warnif("some warning");
	377	warnif("void", "some warning");
	378	warnif($object, "some warning");
	379
599cee73 PM	380	=head1 DESCRIPTION
599cee73 PM	381
0453d815 PM	382	If no import list is supplied, all possible warnings are either enabled
0453d815 PM	383	or disabled.
599cee73	384
0ca4541c	385	A number of functions are provided to assist module authors.
e476b1b5 GS	386
	387	=over 4
	388
d3a7d8c7 GS	389	=item use warnings::register
d3a7d8c7 GS	390
7e6d00f8 PM	391	Creates a new warnings category with the same name as the package where
	392	the call to the pragma is used.
	393
	394	=item warnings::enabled()
	395
	396	Use the warnings category with the same name as the current package.
	397
	398	Return TRUE if that warnings category is enabled in the calling module.
	399	Otherwise returns FALSE.
	400
	401	=item warnings::enabled($category)
	402
	403	Return TRUE if the warnings category, C<$category>, is enabled in the
	404	calling module.
	405	Otherwise returns FALSE.
	406
	407	=item warnings::enabled($object)
	408
	409	Use the name of the class for the object reference, C<$object>, as the
	410	warnings category.
	411
	412	Return TRUE if that warnings category is enabled in the first scope
	413	where the object is used.
	414	Otherwise returns FALSE.
	415
	416	=item warnings::warn($message)
	417
	418	Print C<$message> to STDERR.
	419
	420	Use the warnings category with the same name as the current package.
	421
	422	If that warnings category has been set to "FATAL" in the calling module
	423	then die. Otherwise return.
	424
	425	=item warnings::warn($category, $message)
	426
	427	Print C<$message> to STDERR.
	428
	429	If the warnings category, C<$category>, has been set to "FATAL" in the
	430	calling module then die. Otherwise return.
d3a7d8c7	431
7e6d00f8	432	=item warnings::warn($object, $message)
e476b1b5	433
7e6d00f8	434	Print C<$message> to STDERR.
e476b1b5	435
7e6d00f8 PM	436	Use the name of the class for the object reference, C<$object>, as the
7e6d00f8 PM	437	warnings category.
e476b1b5	438
7e6d00f8 PM	439	If that warnings category has been set to "FATAL" in the scope where C<$object>
7e6d00f8 PM	440	is first used then die. Otherwise return.
599cee73	441
e476b1b5	442
7e6d00f8 PM	443	=item warnings::warnif($message)
	444
	445	Equivalent to:
	446
	447	if (warnings::enabled())
	448	{ warnings::warn($message) }
	449
	450	=item warnings::warnif($category, $message)
	451
	452	Equivalent to:
	453
	454	if (warnings::enabled($category))
	455	{ warnings::warn($category, $message) }
	456
	457	=item warnings::warnif($object, $message)
	458
	459	Equivalent to:
	460
	461	if (warnings::enabled($object))
	462	{ warnings::warn($object, $message) }
d3a7d8c7	463
e476b1b5 GS	464	=back
e476b1b5 GS	465
749f83fa	466	See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73 PM	467
	468	=cut
	469
	470	use Carp ;
	471
	472	KEYWORDS
	473
d3a7d8c7 GS	474	$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
d3a7d8c7 GS	475
599cee73 PM	476	sub bits {
	477	my $mask ;
	478	my $catmask ;
	479	my $fatal = 0 ;
	480	foreach my $word (@_) {
327afb7f GS	481	if ($word eq 'FATAL') {
	482	$fatal = 1;
	483	}
d3a7d8c7 GS	484	elsif ($catmask = $Bits{$word}) {
	485	$mask \|= $catmask ;
	486	$mask \|= $DeadBits{$word} if $fatal ;
599cee73	487	}
d3a7d8c7	488	else
0ca4541c	489	{ croak("unknown warnings category '$word'")}
599cee73 PM	490	}
	491
	492	return $mask ;
	493	}
	494
	495	sub import {
	496	shift;
f1f33818 PM	497	my $mask = ${^WARNING_BITS} ;
	498	if (vec($mask, $Offsets{'all'}, 1)) {
	499	$mask \|= $Bits{'all'} ;
	500	$mask \|= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
	501	}
	502	${^WARNING_BITS} = $mask \| bits(@_ ? @_ : 'all') ;
599cee73 PM	503	}
	504
	505	sub unimport {
	506	shift;
d3a7d8c7 GS	507	my $mask = ${^WARNING_BITS} ;
d3a7d8c7 GS	508	if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818	509	$mask \|= $Bits{'all'} ;
d3a7d8c7 GS	510	$mask \|= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
d3a7d8c7 GS	511	}
08540116	512	${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) \| $All) ;
599cee73 PM	513	}
599cee73 PM	514
7e6d00f8	515	sub __chk
599cee73	516	{
d3a7d8c7 GS	517	my $category ;
d3a7d8c7 GS	518	my $offset ;
7e6d00f8	519	my $isobj = 0 ;
d3a7d8c7 GS	520
	521	if (@_) {
	522	# check the category supplied.
	523	$category = shift ;
7e6d00f8 PM	524	if (ref $category) {
	525	croak ("not an object")
	526	if $category !~ /^([^=]+)=/ ;+
	527	$category = $1 ;
	528	$isobj = 1 ;
	529	}
d3a7d8c7 GS	530	$offset = $Offsets{$category};
	531	croak("unknown warnings category '$category'")
	532	unless defined $offset;
	533	}
	534	else {
0ca4541c	535	$category = (caller(1))[0] ;
d3a7d8c7 GS	536	$offset = $Offsets{$category};
	537	croak("package '$category' not registered for warnings")
	538	unless defined $offset ;
	539	}
	540
0ca4541c	541	my $this_pkg = (caller(1))[0] ;
7e6d00f8 PM	542	my $i = 2 ;
	543	my $pkg ;
	544
	545	if ($isobj) {
	546	while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
	547	last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
	548	}
	549	$i -= 2 ;
	550	}
	551	else {
	552	for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
	553	last if $pkg ne $this_pkg ;
	554	}
0ca4541c	555	$i = 2
7e6d00f8 PM	556	if !$pkg \|\| $pkg eq $this_pkg ;
	557	}
	558
0ca4541c	559	my $callers_bitmask = (caller($i))[9] ;
7e6d00f8 PM	560	return ($callers_bitmask, $offset, $i) ;
	561	}
	562
	563	sub enabled
	564	{
	565	croak("Usage: warnings::enabled([category])")
	566	unless @_ == 1 \|\| @_ == 0 ;
	567
	568	my ($callers_bitmask, $offset, $i) = __chk(@_) ;
	569
	570	return 0 unless defined $callers_bitmask ;
d3a7d8c7 GS	571	return vec($callers_bitmask, $offset, 1) \|\|
d3a7d8c7 GS	572	vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73 PM	573	}
599cee73 PM	574
d3a7d8c7	575
e476b1b5 GS	576	sub warn
e476b1b5 GS	577	{
d3a7d8c7 GS	578	croak("Usage: warnings::warn([category,] 'message')")
d3a7d8c7 GS	579	unless @_ == 2 \|\| @_ == 1 ;
d3a7d8c7	580
7e6d00f8 PM	581	my $message = pop ;
	582	my ($callers_bitmask, $offset, $i) = __chk(@_) ;
	583	local $Carp::CarpLevel = $i ;
0ca4541c	584	croak($message)
d3a7d8c7 GS	585	if vec($callers_bitmask, $offset+1, 1) \|\|
d3a7d8c7 GS	586	vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
e476b1b5 GS	587	carp($message) ;
	588	}
	589
7e6d00f8 PM	590	sub warnif
	591	{
	592	croak("Usage: warnings::warnif([category,] 'message')")
	593	unless @_ == 2 \|\| @_ == 1 ;
	594
	595	my $message = pop ;
	596	my ($callers_bitmask, $offset, $i) = __chk(@_) ;
	597	local $Carp::CarpLevel = $i ;
	598
0ca4541c	599	return
7e6d00f8 PM	600	unless defined $callers_bitmask &&
	601	(vec($callers_bitmask, $offset, 1) \|\|
	602	vec($callers_bitmask, $Offsets{'all'}, 1)) ;
	603
0ca4541c	604	croak($message)
7e6d00f8 PM	605	if vec($callers_bitmask, $offset+1, 1) \|\|
	606	vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
	607
	608	carp($message) ;
	609	}
599cee73	610	1;