X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=warnings.pl;h=9149f691949cd5fe6bb0743b5b9509c65eafc98e;hb=696235b60874be65fe029a39969f44a0133ec2f8;hp=3a5037d40dfd014488479b323a71156df21402e1;hpb=0e06870bf080a38cda51c06c6612359afc2334e1;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/warnings.pl b/warnings.pl
index 3a5037d..9149f69 100644
--- a/warnings.pl
+++ b/warnings.pl
@@ -27,7 +27,6 @@ my $tree = {
 			     	'reserved'	=> DEFAULT_OFF,
 				'digit'		=> DEFAULT_OFF,
 			     	'parenthesis'	=> DEFAULT_OFF,
-       	 			'deprecated'	=> DEFAULT_OFF,
        	 			'printf'	=> DEFAULT_OFF,
        	 			'prototype'	=> DEFAULT_OFF,
        	 			'qw'		=> DEFAULT_OFF,
@@ -37,6 +36,7 @@ my $tree = {
          			'debugging'	=> DEFAULT_ON,
          			'malloc'	=> DEFAULT_ON,
 	 		   },
+        'deprecated'	=> DEFAULT_OFF,
        	'void'		=> DEFAULT_OFF,
        	'recursion'	=> DEFAULT_OFF,
        	'redefine'	=> DEFAULT_OFF,
@@ -47,8 +47,6 @@ my $tree = {
        	'regexp'	=> DEFAULT_OFF,
        	'glob'		=> DEFAULT_OFF,
        	'y2k'		=> DEFAULT_OFF,
-       	'chmod'		=> DEFAULT_OFF,
-       	'umask'		=> DEFAULT_OFF,
        	'untie'		=> DEFAULT_OFF,
 	'substr'	=> DEFAULT_OFF,
 	'taint'		=> DEFAULT_OFF,
@@ -145,9 +143,9 @@ sub printTree
 
 ###########################################################################
 
-sub mkHex
+sub mkHexOct
 {
-    my ($max, @a) = @_ ;
+    my ($f, $max, @a) = @_ ;
     my $mask = "\x00" x $max ;
     my $string = "" ;
 
@@ -155,14 +153,29 @@ sub mkHex
 	vec($mask, $_, 1) = 1 ;
     }
 
-    #$string = unpack("H$max", $mask) ;
-    #$string =~ s/(..)/\x$1/g;
     foreach (unpack("C*", $mask)) {
-	$string .= '\x' . sprintf("%2.2x", $_) ;
+        if ($f eq 'x') {
+            $string .= '\x' . sprintf("%2.2x", $_)
+        }
+        else {
+            $string .= '\\' . sprintf("%o", $_)
+        }
     }
     return $string ;
 }
 
+sub mkHex
+{
+    my($max, @a) = @_;
+    return mkHexOct("x", $max, @a);
+}
+
+sub mkOct
+{
+    my($max, @a) = @_;
+    return mkHexOct("o", $max, @a);
+}
+
 ###########################################################################
 
 if (@ARGV && $ARGV[0] eq "tree")
@@ -172,8 +185,8 @@ if (@ARGV && $ARGV[0] eq "tree")
     exit ;
 }
 
-#unlink "warnings.h";
-#unlink "lib/warnings.pm";
+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";
 
@@ -210,6 +223,10 @@ $index = $offset ;
 #@{ $list{"all"} } = walk ($tree) ;
 walk ($tree) ;
 
+die <<EOM if $index > 255 ;
+Too many warnings categories -- max is 255
+    rewrite packWARN* & unpackWARN* macros 
+EOM
 
 $index *= 2 ;
 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
@@ -224,6 +241,9 @@ 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" ;
+my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
+
+print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
 
 print WARN <<'EOM';
 
@@ -233,11 +253,6 @@ print WARN <<'EOM';
 #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 ||			\
@@ -251,6 +266,23 @@ print WARN <<'EOM';
 	        isWARN_on(PL_curcop->cop_warnings, y) ) ) 		\
 	    ||	(isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 
+#define ckWARN3(x,y,z)							\
+	  ( (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)  ||		\
+	        isWARN_on(PL_curcop->cop_warnings, z) ) ) 		\
+	    ||	(isLEXWARN_off && PL_dowarn & G_WARN_ON) )
+
+#define ckWARN4(x,y,z,t)						\
+	  ( (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)  ||		\
+	        isWARN_on(PL_curcop->cop_warnings, z)  ||		\
+	        isWARN_on(PL_curcop->cop_warnings, t) ) ) 		\
+	    ||	(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 &&			\
@@ -262,6 +294,39 @@ print WARN <<'EOM';
 	        (isWARN_on(PL_curcop->cop_warnings, x)  ||		\
 	         isWARN_on(PL_curcop->cop_warnings, y) ) ) )
 
