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

diff --git a/lib/assertions.pm b/lib/assertions.pm
index 700abf4..0ced4bc 100644
--- a/lib/assertions.pm
+++ b/lib/assertions.pm
@@ -1,6 +1,6 @@
 package assertions;
 
-our $VERSION = '0.01';
+our $VERSION = '0.02';
 
 # use strict;
 # use warnings;
@@ -8,22 +8,21 @@ our $VERSION = '0.01';
 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 my_warn ($) {
-    my $error=shift;
+sub _carp {
     require warnings;
     if (warnings::enabled('assertions')) {
 	require Carp;
-	Carp::carp($error);
+	Carp::carp(@_);
     }
 }
 
-sub calc_expr {
+sub _calc_expr {
     my $expr=shift;
     my @tokens=split / \s*
 		       ( &&     # and
@@ -49,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]='&&';
 	    }
 	    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) {
-			my_warn "assertion status '_' referenced but not previously defined";
+			_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;
@@ -95,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];
 }
@@ -107,7 +107,7 @@ 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;
@@ -119,10 +119,38 @@ sub import {
 }
 
 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__
 
 
@@ -148,7 +176,7 @@ assertions - select assertions in blocks of code
   }
 
   {
-      use assertions ' _ && bar ';
+      use assertions '_ && bar';
       assert { print "asserting 'foo' && 'bar'\n" };
   }
 
@@ -160,17 +188,137 @@ The C<assertions> pragma specifies the tags used to enable and disable
 the execution of assertion subroutines.
 
 An assertion subroutine is declared with the C<:assertion> attribute.
-This subroutine is not normally executed : it's optimized away by perl
+This subroutine is not normally executed: it's optimized away by perl
 at compile-time.
 
-The C<assertion> 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.
+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
+
+Regular expressions can also be used within the -A
+switch. For instance...
+
+  perl -A='foo.*' script.pl
+
+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<perlrun>, L<assertions::activate>, L<assertions::compat>.
 
 =head1 AUTHOR
 
@@ -178,11 +326,9 @@ 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.
 
 =cut
-
-TODO : Some more docs are to be added about assertion expressions.