more complex assertions activation:

Subject: Re: Did the assertion patch/feature submission get overlooked?
Message-ID: <3E52885D.5060903@yahoo.com>

p4raw-id: //depot/perl@18750

diff --git a/lib/assertions.pm b/lib/assertions.pm
index 8369b74..918808d 100644 (file)
--- a/lib/assertions.pm
+++ b/lib/assertions.pm
@@ -7,24 +7,107 @@ our $VERSION = '0.01';
 
 my $hint=0x01000000;
 
+sub syntax_error ($$) {
+    my ($expr, $why)=@_;
+    require Carp;
+    Carp::croak("syntax error on assertion filter '$expr' ($why)");
+}
+
+sub calc_expr {
+    my $expr=shift;
+    my @tokens=split / \s*
+                      ( &&     # and
+                      | \|\|   # or
+                      | \(     # parents
+                      | \) )
+                      \s*
+                      | \s+    # spaces out
+                    /x, $expr;
+
+    # print STDERR "tokens: -", join('-',@tokens), "-\n";
+
+    my @now=1;
+    my @op='start';
+
+    for my $t (@tokens) {
+       if ($t eq '(') {
+           unshift @now, 1;
+           unshift @op, 'start';
+       }
+       else {
+           if ($t eq '||') {
+               defined $op[0]
+                   and syntax_error $expr, 'consecutive operators';
+               $op[0]='||';
+           }
+           elsif ($t eq '&&') {
+               defined $op[0]
+                   and syntax_error $expr, 'consecutive operators';
+               $op[0]='&&';
+           }
+           elsif (!defined $t or $t eq '') {
+               # warn "empty token";
+           }
+           else {
+               if ($t eq ')') {
+                   @now==1 and
+                       syntax_error $expr, 'unbalanced parens';
+                   defined $op[0] and
+                       syntax_error $expr, "key missing after operator '$op[0]'";
+
+                   $t=shift @now;
+                   shift @op;
+               }
+               elsif ($t eq '_') {
+                   $t=($^H & $hint) ? 1 : 0;
+               }
+               elsif ($t ne '0' and $t ne '1') {
+                   # print STDERR "'$t' resolved as ";
+                   $t=grep ({ $t=~$_ } @{^ASSERTING}) ? 1 : 0;
+                   # print STDERR "$t\n";
+               }
+
+               defined $op[0] or
+                   syntax_error $expr, 'operator expected';
+
+               if ($op[0] eq 'start') {
+                   $now[0]=$t;
+               }
+               elsif ($op[0] eq '||') {
+                   $now[0]||=$t;
+               }
+               else {
+                   $now[0]&&=$t;
+               }
+               undef $op[0];
+           }
+       }
+    }
+    @now==1 or syntax_error $expr, 'unbalanced parens';
+    defined $op[0] and syntax_error $expr, "expression ends on operator '$op[0]'";
+
+    return $now[0];
+}
+
+
 sub import {
+    # print STDERR "\@_=", join("|", @_), "\n";
     shift;
     @_=(scalar(caller)) unless @_;
-
-    if ($_[0] eq '&') {
-       return unless $^H & $hint;
-       shift;
-    }
-       
-    for my $tag (@_) {
-       unless (grep { $tag=~$_ } @{^ASSERTING}) {
+    foreach my $expr (@_) {
+       unless (calc_expr $expr) {
+           # print STDERR "assertions deactived";
            $^H &= ~$hint;
            return;
        }
     }
+    # print STDERR "assertions actived";
     $^H |= $hint;
 }
 
+
+
+
 sub unimport {
     $^H &= ~$hint;
 }
@@ -55,8 +138,8 @@ assertions - selects assertions
   }
 
   {
-      use assertions qw( & bar );
-      assert { print "asserting 'foo' & 'bar'\n" };
+      use assertions ' _ && bar ';
+      assert { print "asserting 'foo' && 'bar'\n" };
   }
 
   assert { print "asserting 'foo' again\n" };

diff --git a/lib/assertions/activate.pm b/lib/assertions/activate.pm
index 6f0f37e..f3abd1e 100644 (file)
--- a/lib/assertions/activate.pm
+++ b/lib/assertions/activate.pm
@@ -7,6 +7,7 @@ our $VERSION = '0.01';
 
 sub import {
     shift;
+    @_='.*' unless @_;
     push @{^ASSERTING}, ( map { qr/^$_$/ } @_) ;
 }
 

diff --git a/t/comp/assertions.t b/t/comp/assertions.t
index d3d9783..da9f568 100644 (file)
--- a/t/comp/assertions.t
+++ b/t/comp/assertions.t
@@ -1,16 +1,72 @@
 #!./perl
 
+sub callme ($ ) : assertion {
+    return shift;
+}
+
+# select STDERR; $|=1;
+
+my @expr=( '1' => 1,
+          '0' => 0,
+          '1 && 1' => 1,
+          '1 && 0' => 0,
+          '0 && 1' => 0,
+          '0 && 0' => 0,
+          '1 || 1' => 1,
+          '1 || 0' => 1,
+          '0 || 1' => 1,
+          '0 || 0' => 0,
+          '(1)' => 1,
+          '(0)' => 0,
+          '1 && ((1) && 1)' => 1,
+          '1 && (0 || 1)' => 1,
+          '1 && ( 0' => undef,
+          '1 &&' => undef,
+          '&& 1' => undef,
+          '1 && || 1' => undef,
+          '(1 && 1) && 1)' => undef,
+          'one && two' => 1,
+          '_ && one' => 0,
+          'one && three' => 0,
+          '1 ' => 1,
+          ' 1' => 1,
+          ' 1 ' => 1,
+          ' ( 1 && 1 ) ' => 1,
+          ' ( 1 && 0 ) ' => 0,
+          '(( 1 && 1) && ( 1 || 0)) || _ && one && ( one || three)' => 1 );
+
+my $n=@expr/2+10;
 my $i=1;
-print "1..10\n";
+print "1..$n\n";
 
-sub callme ($) : assertion {
-    return shift;
+use assertions::activate 'one', 'two';
+require assertions;
+
+while (@expr) {
+    my $expr=shift @expr;
+    my $expected=shift @expr;
+    my $result=eval {assertions::calc_expr($expr)};
+    if (defined $expected) {
+       unless (defined $result and $result == $expected) {
+           print STDERR "assertions::calc_expr($expr) failed,".
+               " expected '$expected' but '$result' obtained (\$@=$@)\n";
+           print "not ";
+       }
+    }
+    else {
+       if (defined $result) {
+           print STDERR "assertions::calc_expr($expr) failed,".
+               " expected undef but '$result' obtained\n";
+           print "not ";
+       }
+    }
+    print "ok ", $i++, "\n";
 }
 
 
-# 1
+# @expr/2+1
 if (callme(1)) {
-    print STDERR "assertions called by default";
+    print STDERR "assertions called by default\n";
     print "not ";
 }
 print "ok ", $i++, "\n";
@@ -24,7 +80,7 @@ use assertions::activate 'mine';
   }
   use assertions;
   unless (callme(1)) {
-    print STDERR "'use assertions;' doesn't active assertions based on package name";
+    print STDERR "'use assertions;' doesn't active assertions based on package name\n";
     print "not ";
   }
 }
