[perl5.git] / warnings.pl

#!/usr/bin/perl

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

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

my $tree = {

'all' => {
       	'io'  		=> { 	'pipe' 		=> DEFAULT_OFF,
       				'unopened'	=> DEFAULT_OFF,
       				'closed'	=> DEFAULT_OFF,
       				'newline'	=> DEFAULT_OFF,
       				'exec'		=> DEFAULT_OFF,
			   },
       	'syntax'	=> { 	'ambiguous'	=> DEFAULT_OFF,
			     	'semicolon'	=> DEFAULT_OFF,
			     	'precedence'	=> DEFAULT_OFF,
			     	'bareword'	=> DEFAULT_OFF,
			     	'reserved'	=> DEFAULT_OFF,
				'digit'		=> DEFAULT_OFF,
			     	'parenthesis'	=> DEFAULT_OFF,
       	 			'deprecated'	=> DEFAULT_OFF,
       	 			'printf'	=> DEFAULT_OFF,
       	 			'prototype'	=> DEFAULT_OFF,
       	 			'qw'		=> DEFAULT_OFF,
			   },
       	'severe'	=> { 	'inplace'	=> DEFAULT_ON,
	 			'internal'	=> DEFAULT_ON,
         			'debugging'	=> DEFAULT_ON,
         			'malloc'	=> DEFAULT_ON,
	 		   },
       	'void'		=> DEFAULT_OFF,
       	'recursion'	=> DEFAULT_OFF,
       	'redefine'	=> DEFAULT_OFF,
       	'numeric'	=> DEFAULT_OFF,
        'uninitialized'	=> DEFAULT_OFF,
       	'once'		=> DEFAULT_OFF,
       	'misc'		=> DEFAULT_OFF,
       	'regexp'	=> DEFAULT_OFF,
       	'glob'		=> DEFAULT_OFF,
       	'y2k'		=> DEFAULT_OFF,
       	'chmod'		=> DEFAULT_OFF,
       	'umask'		=> DEFAULT_OFF,
       	'untie'		=> DEFAULT_OFF,
	'substr'	=> DEFAULT_OFF,
	'taint'		=> DEFAULT_OFF,
	'signal'	=> DEFAULT_OFF,
	'closure'	=> DEFAULT_OFF,
	'overflow'	=> DEFAULT_OFF,
	'portable'	=> DEFAULT_OFF,
	'utf8'		=> DEFAULT_OFF,
       	'exiting'	=> DEFAULT_OFF,
       	'pack'		=> DEFAULT_OFF,
       	'unpack'	=> DEFAULT_OFF,
       	 #'default'	=> DEFAULT_ON,
  	}
} ;


###########################################################################
sub tab {
    my($l, $t) = @_;
    $t .= "\t" x ($l - (length($t) + 1) / 8);
    $t;
}

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

my %list ;
my %Value ;
my $index ;

sub walk
{
    my $tre = shift ;
    my @list = () ;
    my ($k, $v) ;

    foreach $k (sort keys %$tre) {
	$v = $tre->{$k};
	die "duplicate key $k\n" if defined $list{$k} ;
	$Value{$index} = uc $k ;
        push @{ $list{$k} }, $index ++ ;
	if (ref $v)
	  { push (@{ $list{$k} }, walk ($v)) }
	push @list, @{ $list{$k} } ;
    }

   return @list ;
}

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

sub mkRange
{
    my @a = @_ ;
    my @out = @a ;
    my $i ;


    for ($i = 1 ; $i < @a; ++ $i) {
      	$out[$i] = ".." 
          if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
    }

    my $out = join(",",@out);

    $out =~ s/,(\.\.,)+/../g ;
    return $out;
}

###########################################################################
sub printTree
{
    my $tre = shift ;
    my $prefix = shift ;
    my $indent = shift ;
    my ($k, $v) ;

    my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;

    $prefix .= " " x $indent ;
    foreach $k (sort keys %$tre) {
	$v = $tre->{$k};
	print $prefix . "|\n" ;
	print $prefix . "+- $k" ;
	if (ref $v)
	{ 
	    print " " . "-" x ($max - length $k ) . "+\n" ;
	    printTree ($v, $prefix . "|" , $max + $indent - 1) 
	}
	else
	  { print "\n" }
    }

}

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