+#define ckWARN3_d(x,y,z)						\
+	  (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)  ||		\
+	         isWARN_on(PL_curcop->cop_warnings, z) ) ) )
+
+#define ckWARN4_d(x,y,z,t)						\
+	  (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)  ||		\
+	         isWARN_on(PL_curcop->cop_warnings, z)  ||		\
+	         isWARN_on(PL_curcop->cop_warnings, t) ) ) )
+
+#define packWARN(a)		(a                                 )
+#define packWARN2(a,b)		((a) | (b)<<8                      )
+#define packWARN3(a,b,c)	((a) | (b)<<8 | (c) <<16           )
+#define packWARN4(a,b,c,d)	((a) | (b)<<8 | (c) <<16 | (d) <<24)
+
+#define unpackWARN1(x)		((x)        & 0xFF)
+#define unpackWARN2(x)		(((x) >>8)  & 0xFF)
+#define unpackWARN3(x)		(((x) >>16) & 0xFF)
+#define unpackWARN4(x)		(((x) >>24) & 0xFF)
+
+#define ckDEAD(x)							\
+	   ( ! specialWARN(PL_curcop->cop_warnings) &&			\
+	    ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || 		\
+	      isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||	\
+	      isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||	\
+	      isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||	\
+	      isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
+
 /* end of file warnings.h */
 
 EOM
@@ -357,9 +422,9 @@ warnings - Perl pragma to control optional warnings
         warnings::warn($object, "some warning");
     }
 
-    warnif("some warning");
-    warnif("void", "some warning");
-    warnif($object, "some warning");
+    warnings::warnif("some warning");
+    warnings::warnif("void", "some warning");
+    warnings::warnif($object, "some warning");
 
 =head1 DESCRIPTION
 
@@ -457,6 +522,12 @@ KEYWORDS
 
 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 
+sub Croaker
+{
+    delete $Carp::CarpInternal{'warnings'};
+    croak @_ ;
+}
+
 sub bits {
     my $mask ;
     my $catmask ;
@@ -470,7 +541,7 @@ sub bits {
 	    $mask |= $DeadBits{$word} if $fatal ;
 	}
 	else
-          { croak("unknown warnings category '$word'")}
+          { Croaker("Unknown warnings category '$word'")}
     }
 
     return $mask ;
@@ -493,7 +564,7 @@ sub unimport {
         $mask |= $Bits{'all'} ;
         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
     }
-    ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : 'all') | $All) ;
+    ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
 }
 
 sub __chk
@@ -506,19 +577,19 @@ sub __chk
         # check the category supplied.
         $category = shift ;
         if (ref $category) {
-            croak ("not an object")
-                if $category !~ /^([^=]+)=/ ;+
+            Croaker ("not an object")
+                if $category !~ /^([^=]+)=/ ;
 	    $category = $1 ;
             $isobj = 1 ;
         }
         $offset = $Offsets{$category};
-        croak("unknown warnings category '$category'")
+        Croaker("Unknown warnings category '$category'")
 	    unless defined $offset;
     }
     else {
         $category = (caller(1))[0] ;
         $offset = $Offsets{$category};
-        croak("package '$category' not registered for warnings")
+        Croaker("package '$category' not registered for warnings")
 	    unless defined $offset ;
     }
 
@@ -546,7 +617,7 @@ sub __chk
 
 sub enabled
 {
-    croak("Usage: warnings::enabled([category])")
+    Croaker("Usage: warnings::enabled([category])")
 	unless @_ == 1 || @_ == 0 ;
 
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
@@ -559,12 +630,11 @@ sub enabled
 
 sub warn
 {
-    croak("Usage: warnings::warn([category,] 'message')")
+    Croaker("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) ;
@@ -573,12 +643,11 @@ sub warn
 
 sub warnif
 {
-    croak("Usage: warnings::warnif([category,] 'message')")
+    Croaker("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 &&