X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8becbb3b066adee4495175867634bdba48ae2c5d..3e5e55bd9605a684d64a1a191319fa2d90836414:/warnings.pl

diff --git a/warnings.pl b/warnings.pl
index 6177952..8d89134 100644
--- a/warnings.pl
+++ b/warnings.pl
@@ -1,6 +1,6 @@
 #!/usr/bin/perl
 
-$VERSION = '1.02';
+$VERSION = '1.02_02';
 
 BEGIN {
   push @INC, './lib';
@@ -49,7 +49,6 @@ my $tree = {
        	'misc'		=> [ 5.008, DEFAULT_OFF],
        	'regexp'	=> [ 5.008, DEFAULT_OFF],
        	'glob'		=> [ 5.008, DEFAULT_OFF],
-       	'y2k'		=> [ 5.008, DEFAULT_OFF],
        	'untie'		=> [ 5.008, DEFAULT_OFF],
 	'substr'	=> [ 5.008, DEFAULT_OFF],
 	'taint'		=> [ 5.008, DEFAULT_OFF],
@@ -253,10 +252,13 @@ if (@ARGV && $ARGV[0] eq "tree")
 unlink "warnings.h";
 unlink "lib/warnings.pm";
 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
+binmode WARN;
 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
+binmode PM;
 
 print WARN <<'EOM' ;
-/* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
+/* -*- buffer-read-only: t -*-
+   !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
    This file is built by warnings.pl
    Any changes made here will be lost!
 */
@@ -274,12 +276,15 @@ print WARN <<'EOM' ;
 #define G_WARN_ONCE		8	/* set if 'once' ever enabled */
 #define G_WARN_ALL_MASK		(G_WARN_ALL_ON|G_WARN_ALL_OFF)
 
-#define pWARN_STD		Nullsv
-#define pWARN_ALL		(Nullsv+1)	/* use warnings 'all' */
-#define pWARN_NONE		(Nullsv+2)	/* no  warnings 'all' */
+#define pWARN_STD		NULL
+#define pWARN_ALL		(((STRLEN*)0)+1)    /* use warnings 'all' */
+#define pWARN_NONE		(((STRLEN*)0)+2)    /* no  warnings 'all' */
 
 #define specialWARN(x)		((x) == pWARN_STD || (x) == pWARN_ALL ||	\
 				 (x) == pWARN_NONE)
+
+/* if PL_warnhook is set to this value, then warnings die */
+#define PERL_WARNHOOK_FATAL	(((SV*)0) + 1)
 EOM
 
 my $offset = 0 ;
@@ -323,69 +328,27 @@ print WARN <<'EOM';
 #define isLEXWARN_on 	(PL_curcop->cop_warnings != pWARN_STD)
 #define isLEXWARN_off	(PL_curcop->cop_warnings == pWARN_STD)
 #define isWARN_ONCE	(PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
-#define isWARN_on(c,x)	(IsSet(SvPVX(c), 2*(x)))
-#define isWARNf_on(c,x)	(IsSet(SvPVX(c), 2*(x)+1))
-
-#define ckWARN(x)							\
-	( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&	\
-	      (PL_curcop->cop_warnings == pWARN_ALL ||			\
-	       isWARN_on(PL_curcop->cop_warnings, x) ) )		\
-	  || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
-
-#define ckWARN2(x,y)							\
-	  ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&	\
-	      (PL_curcop->cop_warnings == pWARN_ALL ||			\
-	        isWARN_on(PL_curcop->cop_warnings, x)  ||		\
-	        isWARN_on(PL_curcop->cop_warnings, y) ) ) 		\
-	    ||	(isLEXWARN_off && PL_dowarn & G_WARN_ON) )
-
-#define ckWARN3(x,y,z)							\
-	  ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&	\
-	      (PL_curcop->cop_warnings == pWARN_ALL ||			\
-	        isWARN_on(PL_curcop->cop_warnings, x)  ||		\
-	        isWARN_on(PL_curcop->cop_warnings, y)  ||		\
-	        isWARN_on(PL_curcop->cop_warnings, z) ) ) 		\
-	    ||	(isLEXWARN_off && PL_dowarn & G_WARN_ON) )
-
-#define ckWARN4(x,y,z,t)						\
-	  ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&	\
-	      (PL_curcop->cop_warnings == pWARN_ALL ||			\
-	        isWARN_on(PL_curcop->cop_warnings, x)  ||		\
-	        isWARN_on(PL_curcop->cop_warnings, y)  ||		\
-	        isWARN_on(PL_curcop->cop_warnings, z)  ||		\
-	        isWARN_on(PL_curcop->cop_warnings, t) ) ) 		\
-	    ||	(isLEXWARN_off && PL_dowarn & G_WARN_ON) )
-
-#define ckWARN_d(x)							\
-	  (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||	\
-	     (PL_curcop->cop_warnings != pWARN_NONE &&			\
-	      isWARN_on(PL_curcop->cop_warnings, x) ) )
-
-#define ckWARN2_d(x,y)							\
-	  (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||	\
-	     (PL_curcop->cop_warnings != pWARN_NONE &&			\
-	        (isWARN_on(PL_curcop->cop_warnings, x)  ||		\
-	         isWARN_on(PL_curcop->cop_warnings, y) ) ) )
-
-#define ckWARN3_d(x,y,z)						\
-	  (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||	\
-	     (PL_curcop->cop_warnings != pWARN_NONE &&			\
-	        (isWARN_on(PL_curcop->cop_warnings, x)  ||		\
-	         isWARN_on(PL_curcop->cop_warnings, y)  ||		\
-	         isWARN_on(PL_curcop->cop_warnings, z) ) ) )
-
-#define ckWARN4_d(x,y,z,t)						\
-	  (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||	\
-	     (PL_curcop->cop_warnings != pWARN_NONE &&			\
-	        (isWARN_on(PL_curcop->cop_warnings, x)  ||		\
-	         isWARN_on(PL_curcop->cop_warnings, y)  ||		\
-	         isWARN_on(PL_curcop->cop_warnings, z)  ||		\
-	         isWARN_on(PL_curcop->cop_warnings, t) ) ) )
-
-#define packWARN(a)		(a                                 )
-#define packWARN2(a,b)		((a) | (b)<<8                      )
-#define packWARN3(a,b,c)	((a) | (b)<<8 | (c) <<16           )
-#define packWARN4(a,b,c,d)	((a) | (b)<<8 | (c) <<16 | (d) <<24)
+#define isWARN_on(c,x)	(IsSet((U8 *)(c + 1), 2*(x)))
+#define isWARNf_on(c,x)	(IsSet((U8 *)(c + 1), 2*(x)+1))
+
+#define DUP_WARNINGS(p)		\
+    (STRLEN*)(specialWARN(p) ? (p)	\
+    : CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, char))
+
+#define ckWARN(w)		Perl_ckwarn(aTHX_ packWARN(w))
+#define ckWARN2(w1,w2)		Perl_ckwarn(aTHX_ packWARN2(w1,w2))
+#define ckWARN3(w1,w2,w3)	Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
+#define ckWARN4(w1,w2,w3,w4)	Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
+
+#define ckWARN_d(w)		Perl_ckwarn_d(aTHX_ packWARN(w))
+#define ckWARN2_d(w1,w2)	Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
+#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 packWARN(a)		(a                                      )
+#define packWARN2(a,b)		((a) | ((b)<<8)                         )
+#define packWARN3(a,b,c)	((a) | ((b)<<8) | ((c)<<16)             )
+#define packWARN4(a,b,c,d)	((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
 
 #define unpackWARN1(x)		((x)        & 0xFF)
 #define unpackWARN2(x)		(((x) >>8)  & 0xFF)
@@ -401,7 +364,7 @@ print WARN <<'EOM';
 	      isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
 
 /* end of file warnings.h */
-
+/* ex: set ro: */
 EOM
 
 close WARN ;
@@ -414,7 +377,7 @@ while (<DATA>) {
 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
 
 $last_ver = 0;
-print PM "our %Offsets : unique = (\n" ;
+print PM "our %Offsets = (\n" ;
 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
     my ($name, $version) = @{ $ValueToName{$k} };
     $name = lc $name;
@@ -430,7 +393,7 @@ foreach my $k (sort { $a <=> $b } keys %ValueToName) {
 
 print PM "  );\n\n" ;
 
-print PM "our %Bits : unique = (\n" ;
+print PM "our %Bits = (\n" ;
 foreach $k (sort keys  %list) {
 
     my $v = $list{$k} ;
@@ -444,7 +407,7 @@ foreach $k (sort keys  %list) {
 
 print PM "  );\n\n" ;
 
-print PM "our %DeadBits : unique = (\n" ;
+print PM "our %DeadBits = (\n" ;
 foreach $k (sort keys  %list) {
 
     my $v = $list{$k} ;
@@ -464,10 +427,11 @@ while (<DATA>) {
     print PM $_ ;
 }
 
+print PM "# ex: set ro:\n";
 close PM ;
 
 __END__
-
+# -*- buffer-read-only: t -*-
 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 # This file was created by warnings.pl
 # Any changes made here will be lost.
@@ -475,7 +439,7 @@ __END__
 
 package warnings;
 
-our $VERSION = '1.03';
+our $VERSION = '1.05';
 
 =head1 NAME
 
@@ -600,14 +564,14 @@ See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 
 =cut
 
-use Carp ();
-
 KEYWORDS
 
 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 
 sub Croaker
 {
+    require Carp::Heavy; # this initializes %CarpInternal
+    local $Carp::CarpInternal{'warnings'};
     delete $Carp::CarpInternal{'warnings'};
     Carp::croak(@_);
 }
@@ -710,6 +674,8 @@ sub unimport
     ${^WARNING_BITS} = $mask ;
 }
 
+my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
+
 sub __chk
 {
     my $category ;
@@ -719,10 +685,10 @@ sub __chk
     if (@_) {
         # check the category supplied.
         $category = shift ;
-        if (ref $category) {
-            Croaker ("not an object")
-                if $category !~ /^([^=]+)=/ ;
-	    $category = $1 ;
+        if (my $type = ref $category) {
+            Croaker("not an object")
+                if exists $builtin_type{$type};
+	    $category = $type;
             $isobj = 1 ;
         }
         $offset = $Offsets{$category};
@@ -747,17 +713,18 @@ sub __chk
 	$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 ;
+        $i = _error_loc(); # see where Carp will allocate the error
     }
 
     my $callers_bitmask = (caller($i))[9] ;
     return ($callers_bitmask, $offset, $i) ;
 }
 
+sub _error_loc {
+    require Carp::Heavy;
+    goto &Carp::short_error_loc; # don't introduce another stack frame
+}                                                             
+
 sub enabled
 {
     Croaker("Usage: warnings::enabled([category])")
@@ -778,6 +745,7 @@ sub warn
 
     my $message = pop ;
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
+    require Carp;
     Carp::croak($message)
 	if vec($callers_bitmask, $offset+1, 1) ||
 	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
@@ -797,6 +765,7 @@ sub warnif
             	(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) ;