[Summary view] [Print] [Text view]

   1  package warnings::register;
   2  
   3  our $VERSION = '1.01';
   4  
   5  =pod
   6  
   7  =head1 NAME
   8  
   9  warnings::register - warnings import function
  10  
  11  =head1 SYNOPSIS
  12  
  13      use warnings::register;
  14  
  15  =head1 DESCRIPTION
  16  
  17  Creates a warnings category with the same name as the current package.
  18  
  19  See L<warnings> and L<perllexwarn> for more information on this module's
  20  usage.
  21  
  22  =cut
  23  
  24  require warnings;
  25  
  26  sub mkMask
  27  {
  28      my ($bit) = @_;
  29      my $mask = "";
  30  
  31      vec($mask, $bit, 1) = 1;
  32      return $mask;
  33  }
  34  
  35  sub import
  36  {
  37      shift;
  38      my $package = (caller(0))[0];
  39      if (! defined $warnings::Bits{$package}) {
  40          $warnings::Bits{$package}     = mkMask($warnings::LAST_BIT);
  41          vec($warnings::Bits{'all'}, $warnings::LAST_BIT, 1) = 1;
  42          $warnings::Offsets{$package}  = $warnings::LAST_BIT ++;
  43      foreach my $k (keys %warnings::Bits) {
  44          vec($warnings::Bits{$k}, $warnings::LAST_BIT, 1) = 0;
  45      }
  46          $warnings::DeadBits{$package} = mkMask($warnings::LAST_BIT);
  47          vec($warnings::DeadBits{'all'}, $warnings::LAST_BIT++, 1) = 1;
  48      }
  49  }
  50  
  51  1;