[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

4 files changed, 48 insertions, 33 deletions

diff --git a/lib/assertions.pm b/lib/assertions.pm
index 918808d00d..7af0fb0994 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 f3abd1e380..0ce73f3316 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 31a562dd72..7c8507c066 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 0400a17527..06091c3788 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 ;