File Coverage

blib/lib/Language/FormulaEngine/Namespace/Default.pm
Criterion Covered Total %
statement 373 405 92.1
branch 91 140 65.0
condition 37 59 62.7
subroutine 114 119 95.8
pod 0 56 0.0
total 615 779 78.9


line stmt bran cond sub pod time code
1             package Language::FormulaEngine::Namespace::Default;
2 6     6   6018 use parent 'Language::FormulaEngine::Namespace';
  6         1653  
  6         39  
3 6     6   326 use strict;
  6         15  
  6         146  
4 6     6   31 use warnings FATAL => 'numeric', 'uninitialized';
  6         14  
  6         199  
5 6     6   32 use Try::Tiny;
  6         13  
  6         329  
6 6     6   91 use List::Util ();
  6         16  
  6         108  
7 6     6   2683 use Math::Trig ();
  6         70579  
  6         138  
8 6     6   50 use Scalar::Util ();
  6         14  
  6         107  
9 6     6   38 use POSIX ();
  6         28  
  6         148  
10             # POSIX::round isn't available everywhere
11 6 50   6   458 BEGIN { eval 'use POSIX "round"; 1;' or eval 'sub round { sprintf "%.*f", $_[1]||0, $_[0] }' }
  6     6   66  
  6         17  
  6         73  
12 6     6   40 use Language::FormulaEngine::Error ':all';
  6         23  
  6         1106  
13 6     6   5228 use DateTime;
  6         2561729  
  6         323  
14 6     6   4518 use DateTime::Format::Flexible;
  6         1643894  
  6         77  
15 6     6   532 use namespace::clean;
  6         15  
  6         63  
16              
17             # ABSTRACT: Default spreadsheet-like set of functions and behavior
18             our $VERSION = '0.07'; # VERSION
19              
20             # No official versioned namespace yet, but this code is for when I publish one.
21              
22             #sub _fake_require {
23             # my $version= shift;
24             # $INC{'Language/FormulaEngine/Namespace/Default/V'.$version.'.pm'}=
25             # $INC{'Language/FormulaEngine/Namespace/Default.pm'};
26             #}
27             #
28             #sub _declare_versioned_namespace {
29             # my ($from_ver, $to_ver, @list)= @_;
30             # no strict 'refs';
31             # my $from_stash= \%{ __PACKAGE__ . '::V' . $from_ver . '::' };
32             # my $to_stash= \%{ __PACKAGE__ . '::V' . $to_ver . '::' };
33             # if (@list) {
34             # for (@list) {
35             # defined $from_stash->{$_} or die "Version $from_ver does not contain method $_";
36             # $to_stash->{$_}= $from_stash->{$_};
37             # }
38             # } else {
39             # for (keys %$from_stash) {
40             # $to_stash->{$_}= $from_stash->{$_}
41             # if defined $from_stash->{$_}{CODE} && !defined $to_stash->{$_};
42             # }
43             # }
44             # @{ __PACKAGE__ . '::V' . $to_ver . '::ISA' }= ( 'Language::FormulaEngine::Namespace' );
45             #}
46             #
47             #_fake_require 0;
48             #@Language::FormulaEngine::Namespace::Default::V0::ISA= ( __PACKAGE__ );
49              
50              
51             *fn_sum= *List::Util::sum0;
52             __PACKAGE__->MODIFY_CODE_ATTRIBUTES(\&fn_sum, 'Pure');
53             sub simplify_sum {
54 2     2 0 6 my ($self, $node)= @_;
55 2         5 my ($const, @unknown)= (0);
56 2         4 for (@{ $node->parameters }) {
  2         7  
57 6 100       15 if ($_->is_constant) {
58 4         33 $const += $_->evaluate($self);
59             } else {
60 2         5 push @unknown, $_;
61             }
62             }
63 2 50 33     4 return $node if @unknown == @{ $node->parameters } && @unknown > 1;
  2         13  
64 2 50       6 push @unknown, Language::FormulaEngine::Parser::Node::Number->new($const) if $const != 0;
65 2 50       17 return $unknown[0] unless @unknown > 1;
66 0         0 return Language::FormulaEngine::Parser::Node::Call->new($node->function_name, \@unknown);
67             }
68             sub perlgen_sum {
69 14     14 0 104 my ($self, $compiler, $node)= @_;
70 14         33 my @arg_code= map $compiler->perlgen($_), @{$node->parameters};
  14         42  
71 14         164 return '( '.join(' + ', @arg_code).' )';
72             }
73              
74             sub fn_negative :Pure {
75 2 50   2 0 8 @_ == 1 or die "Can only negate a single value, not a list\n";
76 2         7 return -$_[0];
77 6     6   4820 }
  6         1416  
  6         107  
