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
 122
 123
 124 sub unimport {
 125     $^H &= ~$hint;
 126 }
 127
 128 1;
 129 __END__
 130
 131
 132 =head1 NAME
 133
 134 assertions - selects assertions
 135
 136 =head1 SYNOPSIS
 137
 138   sub assert (&) : assertion { &{$_[0]}() }
 139
 140   use assertions 'foo';
 141   assert { print "asserting 'foo'\n" };
 142
 143   {
 144       use assertions qw( foo bar );
 145       assert { print "asserting 'foo' & 'bar'\n" };
 146   }
 147
 148   {
 149       use assertions qw( bar );
 150       assert { print "asserting 'bar'\n" };
 151   }
 152
 153   {
 154       use assertions ' _ && bar ';
 155       assert { print "asserting 'foo' && 'bar'\n" };
 156   }
 157
 158   assert { print "asserting 'foo' again\n" };
 159
 160
 161 =head1 ABSTRACT
 162
 163 C<assertions> pragma selects the tags used to control assertion
 164 execution.
 165
 166 =head1 DESCRIPTION
 167
 168
 169
 170
 171 =head2 EXPORT
 172
 173 None by default.
 174
 175 =head1 SEE ALSO
 176
 177
 178
 179 =head1 AUTHOR
 180
 181 Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
 182
 183 =head1 COPYRIGHT AND LICENSE
 184
 185 Copyright 2002 by Salvador FandiE<ntilde>o
 186
 187 This library is free software; you can redistribute it and/or modify
 188 it under the same terms as Perl itself.
 189
 190 =cut