[p5sagit/p5-mst-13.2.git] / warnings.pl

#!/usr/bin/perl


$VERSION = '1.00';

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

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

my $tree = {

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


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

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

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

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

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

   return @list ;
}

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

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


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

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

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

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

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

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

}

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

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

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

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

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

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

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

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


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


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

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

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

my $offset = 0 ;

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


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

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

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

print WARN <<'EOM';

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

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

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

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

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

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

/* end of file warnings.h */

EOM

close WARN ;

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

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

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

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

print PM "  );\n\n" ;

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

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

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

print PM "  );\n\n" ;

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

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

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

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

close PM ;

__END__

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

package warnings;

our $VERSION = '1.00';

=head1 NAME

warnings - Perl pragma to control optional warnings

=head1 SYNOPSIS

    use warnings;
    no warnings;

    use warnings "all";
    no warnings "all";

    use warnings::register;
    if (warnings::enabled()) {
        warnings::warn("some warning");
    }

    if (warnings::enabled("void")) {
        warnings::warn("void", "some warning");
    }

    if (warnings::enabled($object)) {
        warnings::warn($object, "some warning");
    }

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

=head1 DESCRIPTION

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

A number of functions are provided to assist module authors.

=over 4

=item use warnings::register

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

=item warnings::enabled()

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

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

=item warnings::enabled($category)

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

=item warnings::enabled($object)

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

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

=item warnings::warn($message)

Print C<$message> to STDERR.

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

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

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

Print C<$message> to STDERR.

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

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

Print C<$message> to STDERR.

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

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


=item warnings::warnif($message)

Equivalent to:

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

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

Equivalent to:

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

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

Equivalent to:

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

=back

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

=cut

use Carp ;

KEYWORDS

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

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

    return $mask ;
}

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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