78             sub perlgen_negative {
79 2     2 0 17 my ($self, $compiler, $node)= @_;
80 2         4 my @arg_code= map $compiler->perlgen($_), @{$node->parameters};
  2         7  
81 2 50       6 @arg_code == 1 or die "Can only negate a single value, not a list\n";
82 2         12 return '(-('.$arg_code[0].'))';
83             }
84              
85             *fn_mul= *List::Util::product;
86             __PACKAGE__->MODIFY_CODE_ATTRIBUTES(\&fn_mul, 'Pure');
87             sub simplify_mul {
88 4     4 0 8 my ($self, $node)= @_;
89 4         7 my ($const, @unknown)= (1);
90 4         8 for (@{ $node->parameters }) {
  4         10  
91 8 100       17 if ($_->is_constant) {
92 5         28 $const *= $_->evaluate($self);
93             } else {
94 3         8 push @unknown, $_;
95             }
96             }
97 4 50 33     9 return $node if @unknown == @{ $node->parameters } && @unknown > 1;
  4         10  
98 4 100       13 return Language::FormulaEngine::Parser::Node::Number->new(0) if $const == 0;
99 2 50       9 unshift @unknown, Language::FormulaEngine::Parser::Node::Number->new($const) if $const != 1;
100 2 50       10 return $unknown[0] unless @unknown > 1;
101 2         5 return Language::FormulaEngine::Parser::Node::Call->new($node->function_name, \@unknown);
102             }
103             sub perlgen_mul {
104 14     14 0 114 my ($self, $compiler, $node)= @_;
105 14         26 my @arg_code= map $compiler->perlgen($_), @{$node->parameters};
  14         39  
106 14         111 return '( '.join(' * ', @arg_code).' )';
107             }
108              
109             sub fn_div :Pure {
110 1 50   1 0 12 @_ == 2 or die "div() takes exactly two arguments\n";
111 1 50       6 $_[1] or die "division by zero\n";
112 1         11 return $_[0] / $_[1];
113 6     6   3886 }
  6         38  
  6         30  
114             sub perlgen_div {
115 4     4 0 31 my ($self, $compiler, $node)= @_;
116 4         9 my @arg_code= map $compiler->perlgen($_), @{$node->parameters};
  4         13  
117 4         25 return '( '.join(' / ', @arg_code).' )';
118             }
119              
120             sub nodeval_and :Pure { # customize nodeval_ to provide lazy evaluation of arguments
121 3     3 0 9 my ($self, $node)= @_;
122             $_->evaluate($self) or return 0
123 3   100     5 for @{ $node->parameters };
  3         9  
124 2         19 return 1;
125 6     6   1515 }
  6         19  
  6         30  
126             sub simplify_and {
127 1     1 0 3 my ($self, $node)= @_;
128 1         12 my @unknown;
129 1         4 for (@{ $node->parameters }) {
  1         5  
130 2 50       5 if ($_->is_constant) {
131             # true constant causes expression to always evaluate true
132 2 50       6 return Language::FormulaEngine::Parser::Node::Number->new(0)
133             unless $_->evaluate($self);
134             } else {
135 0         0 push @unknown, $_;
136             }
137             }
138 1 50       4 return Language::FormulaEngine::Parser::Node::Number->new(1) unless @unknown;
139 0 0       0 return $node if @unknown == @{ $node->parameters };
  0         0  
140 0         0 return Language::FormulaEngine::Parser::Node::Call->new($node->function_name, \@unknown);
141             }
142             sub perlgen_and {
143 4     4 0 44 my ($self, $compiler, $node)= @_;
144 4         8 my @arg_code= map $compiler->perlgen($_), @{$node->parameters};
  4         14  
145 4         34 return '( ('.join(' and ', @arg_code).')? 1 : 0)';
146             }
147              
148             sub nodeval_or :Pure {
149 0     0 0 0 my ($self, $node)= @_;
150             $_->evaluate($self) and return 1
151 0   0     0 for @{ $node->parameters };
  0         0  
152 0         0 return 0;
153 6     6   2510 }
  6         25  
  6         30  
154             sub simplify_or {
155 2     2 0 3 my ($self, $node)= @_;
156 2         5 my @unknown;
157 2         7 for (@{ $node->parameters }) {
  2         4  
158 2 50       6 if ($_->is_constant) {
159             # true constant causes expression to always evaluate true
160 2 50       6 return Language::FormulaEngine::Parser::Node::Number->new(1)
161             if $_->evaluate($self);
162             } else {
163 0         0 push @unknown, $_;
164             }
165             }
166 0 0       0 return Language::FormulaEngine::Parser::Node::Number->new(0) unless @unknown;
167 0 0       0 return $node if @unknown == @{ $node->parameters };
  0         0  
168 0         0 return Language::FormulaEngine::Parser::Node::Call->new($node->function_name, \@unknown);
169             }
170             sub perlgen_or {
171 0     0 0 0 my ($self, $compiler, $node)= @_;
172 0         0 my @arg_code= map $compiler->perlgen($_), @{$node->parameters};
  0         0  
173 0         0 return '( ('.join(' or ', @arg_code).')? 1 : 0)';
174             }
175              
176             sub fn_not :Pure {
177 2 50   2 0 8 @_ == 1 or die "Too many arguments to 'not'\n";
178 2 100       19 return $_[0]? 0 : 1;
179 6     6   2388 }
  6         14  
  6         48  
