From: Paul Marquess Date: Fri, 18 Aug 2000 22:42:06 +0000 (+0100) Subject: Add warnif(), check warnings further up the stack, X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7e6d00f88633359fc96f8d1e8d7c3aa419c0d976;p=p5sagit%2Fp5-mst-13.2.git Add warnif(), check warnings further up the stack, all the warnings functions now can take an optional object reference. Subject: [PATCH bleedperl@6691] warnings pragma update Message-ID: <000c01c0095d$278e0040$ca01073e@bfs.phone.com> p4raw-id: //depot/perl@6707 --- diff --git a/lib/Class/Struct.pm b/lib/Class/Struct.pm index 63eddac..ac1fb47 100644 --- a/lib/Class/Struct.pm +++ b/lib/Class/Struct.pm @@ -168,8 +168,7 @@ sub struct { $cnt = 0; foreach $name (@methods){ if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) { - warnings::warn "function '$name' already defined, overrides struct accessor method" - if warnings::enabled(); + warnings::warnif("function '$name' already defined, overrides struct accessor method"); } else { $pre = $pst = $cmt = $sel = ''; diff --git a/lib/Tie/Handle.pm b/lib/Tie/Handle.pm index 588ecea..42d0834 100644 --- a/lib/Tie/Handle.pm +++ b/lib/Tie/Handle.pm @@ -120,8 +120,7 @@ sub new { sub TIEHANDLE { my $pkg = shift; if (defined &{"{$pkg}::new"}) { - warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing" - if warnings::enabled(); + warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing"); $pkg->new(@_); } else { diff --git a/lib/Tie/Hash.pm b/lib/Tie/Hash.pm index c6ec3d4..2244711 100644 --- a/lib/Tie/Hash.pm +++ b/lib/Tie/Hash.pm @@ -114,8 +114,7 @@ sub new { sub TIEHASH { my $pkg = shift; if (defined &{"${pkg}::new"}) { - warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing" - if warnings::enabled(); + warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing"); $pkg->new(@_); } else { diff --git a/lib/Tie/Scalar.pm b/lib/Tie/Scalar.pm index 0c67590..89ad03e 100644 --- a/lib/Tie/Scalar.pm +++ b/lib/Tie/Scalar.pm @@ -91,8 +91,7 @@ sub new { sub TIESCALAR { my $pkg = shift; if (defined &{"{$pkg}::new"}) { - warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing" - if warnings::enabled(); + warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing"); $pkg->new(@_); } else { diff --git a/lib/fields.pm b/lib/fields.pm index ac45810..37ff99d 100644 --- a/lib/fields.pm +++ b/lib/fields.pm @@ -172,8 +172,7 @@ sub import { if ($fno and $fno != $next) { require Carp; if ($fno < $fattr->[0]) { - warnings::warn("Hides field '$f' in base class") - if warnings::enabled(); + warnings::warnif("Hides field '$f' in base class") ; } else { Carp::croak("Field name '$f' already in use"); } diff --git a/lib/syslog.pl b/lib/syslog.pl index 70c439b..f0dbb1c 100644 --- a/lib/syslog.pl +++ b/lib/syslog.pl @@ -34,7 +34,7 @@ use warnings::register; $host = 'localhost' unless $host; # set $syslog'host to change if ($] >= 5 && warnings::enabled()) { - warnings::warn "You should 'use Sys::Syslog' instead; continuing"; + warnings::warn("You should 'use Sys::Syslog' instead; continuing"); } require 'syslog.ph'; diff --git a/lib/warnings.pm b/lib/warnings.pm index ac6d919..df9f787 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -26,6 +26,14 @@ warnings - Perl pragma to control optional warnings warnings::warn("void", "some warning"); } + if (warnings::enabled($object)) { + warnings::warn($object, "some warning"); + } + + warnif("some warning"); + warnif("void", "some warning"); + warnif($object, "some warning"); + =head1 DESCRIPTION If no import list is supplied, all possible warnings are either enabled @@ -37,26 +45,78 @@ A number of functions are provided to assist module authors. =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) + +Return TRUE if the warnings category, C<$category>, is enabled in the +calling module. +Otherwise returns FALSE. + +=item warnings::enabled($object) + +Use the name of the class for the object reference, C<$object>, as the +warnings category. + +Return TRUE if that warnings category is enabled in the first scope +where the object is used. +Otherwise returns FALSE. + +=item warnings::warn($message) + +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::enabled([$category]) +=item warnings::warn($object, $message) -Returns TRUE if the warnings category C<$category> is enabled in the -calling module. Otherwise returns FALSE. +Print C<$message> to STDERR. -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) +If that warnings category has been set to "FATAL" in the scope where C<$object> +is first used then die. Otherwise return. -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. -If the parameter, C<$category>, isn't supplied, the current package name -will be used. +=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 @@ -256,31 +316,62 @@ sub unimport { ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : '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) { + croak ("not an object") + if $category !~ /^([^=]+)=/ ;+ + $category = $1 ; + $isobj = 1 ; + } $offset = $Offsets{$category}; croak("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") 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 +{ + croak("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) ; } @@ -290,29 +381,34 @@ sub warn { croak("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 = shift ; + 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) ; carp($message) ; } +sub warnif +{ + croak("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 && + (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) ; +} 1; diff --git a/pod/perllexwarn.pod b/pod/perllexwarn.pod index 0052d33..efc0196 100644 --- a/pod/perllexwarn.pod +++ b/pod/perllexwarn.pod @@ -341,7 +341,7 @@ fatal error. The C pragma provides a number of functions that are useful for module authors. These are used when you want to report a module-specific -warning when the calling module has enabled warnings via the C +warning to a calling module has enabled warnings via the C pragma. Consider the module C below. @@ -361,11 +361,11 @@ Consider the module C below. 1 ; The call to C will create a new warnings category -called "MyMod::abc", i.e. the new category name matches the module -name. The C function in the module will display a warning message -if it gets given a relative path as a parameter. This warnings will only -be displayed if the code that uses C has actually enabled -them with the C pragma like below. +called "MyMod::abc", i.e. the new category name matches the current +package name. The C function in the module will display a warning +message if it gets given a relative path as a parameter. This warnings +will only be displayed if the code that uses C has actually +enabled them with the C pragma like below. use MyMod::Abc; use warnings 'MyMod::Abc'; @@ -379,10 +379,8 @@ this snippet of code: package MyMod::Abc; sub open { - if (warnings::enabled("deprecated")) { - warnings::warn("deprecated", - "open is deprecated, use new instead") ; - } + warnings::warnif("deprecated", + "open is deprecated, use new instead") ; new(@_) ; } @@ -399,18 +397,89 @@ display a warning message whenever the calling module has (at least) the ... MyMod::Abc::open($filename) ; -The C function should be used to actually display the -warnings message. This is because they can make use of the feature that -allows warnings to be escalated into fatal errors. So in this case +Either the C or C function should be +used to actually display the warnings message. This is because they can +make use of the feature that allows warnings to be escalated into fatal +errors. So in this case use MyMod::Abc; use warnings FATAL => 'MyMod::Abc'; ... MyMod::Abc::open('../fred.txt'); -the C function will detect this and die after +the C function will detect this and die after displaying the warning message. +The three warnings functions, C, C +and C can optionally take an object reference in place +of a category name. In this case the functions will use the class name +of the object as the warnings category. + +Consider this example: + + package Original ; + + no warnings ; + use warnings::register ; + + sub new + { + my $class = shift ; + bless [], $class ; + } + + sub check + { + my $self = shift ; + my $value = shift ; + + if ($value % 2 && warnings::enabled($self)) + { warnings::warn($self, "Odd numbers are unsafe") } + } + + sub doit + { + my $self = shift ; + my $value = shift ; + $self->check($value) ; + # ... + } + + 1 ; + + package Derived ; + + use warnings::register ; + use Original ; + our @ISA = qw( Original ) ; + sub new + { + my $class = shift ; + bless [], $class ; + } + + + 1 ; + +The code below makes use of both modules, but it only enables warnings from +C. + + use Original ; + use Derived ; + use warnings 'Derived'; + my $a = new Original ; + $a->doit(1) ; + my $b = new Derived ; + $a->doit(1) ; + +When this code is run only the C object, C<$b>, will generate +a warning. + + Odd numbers are unsafe at main.pl line 7 + +Notice also that the warning is reported at the line where the object is first +used. + =head1 TODO perl5db.pl @@ -424,6 +493,8 @@ displaying the warning message. around the limitations of C<$^W>. Now that those limitations are gone, the module should be revisited. + document calling the warnings::* functions from XS + =head1 SEE ALSO L, L. diff --git a/t/pragma/warn/9enabled b/t/pragma/warn/9enabled index 96f319e..88f85d7 100755 --- a/t/pragma/warn/9enabled +++ b/t/pragma/warn/9enabled @@ -332,7 +332,17 @@ print $@ ; EXPECT Usage: warnings::warn([category,] 'message') at - line 4 unknown warnings category 'fred' at - line 6 - eval {...} called at - line 6 +######## + +# check warnings::warnif +use warnings ; +eval { warnings::warnif() } ; +print $@ ; +eval { warnings::warnif("fred", "joe") } ; +print $@ ; +EXPECT +Usage: warnings::warnif([category,] 'message') at - line 4 +unknown warnings category 'fred' at - line 6 ######## --FILE-- abc.pm @@ -373,6 +383,7 @@ eval { abc::check() ; } ; print "[[$@]]\n"; EXPECT hello at - line 3 + eval {...} called at - line 3 [[]] ######## @@ -388,6 +399,7 @@ eval { abc::check() ; } ; print "[[$@]]\n"; EXPECT [[hello at - line 3 + eval {...} called at - line 3 ]] ######## -W @@ -431,7 +443,37 @@ use warnings 'syntax' ; use abc ; abc::check() ; EXPECT -package 'abc' not registered for warnings at - line 3 +package 'abc' not registered for warnings at abc.pm line 4 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +sub check { + warnings::warn("fred") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +package 'abc' not registered for warnings at abc.pm line 4 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +sub check { + warnings::warnif("fred") ; +} +1; +--FILE-- +use warnings 'syntax' ; +use abc ; +abc::check() ; +EXPECT +package 'abc' not registered for warnings at abc.pm line 4 ######## --FILE-- abc.pm @@ -617,6 +659,7 @@ eval { abc::check() ; } ; print "[[$@]]\n"; EXPECT hello at - line 3 + eval {...} called at - line 3 [[]] ######## @@ -632,6 +675,7 @@ eval { abc::check() ; } ; print "[[$@]]\n"; EXPECT [[hello at - line 3 + eval {...} called at - line 3 ]] ######## -W @@ -723,6 +767,10 @@ sub check { print "ok1\n" if !warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; + warnings::warnif("my message 1") ; + warnings::warnif('abc', "my message 2") ; + warnings::warnif('io', "my message 3") ; + warnings::warnif('all', "my message 4") ; } 1; --FILE-- @@ -867,6 +915,10 @@ sub check { print "ok1\n" if !warnings::enabled() ; print "ok2\n" if !warnings::enabled("io") ; print "ok3\n" if !warnings::enabled("all") ; + warnings::warnif("my message 1") ; + warnings::warnif('abc', "my message 2") ; + warnings::warnif('io', "my message 3") ; + warnings::warnif('all', "my message 4") ; } 1; --FILE-- @@ -901,3 +953,206 @@ EXPECT ok1 ok2 ok3 +######## + +--FILE-- abc.pm +package abc ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + print "ok4\n" if warnings::enabled("abc") ; + warnings::warn("my message 1") ; + warnings::warnif("my message 2") ; + warnings::warnif('abc', "my message 3") ; + warnings::warnif('io', "my message 4") ; + warnings::warnif('all', "my message 5") ; +} +sub in2 { no warnings ; check() } +sub in1 { no warnings ; in2() } +1; +--FILE-- +use abc ; +use warnings 'abc'; +abc::in1() ; +EXPECT +my message 1 at - line 3 +my message 2 at - line 3 +my message 3 at - line 3 +ok1 +ok2 +ok3 +ok4 +######## + +--FILE-- def.pm +package def ; +no warnings ; +use warnings::register ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + print "ok4\n" if warnings::enabled("def") ; + warnings::warn("my message 1") ; + warnings::warnif("my message 2") ; + warnings::warnif('def', "my message 3") ; + warnings::warnif('io', "my message 4") ; + warnings::warnif('all', "my message 5") ; +} +sub in2 { no warnings ; check() } +sub in1 { no warnings ; in2() } +1; +--FILE-- abc.pm +package abc ; +use def ; +use warnings 'def'; +sub in1 { def::in1() ; } +1; +--FILE-- +use abc ; +no warnings; +abc::in1() ; +EXPECT +my message 1 at abc.pm line 4 + abc::in1() called at - line 3 +my message 2 at abc.pm line 4 + abc::in1() called at - line 3 +my message 3 at abc.pm line 4 + abc::in1() called at - line 3 +ok1 +ok2 +ok3 +ok4 +######## + +--FILE-- def.pm +package def ; +no warnings ; +use warnings::register ; +require Exporter; +@ISA = qw( Exporter ) ; +@EXPORT = qw( in1 ) ; +sub check { + print "ok1\n" if warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + print "ok4\n" if warnings::enabled("abc") ; + print "ok5\n" if !warnings::enabled("def") ; + warnings::warn("my message 1") ; + warnings::warnif("my message 2") ; + warnings::warnif('abc', "my message 3") ; + warnings::warnif('def', "my message 4") ; + warnings::warnif('io', "my message 5") ; + warnings::warnif('all', "my message 6") ; +} +sub in2 { no warnings ; check() } +sub in1 { no warnings ; in2() } +1; +--FILE-- abc.pm +package abc ; +use warnings::register ; +use def ; +#@ISA = qw(def) ; +1; +--FILE-- +use abc ; +no warnings; +use warnings 'abc'; +abc::in1() ; +EXPECT +my message 1 at - line 4 +my message 3 at - line 4 +ok2 +ok3 +ok4 +ok5 +######## + +--FILE-- def.pm +package def ; +no warnings ; +use warnings::register ; + +sub new +{ + my $class = shift ; + bless [], $class ; +} + +sub check +{ + my $self = shift ; + print "ok1\n" if !warnings::enabled() ; + print "ok2\n" if !warnings::enabled("io") ; + print "ok3\n" if !warnings::enabled("all") ; + print "ok4\n" if warnings::enabled("abc") ; + print "ok5\n" if !warnings::enabled("def") ; + print "ok6\n" if warnings::enabled($self) ; + + warnings::warn("my message 1") ; + warnings::warn($self, "my message 2") ; + + warnings::warnif("my message 3") ; + warnings::warnif('abc', "my message 4") ; + warnings::warnif('def', "my message 5") ; + warnings::warnif('io', "my message 6") ; + warnings::warnif('all', "my message 7") ; + warnings::warnif($self, "my message 8") ; +} +sub in2 +{ + no warnings ; + my $self = shift ; + $self->check() ; +} +sub in1 +{ + no warnings ; + my $self = shift ; + $self->in2(); +} +1; +--FILE-- abc.pm +package abc ; +use warnings::register ; +use def ; +@ISA = qw(def) ; +sub new +{ + my $class = shift ; + bless [], $class ; +} + +1; +--FILE-- +use abc ; +no warnings; +use warnings 'abc'; +$a = new abc ; +$a->in1() ; +print "**\n"; +$b = new def ; +$b->in1() ; +EXPECT +my message 1 at - line 5 +my message 2 at - line 5 +my message 4 at - line 5 +my message 8 at - line 5 +my message 1 at - line 8 +my message 2 at - line 8 +my message 4 at - line 8 +ok1 +ok2 +ok3 +ok4 +ok5 +ok6 +** +ok1 +ok2 +ok3 +ok4 +ok5 diff --git a/warnings.pl b/warnings.pl index 0e74f3d..4be4280 100644 --- a/warnings.pl +++ b/warnings.pl @@ -348,6 +348,14 @@ warnings - Perl pragma to control optional warnings warnings::warn("void", "some warning"); } + if (warnings::enabled($object)) { + warnings::warn($object, "some warning"); + } + + warnif("some warning"); + warnif("void", "some warning"); + warnif($object, "some warning"); + =head1 DESCRIPTION If no import list is supplied, all possible warnings are either enabled @@ -359,26 +367,78 @@ A number of functions are provided to assist module authors. =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) + +Return TRUE if the warnings category, C<$category>, is enabled in the +calling module. +Otherwise returns FALSE. + +=item warnings::enabled($object) + +Use the name of the class for the object reference, C<$object>, as the +warnings category. + +Return TRUE if that warnings category is enabled in the first scope +where the object is used. +Otherwise returns FALSE. + +=item warnings::warn($message) + +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::enabled([$category]) +=item warnings::warn($object, $message) -Returns TRUE if the warnings category C<$category> is enabled in the -calling module. Otherwise returns FALSE. +Print C<$message> to STDERR. -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) +If that warnings category has been set to "FATAL" in the scope where C<$object> +is first used then die. Otherwise return. -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. -If the parameter, C<$category>, isn't supplied, the current package name -will be used. +=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 @@ -426,31 +486,62 @@ sub unimport { ${^WARNING_BITS} = $mask & ~ (bits(@_ ? @_ : '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) { + croak ("not an object") + if $category !~ /^([^=]+)=/ ;+ + $category = $1 ; + $isobj = 1 ; + } $offset = $Offsets{$category}; croak("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") 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 +{ + croak("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) ; } @@ -460,29 +551,34 @@ sub warn { croak("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 = shift ; + 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) ; carp($message) ; } +sub warnif +{ + croak("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 && + (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) ; +} 1;