X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=warnings.pl;h=0952305b2891d7708b1926e717586c65f79dd5c8;hb=f63f8e2fd0961bccc25f9a9f7fffef07b3c2a65a;hp=9ff41976129f5097aeac4592fe38bdf36d344f29;hpb=4438c4b75b842b6c829a7da9841e97abb875b1d8;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/warnings.pl b/warnings.pl
index 9ff4197..0952305 100644
--- a/warnings.pl
+++ b/warnings.pl
@@ -9,43 +9,52 @@ 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,
+       	'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,
+       	'syntax'	=> { 	'ambiguous'	=> DEFAULT_OFF,
 			     	'semicolon'	=> DEFAULT_OFF,
 			     	'precedence'	=> DEFAULT_OFF,
+			     	'bareword'	=> DEFAULT_OFF,
 			     	'reserved'	=> DEFAULT_OFF,
-				'octal'		=> DEFAULT_OFF,
 				'digit'		=> DEFAULT_OFF,
 			     	'parenthesis'	=> DEFAULT_OFF,
        	 			'deprecated'	=> DEFAULT_OFF,
        	 			'printf'	=> DEFAULT_OFF,
+       	 			'prototype'	=> DEFAULT_OFF,
+       	 			'qw'		=> DEFAULT_OFF,
 			   },
-       	 'severe'	=> { 	'inplace'	=> DEFAULT_ON,
+       	'severe'	=> { 	'inplace'	=> DEFAULT_ON,
 	 			'internal'	=> DEFAULT_ON,
          			'debugging'	=> DEFAULT_ON,
+         			'malloc'	=> DEFAULT_ON,
 	 		   },
-       	 'void'		=> DEFAULT_OFF,
-       	 'recursion'	=> DEFAULT_OFF,
-       	 'redefine'	=> DEFAULT_OFF,
-       	 'numeric'	=> DEFAULT_OFF,
-         'uninitialized'=> DEFAULT_OFF,
-       	 'once'		=> DEFAULT_OFF,
-       	 'misc'		=> DEFAULT_OFF,
+       	'void'		=> DEFAULT_OFF,
+       	'recursion'	=> DEFAULT_OFF,
+       	'redefine'	=> DEFAULT_OFF,
+       	'numeric'	=> DEFAULT_OFF,
+        'uninitialized'	=> DEFAULT_OFF,
+       	'once'		=> DEFAULT_OFF,
+       	'misc'		=> DEFAULT_OFF,
+       	'regexp'	=> DEFAULT_OFF,
+       	'glob'		=> DEFAULT_OFF,
+       	'y2k'		=> DEFAULT_OFF,
+       	'chmod'		=> DEFAULT_OFF,
+       	'umask'		=> DEFAULT_OFF,
+       	'untie'		=> DEFAULT_OFF,
+	'substr'	=> DEFAULT_OFF,
+	'taint'		=> DEFAULT_OFF,
+	'signal'	=> DEFAULT_OFF,
+	'closure'	=> DEFAULT_OFF,
+	'overflow'	=> DEFAULT_OFF,
+	'portable'	=> DEFAULT_OFF,
+	'utf8'		=> DEFAULT_OFF,
+       	'exiting'	=> DEFAULT_OFF,
+       	'pack'		=> DEFAULT_OFF,
+       	'unpack'	=> DEFAULT_OFF,
        	 #'default'	=> DEFAULT_ON,
 	} ;
 
@@ -103,6 +112,32 @@ sub mkRange
 }
 
 ###########################################################################