180             sub perlgen_not {
181 3     3 0 86 my ($self, $compiler, $node)= @_;
182 3         10 my @arg_code= map $compiler->perlgen($_), @{$node->parameters};
  3         12  
183 3 50       14 @arg_code == 1 or die "Too many arguments to 'not'\n";
184 3         15 return '('.$arg_code[0].'? 0 : 1)';
185             }
186              
187             sub fn_compare :Pure {
188 21     21 0 72 my $left= shift;
189 21         60 while (@_) {
190 27         48 my $op= shift;
191 27         44 my $right= shift;
192 27   66     119 my $numeric= Scalar::Util::looks_like_number($left) && Scalar::Util::looks_like_number($right);
193 27 100 66     228 if ($op eq '==' or $op eq '!=') {
    100 100        
    50 66        
194 2 50       11 return 0 unless ($numeric? ($left == $right) : ($left eq $right)) == ($op eq '==');
    50          
195             }
196             elsif ($op eq '>=' or $op eq '<') {
197 6 100       34 return 0 unless ($numeric? ($left >= $right) : ($left ge $right)) == ($op eq '>=');
    50          
198             }
199             elsif ($op eq '<=' or $op eq '>') {
200 19 50       91 return 0 unless ($numeric? ($left <= $right) : ($left le $right)) == ($op eq '<=');
    100          
201             }
202             else {
203 0         0 die "Unhandled operator '$op' in compare()\n";
204             }
205 21         58 $left= $right;
206             }
207 15         87 return 1;
208 6     6   2398 }
  6         22  
  6         35  
209              
210              
211             sub fn_choose :Pure {
212 2 50 33 2 0 16 $_[0] > 0 and $_[0] < @_ or die "CHOSE() selector out of bounds ($_[0])";
213 2         12 return $_[$_[0]];
214 6     6   1081 }
  6         19  
  6         38  
215              
216             sub nodeval_if :Pure { # customize nodeval_ to provide lazy evaluation of arguments
217 2     2 0 7 my ($self, $node)= @_;
218 2 50       5 @{$node->parameters} == 3 or die "IF(test, when_true, when_false) requires all 3 parameters\n";
  2         6  
219 2         20 my $bool= $node->parameters->[0]->evaluate($self);
220 2 100       8 return $node->parameters->[$bool? 1 : 2]->evaluate($self);
221 6     6   1270 }
  6         26  
  6         63  
222             sub perlgen_if {
223 4     4 0 37 my ($self, $compiler, $node)= @_;
224 4         14 my @arg_code= map $compiler->perlgen($_), @{$node->parameters};
  4         14  
225 4 50       18 @arg_code == 3 or die "IF(test, when_true, when_false) requires all 3 parameters\n";
226 4         27 return '( '.$arg_code[0].'? '.$arg_code[1].' : '.$arg_code[2].' )';
227             }
228              
229             sub nodeval_iferror :Pure {
230 6     6 0 22 my ($self, $node)= @_;
231 6         11 my $ret;
232             try {
233 6     6   261 $ret= $node->parameters->[0]->evaluate($self);
234             } catch {
235 5     5   84 my $err= $node->parameters->[1];
236 5 50       15 $ret= defined $err? $err->evaluate($self) : '';
237 6         81 };
238 5         62 return $ret;
239 6     6   2066 }
  6         19  
  6         40  
240             sub perlgen_iferror {
241 6     6 0 44 my ($self, $compiler, $node)= @_;
242 6         12 my @arg_code= map $compiler->perlgen($_), @{$node->parameters};
  6         16  
243 6         31 return '(do { local $@; my $x; eval { $x=('.$arg_code[0].'); 1 }? $x : ('.$arg_code[1].') })';
244             }
245              
246             sub nodeval_ifs :Pure {
247 3     3 0 9 my ($self, $node)= @_;
248 3 50       7 (my @todo= @{$node->parameters}) & 1
  3         8  
249             and die "IFS(cond, val, ...) requires an even number of parameters\n";
250 3         9 while (@todo) {
251 6         17 my ($cond, $val)= splice @todo, 0, 2;
252 6 100       16 return $val->evaluate($self) if $cond->evaluate($self);
253             }
254 1         9 die "IFS() had no true conditions\n";
255 6     6   1896 }
  6         48  
  6         37  
256             sub perlgen_ifs {
257 3     3 0 22 my ($self, $compiler, $node)= @_;
258 3 50       8 (my @arg_code= map $compiler->perlgen($_), @{$node->parameters}) & 1
  3         9  
259             and die "IFS(cond, val, ...) requires an even number of parameters\n";
260 3         8 my $expr= '(';
261 3         10 while (@arg_code) {
262 6         18 my ($cond, $val)= splice @arg_code, 0, 2;
263 6         26 $expr .= "($cond)? ($val) : ";
264             }
265 3         9 $expr .= 'die "IFS() had no true conditions\n")';
266 3         14 return $expr;
267             }
268              
269             sub fn_na :Pure {
270 2     2 0 13 die ErrNA("NA");
271 6     6   1869 }
  6         24  
  6         32  
