Commit | Line | Data |
06492da6 |
1 | package assertions; |
2 | |
ecd685f0 |
3 | our $VERSION = '0.04'; |
06492da6 |
4 | |
5 | # use strict; |
6 | # use warnings; |
7 | |
ecd685f0 |
8 | my $hint = 1; |
9 | my $seen_hint = 2; |
06492da6 |
10 | |
aefc56c5 |
11 | sub _syntax_error ($$) { |
8c63d938 |
12 | my ($expr, $why)=@_; |
13 | require Carp; |
14 | Carp::croak("syntax error on assertion filter '$expr' ($why)"); |
15 | } |
16 | |
aefc56c5 |
17 | sub _carp { |
8fa7688f |
18 | require warnings; |
19 | if (warnings::enabled('assertions')) { |
20 | require Carp; |
aefc56c5 |
21 | Carp::carp(@_); |
8fa7688f |
22 | } |
23 | } |
24 | |
aefc56c5 |
25 | sub _calc_expr { |
8c63d938 |
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 |
42 | next if (!defined $t or $t eq ''); |
43 | |
8c63d938 |
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 |
52 | $op[0]='||'; |
53 | } |
54 | elsif ($t eq '&&') { |
55 | defined $op[0] |
aefc56c5 |
56 | and _syntax_error $expr, 'consecutive operators'; |
8c63d938 |
57 | $op[0]='&&'; |
58 | } |
8c63d938 |
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 |
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 |
74 | } |
75 | elsif ($t ne '0' and $t ne '1') { |
aefc56c5 |
76 | $t = ( grep { ref $_ eq 'Regexp' |
77 | ? $t=~$_ |
78 | : $_->check($t) |
79 | } @{^ASSERTING} ) ? 1 : 0; |
8c63d938 |
80 | } |
81 | |
82 | defined $op[0] or |
aefc56c5 |
83 | _syntax_error $expr, 'operator expected'; |
8c63d938 |
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 |
98 | @now==1 or _syntax_error $expr, 'unbalanced parens'; |
99 | defined $op[0] and _syntax_error $expr, "expression ends on operator '$op[0]'"; |
8c63d938 |
100 | |
101 | return $now[0]; |
102 | } |
103 | |
104 | |
06492da6 |
105 | sub import { |
8c63d938 |
106 | # print STDERR "\@_=", join("|", @_), "\n"; |
06492da6 |
107 | shift; |
108 | @_=(scalar(caller)) unless @_; |
8c63d938 |
109 | foreach my $expr (@_) { |
aefc56c5 |
110 | unless (_calc_expr $expr) { |
8c63d938 |
111 | # print STDERR "assertions deactived"; |
ecd685f0 |
112 | $^H{assertions} &= ~$hint; |
113 | $^H{assertions} |= $seen_hint; |
06492da6 |
114 | return; |
115 | } |
116 | } |
8c63d938 |
117 | # print STDERR "assertions actived"; |
ecd685f0 |
118 | $^H{assertions} |= $hint|$seen_hint; |
06492da6 |
119 | } |
120 | |
121 | sub unimport { |
aefc56c5 |
122 | @_ > 1 |
123 | and _carp($_[0]."->unimport arguments are being ignored"); |
ecd685f0 |
124 | $^H{assertions} &= ~$hint; |
06492da6 |
125 | } |
126 | |
aefc56c5 |
127 | sub enabled { |
128 | if (@_) { |
129 | if ($_[0]) { |
ecd685f0 |
130 | $^H{assertions} |= $hint; |
aefc56c5 |
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 |
138 | } |
139 | |
140 | sub seen { |
141 | if (@_) { |
142 | if ($_[0]) { |
ecd685f0 |
143 | $^H{assertions} |= $seen_hint; |
aefc56c5 |
144 | } |
145 | else { |
ecd685f0 |
146 | $^H{assertions} &= ~$seen_hint; |
aefc56c5 |
147 | } |
148 | } |
ecd685f0 |
149 | return $^H{assertions} & $seen_hint ? 1 : 0; |
aefc56c5 |
150 | } |
151 | |
06492da6 |
152 | 1; |
aefc56c5 |
153 | |
06492da6 |
154 | __END__ |
155 | |
156 | |
157 | =head1 NAME |
158 | |
702815ca |
159 | assertions - select assertions in blocks of code |
06492da6 |
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 |
171 | } |
172 | |
173 | { |
174 | use assertions qw( bar ); |
702815ca |
175 | assert { print "asserting only 'bar'\n" }; |
06492da6 |
176 | } |
177 | |
178 | { |
aefc56c5 |
179 | use assertions '_ && bar'; |
8c63d938 |
180 | assert { print "asserting 'foo' && 'bar'\n" }; |
06492da6 |
181 | } |
182 | |
183 | assert { print "asserting 'foo' again\n" }; |
184 | |
06492da6 |
185 | =head1 DESCRIPTION |
186 | |
e76bdc3c |
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 |
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 |
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 |
322 | |
323 | =head1 SEE ALSO |
324 | |
aefc56c5 |
325 | L<perlrun>, L<assertions::activate>, L<assertions::compat>. |
06492da6 |
326 | |
327 | =head1 AUTHOR |
328 | |
c54bef43 |
329 | Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt> |
06492da6 |
330 | |
331 | =head1 COPYRIGHT AND LICENSE |
332 | |
aefc56c5 |
333 | Copyright 2002, 2005 by Salvador FandiE<ntilde>o |
06492da6 |
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 |