X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=warnings.pl;h=75778a159b3b7ac941a7739f481d2230465d839d;hb=ee81c259faf9e316776482a11aef47426ac2fdab;hp=61602d5608abd8ab19cc83325b6e133ea9738833;hpb=d3a7d8c7d7e4d69d7d81e4e3e900ec57f07ca07c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/warnings.pl b/warnings.pl index 61602d5..75778a1 100644 --- a/warnings.pl +++ b/warnings.pl @@ -1,5 +1,8 @@ #!/usr/bin/perl + +$VERSION = '1.00'; + BEGIN { push @INC, './lib'; } @@ -10,58 +13,60 @@ sub DEFAULT_OFF () { 2 } my $tree = { -'all' => { - 'io' => { 'pipe' => DEFAULT_OFF, - 'unopened' => DEFAULT_OFF, - 'closed' => DEFAULT_OFF, - 'newline' => DEFAULT_OFF, - 'exec' => DEFAULT_OFF, - }, - 'syntax' => { 'ambiguous' => DEFAULT_OFF, - 'semicolon' => DEFAULT_OFF, - 'precedence' => DEFAULT_OFF, - 'bareword' => DEFAULT_OFF, - 'reserved' => DEFAULT_OFF, - 'digit' => DEFAULT_OFF, - 'parenthesis' => DEFAULT_OFF, - 'deprecated' => DEFAULT_OFF, - 'printf' => DEFAULT_OFF, - 'prototype' => DEFAULT_OFF, - 'qw' => DEFAULT_OFF, - }, - '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, - '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, - } +'all' => [ 5.008, { + 'io' => [ 5.008, { + 'pipe' => [ 5.008, DEFAULT_OFF], + 'unopened' => [ 5.008, DEFAULT_OFF], + 'closed' => [ 5.008, DEFAULT_OFF], + 'newline' => [ 5.008, DEFAULT_OFF], + 'exec' => [ 5.008, DEFAULT_OFF], + 'layer' => [ 5.008, DEFAULT_OFF], + }], + 'syntax' => [ 5.008, { + 'ambiguous' => [ 5.008, DEFAULT_OFF], + 'semicolon' => [ 5.008, DEFAULT_OFF], + 'precedence' => [ 5.008, DEFAULT_OFF], + 'bareword' => [ 5.008, DEFAULT_OFF], + 'reserved' => [ 5.008, DEFAULT_OFF], + 'digit' => [ 5.008, DEFAULT_OFF], + 'parenthesis' => [ 5.008, DEFAULT_OFF], + 'printf' => [ 5.008, DEFAULT_OFF], + 'prototype' => [ 5.008, DEFAULT_OFF], + 'qw' => [ 5.008, DEFAULT_OFF], + }], + 'severe' => [ 5.008, { + 'inplace' => [ 5.008, DEFAULT_ON], + 'internal' => [ 5.008, DEFAULT_ON], + 'debugging' => [ 5.008, DEFAULT_ON], + 'malloc' => [ 5.008, DEFAULT_ON], + }], + 'deprecated' => [ 5.008, DEFAULT_OFF], + 'void' => [ 5.008, DEFAULT_OFF], + 'recursion' => [ 5.008, DEFAULT_OFF], + 'redefine' => [ 5.008, DEFAULT_OFF], + 'numeric' => [ 5.008, DEFAULT_OFF], + 'uninitialized' => [ 5.008, DEFAULT_OFF], + 'once' => [ 5.008, DEFAULT_OFF], + 'misc' => [ 5.008, DEFAULT_OFF], + 'regexp' => [ 5.008, DEFAULT_OFF], + 'glob' => [ 5.008, DEFAULT_OFF], + 'y2k' => [ 5.008, DEFAULT_OFF], + 'untie' => [ 5.008, DEFAULT_OFF], + 'substr' => [ 5.008, DEFAULT_OFF], + 'taint' => [ 5.008, DEFAULT_OFF], + 'signal' => [ 5.008, DEFAULT_OFF], + 'closure' => [ 5.008, DEFAULT_OFF], + 'overflow' => [ 5.008, DEFAULT_OFF], + 'portable' => [ 5.008, DEFAULT_OFF], + 'utf8' => [ 5.008, DEFAULT_OFF], + 'exiting' => [ 5.008, DEFAULT_OFF], + 'pack' => [ 5.008, DEFAULT_OFF], + 'unpack' => [ 5.008, DEFAULT_OFF], + 'threads' => [ 5.008, DEFAULT_OFF], + #'default' => [ 5.008, DEFAULT_ON ], + }], } ; - ########################################################################### sub tab { my($l, $t) = @_; @@ -73,8 +78,49 @@ sub tab { my %list ; my %Value ; +my %ValueToName ; +my %NameToValue ; my $index ; +my %v_list = () ; + +sub valueWalk +{ + 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} ; + die "Value associated with key '$k' is not an ARRAY reference" + if !ref $v || ref $v ne 'ARRAY' ; + + my ($ver, $rest) = @{ $v } ; + push @{ $v_list{$ver} }, $k; + + if (ref $rest) + { valueWalk ($rest) } + + } + +} + +sub orderValues +{ + my $index = 0; + foreach my $ver ( sort { $a <=> $b } keys %v_list ) { + foreach my $name (@{ $v_list{$ver} } ) { + $ValueToName{ $index } = [ uc $name, $ver ] ; + $NameToValue{ uc $name } = $index ++ ; + } + } + + return $index ; +} + +########################################################################### + sub walk { my $tre = shift ; @@ -84,10 +130,17 @@ sub walk 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)) } + #$Value{$index} = uc $k ; + die "Can't find key '$k'" + if ! defined $NameToValue{uc $k} ; + push @{ $list{$k} }, $NameToValue{uc $k} ; + die "Value associated with key '$k' is not an ARRAY reference" + if !ref $v || ref $v ne 'ARRAY' ; + + my ($ver, $rest) = @{ $v } ; + if (ref $rest) + { push (@{ $list{$k} }, walk ($rest)) } + push @list, @{ $list{$k} } ; } @@ -104,7 +157,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] ; } @@ -119,20 +172,33 @@ sub printTree { my $tre = shift ; my $prefix = shift ; - my $indent = shift ; my ($k, $v) ; my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ; + my @keys = sort keys %$tre ; - $prefix .= " " x $indent ; - foreach $k (sort keys %$tre) { + while ($k = shift @keys) { $v = $tre->{$k}; - print $prefix . "|\n" ; - print $prefix . "+- $k" ; - if (ref $v) - { - print " " . "-" x ($max - length $k ) . "+\n" ; - printTree ($v, $prefix . "|" , $max + $indent - 1) + die "Value associated with key '$k' is not an ARRAY reference" + if !ref $v || ref $v ne 'ARRAY' ; + + my $offset ; + if ($tre ne $tree) { + print $prefix . "|\n" ; + print $prefix . "+- $k" ; + $offset = ' ' x ($max + 4) ; + } + else { + print $prefix . "$k" ; + $offset = ' ' x ($max + 1) ; + } + + my ($ver, $rest) = @{ $v } ; + if (ref $rest) + { + my $bar = @keys ? "|" : " "; + print " -" . "-" x ($max - length $k ) . "+\n" ; + printTree ($rest, $prefix . $bar . $offset ) } else { print "\n" } @@ -142,9 +208,9 @@ sub printTree ########################################################################### -sub mkHex +sub mkHexOct { - my ($max, @a) = @_ ; + my ($f, $max, @a) = @_ ; my $mask = "\x00" x $max ; my $string = "" ; @@ -152,25 +218,39 @@ 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") { - #print " all -+\n" ; - printTree($tree, " ", 4) ; + printTree($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"; @@ -199,60 +279,33 @@ print WARN <<'EOM' ; #define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \ (x) == pWARN_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 != pWARN_STD && \ - PL_curcop->cop_warnings != pWARN_NONE && \ - (PL_curcop->cop_warnings == pWARN_ALL || \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \ - || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) ) - -#define ckWARN2(x,y) \ - ( (PL_curcop->cop_warnings != pWARN_STD && \ - PL_curcop->cop_warnings != pWARN_NONE && \ - (PL_curcop->cop_warnings == pWARN_ALL || \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \ - || (PL_curcop->cop_warnings == pWARN_STD && PL_dowarn & G_WARN_ON) ) - -#define ckWARN_d(x) \ - (PL_curcop->cop_warnings == pWARN_STD || \ - PL_curcop->cop_warnings == pWARN_ALL || \ - (PL_curcop->cop_warnings != pWARN_NONE && \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) - -#define ckWARN2_d(x,y) \ - (PL_curcop->cop_warnings == pWARN_STD || \ - PL_curcop->cop_warnings == pWARN_ALL || \ - (PL_curcop->cop_warnings != pWARN_NONE && \ - (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ - IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) ) - - -#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD) -#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD) -#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) -#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) - EOM my $offset = 0 ; $index = $offset ; #@{ $list{"all"} } = walk ($tree) ; -walk ($tree) ; +valueWalk ($tree) ; +my $index = orderValues(); + +die < 255 ; +Too many warnings categories -- max is 255 + rewrite packWARN* & unpackWARN* macros +EOM +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" ; +my $last_ver = 0; +foreach $k (sort { $a <=> $b } keys %ValueToName) { + my ($name, $version) = @{ $ValueToName{$k} }; + print WARN "\n/* Warnings Categories added in Perl $version */\n\n" + if $last_ver != $version ; + print WARN tab(5, "#define WARN_$name"), "$k\n" ; + $last_ver = $version ; } print WARN "\n" ; @@ -260,9 +313,92 @@ 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'; +#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD) +#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD) +#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) +#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) +#define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1)) + +#define ckWARN(x) \ + ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \ + (PL_curcop->cop_warnings == pWARN_ALL || \ + isWARN_on(PL_curcop->cop_warnings, x) ) ) \ + || (isLEXWARN_off && PL_dowarn & G_WARN_ON) ) + +#define ckWARN2(x,y) \ + ( (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) ) ) \ + || (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 && \ + isWARN_on(PL_curcop->cop_warnings, x) ) ) + +#define ckWARN2_d(x,y) \ + (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) ) ) ) + +#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 @@ -276,13 +412,19 @@ while () { #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ; -#my %Keys = map {lc $Value{$_}, $_} keys %Value ; - +$last_ver = 0; print PM "%Offsets = (\n" ; -foreach my $k (sort { $a <=> $b } keys %Value) { - my $v = lc $Value{$k} ; +foreach my $k (sort { $a <=> $b } keys %ValueToName) { + my ($name, $version) = @{ $ValueToName{$k} }; + $name = lc $name; $k *= 2 ; - print PM tab(4, " '$v'"), "=> $k,\n" ; + if ( $last_ver != $version ) { + print PM "\n"; + print PM tab(4, " # Warnings Categories added in Perl $version"); + print PM "\n\n"; + } + print PM tab(4, " '$name'"), "=> $k,\n" ; + $last_ver = $version; } print PM " );\n\n" ; @@ -293,9 +435,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" ; } @@ -307,9 +449,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" ; } @@ -325,12 +467,15 @@ close PM ; __END__ +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! # This file was created by warnings.pl # Any changes made here will be lost. # package warnings; +our $VERSION = '1.00'; + =head1 NAME warnings - Perl pragma to control optional warnings @@ -352,41 +497,101 @@ warnings - Perl pragma to control optional warnings warnings::warn("void", "some warning"); } + if (warnings::enabled($object)) { + warnings::warn($object, "some warning"); + } + + warnings::warnif("some warning"); + warnings::warnif("void", "some warning"); + warnings::warnif($object, "some warning"); + =head1 DESCRIPTION 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 =item use warnings::register -Creates a new warnings category which has the same name as the module -where the call to the pragma is used. +Creates a new warnings category with the same name as the package where +the call to the pragma is used. + +=item warnings::enabled() + +Use the warnings category with the same name as the current package. + +Return TRUE if that warnings category is enabled in the calling module. +Otherwise returns FALSE. + +=item warnings::enabled($category) -=item warnings::enabled([$category]) +Return TRUE if the warnings category, C<$category>, is enabled in the +calling module. +Otherwise returns FALSE. -Returns TRUE if the warnings category C<$category> is enabled in the -calling module. Otherwise returns FALSE. +=item warnings::enabled($object) -If the parameter, C<$category>, isn't supplied, the current package name -will be used. +Use the name of the class for the object reference, C<$object>, as the +warnings category. -=item warnings::warn([$category,] $message) +Return TRUE if that warnings category is enabled in the first scope +where the object is used. +Otherwise returns FALSE. -If the calling module has I 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. +=item warnings::warn($message) -If the parameter, C<$category>, isn't supplied, the current package name -will be used. +Print C<$message> to STDERR. + +Use the warnings category with the same name as the current package. + +If that warnings category has been set to "FATAL" in the calling module +then die. Otherwise return. + +=item warnings::warn($category, $message) + +Print C<$message> to STDERR. + +If the warnings category, C<$category>, has been set to "FATAL" in the +calling module then die. Otherwise return. + +=item warnings::warn($object, $message) + +Print C<$message> to STDERR. + +Use the name of the class for the object reference, C<$object>, as the +warnings category. + +If that warnings category has been set to "FATAL" in the scope where C<$object> +is first used then die. Otherwise return. + + +=item warnings::warnif($message) + +Equivalent to: + + if (warnings::enabled()) + { warnings::warn($message) } + +=item warnings::warnif($category, $message) + +Equivalent to: + + if (warnings::enabled($category)) + { warnings::warn($category, $message) } + +=item warnings::warnif($object, $message) + +Equivalent to: + + if (warnings::enabled($object)) + { warnings::warn($object, $message) } =back -See L and L. +See L and L. =cut @@ -396,6 +601,12 @@ KEYWORDS $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; +sub Croaker +{ + delete $Carp::CarpInternal{'warnings'}; + croak @_ ; +} + sub bits { my $mask ; my $catmask ; @@ -409,7 +620,7 @@ sub bits { $mask |= $DeadBits{$word} if $fatal ; } else - { croak("unknown warnings category '$word'")} + { Croaker("Unknown warnings category '$word'")} } return $mask ; @@ -417,44 +628,80 @@ 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 enabled +sub __chk { - croak("Usage: warnings::enabled([category])") - unless @_ == 1 || @_ == 0 ; - local $Carp::CarpLevel = 1 ; my $category ; my $offset ; - my $callers_bitmask = (caller(1))[9] ; - return 0 unless defined $callers_bitmask ; - + my $isobj = 0 ; if (@_) { # check the category supplied. $category = shift ; + if (ref $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(0))[0] ; + $category = (caller(1))[0] ; $offset = $Offsets{$category}; - croak("package '$category' not registered for warnings") + Croaker("package '$category' not registered for warnings") unless defined $offset ; } + my $this_pkg = (caller(1))[0] ; + my $i = 2 ; + my $pkg ; + + if ($isobj) { + while (do { { package DB; $pkg = (caller($i++))[0] } } ) { + last unless @DB::args && $DB::args[0] =~ /^$category=/ ; + } + $i -= 2 ; + } + else { + for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) { + last if $pkg ne $this_pkg ; + } + $i = 2 + if !$pkg || $pkg eq $this_pkg ; + } + + my $callers_bitmask = (caller($i))[9] ; + return ($callers_bitmask, $offset, $i) ; +} + +sub enabled +{ + Croaker("Usage: warnings::enabled([category])") + unless @_ == 1 || @_ == 0 ; + + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + + return 0 unless defined $callers_bitmask ; return vec($callers_bitmask, $offset, 1) || vec($callers_bitmask, $Offsets{'all'}, 1) ; } @@ -462,30 +709,34 @@ sub enabled sub warn { - croak("Usage: warnings::warn([category,] 'message')") + Croaker("Usage: warnings::warn([category,] 'message')") unless @_ == 2 || @_ == 1 ; - local $Carp::CarpLevel = 1 ; - my $category ; - my $offset ; - my $callers_bitmask = (caller(1))[9] ; - if (@_ == 2) { - $category = shift ; - $offset = $Offsets{$category}; - croak("unknown warnings category '$category'") - unless defined $offset ; - } - else { - $category = (caller(0))[0] ; - $offset = $Offsets{$category}; - croak("package '$category' not registered for warnings") - unless defined $offset ; - } + my $message = pop ; + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + croak($message) + if vec($callers_bitmask, $offset+1, 1) || + vec($callers_bitmask, $Offsets{'all'}+1, 1) ; + carp($message) ; +} + +sub warnif +{ + Croaker("Usage: warnings::warnif([category,] 'message')") + unless @_ == 2 || @_ == 1 ; + + my $message = pop ; + my ($callers_bitmask, $offset, $i) = __chk(@_) ; - my $message = shift ; - croak($message) + return + unless defined $callers_bitmask && + (vec($callers_bitmask, $offset, 1) || + vec($callers_bitmask, $Offsets{'all'}, 1)) ; + + croak($message) if vec($callers_bitmask, $offset+1, 1) || vec($callers_bitmask, $Offsets{'all'}+1, 1) ; + carp($message) ; }