X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=warnings.pl;h=138b1db5afb8c9b288df34ba748339d745cb70c1;hb=e42c74e1bbeb8832945ac76bd2905217353ae440;hp=0c2d2ec458ca76905856a976e04d06ecf8c2d36a;hpb=22d4bb9ccb8701e68f9243547d7e3a3c55f70908;p=p5sagit%2Fp5-mst-13.2.git diff --git a/warnings.pl b/warnings.pl index 0c2d2ec..138b1db 100644 --- a/warnings.pl +++ b/warnings.pl @@ -1,5 +1,8 @@ #!/usr/bin/perl + +$VERSION = '1.00'; + BEGIN { push @INC, './lib'; } @@ -104,7 +107,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 +133,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" } @@ -169,8 +172,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"; @@ -289,9 +292,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 +306,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 +330,8 @@ __END__ package warnings; +our $VERSION = '1.00'; + =head1 NAME warnings - Perl pragma to control optional warnings @@ -361,7 +366,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 +470,7 @@ sub bits { $mask |= $DeadBits{$word} if $fatal ; } else - { croak("unknown warnings category '$word'")} + { croak("unknown warnings category '$word'")} } return $mask ; @@ -511,13 +516,13 @@ sub __chk 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 ; @@ -531,11 +536,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) ; } @@ -560,7 +565,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) ; @@ -575,12 +580,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) ;