[perl5.git] / warnings.pl

#!/usr/bin/perl

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