+sub printTree
+{
+    my $tre = shift ;
+    my $prefix = shift ;
+    my $indent = shift ;
+    my ($k, $v) ;
+
+    my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
+
+    $prefix .= " " x $indent ;
+    foreach $k (sort keys %$tre) {
+	$v = $tre->{$k};
+	print $prefix . "|\n" ;
+	print $prefix . "+- $k" ;
+	if (ref $v)
+	{ 
+	    print " " . "-" x ($max - length $k ) . "+\n" ;
+	    printTree ($v, $prefix . "|" , $max + $indent - 1) 
+	}
+	else
+	  { print "\n" }
+    }
+
+}
+
+###########################################################################
 
 sub mkHex
 {
@@ -124,6 +159,12 @@ sub mkHex
 
 ###########################################################################
 
+if (@ARGV && $ARGV[0] eq "tree")
+{
+    print "  all -+\n" ;
+    printTree($tree, "   ", 4) ;
+    exit ;
+}
 
 #unlink "warnings.h";
 #unlink "lib/warnings.pm";
@@ -150,8 +191,8 @@ print WARN <<'EOM' ;
 #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 WARN_ALL		(Nullsv+1)	/* use warnings 'all' */
+#define WARN_NONE		(Nullsv+2)	/* no  warnings 'all' */
 
 #define specialWARN(x)		((x) == WARN_STD || (x) == WARN_ALL ||	\
 				 (x) == WARN_NONE)
@@ -255,6 +296,7 @@ foreach $k (sort keys  %list) {
 }
 
 print PM "  );\n\n" ;
+print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
 while (<DATA>) {
     print PM $_ ;
 }
@@ -281,13 +323,35 @@ warnings - Perl pragma to control optional warnings
     use warnings "all";
     no warnings "all";
 
+    if (warnings::enabled("void") {
+        warnings::warn("void", "some warning");
+    }
+
 =head1 DESCRIPTION
 
 If no import list is supplied, all possible warnings are either enabled
 or disabled.
 
-See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
+Two functions are provided to assist module authors.
+
+=over 4
+
+=item warnings::enabled($category)
+
+Returns TRUE if the warnings category in C<$category> is enabled in the
+calling module. Otherwise returns FALSE.
+
+
+=item warnings::warn($category, $message)
+
+If the calling module has I<not> set C<$category> to "FATAL", print
+C<$message> to STDERR.
+If the calling module has set C<$category> to "FATAL", print C<$message>
+STDERR then die.
 
+=back
+
+See L<perlmod/Pragmatic Modules> and L<perllexwarn>.
 
 =cut
 
@@ -300,14 +364,15 @@ sub bits {
     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 ;
+	if  ($word eq 'FATAL') {
+	    $fatal = 1;
+	}
+	else {
+	    if ($catmask = $Bits{$word}) {
+		$mask |= $catmask ;
+		$mask |= $DeadBits{$word} if $fatal ;
+	    }
 	}
-	else
-	  { croak "unknown warning category '$word'" }
     }
 
     return $mask ;
@@ -315,22 +380,44 @@ sub bits {
 
 sub import {
     shift;
-    ${^Warnings} |= bits(@_ ? @_ : 'all') ;
+    ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
 }
 
 sub unimport {
     shift;
-    ${^Warnings} &= ~ bits(@_ ? @_ : 'all') ;
+    ${^WARNING_BITS} &= ~ bits(@_ ? @_ : 'all') ;
 }
 
 sub enabled
 {
-    my $string = shift ;
-
+    # If no parameters, check for any lexical warnings enabled
+    # in the users scope.
+    my $callers_bitmask = (caller(1))[9] ; 
+    return ($callers_bitmask ne $NONE) if @_ == 0 ;
+
+    # otherwise check for the category supplied.
+    my $category = shift ;
+    return 0
+	unless $Bits{$category} ;
+    return 0 unless defined $callers_bitmask ;
     return 1
-	if $bits{$string} && ${^Warnings} & $bits{$string} ;
+	if ($callers_bitmask & $Bits{$category}) ne $NONE ;
    
     return 0 ; 
 }
 
+sub warn
+{
+    croak "Usage: warnings::warn('category', 'message')"
+	unless @_ == 2 ;
+    my $category = shift ;
+    my $message = shift ;
+    local $Carp::CarpLevel = 1 ;
+    my $callers_bitmask = (caller(1))[9] ; 
+    croak($message) 
+	if defined $callers_bitmask &&
+           ($callers_bitmask & $DeadBits{$category}) ne $NONE ;
+    carp($message) ;
+}
+
 1;