272              
273              
274             *fn_abs= *CORE::abs;
275             *fn_acos= *Math::Trig::acos;
276             *fn_acot= *Math::Trig::acot;
277             *fn_asin= *Math::Trig::asin;
278             *fn_atan= *Math::Trig::atan;
279             __PACKAGE__->MODIFY_CODE_ATTRIBUTES($_, 'Pure') for \&fn_abs, \&fn_acos, \&fn_acot, \&fn_asin, \&fn_atan;
280              
281             sub fn_atan2 :Pure {
282             # Perl differs in argument order from popular spreadsheet programs
283 2     2 0 17 atan2($_[1], $_[0])
284 6     6   1575 }
  6         29  
  6         37  
285              
286             sub fn_average :Pure {
287 4     4 0 51 List::Util::sum0(@_) / @_;
288 6     6   852 }
  6         18  
  6         26  
289              
290             sub fn_base :Pure {
291 4     4 0 19 my ($num, $radix, $min_length)= @_;
292 4         8 my $digits= '';
293 4         13 while ($num > 0) {
294 6     6   932 use integer;
  6         16  
  6         54  
295 16         36 ($num, my $digit)= ($num / $radix, $num % $radix);
296 16 50       54 $digits= chr(($digit < 10? 48 : 65) + $digit) . $digits;
297             }
298 4   100     13 my $pad= ($min_length||0) - length $digits;
299 4 100       31 return $pad > 0? '0'x$pad . $digits : $digits;
300 6     6   697 }
  6         22  
  6         33  
301              
302             *fn_cos= *CORE::cos;
303             *fn_degrees= *Math::Trig::rad2deg;
304             *fn_exp= *CORE::exp;
305             __PACKAGE__->MODIFY_CODE_ATTRIBUTES($_, 'Pure') for \&fn_cos, \&fn_degrees, \&fn_exp;
306              
307             sub fn_fact :Pure {
308 6     6 0 22 my $n= int($_[0]);
309 6 100       25 return 1 unless $n;
310 4 50       12 $n > 0 or die ErrNUM("Can't compute factorial of negative number '$n'");
311 4         40 List::Util::product(1 .. $n);
312 6     6   1601 }
  6         23  
  6         38  
313              
314             *fn_min= *List::Util::min;
315             *fn_max= *List::Util::max;
316             __PACKAGE__->MODIFY_CODE_ATTRIBUTES($_, 'Pure') for \&fn_min, \&fn_max;
317             sub fn_mod :Pure {
318 8     8 0 31 my ($num, $modulo)= @_;
319 8 50       22 $modulo+0 or die ErrNUM("MOD($num, $modulo): can't claculate modulus-0");
320 8         43 $num % $modulo;
321 6     6   1444 }
  6         31  
  6         30  
322              
323             *fn_pi= *Math::Trig::pi;
324             __PACKAGE__->MODIFY_CODE_ATTRIBUTES($_, 'Pure') for \&fn_pi;
325              
326             sub fn_round :Pure {
327 6     6 0 25 my ($num, $digits)= @_;
328 6   100     44 my $scale= 0.1 ** ($_[1] || 0);
329 6         49 return round($num / $scale) * $scale;
330 6     6   1270 }
  6         16  
  6         54  
331              
332             our $epsilon= 5e-14; # fudge factor for avoiding floating point rounding errors
333             sub fn_ceiling :Pure {
334 18     18 0 63 my ($num, $step)= @_;
335 18 100       49 $step= 1 unless defined $step;
336 18         145 return POSIX::ceil($num / $step - $epsilon) * $step;
337 6     6   1190 }
  6         14  
  6         31  
338             sub fn_floor :Pure {
339 18     18 0 59 my ($num, $step)= @_;
340 18 100       49 $step= 1 unless defined $step;
341 18         153 return POSIX::floor($num / $step + $epsilon) * $step;
342 6     6   1104 }
  6         27  
  6         38  
343             sub fn_roundup :Pure {
344 8   100 8 0 79 fn_ceiling($_[0], 0.1 ** ($_[1] || 0));
345 6     6   1003 }
  6         15  
  6         48  
346             sub fn_rounddown :Pure {
347 8   100 8 0 65 fn_floor($_[0], 0.1 ** ($_[1] || 0));
348 6     6   920 }
  6         50  
  6         38  
349              
350             sub fn_power :Pure {
351 2 50   2 0 11 @_ == 2 or die ErrInval("POWER() takes 2 arguments");
352 2         13 return $_[0] ** $_[1];
353 6     6   954 }
  6         18  
  6         35  
