[perl5.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) ;

    while (($k, $v) = each %$tre) {

	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)							\
	   (curcop->cop_warnings != WARN_ALL &&				\
	    curcop->cop_warnings != WARN_NONE &&			\
	    IsSet(SvPVX(curcop->cop_warnings), 2*x+1))

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

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

#else

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

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

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

#endif

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