Convert lib/Tie/Hash/NamedCapture.pm to an XS module in ext/

[perl5.git] / lib / warnings.pm

diff --git a/lib/warnings.pm b/lib/warnings.pm
index 837718c..5aa0a9c 100644 (file)
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -1,12 +1,12 @@
 # -*- buffer-read-only: t -*-
 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
-# This file was created by warnings.pl
+# This file was created by regen/warnings.pl
 # Any changes made here will be lost.
 #
 
 package warnings;
 
-our $VERSION = '1.10';
+our $VERSION = '1.11';
 
 # Verify that we're called correctly so that warnings will work.
 # see also strict.pm.
@@ -153,6 +153,11 @@ Equivalent to:
     if (warnings::enabled($object))
       { warnings::warn($object, $message) }
 
+=item warnings::register_categories(@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>.
@@ -411,11 +416,25 @@ sub unimport
 
 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 
+sub MESSAGE () { 4 };
+sub FATAL () { 2 };
+sub NORMAL () { 1 };
+
 sub __chk
 {
     my $category ;
     my $offset ;
     my $isobj = 0 ;
+    my $wanted = shift;
+    my $has_message = $wanted & MESSAGE;
+
+    unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
+       my $sub = (caller 1)[3];
+       my $syntax = $has_message ? "[category,] 'message'" : '[category]';
+       Croaker("Usage: $sub($syntax)");
+    }
+
+    my $message = pop if $has_message;
 
     if (@_) {
         # check the category supplied.
@@ -453,69 +472,84 @@ sub __chk
 
     # Defaulting this to 0 reduces complexity in code paths below.
     my $callers_bitmask = (caller($i))[9] || 0 ;
-    return ($callers_bitmask, $offset) ;
+
+    my @results;
+    foreach my $type (FATAL, NORMAL) {
+       next unless $wanted & $type;
+
+       push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
+                       vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
+    }
+
+    # &enabled and &fatal_enabled
+    return $results[0] unless $has_message;
+
+    # &warnif, and the category is neither enabled as warning nor as fatal
+    return if $wanted == (NORMAL | FATAL | MESSAGE)
+       && !($results[0] || $results[1]);
+
+    require Carp;
+    Carp::croak($message) if $results[0];
+    # will always get here for &warn. will only get here for &warnif if the
+    # category is enabled
+    Carp::carp($message);
+}
+
+sub _mkMask
+{
+    my ($bit) = @_;
+    my $mask = "";
+
+    vec($mask, $bit, 1) = 1;
+    return $mask;
+}
+
+sub register_categories
+{
+    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
-}                                                             
+}
 
 sub enabled
 {
-    Croaker("Usage: warnings::enabled([category])")
-       unless @_ == 1 || @_ == 0 ;
-
-    my ($callers_bitmask, $offset) = __chk(@_) ;
-
-    return vec($callers_bitmask, $offset, 1) ||
-           vec($callers_bitmask, $Offsets{'all'}, 1) ;
+    return __chk(NORMAL, @_);
 }
 
 sub fatal_enabled
 {
-    Croaker("Usage: warnings::fatal_enabled([category])")
-  unless @_ == 1 || @_ == 0 ;
-
-    my ($callers_bitmask, $offset) = __chk(@_) ;
-
-    return vec($callers_bitmask, $offset + 1, 1) ||
-           vec($callers_bitmask, $Offsets{'all'} + 1, 1) ;
+    return __chk(FATAL, @_);
 }
 
 sub warn
 {
-    Croaker("Usage: warnings::warn([category,] 'message')")
-       unless @_ == 2 || @_ == 1 ;
-
-    my $message = pop ;
-    my ($callers_bitmask, $offset) = __chk(@_) ;
-    require Carp;
-    Carp::croak($message)
-       if vec($callers_bitmask, $offset+1, 1) ||
-          vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
-    Carp::carp($message) ;
+    return __chk(FATAL | MESSAGE, @_);
 }
 
 sub warnif
 {
-    Croaker("Usage: warnings::warnif([category,] 'message')")
-       unless @_ == 2 || @_ == 1 ;
-
-    my $message = pop ;
-    my ($callers_bitmask, $offset) = __chk(@_) ;
-
-    return
-        unless (vec($callers_bitmask, $offset, 1) ||
-               vec($callers_bitmask, $Offsets{'all'}, 1)) ;
-
-    require Carp;
-    Carp::croak($message)
-       if vec($callers_bitmask, $offset+1, 1) ||
-          vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
-
-    Carp::carp($message) ;
+    return __chk(NORMAL | FATAL | MESSAGE, @_);
 }
 
+# These are not part of any public interface, so we can delete them to save
+# space.
+delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
+
 1;
 # ex: set ro: