From: Salvador Fandiño <sfandino@yahoo.com>
Date: Fri, 21 Feb 2003 17:26:16 +0000 (+0000)
Subject: [PATCH] assertions
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8fa7688f7865696bdfa78bc12d4ffb78bd1d6103;p=p5sagit%2Fp5-mst-13.2.git

[PATCH] assertions
       Message-ID: <3E566138.4090709@yahoo.com>
           and the complement : (with added comments)
       Subject: [PATCH] bug in ext/B/t/deparse.t
       Message-ID: <3E563E16.7060303@yahoo.com>
           plus perldiag.pod patch for the new warning
(previous change was, once again, empty)

p4raw-id: //depot/perl@18828
---

diff --git a/ext/B/t/deparse.t b/ext/B/t/deparse.t
index ce133d0..1078112 100644
--- a/ext/B/t/deparse.t
+++ b/ext/B/t/deparse.t
@@ -25,7 +25,12 @@ print "ok " . $i++ . "\n";
 
 # Tell B::Deparse about our ambient pragmas
 { my ($hint_bits, $warning_bits);
- BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
+ # Note: there used to be ${^WARNING_BITS} here, instead of
+ # warnings::bits('all'), but this doesn't work, as ${^WARNING_BITS} is
+ # supposed to be the set of warnings this code has been compiled with, and
+ # later in this test we include modules that themselves use warnings::register
+ # (thus modyfing the warnings mask).
+ BEGIN { ($hint_bits, $warning_bits) = ($^H, warnings::bits('all')); }
  $deparse->ambient_pragmas (
      hint_bits    => $hint_bits,
      warning_bits => $warning_bits,
diff --git a/lib/assertions.pm b/lib/assertions.pm
index 918808d..7af0fb0 100644
--- a/lib/assertions.pm
+++ b/lib/assertions.pm
@@ -6,6 +6,7 @@ our $VERSION = '0.01';
 # use warnings;
 
 my $hint=0x01000000;
+my $seen_hint=0x02000000;
 
 sub syntax_error ($$) {
     my ($expr, $why)=@_;
@@ -13,6 +14,15 @@ sub syntax_error ($$) {
     Carp::croak("syntax error on assertion filter '$expr' ($why)");
 }
 
+sub my_warn ($) {
+    my $error=shift;
+    require warnings;
+    if (warnings::enabled('assertions')) {
+	require Carp;
+	Carp::carp($error);
+    }
+}
+
 sub calc_expr {
     my $expr=shift;
     my @tokens=split / \s*
@@ -30,6 +40,8 @@ sub calc_expr {
     my @op='start';
 
     for my $t (@tokens) {
+	next if (!defined $t or $t eq '');
+
 	if ($t eq '(') {
 	    unshift @now, 1;
 	    unshift @op, 'start';
@@ -45,9 +57,6 @@ sub calc_expr {
 		    and syntax_error $expr, 'consecutive operators';
 		$op[0]='&&';
 	    }
-	    elsif (!defined $t or $t eq '') {
-		# warn "empty token";
-	    }
 	    else {
 		if ($t eq ')') {
 		    @now==1 and
@@ -59,6 +68,9 @@ sub calc_expr {
 		    shift @op;
 		}
 		elsif ($t eq '_') {
+		    unless ($^H & $seen_hint) {
+			my_warn "assertion status '_' referenced but not previously defined";
+		    }
 		    $t=($^H & $hint) ? 1 : 0;
 		}
 		elsif ($t ne '0' and $t ne '1') {
@@ -98,11 +110,12 @@ sub import {
 	unless (calc_expr $expr) {
 	    # print STDERR "assertions deactived";
 	    $^H &= ~$hint;
+	    $^H |= $seen_hint;
 	    return;
 	}
     }
     # print STDERR "assertions actived";
-    $^H |= $hint;
+    $^H |= $hint|$seen_hint;
 }
 
 
diff --git a/lib/assertions/activate.pm b/lib/assertions/activate.pm
index f3abd1e..0ce73f3 100644
--- a/lib/assertions/activate.pm
+++ b/lib/assertions/activate.pm
@@ -8,7 +8,7 @@ our $VERSION = '0.01';
 sub import {
     shift;
     @_='.*' unless @_;
-    push @{^ASSERTING}, ( map { qr/^$_$/ } @_) ;
+    push @{^ASSERTING}, ( map { qr/^(?:$_)$/ } @_) ;
 }
 
 1;
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 31a562d..7c8507c 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -332,18 +332,11 @@ BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until anoth
 # test if assertions are supported and actived:
 BEGIN {
     $ini_assertion=
-      eval "sub asserting_test : assertion {1}; asserting_test()";
+	eval "sub asserting_test : assertion {1}; 1";
     # $ini_assertion = undef => assertions unsupported,
-    #        "       = 0 => assertions supported but inactive
-    #        "       = 1 => assertions suported and active
+    #        "       = 1     => assertions suported
     # print "\$ini_assertion=$ini_assertion\n";
 }
-INIT { # We use also INIT {} because test doesn't work in BEGIN {} if
-       # '-A' flag is in the perl script source file after the shebang
-       # as in '#!/usr/bin/perl -A'
-    $ini_assertion=
-      eval "sub asserting_test1 : assertion {1}; asserting_test1()";
-}
 
 local($^W) = 0;			# Switch run-time warnings off during init.
 warn (			# Do not ;-)
@@ -1001,7 +994,10 @@ EOP
 		        print $OUT "Warning: some settings and command-line options may be lost!\n";
 			my (@script, @flags, $cl);
 			push @flags, '-w' if $ini_warn;
-			push @flags, '-A' if $ini_assertion;
+			if ($ini_assertion and @{^ASSERTING}) {
+			    push @flags, (map { /\:\^\(\?\:(.*)\)\$\)/ ?
+						"-A$1" : "-A$_" } @{^ASSERTING});
+			}
 			# Put all the old includes at the start to get
 			# the same debugger.
 			for (@ini_INC) {
@@ -2630,23 +2626,23 @@ sub OnlyAssertions {
         &warn("Too late to set up OnlyAssertions mode, enabled on next 'R'!\n") if @_;
     }
     if (@_) {
-      unless (defined $ini_assertion) {
-	if ($term) {
-	  &warn("Current Perl interpreter doesn't support assertions");
+	unless (defined $ini_assertion) {
+	    if ($term) {
+		&warn("Current Perl interpreter doesn't support assertions");
+	    }
+	    return 0;
 	}
-	return 0;
-      }
-      if (shift) {
-	unless ($ini_assertion) {
-	  print "Assertions will also be actived on next 'R'!\n";
-	  $ini_assertion=1;
+	if (shift) {
+	    unless ($ini_assertion) {
+		print "Assertions will be active on next 'R'!\n";
+		$ini_assertion=1;
+	    }
+	    $^P&= ~$DollarCaretP_flags{PERLDBf_SUB};
+	    $^P|=$DollarCaretP_flags{PERLDBf_ASSERTION};
+	}
+	else {
+	    $^P|=$DollarCaretP_flags{PERLDBf_SUB};
 	}
-	$^P&= ~$DollarCaretP_flags{PERLDBf_SUB};
-	$^P|=$DollarCaretP_flags{PERLDBf_ASSERTION};
-      }
-      else {
-	$^P|=$DollarCaretP_flags{PERLDBf_SUB};
-      }
     }
     !($^P & $DollarCaretP_flags{PERLDBf_SUB}) || 0;
 }
diff --git a/lib/warnings.pm b/lib/warnings.pm
index 0400a17..06091c3 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -180,11 +180,16 @@ use Carp ;
     'utf8'		=> 88,
     'void'		=> 90,
     'y2k'		=> 92,
+
+    # Warnings Categories added in Perl 5.009
+
+    'assertions'	=> 94,
   );
 
 %Bits = (
-    'all'		=> "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
+    'all'		=> "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
     'ambiguous'		=> "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
+    'assertions'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [47]
     'bareword'		=> "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
     'closed'		=> "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
     'closure'		=> "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
@@ -233,8 +238,9 @@ use Carp ;
   );
 
 %DeadBits = (
-    'all'		=> "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
+    'all'		=> "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
     'ambiguous'		=> "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
+    'assertions'	=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [47]
     'bareword'		=> "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
     'closed'		=> "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
     'closure'		=> "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
@@ -283,7 +289,7 @@ use Carp ;
   );
 
 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
-$LAST_BIT = 94 ;
+$LAST_BIT = 96 ;
 $BYTES    = 12 ;
 
 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
diff --git a/op.c b/op.c
index f015618..0ea6146 100644
--- a/op.c
+++ b/op.c
@@ -5814,7 +5814,13 @@ Perl_ck_subr(pTHX_ OP *o)
 			if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
 			    o->op_private |= OPpENTERSUB_DB;
 		    }
-		    else delete=1;
+		    else {
+			delete=1;
+			if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
+			    Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
+					"Impossible to activate assertion call");
+			}
+		    }
 		}
 	    }
 	}
diff --git a/perl.h b/perl.h
index 0253a43..618da60 100644
--- a/perl.h
+++ b/perl.h
@@ -3241,7 +3241,9 @@ enum {		/* pass one of these to get_vtbl */
 #define HINT_FILETEST_ACCESS	0x00400000 /* filetest pragma */
 #define HINT_UTF8		0x00800000 /* utf8 pragma */
 
+/* assertions pragma */
 #define HINT_ASSERTING          0x01000000
+#define HINT_ASSERTIONSSEEN     0x02000000
 
 /* The following are stored in $sort::hints, not in PL_hints */
 #define HINT_SORT_SORT_BITS	0x000000FF /* allow 256 different ones */
diff --git a/perlapi.c b/perlapi.c
index e6d4219..83d30a9 100644
--- a/perlapi.c
+++ b/perlapi.c
@@ -1,7 +1,7 @@
 /*
  *    perlapi.c
  *
- *    Copyright (c) 1997-2002, Larry Wall
+ *    Copyright (c) 1997-2003, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index e64253e..3881288 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1770,6 +1770,11 @@ name or CLI symbol definition when preparing to iterate over %ENV, and
 didn't see the expected delimiter between key and value, so the line was
 ignored.
 
+=item Impossible to activate assertion call
+
+(W assertions) You're calling an assertion function in a block that is
+not under the control of the C<assertions> pragma.
+
 =item (in cleanup) %s
 
 (W misc) This prefix usually indicates that a DESTROY() method raised
diff --git a/warnings.h b/warnings.h
index 02c3cc2..2798467 100644
--- a/warnings.h
+++ b/warnings.h
@@ -73,6 +73,10 @@
 #define WARN_VOID		45
 #define WARN_Y2K		46
 
+/* Warnings Categories added in Perl 5.009 */
+
+#define WARN_ASSERTIONS		47
+
 #define WARNsize		12
 #define WARN_ALLstring		"\125\125\125\125\125\125\125\125\125\125\125\125"
 #define WARN_NONEstring		"\0\0\0\0\0\0\0\0\0\0\0\0"
diff --git a/warnings.pl b/warnings.pl
index 20ed7ff..875d91e 100644
--- a/warnings.pl
+++ b/warnings.pl
@@ -63,6 +63,8 @@ my $tree = {
        	'pack'		=> [ 5.008, DEFAULT_OFF],
        	'unpack'	=> [ 5.008, DEFAULT_OFF],
        	'threads'	=> [ 5.008, DEFAULT_OFF],
+	'assertions'    => [ 5.009, DEFAULT_OFF],
+
        	 #'default'	=> [ 5.008, DEFAULT_ON ],
   	}],
 } ;