File Coverage

blib/lib/Language/FormulaEngine/Namespace.pm
Criterion Covered Total %
statement 89 112 79.4
branch 38 56 67.8
condition 12 31 38.7
subroutine 17 20 85.0
pod 9 9 100.0
total 165 228 72.3


line stmt bran cond sub pod time code
1             package Language::FormulaEngine::Namespace;
2 7     7   3596 use Moo;
  7         52  
  7         39  
3 7     7   2266 use Carp;
  7         37  
  7         446  
4 7     7   57 use Try::Tiny;
  7         31  
  7         569  
5             require MRO::Compat if $] lt '5.009005';
6 7     7   2780 use Language::FormulaEngine::Error ':all';
  7         38  
  7         1215  
7 7     7   591 use namespace::clean;
  7         9881  
  7         51  
8              
9             # ABSTRACT: Object holding function and variable names
10             our $VERSION = '0.07'; # VERSION
11              
12              
13             has variables => ( is => 'rw', default => sub { +{} } );
14             has constants => ( is => 'rw', default => sub { +{} } );
15             has die_on_unknown_value => ( is => 'rw' );
16              
17              
18             sub clone {
19 0     0 1 0 my $self= shift;
20 0 0 0     0 my %attrs= @_==1 && ref $_[0] eq 'HASH'? %{$_[0]} : @_;
  0         0  
21 0   0     0 $attrs{variables} ||= { %{ $self->variables } };
  0         0  
22 0   0     0 $attrs{constants} ||= { %{ $self->constants } };
  0         0  
23 0         0 $self->new( %$self, %attrs );
24             }
25              
26             # potentially hot method
27             sub clone_and_merge {
28 130     130 1 281 my $self= shift;
29 130 50 33     577 my %attrs= @_==1 && ref $_[0] eq 'HASH'? %{$_[0]} : @_;
  0         0  
30 130 50       222 $attrs{variables}= { %{ $self->variables }, ($attrs{variables}? %{ $attrs{variables} } : () ) };
  130         492  
  130         538  
31 130 50       263 $attrs{constants}= { %{ $self->constants }, ($attrs{constants}? %{ $attrs{constants} } : () ) };
  130         456  
  0         0  
32 130         2570 $self->new( %$self, %attrs );
33             }
34              
35              
36             sub get_constant {
37 80     80 1 594 my ($self, $name)= @_;
38 80         165 $name= lc $name;
39 80         272 $self->constants->{$name};
40             }
41              
42             sub get_value {
43 83     83 1 240 my ($self, $name)= @_;
44 83         159 $name= lc $name;
45 83         168 my $set= $self->variables;
46 83 100       370 return $set->{$name} if exists $set->{$name};
47 6         24 $set= $self->constants;
48 6 50       16 return $set->{$name} if exists $set->{$name};
49 6 50       32 die ErrREF("Unknown variable or constant '$_[1]'")
50             if $self->die_on_unknown_value;
51 6         16 return undef;
52             }
53              
54             our %is_pure_function;
55             sub FETCH_CODE_ATTRIBUTES {
56 0     0   0 my ($class, $ref)= @_;
57 0 0       0 return $class->maybe::mext::method($ref), ($is_pure_function{$ref}? ('Pure') : ());
58             }
59             sub MODIFY_CODE_ATTRIBUTES {
60 372     372   8857 my ($class, $ref, @attr)= @_;
61 372         619 my $n= @attr;
62 372         918 @attr= grep $_ ne 'Pure', @attr;
63 372 50       1674 $is_pure_function{$ref}= 1 if $n > @attr;
64 372         1174 $class->maybe::next::method($ref, @attr);
65             }
66              
67             sub get_function {
68 256     256 1 864 my ($self, $name)= @_;
69 256         488 $name= lc $name;
70             # The value 0E0 is a placeholder for "no such function"
71 256   66     887 my $info= $self->{_function_cache}{$name} ||= do {
72 233         612 my %tmp= $self->_collect_function_info($name);
73 233 50       3749 keys %tmp? \%tmp : '0E0';
74             };
75 256 50       1022 return ref $info? $info : undef;
76             }
77              
78             sub _collect_function_info {
79 233     233   443 my ($self, $name)= @_;
80 233         1021 my $fn= $self->can("fn_$name");
81 233         1042 my $sm= $self->can("simplify_$name");
82 233         889 my $ev= $self->can("nodeval_$name");
83             my $pure= $fn? $is_pure_function{$fn}
84 233 50       914 : $ev? $is_pure_function{$ev}
    100          
85             : 0;
86 233         844 my $pl= $self->can("perlgen_$name");
87             return
88 233 100       1445 ($pure? ( is_pure_function => $pure ) : ()),
    100          
    100          
    100          
    100          
89             ($fn? ( native => $fn ) : ()),
90             ($sm? ( simplify => $sm ) : ()),
91             ($ev? ( evaluator => $ev ) : ()),
92             ($pl? ( perl_generator => $pl ) : ()),
93             $self->maybe::next::method($name);
94             }
95              
96              
97             sub evaluate_call {
98 171     171 1 338 my ($self, $call)= @_;
99 171         464 my $name= $call->function_name;
100 171 50       411 my $info= $self->get_function($name)
101             or die ErrNAME("Unknown function '$name'");
102             # If the namespace supplies a special evaluator method, use that
103 171 100       583 if (my $eval= $info->{evaluator}) {
    50          
104 14         81 return $self->$eval($call);
105             }
106             # Else if the namespace supplies a native plain-old-function, convert the parameters
107             # from parse nodes to plain values and then call the function.
108             elsif (my $fn= $info->{native}) {
109             # The function might be a perl builtin, so need to activate the same
110             # warning flags that would be used by the compiled version.
111 7     7   9871 use warnings FATAL => 'numeric', 'uninitialized';
  7         27  
  7         3892  
112 157         259 my @args= map $_->evaluate($self), @{ $call->parameters };
  157         390  
113 157         7918 return $fn->(@args);
114             }
115             # Else the definition of the function is incomplete.
116 0         0 die ErrNAME("Incomplete function '$name' cannot be evaluated");
117             }
118              
119              
120             sub simplify_call {
121 15     15 1 26 my ($self, $call)= @_;
122 15         31 my ($same, $const)= (1,1);
123 15         21 my @s_params= @{ $call->parameters };
  15         36  
124 15         32 for (@s_params) {
125 27         94 my $s= $_->simplify($self);
126 27   100     148 $same &&= ($s == $_);
127 27   100     102 $const &&= $s->is_constant;
128 27         53 $_= $s;
129             }
130 15 100       56 $call= Language::FormulaEngine::Parser::Node::Call->new($call->function_name, \@s_params)
131             unless $same;
132 15 50       42 if (my $info= $self->get_function($call->function_name)) {
133 15 100 66     75 if (my $method= $info->{simplify}) {
    100          
134 9         34 return $self->$method($call);
135             }
136             # Are they all constants being passed to a pure function?
137             elsif ($const && $info->{is_pure_function}) {
138 2         11 my $val= $self->evaluate_call($call);
139 2 50       23 return !defined $val? $call : $self->_parse_node_for_value($val);
140             }
141             }
142 4         14 return $call;
143             }
144              
145             sub simplify_symref {
146 15     15 1 26 my ($self, $symref)= @_;
147 15         40 local $self->{die_on_unknown_value}= 0;
148 15         36 my $val= $self->get_value($symref->symbol_name);
149 15 100       65 return !defined $val? $symref : $self->_parse_node_for_value($val);
150             }
151             sub _parse_node_for_value {
152 11     11   26 my ($self, $val)= @_;
153             # Take a guess at whether this should be a number or string...
154 11 50 33     63 if (Scalar::Util::looks_like_number($val) && 0+$val eq $val) {
155 11         49 return Language::FormulaEngine::Parser::Node::Number->new($val);
156             } else {
157 0           return Language::FormulaEngine::Parser::Node::String->new($val);
158             }
159             }
160              
161              
162             sub find_methods {
163 0     0 1   my ($self, $pattern)= @_;
164 0   0       my $todo= mro::get_linear_isa(ref $self || $self);
165 0           my (%seen, @ret);
166 0           for my $pkg (@$todo) {
167 7     7   54 my $stash= do { no strict 'refs'; \%{$pkg.'::'} };
  7         24  
  7         1032  
  0            
  0            
  0            
168 0   0       push @ret, grep +($_ =~ $pattern and defined $stash->{$_}{CODE} and !$seen{$_}++), keys %$stash;
169             }
170 0           \@ret;
171             }
172              
173              
174              
175             1;
176              
177             __END__
178              
179             =pod
180              
181             =encoding UTF-8
182              
183             =head1 NAME
184              
185             Language::FormulaEngine::Namespace - Object holding function and variable names
186              
187             =head1 VERSION
188              
189             version 0.07
190              
191             =head1 SYNOPSIS
192              
193             my $ns= Language::FormulaEngine::Namespace->new( values => \%val_by_name );
194              
195             =head1 DESCRIPTION
196              
197             A FormulaEngine Namespace is an object that provides a set of functions and named values.
198             It can also affect language semantics through it's implementation of those functions.
199              
200             The default implementation provides all functions of its own namespace which begin with
201             the prefix "fn_" or "eval_", and provides them case-insensitive. Named values are provided
202             from hashrefs of L</constants> and L</variables>, also case-insensitive.
203              
204             You can subclass this (or just write a class with the same interface) to provide more advanced
205             lookup for the functions or values.
206              
207             =head1 ATTRIBUTES
208              
209             =head2 variables
210              
211             A hashref of C<< name => value >> which formulas may reference. The keys should be lowercase,
212             and incoming variable requests will be converted to lowercase before checking this hash.
213             Variables will not be "compiled" into perl coderefs, and will be looked up from the namespace
214             every time a formula is evaluated.
215              
216             =head2 constants
217              
218             Same as L</variables>, but these may be compiled into coderefs.
219              
220             =head2 die_on_unknown_value
221              
222             Controls behavior of L</get_value>. If false (the default) unknown symbol names will resolve
223             as perl C<undef> values. If true, unknown symbol names will throw an
224             L<ErrREF exception|Language::FormulaEngine::Error/ErrREF>.
225              
226             =head1 METHODS
227              
228             =head2 clone
229              
230             my $ns2= $ns1->clone(variables => \%different_vars);
231              
232             Return a copy of the namespace, optionally with some attributes overridden.
233              
234             =head2 clone_and_merge
235              
236             my $ns2= $ns1->clone_and_merge(variables => \%override_some_vars);
237              
238             Return a copy of the namespace, with any new attributes merged into the existing ones.
239              
240             =head2 get_constant
241              
242             my $val= $ns->get_constant( $symbolic_name );
243              
244             Mehod to check for availability of a named constant, before assuming that a name is a variable.
245             This never throws an exception; it returns C<undef> if no constant exists by that name.
246              
247             =head2 get_value
248              
249             my $val= $ns->get_value( $symbolic_name );
250              
251             Lowercases C<$symbolic_name> and then looks in C<variables> or C<constants>. May die depending
252             on setting of L</die_on_unknown_value>.
253              
254             =head2 get_function
255              
256             $ns->get_function( $symbolic_name );
257            
258             # Returns:
259             # {
260             # native => $coderef,
261             # evaluator => $method,
262             # perl_generator => $method,
263             # }
264              
265             If a function by this name is available in the namespace, ths method returns a hashref of
266             information about it. It may include some or all of the following:
267              
268             =over
269              
270             =item native
271              
272             A native perl implementation of this function. Speficially, a non-method plain old function
273             that takes a list of values (not parse nodes) and returns the computed value.
274              
275             Note that if C<< Sub::Util::subname($native) >> returns a name with colons in it, the compiler
276             will assume it is safe to inline this function name into the generated perl code. (but this
277             only happens if C<perl_generator> was not available)
278              
279             =item evaluator
280              
281             A coderef or method name which will be called on the namespace to evaluate a parse tree for
282             this function.
283              
284             $value= $namespace->$evaluator( $parse_node );
285              
286             =item perl_generator
287              
288             A coderef or method name which will be called on the namespace to convert a parse tree into
289             perl source code.
290              
291             $perl= $namespace->$generator( $compiler, $parse_node );
292              
293             =back
294              
295             The default implementation lowercases the C<$symbolic_name> and then checks for three method
296             names: C<< $self->can("fn_$name") >>, C<< $self->can("nodeval_$name") >> and
297             C<< $self->can("perlgen_$name") >>.
298              
299             =head2 evaluate_call
300              
301             my $value= $namespace->evaluate_call( $Call_parse_node );
302              
303             Evaluate a function call, passing it either to a specialized evaluator or performing a more
304             generic evaluation of the arguments followed by calling a native perl function.
305              
306             =head2 simplify_call
307              
308             $new_tree= $namespace->simplify_call( $parse_tree );
309              
310             Create a simplified formula by reducing variables and evaluating
311             functions down to constants. If all variables required by the
312             formula are defined, and true functions without side effects, this
313             will return a single parse node which is a constant the same as
314             evaluate() would return.
315              
316             =head2 simplify_symref
317              
318             $parse_node= $namespace->simplify_symref( $parse_node );
319              
320             This is a helper for the "simplify" mechanism that returns a parse
321             node holding the constant value of C<< $self->get_value($name) >>
322             if the value is defined, else passes-through the same parse node.
323              
324             =head2 find_methods
325              
326             Find methods on this object that match a regex.
327              
328             my $method_name_arrayref= $ns->find_methods(qr/^fn_/);
329              
330             =head1 FUNCTION LIBRARY
331              
332             Theis base Namespace class does not contain any user-visible functions; those are found within
333             the sub-classes such L<Language::FormulaEngine::Namespace::Default>.
334              
335             =head1 AUTHOR
336              
337             Michael Conrad <mconrad@intellitree.com>
338              
339             =head1 COPYRIGHT AND LICENSE
340              
341             This software is copyright (c) 2023 by Michael Conrad, IntelliTree Solutions llc.
342              
343             This is free software; you can redistribute it and/or modify it under
344             the same terms as the Perl 5 programming language system itself.
345              
346             =cut