This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
918808d00d301b12b41b5843aed52ab54b84ba19
[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
10 sub syntax_error ($$) {
11     my ($expr, $why)=@_;
12     require Carp;
13     Carp::croak("syntax error on assertion filter '$expr' ($why)");
14 }
15
16 sub calc_expr {
17     my $expr=shift;
18     my @tokens=split / \s*
19                        ( &&     # and
20                        | \|\|   # or
21                        | \(     # parents
22                        | \) )
23                        \s*
24                        | \s+    # spaces out
25                      /x, $expr;
26
27     # print STDERR "tokens: -", join('-',@tokens), "-\n";
28
29     my @now=1;
30     my @op='start';
31
32     for my $t (@tokens) {
33         if ($t eq '(') {
34             unshift @now, 1;
35             unshift @op, 'start';
36         }
37         else {
38             if ($t eq '||') {
39                 defined $op[0]
40                     and syntax_error $expr, 'consecutive operators';
41                 $op[0]='||';
42             }
43             elsif ($t eq '&&') {
44                 defined $op[0]
45                     and syntax_error $expr, 'consecutive operators';
46                 $op[0]='&&';
47             }
48             elsif (!defined $t or $t eq '') {
49                 # warn "empty token";
50             }
51             else {
52                 if ($t eq ')') {
53                     @now==1 and
54                         syntax_error $expr, 'unbalanced parens';
55                     defined $op[0] and
56                         syntax_error $expr, "key missing after operator '$op[0]'";
57
58                     $t=shift @now;
59                     shift @op;
60                 }
61                 elsif ($t eq '_') {
62                     $t=($^H & $hint) ? 1 : 0;
63                 }
64                 elsif ($t ne '0' and $t ne '1') {
65                     # print STDERR "'$t' resolved as ";
66                     $t=grep ({ $t=~$_ } @{^ASSERTING}) ? 1 : 0;
67                     # print STDERR "$t\n";
68                 }
69
70                 defined $op[0] or
71                     syntax_error $expr, 'operator expected';
72
73                 if ($op[0] eq 'start') {
74                     $now[0]=$t;
75                 }
76                 elsif ($op[0] eq '||') {
77                     $now[0]||=$t;
78                 }
79                 else {
80                     $now[0]&&=$t;
81                 }
82                 undef $op[0];
83             }
84         }
85     }
86     @now==1 or syntax_error $expr, 'unbalanced parens';
87     defined $op[0] and syntax_error $expr, "expression ends on operator '$op[0]'";
88
89     return $now[0];
90 }
91
92
93 sub import {
94     # print STDERR "\@_=", join("|", @_), "\n";
95     shift;
96     @_=(scalar(caller)) unless @_;
97     foreach my $expr (@_) {
98         unless (calc_expr $expr) {
99             # print STDERR "assertions deactived";
100             $^H &= ~$hint;
101             return;
102         }
103     }
104     # print STDERR "assertions actived";
105     $^H |= $hint;
106 }
107
108
109
110
111 sub unimport {
112     $^H &= ~$hint;
113 }
114
115 1;
116 __END__
117
118
119 =head1 NAME
120
121 assertions - selects assertions
122
123 =head1 SYNOPSIS
124
125   sub assert (&) : assertion { &{$_[0]}() }
126
127   use assertions 'foo';
128   assert { print "asserting 'foo'\n" };
129
130   {
131       use assertions qw( foo bar );
132       assert { print "asserting 'foo' & 'bar'\n" };
133   }
134
135   {
136       use assertions qw( bar );
137       assert { print "asserting 'bar'\n" };
138   }
139
140   {
141       use assertions ' _ && bar ';
142       assert { print "asserting 'foo' && 'bar'\n" };
143   }
144
145   assert { print "asserting 'foo' again\n" };
146
147
148 =head1 ABSTRACT
149
150 C<assertions> pragma selects the tags used to control assertion
151 execution.
152
153 =head1 DESCRIPTION
154
155
156
157
158 =head2 EXPORT
159
160 None by default.
161
162 =head1 SEE ALSO
163
164
165
166 =head1 AUTHOR
167
168 Salvador FandiE<ntilde>o, E<lt>sfandino@yahoo.comE<gt>
169
170 =head1 COPYRIGHT AND LICENSE
171
172 Copyright 2002 by Salvador FandiE<ntilde>o
173
174 This library is free software; you can redistribute it and/or modify
175 it under the same terms as Perl itself.
176
177 =cut