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

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