In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/572bfd364a342a66f375085e1dff02253f3de103?hp=3167abe51b640d3c3589b1f66145bedb05d9405f>
- Log -----------------------------------------------------------------
commit 572bfd364a342a66f375085e1dff02253f3de103
Author: Ricardo Signes <r...@cpan.org>
Date: Wed Sep 8 16:40:26 2010 -0400
improve registration of warning categories
1. &warnings::register is added as the public mechanism for adding
new warning categories, rather than warnings::register::import
knowing about warnings's internals
2. warnings::register::import is updated to use &warnings::register
3. warnings::register::import can take a list of subcategories
The upshot is that you can now write:
package MyTool;
use warnings::register qw(io typos);
warnings::warnif('MyTool::io', $message);
...and tools that register new warnings categories do not need to cargo cult
code from warnings/register.pm
-----------------------------------------------------------------------
Summary of changes:
lib/warnings.pm | 33 +++++++++++++++++++++++++++++++++
lib/warnings/register.pm | 17 +++++++----------
pod/perllexwarn.pod | 10 ++++++++++
t/lib/warnings/9enabled | 18 ++++++++++++++++++
4 files changed, 68 insertions(+), 10 deletions(-)
diff --git a/lib/warnings.pm b/lib/warnings.pm
index eedbc32..e01027e 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -153,6 +153,12 @@ Equivalent to:
if (warnings::enabled($object))
{ warnings::warn($object, $message) }
+
+=item warnings::register(@names)
+
+This registers warning categories for the given names and is primarily for
+use by the warnings::register pragma, for which see L<perllexwarn>.
+
=back
See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
@@ -490,6 +496,33 @@ sub __chk
Carp::carp($message);
}
+sub _mkMask
+{
+ my ($bit) = @_;
+ my $mask = "";
+
+ vec($mask, $bit, 1) = 1;
+ return $mask;
+}
+
+sub register
+{
+ my @names = @_;
+
+ for my $name (@names) {
+ if (! defined $Bits{$name}) {
+ $Bits{$name} = _mkMask($LAST_BIT);
+ vec($Bits{'all'}, $LAST_BIT, 1) = 1;
+ $Offsets{$name} = $LAST_BIT ++;
+ foreach my $k (keys %Bits) {
+ vec($Bits{$k}, $LAST_BIT, 1) = 0;
+ }
+ $DeadBits{$name} = _mkMask($LAST_BIT);
+ vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
+ }
+ }
+}
+
sub _error_loc {
require Carp;
goto &Carp::short_error_loc; # don't introduce another stack frame
diff --git a/lib/warnings/register.pm b/lib/warnings/register.pm
index 57c865d..4cf93b2 100644
--- a/lib/warnings/register.pm
+++ b/lib/warnings/register.pm
@@ -23,6 +23,8 @@ usage.
require warnings;
+# left here as cruft in case other users were using this undocumented routine
+# -- rjbs, 2010-09-08
sub mkMask
{
my ($bit) = @_;
@@ -35,17 +37,12 @@ sub mkMask
sub import
{
shift;
+ my @categories = @_;
+
my $package = (caller(0))[0];
- if (! defined $warnings::Bits{$package}) {
- $warnings::Bits{$package} = mkMask($warnings::LAST_BIT);
- vec($warnings::Bits{'all'}, $warnings::LAST_BIT, 1) = 1;
- $warnings::Offsets{$package} = $warnings::LAST_BIT ++;
- foreach my $k (keys %warnings::Bits) {
- vec($warnings::Bits{$k}, $warnings::LAST_BIT, 1) = 0;
- }
- $warnings::DeadBits{$package} = mkMask($warnings::LAST_BIT);
- vec($warnings::DeadBits{'all'}, $warnings::LAST_BIT++, 1) = 1;
- }
+ warnings::register($package);
+
+ warnings::register($package . "::$_") for @categories;
}
1;
diff --git a/pod/perllexwarn.pod b/pod/perllexwarn.pod
index 835914e..ab71729 100644
--- a/pod/perllexwarn.pod
+++ b/pod/perllexwarn.pod
@@ -520,6 +520,16 @@ a warning.
Notice also that the warning is reported at the line where the object is first
used.
+When registering new categories of warning, you can supply more names to
+warnings::register like this:
+
+ package MyModule;
+ use warnings::register qw(format precision);
+
+ ...
+
+ warnings::warnif('MyModule::format', '...');
+
=head1 SEE ALSO
L<warnings>, L<perldiag>.
diff --git a/t/lib/warnings/9enabled b/t/lib/warnings/9enabled
index a535689..68b0a27 100644
--- a/t/lib/warnings/9enabled
+++ b/t/lib/warnings/9enabled
@@ -1181,6 +1181,24 @@ my message 2 at - line 8
my message 4 at - line 8
########
+--FILE-- abc52.pm
+package abc52 ;
+use warnings::register ('foo', 'bar');
+sub check {
+ warnings::warnif('abc52', "hello");
+ warnings::warnif('abc52::foo', "hello foo");
+ warnings::warnif('abc52::bar', "hello bar");
+}
+1;
+--FILE--
+use abc52;
+use warnings("abc52", "abc52::bar");
+abc52::check() ;
+EXPECT
+hello at - line 3
+hello bar at - line 3
+########
+
--FILE--
# test for bug [perl #15395]
my ( $warn_cat, # warning category we'll try to control
--
Perl5 Master Repository
