lib/assertions.pm

   1 package assertions;
   2
   3 our $VERSION = '0.01';
   4
   5 # use strict;
   6 # use warnings;
   7
   8 my $hint=0x01000000;
   9 my $seen_hint=0x02000000;
  10
  11 sub syntax_error ($$) {
  12     my ($expr, $why)=@_;
  13     require Carp;
  14     Carp::croak("syntax error on assertion filter '$expr' ($why)");
  15 }
  16
  17 sub my_warn ($) {
  18     my $error=shift;
  19     require warnings;
  20     if (warnings::enabled('assertions')) {
  21         require Carp;
  22         Carp::carp($error);
  23     }
  24 }
  25
  26 sub calc_expr {
  27     my $expr=shift;
  28     my @tokens=split / \s*
  29                        ( &&     # and
  30                        | \|\|   # or
  31                        | \(     # parents
  32                        | \) )
  33                        \s*
  34                        | \s+    # spaces out
  35                      /x, $expr;
  36
  37     # print STDERR "tokens: -", join('-',@tokens), "-\n";
  38
  39     my @now=1;
  40     my @op='start';
  41
  42     for my $t (@tokens) {
  43         next if (!defined $t or $t eq '');
  44
  45         if ($t eq '(') {
  46             unshift @now, 1;
  47             unshift @op, 'start';
  48         }
  49         else {
  50             if ($t eq '||') {
  51                 defined $op[0]
  52                     and syntax_error $expr, 'consecutive operators';
  53                 $op[0]='||';
  54             }
  55             elsif ($t eq '&&') {
  56                 defined $op[0]
  57                     and syntax_error $expr, 'consecutive operators';
  58                 $op[0]='&&';
  59             }
  60             else {
  61                 if ($t eq ')') {
  62                     @now==1 and
  63                         syntax_error $expr, 'unbalanced parens';
  64                     defined $op[0] and
  65                         syntax_error $expr, "key missing after operator '$op[0]'";
  66
  67                     $t=shift @now;
  68                     shift @op;
  69                 }
  70                 elsif ($t eq '_') {
  71                     unless ($^H & $seen_hint) {
  72                         my_warn "assertion status '_' referenced but not previously defined";
  73                     }
  74                     $t=($^H & $hint) ? 1 : 0;
  75                 }
  76                 elsif ($t ne '0' and $t ne '1') {
  77                     # print STDERR "'$t' resolved as ";
  78                     $t=grep ({ $t=~$_ } @{^ASSERTING}) ? 1 : 0;
  79                     # print STDERR "$t\n";
  80                 }
  81
  82                 defined $op[0] or
  83                     syntax_error $expr, 'operator expected';
  84
  85                 if ($op[0] eq 'start') {
  86                     $now[0]=$t;
  87                 }
  88                 elsif ($op[0] eq '||') {
  89                     $now[0]||=$t;
  90                 }
  91                 else {
  92                     $now[0]&&=$t;
  93                 }
  94                 undef $op[0];
  95             }
  96         }
  97     }
  98     @now==1 or syntax_error $expr, 'unbalanced parens';
  99     defined $op[0] and syntax_error $expr, "expression ends on operator '$op[0]'";
 100
 101     return $now[0];
 102 }
 103
 104
 105 sub import {
 106     # print STDERR "\@_=", join("|", @_), "\n";
 107     shift;
 108     @_=(scalar(caller)) unless @_;
 109     foreach my $expr (@_) {
 110         unless (calc_expr $expr) {
 111             # print STDERR "assertions deactived";
 112             $^H &= ~$hint;
 113             $^H |= $seen_hint;
 114             return;
 115         }
 116     }
 117     # print STDERR "assertions actived";
 118     $^H |= $hint|$seen_hint;
 119 }
 120
 121 sub unimport {
 122     $^H &= ~$hint;
 123 }
 124
 125 1;
 126 __END__
 127
 128
 129 =head1 NAME
 130
 131 assertions - select assertions in blocks of code
 132
 133 =head1 SYNOPSIS
 134
 135   sub assert (&) : assertion { &{$_[0]}() }
 136
 137   use assertions 'foo';
 138   assert { print "asserting 'foo'\n" };
 139
 140   {
 141       use assertions qw( foo bar );
 142       assert { print "asserting 'foo' and 'bar'\n" };
 143   }
 144
 145   {
 146       use assertions qw( bar );
 147       assert { print "asserting only 'bar'\n" };
 148   }
 149
 150   {
 151       use assertions ' _ && bar ';
 152       assert { print "asserting 'foo' && 'bar'\n" };
 153   }
 154
 155   assert { print "asserting 'foo' again\n" };
 156
 157 =head1 DESCRIPTION
 158
 159 The C<assertions> pragma specifies the tags used to enable and disable
 160 the execution of assertion subroutines.
 161
 162 An assertion subroutine is declared with the C<:assertion> attribute.
 163 This subroutine is not normally executed : it's optimized away by perl
 164 at compile-time.
 165
 166 The C<assertion> pragma associates to its lexical scope one or several
 167 assertion tags. Then, to activate the execution of the assertions
 168 subroutines in this scope, these tags must be given to perl via the
 169 B<-A> command-line option.
 170
 171 =head1 SEE ALSO
 172
 173 L<perlrun>.
 174
 175 =head1 AUTHOR
 176
 177 Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
 178
 179 =head1 COPYRIGHT AND LICENSE
 180
 181 Copyright 2002 by Salvador FandiE<ntilde>o
 182
 183 This library is free software; you can redistribute it and/or modify
 184 it under the same terms as Perl itself.
 185
 186 =cut
 187
 188 TODO : Some more docs are to be added about assertion expressions.