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

#!/usr/bin/perl

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 

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