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