Commit | Line | Data |
---|---|---|
06492da6 SF |
1 | package assertions; |
2 | ||
3 | our $VERSION = '0.01'; | |
4 | ||
5 | # use strict; | |
6 | # use warnings; | |
7 | ||
8 | my $hint=0x01000000; | |
8fa7688f | 9 | my $seen_hint=0x02000000; |
06492da6 | 10 | |
8c63d938 SF |
11 | sub syntax_error ($$) { |
12 | my ($expr, $why)=@_; | |
13 | require Carp; | |
14 | Carp::croak("syntax error on assertion filter '$expr' ($why)"); | |
15 | } | |
16 | ||
8fa7688f SF |
17 | sub my_warn ($) { |
18 | my $error=shift; | |
19 | require warnings; | |
20 | if (warnings::enabled('assertions')) { | |
21 | require Carp; | |
22 | Carp::carp($error); | |
23 | } | |
24 | } | |
25 | ||
8c63d938 SF |
26 | sub calc_expr { |
27 | my $expr=shift; | |
28 | my @tokens=split / \s* | |
29 | ( && # and | |
30 | | \|\| # or | |
31 | | \( # parents | |
32 | | \) ) | |
33 | \s* | |
34 | | \s+ # spaces out | |
35 | /x, $expr; | |
36 | ||
37 | # print STDERR "tokens: -", join('-',@tokens), "-\n"; | |
38 | ||
39 | my @now=1; | |
40 | my @op='start'; | |
41 | ||
42 | for my $t (@tokens) { | |
8fa7688f SF |
43 | next if (!defined $t or $t eq ''); |
44 | ||
8c63d938 SF |
45 | if ($t eq '(') { |
46 | unshift @now, 1; | |
47 | unshift @op, 'start'; | |
48 | } | |
49 | else { | |
50 | if ($t eq '||') { | |
51 | defined $op[0] | |
52 | and syntax_error $expr, 'consecutive operators'; | |
53 | $op[0]='||'; | |
54 | } | |
55 | elsif ($t eq '&&') { | |
56 | defined $op[0] | |
57 | and syntax_error $expr, 'consecutive operators'; | |
58 | $op[0]='&&'; | |
59 | } | |
8c63d938 SF |
60 | else { |
61 | if ($t eq ')') { | |
62 | @now==1 and | |
63 | syntax_error $expr, 'unbalanced parens'; | |
64 | defined $op[0] and | |
65 | syntax_error $expr, "key missing after operator '$op[0]'"; | |
66 | ||
67 | $t=shift @now; | |
68 | shift @op; | |
69 | } | |
70 | elsif ($t eq '_') { | |
8fa7688f SF |
71 | unless ($^H & $seen_hint) { |
72 | my_warn "assertion status '_' referenced but not previously defined"; | |
73 | } | |
8c63d938 SF |
74 | $t=($^H & $hint) ? 1 : 0; |
75 | } | |
76 | elsif ($t ne '0' and $t ne '1') { | |
77 | # print STDERR "'$t' resolved as "; | |
78 | $t=grep ({ $t=~$_ } @{^ASSERTING}) ? 1 : 0; | |
79 | # print STDERR "$t\n"; | |
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 | ||
06492da6 | 105 | sub import { |
8c63d938 | 106 | # print STDERR "\@_=", join("|", @_), "\n"; |
06492da6 SF |
107 | shift; |
108 | @_=(scalar(caller)) unless @_; | |
8c63d938 SF |
109 | foreach my $expr (@_) { |
110 | unless (calc_expr $expr) { | |
111 | # print STDERR "assertions deactived"; | |
06492da6 | 112 | $^H &= ~$hint; |
8fa7688f | 113 | $^H |= $seen_hint; |
06492da6 SF |
114 | return; |
115 | } | |
116 | } | |
8c63d938 | 117 | # print STDERR "assertions actived"; |
8fa7688f | 118 | $^H |= $hint|$seen_hint; |
06492da6 SF |
119 | } |
120 | ||
121 | sub unimport { | |
122 | $^H &= ~$hint; | |
123 | } | |
124 | ||
125 | 1; | |
126 | __END__ | |
127 | ||
128 | ||
129 | =head1 NAME | |
130 | ||
702815ca | 131 | assertions - select assertions in blocks of code |
06492da6 SF |
132 | |
133 | =head1 SYNOPSIS | |
134 | ||
135 | sub assert (&) : assertion { &{$_[0]}() } | |
136 | ||
137 | use assertions 'foo'; | |
138 | assert { print "asserting 'foo'\n" }; | |
139 | ||
140 | { | |
141 | use assertions qw( foo bar ); | |
702815ca | 142 | assert { print "asserting 'foo' and 'bar'\n" }; |
06492da6 SF |
143 | } |
144 | ||
145 | { | |
146 | use assertions qw( bar ); | |
702815ca | 147 | assert { print "asserting only 'bar'\n" }; |
06492da6 SF |
148 | } |
149 | ||
150 | { | |
8c63d938 SF |
151 | use assertions ' _ && bar '; |
152 | assert { print "asserting 'foo' && 'bar'\n" }; | |
06492da6 SF |
153 | } |
154 | ||
155 | assert { print "asserting 'foo' again\n" }; | |
156 | ||
06492da6 SF |
157 | =head1 DESCRIPTION |
158 | ||
702815ca RGS |
159 | The C<assertions> pragma specifies the tags used to enable and disable |
160 | the execution of assertion subroutines. | |
06492da6 | 161 | |
702815ca RGS |
162 | An assertion subroutine is declared with the C<:assertion> attribute. |
163 | This subroutine is not normally executed : it's optimized away by perl | |
164 | at compile-time. | |
06492da6 | 165 | |
702815ca RGS |
166 | The C<assertion> pragma associates to its lexical scope one or several |
167 | assertion tags. Then, to activate the execution of the assertions | |
168 | subroutines in this scope, these tags must be given to perl via the | |
169 | B<-A> command-line option. | |
06492da6 SF |
170 | |
171 | =head1 SEE ALSO | |
172 | ||
702815ca | 173 | L<perlrun>. |
06492da6 SF |
174 | |
175 | =head1 AUTHOR | |
176 | ||
c54bef43 | 177 | Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt> |
06492da6 SF |
178 | |
179 | =head1 COPYRIGHT AND LICENSE | |
180 | ||
c54bef43 | 181 | Copyright 2002 by Salvador FandiE<ntilde>o |
06492da6 SF |
182 | |
183 | This library is free software; you can redistribute it and/or modify | |
184 | it under the same terms as Perl itself. | |
185 | ||
186 | =cut | |
702815ca RGS |
187 | |
188 | TODO : Some more docs are to be added about assertion expressions. |