cosmetic OS/2 patches

[perl5.git] / warnings.pl

diff --git a/warnings.pl b/warnings.pl
index 4be4280..e5ac703 100644 (file)
--- a/warnings.pl
+++ b/warnings.pl
@@ -1,5 +1,8 @@
 #!/usr/bin/perl
 
+
+$VERSION = '1.00';
+
 BEGIN {
   push @INC, './lib';
 }
@@ -44,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,
@@ -104,7 +105,7 @@ sub mkRange
 
 
     for ($i = 1 ; $i < @a; ++ $i) {
-       $out[$i] = ".." 
+       $out[$i] = ".."
           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
     }
 
@@ -130,9 +131,9 @@ sub printTree
        print $prefix . "|\n" ;
        print $prefix . "+- $k" ;
        if (ref $v)
-       { 
+       {
            print " " . "-" x ($max - length $k ) . "+\n" ;
-           printTree ($v, $prefix . "|" , $max + $indent - 1) 
+           printTree ($v, $prefix . "|" , $max + $indent - 1)
        }
        else
          { print "\n" }
@@ -142,9 +143,9 @@ sub printTree
 
 ###########################################################################
 
-sub mkHex
+sub mkHexOct
 {
-    my ($max, @a) = @_ ;
+    my ($f, $max, @a) = @_ ;
     my $mask = "\x00" x $max ;
     my $string = "" ;
 
@@ -152,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")
@@ -169,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";
 
@@ -221,6 +237,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';
 
@@ -289,9 +308,9 @@ 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), 
+    print PM tab(4, "    '$k'"), '=> "',
+               # mkHex($warn_size, @list),
+               mkHex($warn_size, map $_ * 2 , @list),
                '", # [', mkRange(@list), "]\n" ;
 }
 
@@ -303,9 +322,9 @@ 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), 
+    print PM tab(4, "    '$k'"), '=> "',
+               # mkHex($warn_size, @list),
+               mkHex($warn_size, map $_ * 2 + 1 , @list),
                '", # [', mkRange(@list), "]\n" ;
 }
 
@@ -327,6 +346,8 @@ __END__
 
 package warnings;
 
+our $VERSION = '1.00';
+
 =head1 NAME
 
 warnings - Perl pragma to control optional warnings
@@ -361,7 +382,7 @@ warnings - Perl pragma to control optional warnings
 If no import list is supplied, all possible warnings are either enabled
 or disabled.
 
-A number of functions are provided to assist module authors. 
+A number of functions are provided to assist module authors.
 
 =over 4
 
@@ -465,7 +486,7 @@ sub bits {
            $mask |= $DeadBits{$word} if $fatal ;
        }
        else
-          { croak("unknown warnings category '$word'")}  
+          { croak("Unknown warnings category '$word'")}
     }
 
     return $mask ;
@@ -473,17 +494,22 @@ sub bits {
 
 sub import {
     shift;
-    ${^WARNING_BITS} |= bits(@_ ? @_ : 'all') ;
+    my $mask = ${^WARNING_BITS} ;
+    if (vec($mask, $Offsets{'all'}, 1)) {
+        $mask |= $Bits{'all'} ;
+        $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
+    }
+    ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
 }
 
 sub unimport {
     shift;
     my $mask = ${^WARNING_BITS} ;
     if (vec($mask, $Offsets{'all'}, 1)) {
-        $mask = $Bits{'all'} ;
+        $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
@@ -497,22 +523,22 @@ sub __chk
         $category = shift ;
         if (ref $category) {
             croak ("not an object")
-                if $category !~ /^([^=]+)=/ ;+
+                if $category !~ /^([^=]+)=/ ;
            $category = $1 ;
             $isobj = 1 ;
         }
         $offset = $Offsets{$category};
-        croak("unknown warnings category '$category'")
+        croak("Unknown warnings category '$category'")
            unless defined $offset;
     }
     else {
-        $category = (caller(1))[0] ; 
+        $category = (caller(1))[0] ;
         $offset = $Offsets{$category};
         croak("package '$category' not registered for warnings")
            unless defined $offset ;
     }
 
-    my $this_pkg = (caller(1))[0] ; 
+    my $this_pkg = (caller(1))[0] ;
     my $i = 2 ;
     my $pkg ;
 
@@ -526,11 +552,11 @@ sub __chk
         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
             last if $pkg ne $this_pkg ;
         }
-        $i = 2 
+        $i = 2
             if !$pkg || $pkg eq $this_pkg ;
     }
 
-    my $callers_bitmask = (caller($i))[9] ; 
+    my $callers_bitmask = (caller($i))[9] ;
     return ($callers_bitmask, $offset, $i) ;
 }
 
@@ -555,7 +581,7 @@ sub warn
     my $message = pop ;
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
     local $Carp::CarpLevel = $i ;
-    croak($message) 
+    croak($message)
        if vec($callers_bitmask, $offset+1, 1) ||
           vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
     carp($message) ;
@@ -570,12 +596,12 @@ sub warnif
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
     local $Carp::CarpLevel = $i ;
 
-    return 
+    return
         unless defined $callers_bitmask &&
                (vec($callers_bitmask, $offset, 1) ||
                vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 
-    croak($message) 
+    croak($message)
        if vec($callers_bitmask, $offset+1, 1) ||
           vec($callers_bitmask, $Offsets{'all'}+1, 1) ;