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