354              
355             *fn_rand= *CORE::rand;
356             *fn_sin= *CORE::sin;
357             *fn_sqrt= *CORE::sqrt;
358             *fn_tan= *Math::Trig::tan;
359             __PACKAGE__->MODIFY_CODE_ATTRIBUTES($_, 'Pure') for \&fn_sin, \&fn_sqrt, \&fn_tan;
360              
361              
362             *fn_char= *CORE::chr;
363             sub fn_clean {
364 14     14 0 50 my $str= shift;
365 14         62 $str =~ s/[[:^print:]]+//g;
366 14         76 $str;
367             }
368             *fn_code= *CORE::ord;
369             *fn_upper= *CORE::uc;
370             *fn_lower= *CORE::lc;
371             __PACKAGE__->MODIFY_CODE_ATTRIBUTES($_, 'Pure') for \&fn_char, \&fn_code, \&fn_upper, \&fn_lower;
372              
373             sub fn_replace :Pure {
374 0 0   0 0 0 @_ == 4 or die ErrInval("REPLACE() takes 4 arguments");
375 0         0 my ($text, $ofs, $n, $newtext)= @_;
376 0         0 substr($text, $ofs, $n)= $newtext;
377 0         0 return $text;
378 6     6   2817 }
  6         19  
  6         42  
379              
380             *fn_substr= *CORE::substr;
381             *fn_len= *CORE::length;
382              
383             sub fn_concatenate :Pure {
384 0     0 0 0 join '', @_;
385 6     6   1250 }
  6         17  
  6         29  
386             *fn_concat= *fn_concatenate;
387             *fn_join= *CORE::join;
388              
389             __PACKAGE__->MODIFY_CODE_ATTRIBUTES($_, 'Pure') for \&fn_substr, \&fn_len, \&fn_join;
390              
391             sub fn_find :Pure {
392 0     0 0 0 my ($needle, $haystack, $ofs)= @_;
393 0 0 0     0 $ofs= 1 unless $ofs && $ofs > 0;
394 0         0 return index($haystack, $needle, $ofs) + 1;
395 6     6   1643 }
  6         61  
  6         37  
396              
397             sub fn_fixed :Pure {
398 10     10 0 41 my ($number, $places, $comma)= @_;
399 10 100       29 $places= 2 unless defined $places;
400 10 100 66     43 $comma= ',' unless defined $comma && (!$comma or $comma eq '.');
      66        
401 10 100       83 $number= $places > 0? sprintf("%.*f", $places, $number) : fn_round($number, $places);
402 10 100       28 if ($comma) {
403 8 100       25 $number =~ s/\./,/ if $comma eq '.';
404 8 100       45 my $tmp= reverse substr($number, 0, $places > 0? -($places+1) : length $number);
405 8         39 $tmp =~ s/(\d\d\d)(?=\d)/$1$comma/g;
406 8 100       34 substr($number, 0, $places > 0? -($places+1) : length $number)= reverse $tmp;
407             }
408 10         59 return $number;
409 6     6   2374 }
  6         25  
  6         30  
410              
411             sub fn_trim :Pure {
412 12     12 0 43 my $str= shift;
413 12         58 $str =~ s/\p{Space}+/ /g;
414 12         37 $str =~ s/^ //;
415 12         34 $str =~ s/ $//;
416 12         91 $str;
417 6     6   6714 }
  6         16  
  6         42  
418              
419              
420             sub fn_datevalue :Pure {
421 82     82 0 9391 my $date= shift;
422 82 100 66     532 return $date if ref $date && ref($date)->isa('DateTime');
423 34     34   1567 try { DateTime::Format::Flexible->parse_datetime($date) }
424 34     2   245 catch { die ErrInval("Not a date: '$date'") };
  2         6649  
425 6     6   1370 }
  6         21  
  6         39  
426 6     6   1752 BEGIN { *_date= *fn_datevalue; } # for convenience
427             sub fn_date :Pure {
428 4     4 0 17 my ($y, $m, $d)= @_;
429 4     4   186 try { DateTime->new(year => $y, month => $m, day => $d) }
430 4 50 33 2   32 catch { die ErrInval(ref $_ && $_->can("message")? $_->message : "$_") };
  2         2540  
431 6     6   64 }
  6         28  
  6         58  
432              
433             sub fn_datedif :Pure {
434 2     2 0 9 my ($start, $end, $unit)= @_;
435 2   50     9 $unit= uc($unit || '');
436 2 50       8 if ($unit eq 'Y') { return _date($end)->delta_md(_date($start))->in_units('years') }
  0         0  
437 2 50       8 if ($unit eq 'M') { return _date($end)->delta_md(_date($start))->in_units('months') }
  2         10  
438 0 0       0 if ($unit eq 'D') { return _date($end)->delta_days(_date($start))->in_units('days') }
  0         0  
439 0         0 die ErrInval "Unsupported datedif unit '$unit'";
440 6     6   1799 }
  6         17  
  6         50  
