This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH] assertions
[perl5.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
122
123
124 sub unimport {
125     $^H &= ~$hint;
126 }
127
128 1;
129 __END__
130
131
132 =head1 NAME
133
134 assertions - selects assertions
135
136 =head1 SYNOPSIS
137
138   sub assert (&) : assertion { &{$_[0]}() }
139
140   use assertions 'foo';
141   assert { print "asserting 'foo'\n" };
142
143   {
144       use assertions qw( foo bar );
145       assert { print "asserting 'foo' & 'bar'\n" };
146   }
147
148   {
149       use assertions qw( bar );
150       assert { print "asserting 'bar'\n" };
151   }
152
153   {
154       use assertions ' _ && bar ';
155       assert { print "asserting 'foo' && 'bar'\n" };
156   }
157
158   assert { print "asserting 'foo' again\n" };
159
160
161 =head1 ABSTRACT
162
163 C<assertions> pragma selects the tags used to control assertion
164 execution.
165
166 =head1 DESCRIPTION
167
168
169
170
171 =head2 EXPORT
172
173 None by default.
174
175 =head1 SEE ALSO
176
177
178
179 =head1 AUTHOR
180
181 Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
182
183 =head1 COPYRIGHT AND LICENSE
184
185 Copyright 2002 by Salvador FandiE<ntilde>o
186
187 This library is free software; you can redistribute it and/or modify
188 it under the same terms as Perl itself.
189
190 =cut