# use warnings;
my $hint=0x01000000;
+my $seen_hint=0x02000000;
+
+sub syntax_error ($$) {
+ my ($expr, $why)=@_;
+ require Carp;
+ 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*
+ ( && # 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) {
+ next if (!defined $t or $t eq '');
+
+ 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]='&&';
+ }
+ 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 '_') {
+ 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') {
+ # 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;
+ $^H |= $seen_hint;
return;
}
}
- $^H |= $hint;
+ # print STDERR "assertions actived";
+ $^H |= $hint|$seen_hint;
}
sub unimport {
=head1 NAME
-assertions - selects assertions
+assertions - select assertions in blocks of code
=head1 SYNOPSIS
{
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 qw( & bar );
- assert { print "asserting 'foo' & 'bar'\n" };
+ use assertions ' _ && bar ';
+ assert { print "asserting 'foo' && 'bar'\n" };
}
assert { print "asserting 'foo' again\n" };
-
-=head1 ABSTRACT
-
-C<assertions> pragma selects the tags used to control assertion
-execution.
-
=head1 DESCRIPTION
+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
+at compile-time.
-
-=head2 EXPORT
-
-None by default.
+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.
=head1 SEE ALSO
-
+L<perlrun>.
=head1 AUTHOR
it under the same terms as Perl itself.
=cut
+
+TODO : Some more docs are to be added about assertion expressions.