Commit | Line | Data |
06492da6 |
1 | package assertions; |
2 | |
3 | our $VERSION = '0.01'; |
4 | |
5 | # use strict; |
6 | # use warnings; |
7 | |
8 | my $hint=0x01000000; |
9 | |
8c63d938 |
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 | |
06492da6 |
93 | sub import { |
8c63d938 |
94 | # print STDERR "\@_=", join("|", @_), "\n"; |
06492da6 |
95 | shift; |
96 | @_=(scalar(caller)) unless @_; |
8c63d938 |
97 | foreach my $expr (@_) { |
98 | unless (calc_expr $expr) { |
99 | # print STDERR "assertions deactived"; |
06492da6 |
100 | $^H &= ~$hint; |
101 | return; |
102 | } |
103 | } |
8c63d938 |
104 | # print STDERR "assertions actived"; |
06492da6 |
105 | $^H |= $hint; |
106 | } |
107 | |
8c63d938 |
108 | |
109 | |
110 | |
06492da6 |
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 | { |
8c63d938 |
141 | use assertions ' _ && bar '; |
142 | assert { print "asserting 'foo' && 'bar'\n" }; |
06492da6 |
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 | |
c54bef43 |
168 | Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt> |
06492da6 |
169 | |
170 | =head1 COPYRIGHT AND LICENSE |
171 | |
c54bef43 |
172 | Copyright 2002 by Salvador FandiE<ntilde>o |
06492da6 |
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 |