441             sub fn_day :Pure {
442 8     8 0 5954 _date($_[0])->day
443 6     6   880 }
  6         21  
  6         32  
444             sub fn_days :Pure {
445 4     4 0 19 my ($end, $start)= ( _date($_[0]), _date($_[1]) );
446 4         2415 my $n= $end->delta_days($start)->in_units('days');
447 4 100       600 return $end > $start? $n : -$n;
448 6     6   1230 }
  6         20  
  6         42  
449             sub fn_eomonth :Pure {
450 6     6 0 27 my ($start, $m_ofs)= @_;
451 6 100       19 $m_ofs= 0 unless @_ > 1;
452 6         21 _date($start)->clone->add(months => $m_ofs+1)->truncate(to => 'month')->subtract(days => 1);
453 6     6   1330 }
  6         22  
  6         35  
454             sub fn_hour :Pure {
455 4     4 0 20 _date($_[0])->hour
456 6     6   874 }
  6         12  
  6         47  
457             sub fn_minute :Pure {
458 2     2 0 11 _date($_[0])->minute
459 6     6   878 }
  6         31  
  6         33  
460             sub fn_month :Pure {
461 2     2 0 11 _date($_[0])->month
462 6     6   915 }
  6         22  
  6         58  
463             sub fn_now {
464 2     2 0 15 DateTime->now;
465             }
466             sub fn_second :Pure {
467 2     2 0 13 _date($_[0])->second
468 6     6   985 }
  6         21  
  6         45  
469             sub fn_today {
470 2     2 0 14 DateTime->now->truncate(to => 'day');
471             }
472             sub fn_weekday :Pure {
473 44     44 0 160 my ($date, $standard)= @_;
474 44         111 my $day_mon1= _date($date)->day_of_week;
475 44 100 100     338 return $day_mon1 % 7 + 1 if !$standard or $standard == 1;
476 36 100 100     177 return $day_mon1 if $standard == 2 or $standard == 11;
477 28 100       88 return $day_mon1-1 if $standard == 3;
478 24 50 33     196 return ($day_mon1 - ($standard - 10)) % 7 + 1 if $standard >= 12 && $standard <= 17;
479 0         0 die ErrInval("No known weekday standard '$standard'");
480 6     6   1587 }
  6         20  
  6         37  
481             sub fn_year :Pure {
482 2     2 0 10 _date($_[0])->year
483 6     6   897 }
  6         32  
  6         33  
