Rename warning to warnings, from Paul Marquess.

p4raw-id: //depot/cfgperl@4038

1 files changed, 336 insertions, 0 deletions

diff --git a/warnings.pl b/warnings.pl
new file mode 100644
index 0000000000..9ff4197612
--- /dev/null
+++ b/warnings.pl
@@ -0,0 +1,336 @@
+#!/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,
+				'overflow'	=> DEFAULT_OFF,
+				'portable'	=> 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,
+				'digit'		=> DEFAULT_OFF,
+			     	'parenthesis'	=> DEFAULT_OFF,
+       	 			'deprecated'	=> DEFAULT_OFF,
+       	 			'printf'	=> DEFAULT_OFF,
+			   },
+       	 'severe'	=> { 	'inplace'	=> DEFAULT_ON,
+	 			'internal'	=> DEFAULT_ON,
+         			'debugging'	=> DEFAULT_ON,
+	 		   },
+       	 '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 "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 WARN_STD		Nullsv
+#define WARN_ALL		(&PL_sv_yes)	/* use warnings 'all' */
+#define WARN_NONE		(&PL_sv_no)	/* no  warnings 'all' */
+
+#define specialWARN(x)		((x) == WARN_STD || (x) == WARN_ALL ||	\
+				 (x) == WARN_NONE)
+
+#define ckDEAD(x)							\
+	   ( ! specialWARN(PL_curcop->cop_warnings) &&			\
+	    IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1))
+
+#define ckWARN(x)							\
+	( (PL_curcop->cop_warnings != WARN_STD &&			\
+	   PL_curcop->cop_warnings != WARN_NONE &&			\
+	      (PL_curcop->cop_warnings == WARN_ALL ||			\
+	       IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )		\
+	  || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
+
+#define ckWARN2(x,y)							\
+	  ( (PL_curcop->cop_warnings != WARN_STD  &&			\
+	     PL_curcop->cop_warnings != WARN_NONE &&			\
+	      (PL_curcop->cop_warnings == WARN_ALL ||			\
+	        IsSet(SvPVX(PL_curcop->cop_warnings), 2*x)  ||		\
+	        IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) 		\
+	    ||	(PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) )
+
+#define ckWARN_d(x)							\
+	  (PL_curcop->cop_warnings == WARN_STD ||			\
+	   PL_curcop->cop_warnings == WARN_ALL ||			\
+	     (PL_curcop->cop_warnings != WARN_NONE &&			\
+	      IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) )
+
+#define ckWARN2_d(x,y)							\
+	  (PL_curcop->cop_warnings == WARN_STD ||			\
+	   PL_curcop->cop_warnings == WARN_ALL ||			\
+	     (PL_curcop->cop_warnings != WARN_NONE &&			\
+	        (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x)  ||		\
+	         IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) )
+
+
+#define isLEXWARN_on 	(PL_curcop->cop_warnings != WARN_STD)
+#define isLEXWARN_off	(PL_curcop->cop_warnings == WARN_STD)
+#define isWARN_ONCE	(PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
+#define isWARN_on(c,x)	(IsSet(SvPVX(c), 2*(x)))
+
+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 warnings.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 warnings.pl
+# Any changes made here will be lost.
+#
+
+package warnings;
+
+=head1 NAME
+
+warnings - Perl pragma to control optional warnings
+
+=head1 SYNOPSIS
+
+    use warnings;
+    no warnings;
+
+    use warnings "all";
+    no warnings "all";
+
+=head1 DESCRIPTION
+
+If no import list is supplied, all possible warnings are either enabled
+or disabled.
+
+See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
+
+
+=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;
+    ${^Warnings} |= bits(@_ ? @_ : 'all') ;
+}
+
+sub unimport {
+    shift;
+    ${^Warnings} &= ~ bits(@_ ? @_ : 'all') ;
+}
+
+sub enabled
+{
+    my $string = shift ;
+
+    return 1
+	if $bits{$string} && ${^Warnings} & $bits{$string} ;
+   
+    return 0 ; 
+}
+
+1;