@@ -33,7 +89,7 @@ print "ok ", $i++, "\n";
 # 3
 use assertions 'foo';
 if (callme(1)) {
-    print STDERR "assertion deselection doesn't work";
+    print STDERR "assertion deselection doesn't work\n";
     print "not ";
 }
 print "ok ", $i++, "\n";
@@ -42,23 +98,23 @@ print "ok ", $i++, "\n";
 use assertions::activate 'bar', 'doz';
 use assertions 'bar';
 unless (callme(1)) {
-    print STDERR "assertion selection doesn't work";
+    print STDERR "assertion selection doesn't work\n";
     print "not ";
 }
 print "ok ", $i++, "\n";
 
 # 5
-use assertions '&', 'doz';
+use assertions q(_ && doz);
 unless (callme(1)) {
-    print STDERR "assertion activation filtering doesn't work";
+    print STDERR "assertion activation filtering doesn't work\n";
     print "not ";
 }
 print "ok ", $i++, "\n";
 
 # 6
-use assertions '&', 'foo';
+use assertions q(_ && foo);
 if (callme(1)) {
-    print STDERR "assertion deactivation filtering doesn't work";
+    print STDERR "assertion deactivation filtering doesn't work\n";
     print "not ";
 }
 print "ok ", $i++, "\n";
@@ -68,7 +124,7 @@ if (1) {
     use assertions 'bar';
 }
 if (callme(1)) {
-    print STDERR "assertion scoping doesn't work";
+    print STDERR "assertion scoping doesn't work\n";
     print "not ";
 }
 print "ok ", $i++, "\n";
@@ -77,7 +133,7 @@ print "ok ", $i++, "\n";
 use assertions::activate 're.*';
 use assertions 'reassert';
 unless (callme(1)) {
-    print STDERR "assertion selection with re failed";
+    print STDERR "assertion selection with re failed\n";
     print "not ";
 }
 print "ok ", $i++, "\n";
@@ -88,7 +144,7 @@ my $b=12;
     use assertions 'bar';
     callme(my $b=45);
     unless ($b == 45) {
-       print STDERR "this shouldn't fail ever (b=$b)";
+       print STDERR "this shouldn't fail ever (b=$b)\n";
        print "not ";
     }
 }
@@ -99,7 +155,7 @@ print "ok ", $i++, "\n";
     no assertions;
     callme(my $b=46);
     if (defined $b) {
-       print STDERR "lexical declaration in assertion arg ignored";
+       print STDERR "lexical declaration in assertion arg ignored (b=$b\n";
        print "not ";
     }
 }