extra code in pp_concat, Take 2
[p5sagit/p5-mst-13.2.git] / lib / assertions.pm
1 package assertions;
2
3 our $VERSION = '0.01';
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 my_warn ($) {
18     my $error=shift;
19     require warnings;
20     if (warnings::enabled('assertions')) {
21         require Carp;
22         Carp::carp($error);
23     }
24 }
25
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) {
43         next if (!defined $t or $t eq '');
44
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             }
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 '_') {
71                     unless ($^H & $seen_hint) {
72                         my_warn "assertion status '_' referenced but not previously defined";
73                     }
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
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     $^H &= ~$hint;
123 }
124
125 1;
126 __END__
127
128
129 =head1 NAME
130
131 assertions - select assertions in blocks of code
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 );
142       assert { print "asserting 'foo' and 'bar'\n" };
143   }
144
145   {
146       use assertions qw( bar );
147       assert { print "asserting only 'bar'\n" };
148   }
149
150   {
151       use assertions ' _ && bar ';
152       assert { print "asserting 'foo' && 'bar'\n" };
153   }
154
155   assert { print "asserting 'foo' again\n" };
156
157 =head1 DESCRIPTION
158
159 The C<assertions> pragma specifies the tags used to enable and disable
160 the execution of assertion subroutines.
161
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.
165
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.
170
171 =head1 SEE ALSO
172
173 L<perlrun>.
174
175 =head1 AUTHOR
176
177 Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
178
179 =head1 COPYRIGHT AND LICENSE
180
181 Copyright 2002 by Salvador FandiE<ntilde>o
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
187
188 TODO : Some more docs are to be added about assertion expressions.