[perl5.git] / warning.pl

#!/usr/bin/perl

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

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

my $tree = {
       	 'unsafe'	=> { 	'untie'		=> DEFAULT_OFF,
				'substr'	=> DEFAULT_OFF,
				'taint'		=> DEFAULT_OFF,
				'signal'	=> DEFAULT_OFF,
				'closure'	=> DEFAULT_OFF,
				'utf8'		=> DEFAULT_OFF,
			   } ,
       	 'io'  		=> { 	'pipe' 		=> DEFAULT_OFF,
       				'unopened'	=> DEFAULT_OFF,
       				'closed'	=> DEFAULT_OFF,
       				'newline'	=> DEFAULT_OFF,
       				'exec'		=> DEFAULT_OFF,
       				#'wr in in file'=> DEFAULT_OFF,
			   },
       	 'syntax'	=> { 	'ambiguous'	=> DEFAULT_OFF,
			     	'semicolon'	=> DEFAULT_OFF,
			     	'precedence'	=> DEFAULT_OFF,
			     	'reserved'	=> DEFAULT_OFF,
				'octal'		=> DEFAULT_OFF,
			     	'parenthesis'	=> DEFAULT_OFF,
       	 			'deprecated'	=> DEFAULT_OFF,
       	 			'printf'	=> DEFAULT_OFF,
			   },
       	 'void'		=> DEFAULT_OFF,
       	 'recursion'	=> DEFAULT_OFF,
       	 'redefine'	=> DEFAULT_OFF,
       	 'numeric'	=> DEFAULT_OFF,
         'uninitialized'=> DEFAULT_OFF,
       	 'once'		=> DEFAULT_OFF,
       	 'misc'		=> 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 = 0 ;

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 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 ;
}

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


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

print WARN <<'EOM' ;
/* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
   This file is built by warning.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 != 0 */
#define G_WARN_ALL_ON		2	/* -W flag */
#define G_WARN_ALL_OFF		4	/* -X flag */
#define G_WARN_ALL_MASK		(G_WARN_ALL_ON|G_WARN_ALL_OFF)

#if 1

/* Part of the logic below assumes that WARN_NONE is NULL */

#define ckDEAD(x)							\
	   (PL_curcop->cop_warnings != WARN_ALL &&			\
	    PL_curcop->cop_warnings != WARN_NONE &&			\
	    IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))