sub mkHex
{
    my ($max, @a) = @_ ;
    my $mask = "\x00" x $max ;
    my $string = "" ;

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

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

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

if (@ARGV && $ARGV[0] eq "tree")
{
    #print "  all -+\n" ;
    printTree($tree, "   ", 4) ;
    exit ;
}

#unlink "warnings.h";
#unlink "lib/warnings.pm";
open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";

print WARN <<'EOM' ;
/* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
   This file is built by warnings.pl
   Any changes made here will be lost!
*/


#define Off(x)			((x) / 8)
#define Bit(x)			(1 << ((x) % 8))
#define IsSet(a, x)		((a)[Off(x)] & Bit(x))


#define G_WARN_OFF		0 	/* $^W == 0 */
#define G_WARN_ON		1	/* -w flag and $^W != 0 */
#define G_WARN_ALL_ON		2	/* -W flag */
#define G_WARN_ALL_OFF		4	/* -X flag */
#define G_WARN_ONCE		8	/* set if 'once' ever enabled */
#define G_WARN_ALL_MASK		(G_WARN_ALL_ON|G_WARN_ALL_OFF)

#define pWARN_STD		Nullsv
#define pWARN_ALL		(Nullsv+1)	/* use warnings 'all' */
#define pWARN_NONE		(Nullsv+2)	/* no  warnings 'all' */

#define specialWARN(x)		((x) == pWARN_STD || (x) == pWARN_ALL ||	\
				 (x) == pWARN_NONE)
EOM

my $offset = 0 ;

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


$index *= 2 ;
my $warn_size = int($index / 8) + ($index % 8 != 0) ;

my $k ;
foreach $k (sort { $a <=> $b } keys %Value) {
    print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
}
print WARN "\n" ;

print WARN tab(5, '#define WARNsize'),	"$warn_size\n" ;
#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;

print WARN <<'EOM';

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

#define ckDEAD(x)							\
	   ( ! specialWARN(PL_curcop->cop_warnings) &&			\
	    ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || 		\
	      isWARNf_on(PL_curcop->cop_warnings, x)))

#define ckWARN(x)							\
	( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&	\
	      (PL_curcop->cop_warnings == pWARN_ALL ||			\
	       isWARN_on(PL_curcop->cop_warnings, x) ) )		\
	  || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )

#define ckWARN2(x,y)							\
	  ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&	\
	      (PL_curcop->cop_warnings == pWARN_ALL ||			\
	        isWARN_on(PL_curcop->cop_warnings, x)  ||		\
	        isWARN_on(PL_curcop->cop_warnings, y) ) ) 		\
	    ||	(isLEXWARN_off && PL_dowarn & G_WARN_ON) )

#define ckWARN_d(x)							\
	  (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||	\
	     (PL_curcop->cop_warnings != pWARN_NONE &&			\
	      isWARN_on(PL_curcop->cop_warnings, x) ) )

#define ckWARN2_d(x,y)							\
	  (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||	\
	     (PL_curcop->cop_warnings != pWARN_NONE &&			\
	        (isWARN_on(PL_curcop->cop_warnings, x)  ||		\
	         isWARN_on(PL_curcop->cop_warnings, y) ) ) )

/* end of file warnings.h */

EOM

close WARN ;

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

#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;

#my %Keys = map {lc $Value{$_}, $_} keys %Value ;

print PM "%Offsets = (\n" ;
foreach my $k (sort { $a <=> $b } keys %Value) {
    my $v = lc $Value{$k} ;
    $k *= 2 ;
    print PM tab(4, "    '$v'"), "=> $k,\n" ;
}

print PM "  );\n\n" ;

print PM "%Bits = (\n" ;
foreach $k (sort keys  %list) {

    my $v = $list{$k} ;
    my @list = sort { $a <=> $b } @$v ;

    print PM tab(4, "    '$k'"), '=> "', 
		# mkHex($warn_size, @list), 
		mkHex($warn_size, map $_ * 2 , @list), 
		'", # [', mkRange(@list), "]\n" ;
}

print PM "  );\n\n" ;

print PM "%DeadBits = (\n" ;
foreach $k (sort keys  %list) {

    my $v = $list{$k} ;
    my @list = sort { $a <=> $b } @$v ;

    print PM tab(4, "    '$k'"), '=> "', 
		# mkHex($warn_size, @list), 
		mkHex($warn_size, map $_ * 2 + 1 , @list), 
		'", # [', mkRange(@list), "]\n" ;
}

print PM "  );\n\n" ;
print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
print PM '$LAST_BIT = ' . "$index ;\n" ;
print PM '$BYTES    = ' . "$warn_size ;\n" ;
while (<DATA>) {
    print PM $_ ;
}

close PM ;

__END__

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

package warnings;

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