RE: Combining UTF-16 output with :crlf is awkward
[perl.git] / lib / assertions.pm
1 package assertions;
2
3 our $VERSION = '0.04';
4
5 # use strict;
6 # use warnings;
7
8 my $hint = 1;
9 my $seen_hint = 2;
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{assertions} & $seen_hint) {
71                         _carp "assertion status '_' referenced but not previously defined";
72                     }
73                     $t=($^H{assertions} & $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{assertions} &= ~$hint;
113             $^H{assertions} |= $seen_hint;
114             return;
115         }
116     }
117     # print STDERR "assertions actived";
118     $^H{assertions} |= $hint|$seen_hint;
119 }
120
121 sub unimport {
122     @_ > 1
123         and _carp($_[0]."->unimport arguments are being ignored");
124     $^H{assertions} &= ~$hint;
125 }
126
127 sub enabled {
128     if (@_) {
129         if ($_[0]) {
130             $^H{assertions} |= $hint;
131         }
132         else {
133             $^H{assertions} &= ~$hint;
134         }
135         $^H{assertions} |= $seen_hint;
136     }
137     return $^H{assertions} & $hint ? 1 : 0;
138 }
139
140 sub seen {
141     if (@_) {
142         if ($_[0]) {
143             $^H{assertions} |= $seen_hint;
144         }
145         else {
146             $^H{assertions} &= ~$seen_hint;
147         }
148     }
149     return $^H{assertions} & $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   *** 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
191 The C<assertions> pragma specifies the tags used to enable and disable
192 the execution of assertion subroutines.
193
194 An assertion subroutine is declared with the C<:assertion> attribute.
195 This subroutine is not normally executed: it's optimized away by perl
196 at compile-time.
197
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
322
323 =head1 SEE ALSO
324
325 L<perlrun>, L<assertions::activate>, L<assertions::compat>.
326
327 =head1 AUTHOR
328
329 Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
330
331 =head1 COPYRIGHT AND LICENSE
332
333 Copyright 2002, 2005 by Salvador FandiE<ntilde>o
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