Commit | Line | Data |
---|---|---|
06492da6 SF |
1 | package assertions; |
2 | ||
ecd685f0 | 3 | our $VERSION = '0.04'; |
06492da6 SF |
4 | |
5 | # use strict; | |
6 | # use warnings; | |
7 | ||
ecd685f0 RGS |
8 | my $hint = 1; |
9 | my $seen_hint = 2; | |
06492da6 | 10 | |
aefc56c5 | 11 | sub _syntax_error ($$) { |
8c63d938 SF |
12 | my ($expr, $why)=@_; |
13 | require Carp; | |
14 | Carp::croak("syntax error on assertion filter '$expr' ($why)"); | |
15 | } | |
16 | ||
aefc56c5 | 17 | sub _carp { |
8fa7688f SF |
18 | require warnings; |
19 | if (warnings::enabled('assertions')) { | |
20 | require Carp; | |
aefc56c5 | 21 | Carp::carp(@_); |
8fa7688f SF |
22 | } |
23 | } | |
24 | ||
aefc56c5 | 25 | sub _calc_expr { |
8c63d938 SF |
26 | my $expr=shift; |
27 | my @tokens=split / \s* | |
28 | ( && # and | |
29 | | \|\| # or | |
30 | | \( # parents | |
31 | | \) ) | |
32 | \s* | |
33 | | \s+ # spaces out | |
34 | /x, $expr; | |
35 | ||
36 | # print STDERR "tokens: -", join('-',@tokens), "-\n"; | |
37 | ||
38 | my @now=1; | |
39 | my @op='start'; | |
40 | ||
41 | for my $t (@tokens) { | |
8fa7688f SF |
42 | next if (!defined $t or $t eq ''); |
43 | ||
8c63d938 SF |
44 | if ($t eq '(') { |
45 | unshift @now, 1; | |
46 | unshift @op, 'start'; | |
47 | } | |
48 | else { | |
49 | if ($t eq '||') { | |
50 | defined $op[0] | |
aefc56c5 | 51 | and _syntax_error $expr, 'consecutive operators'; |
8c63d938 SF |
52 | $op[0]='||'; |
53 | } | |
54 | elsif ($t eq '&&') { | |
55 | defined $op[0] | |
aefc56c5 | 56 | and _syntax_error $expr, 'consecutive operators'; |
8c63d938 SF |
57 | $op[0]='&&'; |
58 | } | |
8c63d938 SF |
59 | else { |
60 | if ($t eq ')') { | |
61 | @now==1 and | |
aefc56c5 | 62 | _syntax_error $expr, 'unbalanced parens'; |
8c63d938 | 63 | defined $op[0] and |
aefc56c5 | 64 | _syntax_error $expr, "key missing after operator '$op[0]'"; |
8c63d938 SF |
65 | |
66 | $t=shift @now; | |
67 | shift @op; | |
68 | } | |
69 | elsif ($t eq '_') { | |
ecd685f0 | 70 | unless ($^H{assertions} & $seen_hint) { |
aefc56c5 | 71 | _carp "assertion status '_' referenced but not previously defined"; |
8fa7688f | 72 | } |
ecd685f0 | 73 | $t=($^H{assertions} & $hint) ? 1 : 0; |
8c63d938 SF |
74 | } |
75 | elsif ($t ne '0' and $t ne '1') { | |
aefc56c5 SF |
76 | $t = ( grep { ref $_ eq 'Regexp' |
77 | ? $t=~$_ | |
78 | : $_->check($t) | |
79 | } @{^ASSERTING} ) ? 1 : 0; | |
8c63d938 SF |
80 | } |
81 | ||
82 | defined $op[0] or | |
aefc56c5 | 83 | _syntax_error $expr, 'operator expected'; |
8c63d938 SF |
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 | } | |
aefc56c5 SF |
98 | @now==1 or _syntax_error $expr, 'unbalanced parens'; |
99 | defined $op[0] and _syntax_error $expr, "expression ends on operator '$op[0]'"; | |
8c63d938 SF |
100 | |
101 | return $now[0]; | |
102 | } | |
103 | ||
104 | ||
06492da6 | 105 | sub import { |
8c63d938 | 106 | # print STDERR "\@_=", join("|", @_), "\n"; |
06492da6 SF |
107 | shift; |
108 | @_=(scalar(caller)) unless @_; | |
8c63d938 | 109 | foreach my $expr (@_) { |
aefc56c5 | 110 | unless (_calc_expr $expr) { |
8c63d938 | 111 | # print STDERR "assertions deactived"; |
ecd685f0 RGS |
112 | $^H{assertions} &= ~$hint; |
113 | $^H{assertions} |= $seen_hint; | |
06492da6 SF |
114 | return; |
115 | } | |
116 | } | |
8c63d938 | 117 | # print STDERR "assertions actived"; |
ecd685f0 | 118 | $^H{assertions} |= $hint|$seen_hint; |
06492da6 SF |
119 | } |
120 | ||
121 | sub unimport { | |
aefc56c5 SF |
122 | @_ > 1 |
123 | and _carp($_[0]."->unimport arguments are being ignored"); | |
ecd685f0 | 124 | $^H{assertions} &= ~$hint; |
06492da6 SF |
125 | } |
126 | ||
aefc56c5 SF |
127 | sub enabled { |
128 | if (@_) { | |
129 | if ($_[0]) { | |
ecd685f0 | 130 | $^H{assertions} |= $hint; |
aefc56c5 SF |
131 | } |
132 | else { | |
ecd685f0 | 133 | $^H{assertions} &= ~$hint; |
aefc56c5 | 134 | } |
ecd685f0 | 135 | $^H{assertions} |= $seen_hint; |
aefc56c5 | 136 | } |
ecd685f0 | 137 | return $^H{assertions} & $hint ? 1 : 0; |
aefc56c5 SF |
138 | } |
139 | ||
140 | sub seen { | |
141 | if (@_) { | |
142 | if ($_[0]) { | |
ecd685f0 | 143 | $^H{assertions} |= $seen_hint; |
aefc56c5 SF |
144 | } |
145 | else { | |
ecd685f0 | 146 | $^H{assertions} &= ~$seen_hint; |
aefc56c5 SF |
147 | } |
148 | } | |
ecd685f0 | 149 | return $^H{assertions} & $seen_hint ? 1 : 0; |
aefc56c5 SF |
150 | } |
151 | ||
06492da6 | 152 | 1; |
aefc56c5 | 153 | |
06492da6 SF |
154 | __END__ |
155 | ||
156 | ||
157 | =head1 NAME | |
158 | ||
702815ca | 159 | assertions - select assertions in blocks of code |
06492da6 SF |
160 | |
161 | =head1 SYNOPSIS | |
162 | ||
163 | sub assert (&) : assertion { &{$_[0]}() } | |
164 | ||
165 | use assertions 'foo'; | |
166 | assert { print "asserting 'foo'\n" }; | |
167 | ||
168 | { | |
169 | use assertions qw( foo bar ); | |
702815ca | 170 | assert { print "asserting 'foo' and 'bar'\n" }; |
06492da6 SF |
171 | } |
172 | ||
173 | { | |
174 | use assertions qw( bar ); | |
702815ca | 175 | assert { print "asserting only 'bar'\n" }; |
06492da6 SF |
176 | } |
177 | ||
178 | { | |
aefc56c5 | 179 | use assertions '_ && bar'; |
8c63d938 | 180 | assert { print "asserting 'foo' && 'bar'\n" }; |
06492da6 SF |
181 | } |
182 | ||
183 | assert { print "asserting 'foo' again\n" }; | |
184 | ||
06492da6 SF |
185 | =head1 DESCRIPTION |
186 | ||
e76bdc3c SP |
187 | *** WARNING: assertion support is only available from perl version |
188 | *** 5.9.0 and upwards. Check assertions::compat (also available from | |
189 | *** this package) for an alternative backwards compatible module. | |
190 | ||
702815ca RGS |
191 | The C<assertions> pragma specifies the tags used to enable and disable |
192 | the execution of assertion subroutines. | |
06492da6 | 193 | |
702815ca | 194 | An assertion subroutine is declared with the C<:assertion> attribute. |
aefc56c5 | 195 | This subroutine is not normally executed: it's optimized away by perl |
702815ca | 196 | at compile-time. |
06492da6 | 197 | |
aefc56c5 SF |
198 | The C<assertions> pragma associates to its lexical scope one or |
199 | several assertion tags. Then, to activate the execution of the | |
200 | assertions subroutines in this scope, these tags must be given to perl | |
201 | via the B<-A> command-line option. For instance, if... | |
202 | ||
203 | use assertions 'foobar'; | |
204 | ||
205 | is used, assertions on the same lexical scope will only be executed | |
206 | when perl is called as... | |
207 | ||
208 | perl -A=foobar script.pl | |
209 | ||
210 | Regular expressions can also be used within the -A | |
211 | switch. For instance... | |
212 | ||
213 | perl -A='foo.*' script.pl | |
214 | ||
215 | will activate assertions tagged as C<foo>, C<foobar>, C<foofoo>, etc. | |
216 | ||
217 | =head2 Selecting assertions | |
218 | ||
219 | Selecting which tags are required to activate assertions inside a | |
220 | lexical scope, is done with the arguments passed on the C<use | |
221 | assertions> sentence. | |
222 | ||
223 | If no arguments are given, the package name is used as the assertion tag: | |
224 | ||
225 | use assertions; | |
226 | ||
227 | is equivalent to | |
228 | ||
229 | use assertions __PACKAGE__; | |
230 | ||
231 | When several tags are given, all of them have to be activated via the | |
232 | C<-A> switch to activate assertion execution on that lexical scope, | |
233 | i.e.: | |
234 | ||
235 | use assertions qw(Foo Bar); | |
236 | ||
237 | Constants C<1> and C<0> can be used to force unconditional activation | |
238 | or deactivation respectively: | |
239 | ||
240 | use assertions '0'; | |
241 | use assertions '1'; | |
242 | ||
243 | Operators C<&&> and C<||> and parenthesis C<(...)> can be used to | |
244 | construct logical expressions: | |
245 | ||
246 | use assertions 'foo && bar'; | |
247 | use assertions 'foo || bar'; | |
248 | use assertions 'foo && (bar || doz)'; | |
249 | ||
250 | (note that the logical operators and the parens have to be included | |
251 | inside the quoted string). | |
252 | ||
253 | Finally, the special tag C<_> refers to the current assertion | |
254 | activation state: | |
255 | ||
256 | use assertions 'foo'; | |
257 | use assertions '_ && bar; | |
258 | ||
259 | is equivalent to | |
260 | ||
261 | use assertions 'foo && bar'; | |
262 | ||
263 | =head2 Handling assertions your own way | |
264 | ||
265 | The C<assertions> module also provides a set of low level functions to | |
266 | allow for custom assertion handling modules. | |
267 | ||
268 | Those functions are not exported and have to be fully qualified with | |
269 | the package name when called, for instance: | |
270 | ||
271 | require assertions; | |
272 | assertions::enabled(1); | |
273 | ||
274 | (note that C<assertions> is loaded with the C<require> keyword | |
275 | to avoid calling C<assertions::import()>). | |
276 | ||
277 | Those functions have to be called at compile time (they are | |
278 | useless at runtime). | |
279 | ||
280 | =over 4 | |
281 | ||
282 | =item enabled($on) | |
283 | ||
284 | activates or deactivates assertion execution. For instance: | |
285 | ||
286 | package assertions::always; | |
287 | ||
288 | require assertions; | |
289 | sub import { assertions::enabled(1) } | |
290 | ||
291 | 1; | |
292 | ||
293 | This function calls C<assertion::seen(1)> also (see below). | |
294 | ||
295 | =item enabled() | |
296 | ||
297 | returns a true value when assertion execution is active. | |
298 | ||
299 | =item seen($on) | |
300 | ||
301 | A warning is generated when an assertion subroutine is found before | |
302 | any assertion selection code. This function is used to just tell perl | |
303 | that assertion selection code has been seen and that the warning is | |
304 | not required for the currently compiling lexical scope. | |
305 | ||
306 | =item seen() | |
307 | ||
308 | returns true if any assertion selection module (or code) has been | |
309 | called before on the currently compiling lexical scope. | |
310 | ||
311 | =back | |
312 | ||
313 | =head1 COMPATIBILITY | |
314 | ||
315 | Support for assertions is only available in perl from version 5.9. On | |
316 | previous perl versions this module will do nothing, though it will not | |
317 | harm either. | |
318 | ||
319 | L<assertions::compat> provides an alternative way to use assertions | |
320 | compatible with lower versions of perl. | |
321 | ||
06492da6 SF |
322 | |
323 | =head1 SEE ALSO | |
324 | ||
aefc56c5 | 325 | L<perlrun>, L<assertions::activate>, L<assertions::compat>. |
06492da6 SF |
326 | |
327 | =head1 AUTHOR | |
328 | ||
c54bef43 | 329 | Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt> |
06492da6 SF |
330 | |
331 | =head1 COPYRIGHT AND LICENSE | |
332 | ||
aefc56c5 | 333 | Copyright 2002, 2005 by Salvador FandiE<ntilde>o |
06492da6 SF |
334 | |
335 | This library is free software; you can redistribute it and/or modify | |
336 | it under the same terms as Perl itself. | |
337 | ||
338 | =cut |