#define ckWARN(x)							\
	( (PL_curcop->cop_warnings &&					\
	      (PL_curcop->cop_warnings == WARN_ALL ||			\
	       IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )		\
	  || (PL_dowarn & G_WARN_ON) )

#define ckWARN2(x,y)							\
	  ( (PL_curcop->cop_warnings &&					\
	      (PL_curcop->cop_warnings == WARN_ALL ||			\
	        IsSet(SvPVX(PL_curcop->cop_warnings), 2*x)  ||		\
	        IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) 		\
	    ||	(PL_dowarn & G_WARN_ON) )

#else

#define ckDEAD(x)							\
	   (PL_curcop->cop_warnings != WARN_ALL &&			\
	    PL_curcop->cop_warnings != WARN_NONE &&			\
	    SvPVX(PL_curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) )

#define ckWARN(x)							\
	( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && 	\
	  PL_curcop->cop_warnings &&					\
	  ( PL_curcop->cop_warnings == WARN_ALL ||			\
	    SvPVX(PL_curcop->cop_warnings)[Off(2*x)] & Bit(2*x)  ) ) )

#define ckWARN2(x,y)							\
	( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && 	\
	  PL_curcop->cop_warnings &&					\
	  ( PL_curcop->cop_warnings == WARN_ALL ||			\
	    SvPVX(PL_curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || 	\
	    SvPVX(PL_curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) ) 

#endif

#define WARN_NONE		NULL
#define WARN_ALL		(&PL_sv_yes)

EOM


$index = 0 ;
@{ $list{"all"} } = 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';

/* end of file warning.h */

EOM

close WARN ;

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

$list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
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" ;
while (<DATA>) {
    print PM $_ ;
}

close PM ;

__END__

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

package warning;

=head1 NAME

warning - Perl pragma to control optional warnings

=head1 SYNOPSIS

    use warning;

    use warning "all";
    use warning "deprecated";

    use warning;
    no warning "unsafe";

=head1 DESCRIPTION

If no import list is supplied, all possible restrictions are assumed.
(This is the safest mode to operate in, but is sometimes too strict for
casual programming.)  Currently, there are three possible things to be
strict about:  

=over 6

=item C<warning deprecated>

This generates a runtime error if you use deprecated 

    use warning 'deprecated';

=back

See L<perlmod/Pragmatic Modules>.


=cut

use Carp ;

KEYWORDS

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 warning category '$word'" }
    }

    return $mask ;
}

sub import {
    shift;
    $^B |= bits(@_ ? @_ : 'all') ;
}

sub unimport {
    shift;
    $^B &= ~ bits(@_ ? @_ : 'all') ;
}


sub make_fatal
{
    my $self = shift ;
    my $bitmask = $self->bits(@_) ;
    $SIG{__WARN__} =
        sub
        {
            die @_ if $^B & $bitmask ;
            warn @_
        } ;
}

sub bitmask
{
    return $^B ;
}

sub enabled
{
    my $string = shift ;

    return 1
	if $bits{$string} && $^B & $bits{$string} ;
   
    return 0 ; 
}

1;
Commit	Line	Data
599cee73 PM	1	#!/usr/bin/perl
599cee73 PM	2
73f0cc2d GS	3	BEGIN {
	4	push @INC, './lib';
	5	}
599cee73 PM	6	use strict ;
	7
	8	sub DEFAULT_ON () { 1 }
	9	sub DEFAULT_OFF () { 2 }
	10
	11	my $tree = {
	12	'unsafe' => { 'untie' => DEFAULT_OFF,
	13	'substr' => DEFAULT_OFF,
	14	'taint' => DEFAULT_OFF,
	15	'signal' => DEFAULT_OFF,
	16	'closure' => DEFAULT_OFF,
	17	'utf8' => DEFAULT_OFF,
	18	} ,
	19	'io' => { 'pipe' => DEFAULT_OFF,
	20	'unopened' => DEFAULT_OFF,
	21	'closed' => DEFAULT_OFF,
	22	'newline' => DEFAULT_OFF,
	23	'exec' => DEFAULT_OFF,
	24	#'wr in in file'=> DEFAULT_OFF,
	25	},
	26	'syntax' => { 'ambiguous' => DEFAULT_OFF,
	27	'semicolon' => DEFAULT_OFF,
	28	'precedence' => DEFAULT_OFF,
	29	'reserved' => DEFAULT_OFF,
	30	'octal' => DEFAULT_OFF,
	31	'parenthesis' => DEFAULT_OFF,
	32	'deprecated' => DEFAULT_OFF,
	33	'printf' => DEFAULT_OFF,
	34	},
	35	'void' => DEFAULT_OFF,
	36	'recursion' => DEFAULT_OFF,
	37	'redefine' => DEFAULT_OFF,
	38	'numeric' => DEFAULT_OFF,
	39	'uninitialized'=> DEFAULT_OFF,
	40	'once' => DEFAULT_OFF,
	41	'misc' => DEFAULT_OFF,
	42	'default' => DEFAULT_ON,
	43	} ;
	44
	45
	46	###########################################################################
	47	sub tab {
	48	my($l, $t) = @_;
	49	$t .= "\t" x ($l - (length($t) + 1) / 8);
	50	$t;
	51	}
	52
	53	###########################################################################
	54
	55	my %list ;
	56	my %Value ;
	57	my $index = 0 ;
	58
	59	sub walk
	60	{
	61	my $tre = shift ;
	62	my @list = () ;
	63	my ($k, $v) ;
	64
95dfd3ab GS	65	foreach $k (sort keys %$tre) {
95dfd3ab GS	66	$v = $tre->{$k};
599cee73 PM	67	die "duplicate key $k\n" if defined $list{$k} ;
	68	$Value{$index} = uc $k ;
	69	push @{ $list{$k} }, $index ++ ;
	70	if (ref $v)
	71	{ push (@{ $list{$k} }, walk ($v)) }
	72	push @list, @{ $list{$k} } ;
	73	}
	74
	75	return @list ;
599cee73 PM	76	}
	77
	78	###########################################################################
	79
	80	sub mkRange
	81	{
	82	my @a = @_ ;
	83	my @out = @a ;
	84	my $i ;
	85
	86
	87	for ($i = 1 ; $i < @a; ++ $i) {
	88	$out[$i] = ".."
	89	if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
	90	}
	91
	92	my $out = join(",",@out);
	93
	94	$out =~ s/,(\.\.,)+/../g ;
	95	return $out;
	96	}
	97
	98	###########################################################################
	99
	100	sub mkHex
	101	{
	102	my ($max, @a) = @_ ;
	103	my $mask = "\x00" x $max ;
	104	my $string = "" ;
	105
	106	foreach (@a) {
	107	vec($mask, $_, 1) = 1 ;
	108	}
	109
	110	#$string = unpack("H$max", $mask) ;
	111	#$string =~ s/(..)/\x$1/g;
	112	foreach (unpack("C*", $mask)) {
	113	$string .= '\x' . sprintf("%2.2x", $_) ;
	114	}
	115	return $string ;
	116	}
	117
	118	###########################################################################
	119
	120
	121	#unlink "warning.h";
	122	#unlink "lib/warning.pm";
	123	open(WARN, ">warning.h") \|\| die "Can't create warning.h: $!\n";
	124	open(PM, ">lib/warning.pm") \|\| die "Can't create lib/warning.pm: $!\n";
	125
	126	print WARN <<'EOM' ;
	127	/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
	128	This file is built by warning.pl
	129	Any changes made here will be lost!
	130	*/
	131
	132
	133	#define Off(x) ((x) / 8)
	134	#define Bit(x) (1 << ((x) % 8))
	135	#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
	136
	137	#define G_WARN_OFF 0 /* $^W == 0 */
	138	#define G_WARN_ON 1 /* $^W != 0 */
	139	#define G_WARN_ALL_ON 2 /* -W flag */
140	#define G_WARN_ALL_OFF 4 /* -X flag */
141	#define G_WARN_ALL_MASK (G_WARN_ALL_ON\|G_WARN_ALL_OFF)
142
143	#if 1
144
145	/* Part of the logic below assumes that WARN_NONE is NULL */
146
147	#define ckDEAD(x) \
e24b16f9 GS	148	(PL_curcop->cop_warnings != WARN_ALL && \
	149	PL_curcop->cop_warnings != WARN_NONE && \
	150	IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
599cee73 PM	151
599cee73 PM	152	#define ckWARN(x) \
e24b16f9 GS	153	( (PL_curcop->cop_warnings && \
	154	(PL_curcop->cop_warnings == WARN_ALL \|\| \
	155	IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \
599cee73 PM	156	\|\| (PL_dowarn & G_WARN_ON) )
	157
	158	#define ckWARN2(x,y) \
e24b16f9 GS	159	( (PL_curcop->cop_warnings && \
	160	(PL_curcop->cop_warnings == WARN_ALL \|\| \
	161	IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) \|\| \
	162	IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \
599cee73 PM	163	\|\| (PL_dowarn & G_WARN_ON) )
	164
	165	#else
	166
e24b16f9 GS	167	#define ckDEAD(x) \
	168	(PL_curcop->cop_warnings != WARN_ALL && \
	169	PL_curcop->cop_warnings != WARN_NONE && \
	170	SvPVX(PL_curcop->cop_warnings)[Off(2x+1)] & Bit(2x+1) )
599cee73	171
e24b16f9	172	#define ckWARN(x) \
599cee73	173	( (PL_dowarn & G_WARN_ON) \|\| ( (PL_dowarn & G_WARN_DISABLE) && \
e24b16f9 GS	174	PL_curcop->cop_warnings && \
	175	( PL_curcop->cop_warnings == WARN_ALL \|\| \
	176	SvPVX(PL_curcop->cop_warnings)[Off(2x)] & Bit(2x) ) ) )
599cee73	177
e24b16f9	178	#define ckWARN2(x,y) \
599cee73	179	( (PL_dowarn & G_WARN_ON) \|\| ( (PL_dowarn & G_WARN_DISABLE) && \
e24b16f9 GS	180	PL_curcop->cop_warnings && \
	181	( PL_curcop->cop_warnings == WARN_ALL \|\| \
	182	SvPVX(PL_curcop->cop_warnings)[Off(2x)] & Bit(2x) \|\| \
	183	SvPVX(PL_curcop->cop_warnings)[Off(2y)] & Bit(2y) ) ) )
599cee73 PM	184
	185	#endif
	186
	187	#define WARN_NONE NULL
e24b16f9	188	#define WARN_ALL (&PL_sv_yes)
599cee73 PM	189
	190	EOM
	191
	192
	193	$index = 0 ;
	194	@{ $list{"all"} } = walk ($tree) ;
	195
	196	$index *= 2 ;
	197	my $warn_size = int($index / 8) + ($index % 8 != 0) ;
	198
	199	my $k ;
	200	foreach $k (sort { $a <=> $b } keys %Value) {
	201	print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
	202	}
	203	print WARN "\n" ;
	204
	205	print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
	206	#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
	207	print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
	208	print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
	209
	210	print WARN <<'EOM';
	211
	212	/* end of file warning.h */
	213
	214	EOM
	215
	216	close WARN ;
	217
	218	while (<DATA>) {
	219	last if /^KEYWORDS$/ ;
	220	print PM $_ ;
	221	}
	222
	223	$list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
	224	print PM "%Bits = (\n" ;
	225	foreach $k (sort keys %list) {
	226
	227	my $v = $list{$k} ;
	228	my @list = sort { $a <=> $b } @$v ;
	229
	230	print PM tab(4, " '$k'"), '=> "',
	231	# mkHex($warn_size, @list),
	232	mkHex($warn_size, map $_ * 2 , @list),
	233	'", # [', mkRange(@list), "]\n" ;
	234	}
	235
	236	print PM " );\n\n" ;
	237
	238	print PM "%DeadBits = (\n" ;
	239	foreach $k (sort keys %list) {
	240
	241	my $v = $list{$k} ;
	242	my @list = sort { $a <=> $b } @$v ;
	243
	244	print PM tab(4, " '$k'"), '=> "',
	245	# mkHex($warn_size, @list),
	246	mkHex($warn_size, map $_ * 2 + 1 , @list),
	247	'", # [', mkRange(@list), "]\n" ;
	248	}
	249
	250	print PM " );\n\n" ;
	251	while (<DATA>) {
	252	print PM $_ ;
253	}
254
255	close PM ;
256
257	__END__
258
259	# This file was created by warning.pl
260	# Any changes made here will be lost.
261	#
262
263	package warning;
264
265	=head1 NAME
266
4c97a74d	267	warning - Perl pragma to control optional warnings
599cee73 PM	268
	269	=head1 SYNOPSIS
	270
	271	use warning;
	272
	273	use warning "all";
	274	use warning "deprecated";
	275
	276	use warning;
	277	no warning "unsafe";
	278
	279	=head1 DESCRIPTION
	280
	281	If no import list is supplied, all possible restrictions are assumed.
	282	(This is the safest mode to operate in, but is sometimes too strict for
	283	casual programming.) Currently, there are three possible things to be
	284	strict about:
	285
	286	=over 6
	287
	288	=item C<warning deprecated>
	289
	290	This generates a runtime error if you use deprecated
	291
	292	use warning 'deprecated';
	293
	294	=back
	295
	296	See L<perlmod/Pragmatic Modules>.
	297
	298
	299	=cut
	300
	301	use Carp ;
	302
	303	KEYWORDS
	304
	305	sub bits {
	306	my $mask ;
	307	my $catmask ;
	308	my $fatal = 0 ;
	309	foreach my $word (@_) {
	310	if ($word eq 'FATAL')
	311	{ $fatal = 1 }
	312	elsif ($catmask = $Bits{$word}) {
	313	$mask \|= $catmask ;
	314	$mask \|= $DeadBits{$word} if $fatal ;
	315	}
	316	else
	317	{ croak "unknown warning category '$word'" }
	318	}
	319
	320	return $mask ;
	321	}
	322
	323	sub import {
	324	shift;
	325	$^B \|= bits(@_ ? @_ : 'all') ;
	326	}
	327
	328	sub unimport {
	329	shift;
	330	$^B &= ~ bits(@_ ? @_ : 'all') ;
	331	}
332
333
334	sub make_fatal
335	{
336	my $self = shift ;
337	my $bitmask = $self->bits(@_) ;
338	$SIG{__WARN__} =
339	sub
340	{
341	die @_ if $^B & $bitmask ;
342	warn @_
343	} ;
344	}
345
346	sub bitmask
347	{
348	return $^B ;
349	}
350
351	sub enabled
352	{
353	my $string = shift ;
354
355	return 1
356	if $bits{$string} && $^B & $bits{$string} ;
357
358	return 0 ;
359	}
360
361	1;