File Coverage

blib/lib/Math/Formula/Token.pm
Criterion Covered Total %
statement 66 69 95.6
branch 10 16 62.5
condition 4 6 66.6
subroutine 28 30 93.3
pod 0 2 0.0
total 108 123 87.8


line stmt bran cond sub pod time code
1             # Copyrights 2023 by [Mark Overmeer <markov@cpan.org>].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.03.
5 28     28   771 use warnings;
  28         51  
  28         798  
6 28     28   127 use strict;
  28         49  
  28         714  
7              
8             package Math::Formula::Token;
9 28     28   121 use vars '$VERSION';
  28         47  
  28         3620  
10             $VERSION = '0.16';
11              
12              
13             #!!! The declarations of all other packages in this file are indented to avoid
14             #!!! indexing by CPAN.
15              
16             #!!! Classes and methods which are of interest of normal users are documented
17             #!!! in ::Types, because the package set-up caused too many issues with OODoc.
18              
19             # The object is an ARRAY.
20 1748     1748 0 47209 sub new(%) { my $class = shift; bless [@_], $class }
  1748         7968  
21              
22              
23             # Returns the token in string form. This may be a piece of text as parsed
24             # from the expression string, or generated when the token is computed.
25              
26 722   100 722 0 36224 sub token { $_[0][0] //= $_[0]->_token($_[0]->value) }
27 61     61   295 sub _token { $_[1] }
28              
29             #-------------------
30             # MF::PARENS, parenthesis tokens
31             # Parser object to administer parenthesis, but disappears in the AST.
32              
33             package
34             MF::PARENS;
35              
36 28     28   163 use base 'Math::Formula::Token';
  28         64  
  28         3350  
37              
38 12     12   31 sub level { $_[0][1] }
39              
40             #-------------------
41             # MF::OPERATOR, operator of yet unknown type.
42             # In the AST upgraded to either MF::PREFIX or MF::INFIX.
43              
44             package
45             MF::OPERATOR;
46              
47 28     28   167 use base 'Math::Formula::Token';
  28         45  
  28         2149  
48 28     28   560 use Log::Report 'math-formula', import => [ 'panic' ];
  28         89247  
  28         142  
49              
50             use constant {
51             # Associativity
52 28         8182 LTR => 1, RTL => 2, NOCHAIN => 3,
53 28     28   3524 };
  28         58  
54              
55             # method operator(): Returns the operator value in this token, which
56             # "accidentally" is the same value as the M<token()> method produces.
57 267     267   542 sub operator() { $_[0][0] }
58              
59             sub compute
60 0     0   0 { my ($self, $context) = @_;
61 0         0 panic +(ref $self) . ' does not compute';
62             }
63              
64             my %table;
65             {
66             # Prefix operators and parenthesis are not needed here
67             # Keep in sync with the table in Math::Formula
68             my @order = (
69             # [ LTR, ',' ],
70             [ LTR, '?', ':' ], # ternary ?:
71             [ NOCHAIN, '->' ],
72             [ LTR, qw/or xor/, '//' ],
73             [ LTR, 'and' ],
74             [ NOCHAIN, qw/ <=> < <= == != >= > / ],
75             [ NOCHAIN, qw/ cmp lt le eq ne ge gt/ ],
76             [ LTR, qw/+ - ~/ ],
77             [ LTR, qw!* / %! ],
78             [ LTR, qw/=~ !~ like unlike/ ],
79             [ LTR, '#', '.' ],
80             );
81              
82             my $level;
83             foreach (@order)
84             { my ($assoc, @line) = @$_;
85             $level++;
86             $table{$_} = [ $level, $assoc ] for @line;
87             }
88             }
89              
90             # method find($operator)
91             # Returns a list with knowledge about a know operator.
92             # The first argument is a priority level for this operator. The actual
93             # priority numbers may change over releases of this module.
94             # The second value is a constant of associativety. Either the constant
95             # LTR (compute left to right), RTL (right to left), or NOCHAIN (non-stackable
96             # operator).
97              
98 288   33 288   338 sub find($) { @{$table{$_[1]} // panic "op $_[1]" } }
  288         1017  
99              
100             #-------------------
101             # MF::PREFIX, monadic prefix operator
102             # Prefix operators process the result of the expression which follows it.
103             # This is a specialization from the MF::OPERATOR type, hence shares its methods.
104              
105             package
106             MF::PREFIX;
107              
108 28     28   176 use base 'MF::OPERATOR';
  28         49  
  28         9608  
109              
110             # method child(): Returns the AST where this operator works on.
111 30     30   110 sub child() { $_[0][1] }
112              
113             sub compute($$)
114 30     30   53 { my ($self, $context) = @_;
115 30 50       55 my $value = $self->child->compute($context)
116             or return undef;
117              
118 30         86 $value->prefix($self->operator, $context);
119             }
120              
121             #-------------------
122             # MF::INFIX, infix (dyadic) operator
123             # Infix operators have two arguments. This is a specialization from the
124             # MF::OPERATOR type, hence shares its methods.
125              
126             package
127             MF::INFIX;
128              
129 28     28   180 use base 'MF::OPERATOR';
  28         50  
  28         17088  
130              
131             # method left(): Returns the AST left from the infix operator.
132 237     237   630 sub left() { $_[0][1] }
133              
134             # method right(): Returns the AST right from the infix operator.
135 237     237   476 sub right() { $_[0][2] }
136              
137             my %comparison = (
138             '<' => [ '<=>', sub { $_[0] < 0 } ],
139             '<=' => [ '<=>', sub { $_[0] <= 0 } ],
140             '==' => [ '<=>', sub { $_[0] == 0 } ],
141             '!=' => [ '<=>', sub { $_[0] != 0 } ],
142             '>=' => [ '<=>', sub { $_[0] >= 0 } ],
143             '>' => [ '<=>', sub { $_[0] > 0 } ],
144             'lt' => [ 'cmp', sub { $_[0] < 0 } ],
145             'le' => [ 'cmp', sub { $_[0] <= 0 } ],
146             'eq' => [ 'cmp', sub { $_[0] == 0 } ],
147             'ne' => [ 'cmp', sub { $_[0] != 0 } ],
148             'ge' => [ 'cmp', sub { $_[0] >= 0 } ],
149             'gt' => [ 'cmp', sub { $_[0] > 0 } ],
150             );
151              
152 0     0   0 sub _compare_ops { keys %comparison }
153              
154             sub compute($$)
155 237     237   416 { my ($self, $context) = @_;
156              
157 237 50       449 my $left = $self->left->compute($context)
158             or return undef;
159              
160 237 50       476 my $right = $self->right->compute($context)
161             or return undef;
162              
163             # Comparison operators are all implemented via a space-ship, when available.
164             # Otherwise, the usual track is taken.
165              
166 237         468 my $op = $self->operator;
167 237 100       524 if(my $rewrite = $comparison{$op})
168 36         62 { my ($spaceship, $compare) = @$rewrite;
169 36 50       77 if(my $result = $left->infix($spaceship, $right, $context))
170 36         80 { return MF::BOOLEAN->new(undef, $compare->($result->value));
171             }
172             }
173              
174 201         461 $left->infix($op, $right, $context);
175             }
176              
177              
178             #-------------------
179             # MF::TERNARY, if ? then : else
180             # Ternary operators have three arguments. This is a specialization from the
181             # MF::OPERATOR type, hence shares its methods.
182              
183             package
184             MF::TERNARY;
185              
186 28     28   183 use base 'MF::OPERATOR';
  28         53  
  28         9062  
187              
188 7     7   20 sub condition() { $_[0][1] }
189 3     3   8 sub then() { $_[0][2] }
190 4     4   9 sub else() { $_[0][3] }
191              
192             sub compute($$)
193 7     7   12 { my ($self, $context) = @_;
194              
195 7 50       14 my $cond = $self->condition->compute($context)
196             or return undef;
197              
198 7 100       17 ($cond->value ? $self->then : $self->else)->compute($context)
199             }
200              
201             #-------------------
202             # When used, this returns a MF::STRING taken from the captures in the context.
203              
204             package
205             MF::CAPTURE;
206 28     28   187 use base 'Math::Formula::Token';
  28         65  
  28         4752  
207              
208 4     4   14 sub seqnr() { $_[0][0] }
209              
210             sub compute($$)
211 4     4   6 { my ($self, $context) = @_;
212 4         7 my $v = $context->capture($self->seqnr -1);
213 4 50       12 defined $v ? MF::STRING->new(undef, $v) : undef;
214             }
215              
216             1;