X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fassertions.pm;h=0ced4bc228808a4c967aa7621584ac80707a6528;hb=1f42692825f0c2ae2aff7c8dc9679ad797e3f97c;hp=918808d00d301b12b41b5843aed52ab54b84ba19;hpb=8c63d93843745ff8766bc75490d35dc2b080c5c0;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/assertions.pm b/lib/assertions.pm
index 918808d..0ced4bc 100644
--- a/lib/assertions.pm
+++ b/lib/assertions.pm
@@ -1,19 +1,28 @@
 package assertions;
 
-our $VERSION = '0.01';
+our $VERSION = '0.02';
 
 # use strict;
 # use warnings;
 
 my $hint=0x01000000;
+my $seen_hint=0x02000000;
 
-sub syntax_error ($$) {
+sub _syntax_error ($$) {
     my ($expr, $why)=@_;
     require Carp;
     Carp::croak("syntax error on assertion filter '$expr' ($why)");
 }
 
-sub calc_expr {
+sub _carp {
+    require warnings;
+    if (warnings::enabled('assertions')) {
+	require Carp;
+	Carp::carp(@_);
+    }
+}
+
+sub _calc_expr {
     my $expr=shift;
     my @tokens=split / \s*
 		       ( &&     # and
@@ -30,6 +39,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';
@@ -37,38 +48,39 @@ sub calc_expr {
 	else {
 	    if ($t eq '||') {
 		defined $op[0]
-		    and syntax_error $expr, 'consecutive operators';
+		    and _syntax_error $expr, 'consecutive operators';
 		$op[0]='||';
 	    }
 	    elsif ($t eq '&&') {
 		defined $op[0]
-		    and syntax_error $expr, 'consecutive operators';
+		    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';
+			_syntax_error $expr, 'unbalanced parens';
 		    defined $op[0] and
-			syntax_error $expr, "key missing after operator '$op[0]'";
+			_syntax_error $expr, "key missing after operator '$op[0]'";
 
 		    $t=shift @now;
 		    shift @op;
 		}
 		elsif ($t eq '_') {
+		    unless ($^H & $seen_hint) {
+			_carp "assertion status '_' referenced but not previously defined";
+		    }
 		    $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";
+		    $t = ( grep { ref $_ eq 'Regexp'
+				      ? $t=~$_
+				      : $_->check($t)
+				} @{^ASSERTING} ) ? 1 : 0;
 		}
 
 		defined $op[0] or
-		    syntax_error $expr, 'operator expected';
+		    _syntax_error $expr, 'operator expected';
 
 		if ($op[0] eq 'start') {
 		    $now[0]=$t;
@@ -83,8 +95,8 @@ sub calc_expr {
 	    }
 	}
     }
-    @now==1 or syntax_error $expr, 'unbalanced parens';
-    defined $op[0] and syntax_error $expr, "expression ends on operator '$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];
 }
@@ -95,30 +107,56 @@ sub import {
     shift;
     @_=(scalar(caller)) unless @_;
     foreach my $expr (@_) {
-	unless (calc_expr $expr) {
+	unless (_calc_expr $expr) {
 	    # print STDERR "assertions deactived";
 	    $^H &= ~$hint;
+	    $^H |= $seen_hint;
 	    return;
 	}
     }
     # print STDERR "assertions actived";
-    $^H |= $hint;
+    $^H |= $hint|$seen_hint;
 }
 
-
-
-
 sub unimport {
+    @_ > 1
+	and _carp($_[0]."->unimport arguments are being ignored");
     $^H &= ~$hint;
 }
 
+sub enabled {
+    if (@_) {
+	if ($_[0]) {
+	    $^H |= $hint;
+	}
+	else {
+	    $^H &= ~$hint;
+	}
+	$^H |= $seen_hint;
+    }
+    return $^H & $hint ? 1 : 0;
+}
+
+sub seen {
+    if (@_) {
+	if ($_[0]) {
+	    $^H |= $seen_hint;
+	}
+	else {
+	    $^H &= ~$seen_hint;
+	}
+    }
+    return $^H & $seen_hint ? 1 : 0;
+}
+
 1;
+
 __END__
 
 
 =head1 NAME
 
-assertions - selects assertions
+assertions - select assertions in blocks of code
 
 =head1 SYNOPSIS
 
@@ -129,39 +167,158 @@ assertions - selects assertions
 
   {
       use assertions qw( foo bar );
-      assert { print "asserting 'foo' & 'bar'\n" };
+      assert { print "asserting 'foo' and 'bar'\n" };
   }
 
   {
       use assertions qw( bar );
-      assert { print "asserting 'bar'\n" };
+      assert { print "asserting only 'bar'\n" };
   }
 
   {
-      use assertions ' _ && bar ';
+      use assertions '_ && bar';
       assert { print "asserting 'foo' && 'bar'\n" };
   }
 
   assert { print "asserting 'foo' again\n" };
 
+=head1 DESCRIPTION
 
-=head1 ABSTRACT
+The C<assertions> pragma specifies the tags used to enable and disable
+the execution of assertion subroutines.
 
-C<assertions> pragma selects the tags used to control assertion
-execution.
+An assertion subroutine is declared with the C<:assertion> attribute.
+This subroutine is not normally executed: it's optimized away by perl
+at compile-time.
 
-=head1 DESCRIPTION
+The C<assertions> pragma associates to its lexical scope one or
+several assertion tags. Then, to activate the execution of the
+assertions subroutines in this scope, these tags must be given to perl
+via the B<-A> command-line option. For instance, if...
 
+  use assertions 'foobar';
 
+is used, assertions on the same lexical scope will only be executed
+when perl is called as...
 
+  perl -A=foobar script.pl
 
-=head2 EXPORT
+Regular expressions can also be used within the -A
+switch. For instance...
 
-None by default.
+  perl -A='foo.*' script.pl
 
-=head1 SEE ALSO
+will activate assertions tagged as C<foo>, C<foobar>, C<foofoo>, etc.
+
+=head2 Selecting assertions
+
+Selecting which tags are required to activate assertions inside a
+lexical scope, is done with the arguments passed on the C<use
+assertions> sentence.
+
+If no arguments are given, the package name is used as the assertion tag:
+
+  use assertions;
+
+is equivalent to
+
+  use assertions __PACKAGE__;
+
+When several tags are given, all of them have to be activated via the
+C<-A> switch to activate assertion execution on that lexical scope,
+i.e.:
+
+  use assertions qw(Foo Bar);
+
+Constants C<1> and C<0> can be used to force unconditional activation
+or deactivation respectively:
 
+  use assertions '0';
+  use assertions '1';
+
+Operators C<&&> and C<||> and parenthesis C<(...)> can be used to
+construct logical expressions:
+
+  use assertions 'foo && bar';
+  use assertions 'foo || bar';
+  use assertions 'foo && (bar || doz)';
+
+(note that the logical operators and the parens have to be included
+inside the quoted string).
+
+Finally, the special tag C<_> refers to the current assertion
+activation state:
+
+  use assertions 'foo';
+  use assertions '_ && bar;
+
+is equivalent to
+
+  use assertions 'foo && bar';
+
+=head2 Handling assertions your own way
+
+The C<assertions> module also provides a set of low level functions to
+allow for custom assertion handling modules.
+
+Those functions are not exported and have to be fully qualified with
+the package name when called, for instance:
+
+  require assertions;
+  assertions::enabled(1);
+
+(note that C<assertions> is loaded with the C<require> keyword
+to avoid calling C<assertions::import()>).
+
+Those functions have to be called at compile time (they are
+useless at runtime).
+
+=over 4
+
+=item enabled($on)
+
+activates or deactivates assertion execution. For instance:
+
+  package assertions::always;
+
+  require assertions;
+  sub import { assertions::enabled(1) }
+
+  1;
+
+This function calls C<assertion::seen(1)> also (see below).
+
+=item enabled()
+
+returns a true value when assertion execution is active.
+
+=item seen($on)
+
+A warning is generated when an assertion subroutine is found before
+any assertion selection code. This function is used to just tell perl
+that assertion selection code has been seen and that the warning is
+not required for the currently compiling lexical scope.
+
+=item seen()
+
+returns true if any assertion selection module (or code) has been
+called before on the currently compiling lexical scope.
+
+=back
+
+=head1 COMPATIBILITY
+
+Support for assertions is only available in perl from version 5.9. On
+previous perl versions this module will do nothing, though it will not
+harm either.
+
+L<assertions::compat> provides an alternative way to use assertions
+compatible with lower versions of perl.
+
+
+=head1 SEE ALSO
 
+L<perlrun>, L<assertions::activate>, L<assertions::compat>.
 
 =head1 AUTHOR
 
@@ -169,7 +326,7 @@ Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
 
 =head1 COPYRIGHT AND LICENSE
 
-Copyright 2002 by Salvador FandiE<ntilde>o
+Copyright 2002, 2005 by Salvador FandiE<ntilde>o
 
 This library is free software; you can redistribute it and/or modify
 it under the same terms as Perl itself.