better assertion support

Message-ID: <20050613154719.29295.qmail@lists.develooper.com>

p4raw-id: //depot/perl@24832

3 files changed, 365 insertions, 32 deletions

diff --git a/lib/assertions.pm b/lib/assertions.pm
index 700abf46bb..0ced4bc228 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.
diff --git a/lib/assertions/activate.pm b/lib/assertions/activate.pm
index 198b8368a6..04bc032dbd 100644
--- a/lib/assertions/activate.pm
+++ b/lib/assertions/activate.pm
@@ -1,11 +1,11 @@
 package assertions::activate;
 
-our $VERSION = '0.01';
+our $VERSION = '0.02';
 
 sub import {
     shift;
     @_ = '.*' unless @_;
-    push @{^ASSERTING}, map { qr/^(?:$_)\z/ } @_;
+    push @{^ASSERTING}, map { ref $_ eq 'Regexp' ? $_ : qr/^(?:$_)\z/ } @_;
 }
 
 1;
@@ -25,7 +25,11 @@ assertions::activate - activate assertions
 =head1 DESCRIPTION
 
 This module is used internally by perl (and its C<-A> command-line switch) to
-enable and disable assertions. It can also be used directly.
+enable and disable assertions.
+
+It can also be used directly:
+
+  use assertions::activate qw(foo bar);
 
 The import parameters are a list of strings or of regular expressions. The
 assertion tags that match those regexps are enabled. If no parameter is
@@ -41,7 +45,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.
diff --git a/lib/assertions/compat.pm b/lib/assertions/compat.pm
new file mode 100644
index 0000000000..156f89757d
--- /dev/null
+++ b/lib/assertions/compat.pm
@@ -0,0 +1,183 @@
+package assertions::compat;
+
+require assertions;
+our @ISA = qw(assertions);
+
+sub _on () { 1 }
+sub _off () { 0 }
+
+sub import {
+    my $class = shift;
+    my $name = @_ ? shift : 'asserting';
+    my $pkg = caller;
+    $name =~ /::/ or $name = "${pkg}::${name}";
+    @_ = $pkg unless @_;
+    $class->SUPER::import(@_);
+    my $enabled = assertions::enabled();
+    {
+	no strict 'vars';
+	no warnings;
+	undef &{$name};
+	*{$name} = $enabled ? \&_on : \&_off;
+    }
+}
+
+sub _compat_assertion_handler {
+    shift; shift;
+    grep $_ ne 'assertion', @_
+}
+
+sub _do_nothing_handler {}
+
+# test if 'assertion' attribute is natively supported
+my $assertion_ok=eval q{
+    sub _my_asserting_test : assertion { 1 }
+    _my_asserting_test()
+};
+
+*MODIFY_CODE_ATTRIBUTES =
+    defined($assertion_ok)
+    ? \&_do_nothing_handler
+    : \&_compat_assertion_handler;
+
+1;
+
+__END__
+
+=head1 NAME
+
+assertions::compat - assertions for pre-5.9 versions of perl
+
+=head1 SYNOPSIS
+
+  # add support for 'assertion' attribute:
+  use base 'assertions::compat';
+  sub assert_foo : assertion { ... };
+
+  # then, maybe in another module:
+  package Foo::Bar;
+
+  # define sub 'asserting' with the assertion status:
+  use assertions::compat;
+  asserting and assert_foo(1,2,3,4);
+
+  # or
+  use assertions::compat ASST => 'Foo::Bar::doz';
+  ASST and assert_foo('dozpera');
+
+=head1 DESCRIPTION
+
+C<assertions::compat> allows to use assertions on perl versions prior
+to 5.9.0 (that is the first one to natively support them). Though,
+it's not magic, do not expect it to allow for conditional executed
+subroutines.
+
+This module provides support for two different functionalities:
+
+=head2 The C<assertion> attribute handler
+
+The subroutine attribute C<assertion> is not recognised on perls
+without assertion support. This module provides a
+C<MODIFY_CODE_ATTRIBUTES> handler for this attribute. It must be used
+via inheritance:
+
+  use base 'assertions::compat';
+
+  sub assert_foo : assertion { ... }
+
+Be aware that the handler just discards the attribute, so subroutines
+declared as assertions will be B<unconditionally> called on perl without
+native support for them.
+
+=head2 Assertion execution status as a constant
+
+C<assertions::compat> also allows to create constant subs which value
+is the assertion execution status. That allows checking explicitly and
+efficiently if assertions have to be executed on perls without native
+assertion support.
+
+For instance...
+
+  use assertions::compat ASST => 'Foo::Bar';
+
+exports constant subroutine C<ASST>. Its value is true when assertions
+tagged as C<Foo::Bar> has been activated via L<assertions::activate>;
+usually done with the -A switch from the command line on perls
+supporting it...
+
+  perl -A=Foo::Bar my_script.pl
+
+or alternatively with...
+
+  perl -Massertions::activate=Foo::Bar my_script.pl
+
+on pre-5.9.0 versions of perl.
+
+The constant sub defined can be used following this idiom:
+
+  use assertions::compat ASST => 'Foo::Bar';
+  ...
+  ASST and assert_foo();
+
+When ASST is false, the perl interpreter optimizes away the rest of
+the C<and> statement at compile time.
+
+
+When no assertion selection tags are passed to C<use
+assertions::compat>, the current module name is used as the selection
+tag, so...
+
+  use assertions::compat 'ASST';
+
+is equivalent to...
+
+  use assertions::compat ASST => __PACKAGE__;
+
+If the name of the constant subroutine is also omitted, C<asserting>
+is used.
+
+This module will not emit a warning when the constant is redefined.
+this is done on purpose to allow for code like that:
+
+  use assertions::compat ASST => 'Foo';
+  ASST and assert_foo();
+
+  use assertions::compat ASST => 'Bar';
+  ASST and assert_bar();
+
+Finally, be aware that while assertion execution status is lexical
+scoped, defined constants are not. You should be careful on that to
+not write inconsistent code. For instance...
+
+  package Foo;
+
+  use MyAssertions qw(assert_foo);
+
+  use assertions::compat ASST => 'Foo::Out'
+  {
+    use assertions::compat ASST => 'Foo::In';
+    ASST and assert_foo(); # ok!
+  }
+
+  ASST and assert_foo()   # bad usage!
+  # ASST refers to tag Foo::In while assert_foo() is
+  # called only when Foo::Out has been activated.
+  # This is not what you want!!!
+
+
+=head1 SEE ALSO
+
+L<perlrun>, L<assertions>, L<assertions::activate>, L<attributes>.
+
+=head1 AUTHOR
+
+Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 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