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