484              
485             # Perl older than 5.16 can't actually reference the functions in CORE:: namespace.
486             # For example, perl -e 'my $sub= sub { CORE::ord(shift) }; print $sub->("A")' works but
487             # perl -e 'my $sub= sub { &CORE::ord }; print $sub->("A")' does not. Neither does
488             # perl -e 'CORE->can("ord")->("A")', nor does *fn_foo= *CORE::foo used above.
489             # I could of course just wrap each core function with a function defined in this
490             # package, but it would be a needless performance hit for modern perl, and clutter
491             # the code above.
492             if ($] < 5.016) {
493             require Sub::Util;
494             my $stash= \%Language::FormulaEngine::Namespace::Default::;
495             for my $fn (grep /^fn_/, keys %$stash) {
496             my $symname= "$stash->{$fn}";
497             next unless $symname =~ s/^\*CORE/CORE/;
498             #print "# Stash $fn is $symname\n";
499             # prototypes make this annoying
500             my $code= $symname eq 'CORE::substr'? "sub { substr(shift, \@_) }"
501             : $symname eq 'CORE::join'? "sub { join(shift, \@_) }"
502             : "sub { $symname(shift) }";
503             my $sub= eval $code or die "$@";
504 6     6   1554 no strict 'refs'; no warnings 'redefine';
  6     6   19  
  6         276  
  6         36  
  6         12  
  6         655  
505             # The name of the sub needs to remain as CORE::foo else test cases will fail
506             *$fn= Sub::Util::set_subname($symname, $sub);
507             }
508             }
509              
510              
511             1;
512              
513             __END__
514              
515             =pod
516              
517             =encoding UTF-8
518              
519             =head1 NAME
520              
521             Language::FormulaEngine::Namespace::Default - Default spreadsheet-like set of functions and behavior
522              
523             =head1 VERSION
524              
525             version 0.07
526              
527             =head1 DESCRIPTION
528              
529             This is a L<namespace|Language::FormulaEngine::Namespace> containing many spreadsheet-like
530             functions. It aims for spreadsheet similarity rather than compatibility; the goal to give
531             users of the FormulaEngine a familiar environmet rather than to try duplicating all features
532             and misfeatures Excel.
533              
534             =head2 Core Grammar Functionality
535              
536             These are the methods that implement the infix operators.
537              
538             =over
539              
540             =item C<< sum( num1, num2 ... ) >>
541              
542             =item C<< negative( num1 ) >>
543              
544             =item C<< mul( num1, num2, ... ) >>
545              
546             =item C<< div( numerator, denominator ) >>
547              
548             =item C<< and( bool1, bool2, ... ) >>
549              
550             This applies perl-ish boolean semantics to each argument, and returns a numeric 0 or 1.
551             No arguments are evaluated after the first false value.
552              
553             =item C<< or( bool1, bool2, ... ) >>
554              
555             This applies perl-ish boolean semantics to each argument, and returns a numeric 0 or 1.
556             No arguments are evaluated after the first true value.
557              
558             =item C<< not( bool1 ) >>
559              
560             This applies perl-ish boolean semantics to the argument and returns numeric 1 or 0.
561              
562             =item C<< compare( val1, op, val2, ...op, val ) >>
563              
564             This compares two or more values against the 6 canonical operators
565             C<< "<", "<=", ">", ">=", "==", "!=" >> and returns 0 or 1.
566              
567             It uses numeric comparison if both sides of an operator C<looks_like_number>, and uses string
568             comparison otherwise.
569              
570             =back
571              
572             =head2 Utility Functions
573              
574             =over
575              
576             =item C<< choose( offset, val1, val2, val3, ... ) >>
577              
578             Given a 1-based offset, return the value of the Nth parameter.
579              
580             =item C<< if( condition, val_if_true, val_if_false ) >>
581              
582             If C<condition> is "true" (Perl interpretation) return C<val_if_true>, else C<val_if_false>.
583              
584             =item C<< iferror( value_maybe_error, alternate_value ) >>
585              
586             If C<value_maybe_error> does not throw an exception, return it, else return the
587             C<alternate_value>.
588              
589             =item C<< ifs( condition1, value1, condition2, value2, ... ) >>
590              
591             A simplified sequence of IF functions. If C<condition1> is true, it returns C<value1>, else if
592             C<condition2> is true it returns C<value2>, and so on. If no condition is true it dies. (use
593             a final true condition and value to provide a default)
594              
595             =item C<< na() >>
596              
597             Throw an NA exception.
598              
599             =back
600              
601             =head2 Math Functions
602              
603             =over
604              
605             =item C<< abs( number ) >>
606              
607             Return absolute value of number
608              
609             =item C<< acos( ratio ) >>
610              
611             Return angle in radians of the ratio adjacent/hypotenuse.
612              
613             =item C<< acot( ratio ) >>
614              
615             Return angle in radians of the ratio adjacent/opposite.
616              
617             =item C<< asin( ratio ) >>
618              
619             Return angle in radians of the ratio opposite/hypotenuse.
620              
621             =item C<< atan( ratio ) >>
622              
623             Return angle in radians of the ratio opposite/adjacent.
624              
625             =item C<< atan2( x, y ) >>
626              
627             Same as atan, but without division, so x=0 returns PI/2 instead of division error.
628              
629             =item C<< average( num1, ... ) >>
630              
631             Return sum of numbers divided by number of arguments
632              
633             =item C<< base( num1, radix, min_length=0 ) >>
634              
635             Return number converted to different base, with optional leading zeroes to reach min_length.
636              
637             =item C<< ceiling( number, step=1 ) >>
638              
639             Round a number up to the next multiple of C<step>. If step is negative, this rounds away from
640             zero in the negative direction.
641              
642             =item C<< cos( angle ) >>
643              
644             Cosine of C<angle> in radians
645              
646             =item C<< cot( ratio ) >>
647              
648             Return the angle for the triangle ratio adjacent/opposite.
649              
650             =item C<< degrees( angle_in_radians ) >>
651              
652             Convert radians to degrees
653              
654             =item C<< exp( power ) >>
655              
656             Return base of the natural log raised to the specified power.
657              
658             =item C<< fact( n ) >>
659              
660             Compute factorial of C<n>. (C<< 1 * 2 * 3 * ... n >>)
661              
662             =item C<< floor( number, step=1 ) >>
663              
664             Round a number down to the previous multiple of C<step>. If step is negative, this rounds
665             toward zero in the positive direction.
666              
667             =item C<< max( number, ... ) >>
668              
669             Return largest value in list
670              
671             =item C<< min( number, ... ) >>
672              
673             Return smallest value in list
674              
675             =item C<< mod( number, modulo ) >>
676              
677             Returns true modulous of a number. This uses Perl's (and math's) definition. For the Excel-
678             compatible MOD function, see C<remainder>.
679              
680             =item C<< pi() >>
681              
682             Value of π
683              
684             =item C<< radians( angle_in_degrees ) >>
685              
686             Convert degrees to radians.
687              
688             =item C<< rand( range=1 ) >>
689              
690             Returns pseudo-random value greater or equal to 0 and less than C<range>. This uses perl's
691             (C's) built-in C<< rand() >> function which is likely not as good as the generators used by
692             spreadsheet programs, but I didn't want to add a hefty dependency.
693              
694             =item C<< remainder( number, divisor ) >>
695              
696             Return the number after subtracting the biggest multiple of divisor that can be removed from it.
697             The remainder's sign will be the same as the sign of C<divisor> (unless remainder is zero).
698              
699             =item C<< round( number, digits=0 ) >>
700              
701             Round NUMBER to DIGITS decimal places of precision. Uses the IEEE
702             5-round-to-even algorithm that C gives us. DIGITS defaults to 0,
703             making it round to the nearest integer.
704              
705             Dies if you attempt to round something that isn't a number.
706              
707             =item C<< roundup( number, digits=0 ) >>
708              
709             Like L</round>, but always round up. See also L</ceiling>.
710              
711             =item C<< rounddown( number, digits=0 ) >>
712              
713             Like L</round>, but always round down. See also L</floor>.
714              
715             =item C<< sign( value ) >>
716              
717             Return 1, 0, or -1 depending on the sign of C<value>.
718              
719             =item C<< sin( angle ) >>
720              
721             Returns ratio of opposite/adjacent for a given angle in radians.
722              
723             =item C<< sqrt( number ) >>
724              
725             Return square root of a number.
726              
727             =item C<< tan( angle ) >>
728              
729             Return ratio of opposite/adjacent for an angle.
730              
731             =back
732              
733             =head2 String Functions
734              
735             =over
736              
737             =item C<< char( codepoint_value ) >>
738              
739             Return a unicode character.
740              
741             =item C<< clean( string ) >>
742              
743             Returns C<string> after removing all non-printable characters (defined as C<< [:^print:] >> )
744              
745             =item C<< code( string ) >>
746              
747             Opposite of L</char>, known as C<ord()> in other languages. Returns the unicode codepoint
748             number of the first character of the string.
749              
750             =item C<< concat, concatenate( string, ... ) >>
751              
752             Returns all arguments concatenated as a string
753              
754             =item C<< find( needle, haystack, from_offset=1 ) >>
755              
756             Return the character offset of C<needle> from start of C<haystack>, beginning the search at
757             from_offset. All offsets are 1-based.
758              
759             =item C<< fixed( number, decimals=2, no_commas=false ) >>
760              
761             Return the number formatted with a fixed number of decimal places. By default, it gets commas
762             added in the USA notation, but this can be disabled.
763              
764             =item C<< len( string ) >>
765              
766             Return number of unicode characters in STRING.
767              
768             =item C<< lower( string ) >>
769              
770             Return lowercase version of STRING.
771              
772             =item C<< replace( string, offset, length, new_text ) >>
773              
774             Replace text in C<string> with C<new_text>, overwriting C<length> characters from C<offset>.
775              
776             =item C<< substr( string, offset, length=max ) >>
777              
778             Same as perl's builtin.
779              
780             =item C<< trim( string ) >>
781              
782             Remove all leading and trailing whitespace and replace runs of whitespace with a single space
783             character.
784              
785             =item C<< upper( string ) >>
786              
787             Return uppercase version of STRING.
788              
789             =item C<< textjoin, join( separator, string, ... ) >>
790              
791             Same as perl's builtin.
792              
793             =back
794              
795             =head2 DateTime Functions
796              
797             Date math is implemented using the L<DateTime> module. Strings are coerced into dates using
798             the L<DateTime::Format::Flexible> module for any parameter where a spreadsheet function would
799             normally expect a date value. "Since 1900" date serial numbers are not used at all.
800              
801             =over
802              
803             =item C<< date( year, month, day ) >>
804              
805             Convert a (year,month,day) triplet into a date.
806              
807             =item C<< datedif( start_date, end_date, unit ) >>
808              
809             Calculate difference bwteen two dates. Unit can be one of: C<"Y"> (whole years), C<"M"> (whole
810             months), C<"D"> (whole days). Dates can be parsed from any string resembling a date.
811              
812             =item C<< datevalue( text ) >>
813              
814             Parse a date, or die trying.
815              
816             =item C<< day( date ) >>
817              
818             Returns the day number of a date
819              
820             =item C<< days( end_date, start_date ) >>
821              
822             Returns number of days difference between start and end date.
823              
824             =item C<< eomonth( start_date, months ) >>
825              
826             Calculate the date of End-Of-Month at some offset from the start date.
827              
828             =item C<< hour( date ) >>
829              
830             Return the hour field of a date.
831              
832             =item C<< minute( date ) >>
833              
834             Return minute field of a date.
835              
836             =item C<< month( date ) >>
837              
838             Return month field of a date.
839              
840             =item C<< year( date ) >>
841              
842             Return the year field of a date.
843              
844             =back
845              
846             =head1 AUTHOR
847              
848             Michael Conrad <mconrad@intellitree.com>
849              
850             =head1 COPYRIGHT AND LICENSE
851              
852             This software is copyright (c) 2023 by Michael Conrad, IntelliTree Solutions llc.
853              
854             This is free software; you can redistribute it and/or modify it under
855             the same terms as the Perl 5 programming language system itself.
856              
857             =cut