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
  10 sub syntax_error ($$) {
  11     my ($expr, $why)=@_;
  12     require Carp;
  13     Carp::croak("syntax error on assertion filter '$expr' ($why)");
  14 }
  15
  16 sub calc_expr {
  17     my $expr=shift;
  18     my @tokens=split / \s*
  19                        ( &&     # and
  20                        | \|\|   # or
  21                        | \(     # parents
  22                        | \) )
  23                        \s*
  24                        | \s+    # spaces out
  25                      /x, $expr;
  26
  27     # print STDERR "tokens: -", join('-',@tokens), "-\n";
  28
  29     my @now=1;
  30     my @op='start';
  31
  32     for my $t (@tokens) {
  33         if ($t eq '(') {
  34             unshift @now, 1;
  35             unshift @op, 'start';
  36         }
  37         else {
  38             if ($t eq '||') {
  39                 defined $op[0]
  40                     and syntax_error $expr, 'consecutive operators';
  41                 $op[0]='||';
  42             }
  43             elsif ($t eq '&&') {
  44                 defined $op[0]
  45                     and syntax_error $expr, 'consecutive operators';
  46                 $op[0]='&&';
  47             }
  48             elsif (!defined $t or $t eq '') {
  49                 # warn "empty token";
  50             }
  51             else {
  52                 if ($t eq ')') {
  53                     @now==1 and
  54                         syntax_error $expr, 'unbalanced parens';
  55                     defined $op[0] and
  56                         syntax_error $expr, "key missing after operator '$op[0]'";
  57
  58                     $t=shift @now;
  59                     shift @op;
  60                 }
  61                 elsif ($t eq '_') {
  62                     $t=($^H & $hint) ? 1 : 0;
  63                 }
  64                 elsif ($t ne '0' and $t ne '1') {
  65                     # print STDERR "'$t' resolved as ";
  66                     $t=grep ({ $t=~$_ } @{^ASSERTING}) ? 1 : 0;
  67                     # print STDERR "$t\n";
  68                 }
  69
  70                 defined $op[0] or
  71                     syntax_error $expr, 'operator expected';
  72
  73                 if ($op[0] eq 'start') {
  74                     $now[0]=$t;
  75                 }
  76                 elsif ($op[0] eq '||') {
  77                     $now[0]||=$t;
  78                 }
  79                 else {
  80                     $now[0]&&=$t;
  81                 }
  82                 undef $op[0];
  83             }
  84         }
  85     }
  86     @now==1 or syntax_error $expr, 'unbalanced parens';
  87     defined $op[0] and syntax_error $expr, "expression ends on operator '$op[0]'";
  88
  89     return $now[0];
  90 }
  91
  92
  93 sub import {
  94     # print STDERR "\@_=", join("|", @_), "\n";
  95     shift;
  96     @_=(scalar(caller)) unless @_;
  97     foreach my $expr (@_) {
  98         unless (calc_expr $expr) {
  99             # print STDERR "assertions deactived";
 100             $^H &= ~$hint;
 101             return;
 102         }
 103     }
 104     # print STDERR "assertions actived";
 105     $^H |= $hint;
 106 }
 107
 108
 109
 110
 111 sub unimport {
 112     $^H &= ~$hint;
 113 }
 114
 115 1;
 116 __END__
 117
 118
 119 =head1 NAME
 120
 121 assertions - selects assertions
 122
 123 =head1 SYNOPSIS
 124
 125   sub assert (&) : assertion { &{$_[0]}() }
 126
 127   use assertions 'foo';
 128   assert { print "asserting 'foo'\n" };
 129
 130   {
 131       use assertions qw( foo bar );
 132       assert { print "asserting 'foo' & 'bar'\n" };
 133   }
 134
 135   {
 136       use assertions qw( bar );
 137       assert { print "asserting 'bar'\n" };
 138   }
 139
 140   {
 141       use assertions ' _ && bar ';
 142       assert { print "asserting 'foo' && 'bar'\n" };
 143   }
 144
 145   assert { print "asserting 'foo' again\n" };
 146
 147
 148 =head1 ABSTRACT
 149
 150 C<assertions> pragma selects the tags used to control assertion
 151 execution.
 152
 153 =head1 DESCRIPTION
 154
 155
 156
 157
 158 =head2 EXPORT
 159
 160 None by default.
 161
 162 =head1 SEE ALSO
 163
 164
 165
 166 =head1 AUTHOR
 167
 168 Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
 169
 170 =head1 COPYRIGHT AND LICENSE
 171
 172 Copyright 2002 by Salvador FandiE<ntilde>o
 173
 174 This library is free software; you can redistribute it and/or modify
 175 it under the same terms as Perl itself.
 176
 177 =cut