X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=warnings.pl;h=835fd7c5e4edd46505ee71597d88bc78f9c3a1e4;hb=a80e323fbf3c4c14f0fce8c693c9a91eb9d69497;hp=669d13c6e64b11c5e1b158d32b4a8a396f6d131c;hpb=424a4936e3f61f4e8db394f496a116e698cede85;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/warnings.pl b/warnings.pl
index 669d13c..835fd7c 100644
--- a/warnings.pl
+++ b/warnings.pl
@@ -1,6 +1,19 @@
 #!/usr/bin/perl
+# 
+# Regenerate (overwriting only if changed):
+#
+#    lib/warnings.pm
+#    warnings.h
+#
+# from information hardcoded into this script (the $tree hash), plus the
+# template for warnings.pm in the DATA section.
+#
+# With an argument of 'tree', just dump the contents of $tree and exits.
+# Also accepts the standard regen_lib -q and -v args.
+#
+# This script is normally invoked from regen.pl.
 
-$VERSION = '1.02_02';
+$VERSION = '1.02_03';
 
 BEGIN {
     require 'regen_lib.pl';
@@ -340,6 +353,8 @@ print $warn <<'EOM';
 #define ckWARN3_d(w1,w2,w3)	Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
 #define ckWARN4_d(w1,w2,w3,w4)	Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
 
+#define WARNshift		8
+
 #define packWARN(a)		(a                                      )
 #define packWARN2(a,b)		((a) | ((b)<<8)                         )
 #define packWARN3(a,b,c)	((a) | ((b)<<8) | ((c)<<16)             )
@@ -362,7 +377,7 @@ print $warn <<'EOM';
 /* ex: set ro: */
 EOM
 
-close $warn;
+safer_close $warn;
 rename_if_different("warnings.h-new", "warnings.h");
 
 while (<DATA>) {
@@ -424,7 +439,7 @@ while (<DATA>) {
 }
 
 print $pm "# ex: set ro:\n";
-close $pm;
+safer_close $pm;
 rename_if_different("lib/warnings.pm-new", "lib/warnings.pm");
 
 __END__
@@ -436,7 +451,7 @@ __END__
 
 package warnings;
 
-our $VERSION = '1.06';
+our $VERSION = '1.08';
 
 # Verify that we're called correctly so that warnings will work.
 # see also strict.pm.
@@ -514,6 +529,27 @@ Return TRUE if that warnings category is enabled in the first scope
 where the object is used.
 Otherwise returns FALSE.
 
+=item warnings::fatal_enabled()
+
+Return TRUE if the warnings category with the same name as the current
+package has been set to FATAL in the calling module.
+Otherwise returns FALSE.
+
+=item warnings::fatal_enabled($category)
+
+Return TRUE if the warnings category C<$category> has been set to FATAL in
+the calling module.
+Otherwise returns FALSE.
+
+=item warnings::fatal_enabled($object)
+
+Use the name of the class for the object reference, C<$object>, as the
+warnings category.
+
+Return TRUE if that warnings category has been set to FATAL in the first
+scope where the object is used.
+Otherwise returns FALSE.
+
 =item warnings::warn($message)
 
 Print C<$message> to STDERR.
@@ -574,7 +610,7 @@ $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 
 sub Croaker
 {
-    require Carp::Heavy; # this initializes %CarpInternal
+    require Carp; # this initializes %CarpInternal
     local $Carp::CarpInternal{'warnings'};
     delete $Carp::CarpInternal{'warnings'};
     Carp::croak(@_);
@@ -725,7 +761,7 @@ sub __chk
 }
 
 sub _error_loc {
-    require Carp::Heavy;
+    require Carp;
     goto &Carp::short_error_loc; # don't introduce another stack frame
 }                                                             
 
@@ -741,6 +777,17 @@ sub enabled
            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 }
 
+sub fatal_enabled
+{
+    Croaker("Usage: warnings::fatal_enabled([category])")
+  unless @_ == 1 || @_ == 0 ;
+
+    my ($callers_bitmask, $offset, $i) = __chk(@_) ;
+
+    return 0 unless defined $callers_bitmask;
+    return vec($callers_bitmask, $offset + 1, 1) ||
+           vec($callers_bitmask, $Offsets{'all'} + 1, 1) ;
+}
 
 sub warn
 {