[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 ],
        }],
 } ;