File Coverage

blib/lib/Math/Util/CalculatedValue.pm
Criterion Covered Total %
statement 121 121 100.0
branch 41 42 97.6
condition 23 24 95.8
subroutine 22 22 100.0
pod 15 15 100.0
total 222 224 99.1


line stmt bran cond sub pod time code
1             package Math::Util::CalculatedValue;
2              
3 3     3   50094 use 5.006;
  3         9  
  3         170  
4 3     3   18 use strict;
  3         3  
  3         112  
5 3     3   14 use warnings FATAL => 'all';
  3         15  
  3         155  
6              
7 3     3   16 use Carp qw(confess);
  3         4  
  3         204  
8 3     3   73 use List::Util qw(min max);
  3         5  
  3         4773  
9              
10             =head1 NAME
11              
12             Math::Util::CalculatedValue - math adjustment, which can containe another adjustments
13              
14             =head1 VERSION
15              
16             Version 0.06
17              
18             =head1 DESCRIPTION
19              
20             Represents an adjustment to a value (which can contain additional adjustments).
21              
22             =cut
23              
24             our $VERSION = '0.06';
25              
26             =head1 SYNOPSIS
27              
28             my $tid = Math::Util::CalculatedValue->new({
29             name => 'time_in_days',
30             description => 'Duration in days',
31             set_by => 'Contract',
32             base_amount => 0,
33             });
34              
35             my $tiy = Math::Util::CalculatedValue->new({
36             name => 'time_in_years',
37             description => 'Duration in years',
38             set_by => 'Contract',
39             base_amount => 1,
40             });
41              
42             my $dpy = Math::Util::CalculatedValue->new({
43             name => 'days_per_year',
44             description => 'days in a year',
45             set_by => 'Contract',
46             base_amount => 365,
47             });
48              
49             $tid->include_adjustment('reset', $tiy);
50             $tid->include_adjustment('multiply', $dpy);
51              
52             print $tid->amount;
53              
54             =head1 ATTRIBUTES
55              
56             =head2 name
57              
58             This is the name of the operation which called this module
59              
60             =cut
61              
62             sub name {
63 173     173 1 127 my ($self) = @_;
64 173         328 return $self->{'name'};
65             }
66              
67             =head2 description
68              
69             This is the description of the operation which called this module
70              
71             =cut
72              
73             sub description {
74 1     1 1 2 my ($self) = @_;
75 1         5 return $self->{'description'};
76             }
77              
78             =head2 set_by
79              
80             This is the name of the module which called this module
81              
82             =cut
83              
84             sub set_by {
85 1     1 1 1 my ($self) = @_;
86 1         5 return $self->{'set_by'};
87             }
88              
89             =head2 base_amount
90              
91             This is the base amount on which the adjustments are to be made
92              
93             =cut
94              
95             sub base_amount {
96 4     4 1 8 my ($self) = @_;
97 4   100     20 return $self->{'base_amount'} || 0;
98             }
99              
100             =head2 metadata
101              
102             Additional information that you wish to include.
103              
104             =cut
105              
106             sub metadata {
107 1     1 1 2 my ($self) = @_;
108 1         5 return $self->{'metadata'};
109             }
110              
111             =head2 minimum
112              
113             The minimum value for amount
114              
115             =cut
116              
117             sub minimum {
118 1     1 1 2 my ($self) = @_;
119 1         4 return $self->{'minimum'};
120             }
121              
122             =head2 maximum
123              
124             The maximum value for amount
125              
126             =cut
127              
128             sub maximum {
129 1     1 1 1 my ($self) = @_;
130 1         4 return $self->{'maximum'};
131             }
132              
133             my %available_adjustments = (
134             'add' => sub { my ( $this, $prev ) = @_; return $prev + $this->amount; },
135             'multiply' => sub { my ( $this, $prev ) = @_; return $prev * $this->amount; },
136             'subtract' => sub { my ( $this, $prev ) = @_; return $prev - $this->amount; },
137             'divide' => sub { my ( $this, $prev ) = @_; return $prev / $this->amount; },
138             'reset' => sub { my ( $this, $prev ) = @_; return $this->amount; },
139             'exp' => sub { my ( $this, $prev ) = @_; return exp( $this->amount ); },
140             'log' => sub { my ( $this, $prev ) = @_; return log( $this->amount ); },
141             'info' => sub { my ( $this, $prev ) = @_; return $prev; },
142             'absolute' => sub { my ( $this, $prev ) = @_; return abs( $this->amount ); },
143             );
144              
145             =head1 Methods
146              
147             =head2 new
148              
149             New instance method
150              
151             =cut
152              
153             sub new {
154 36     36 1 12411 my $class = shift;
155 36 50       78 my %params_ref = ref( $_[0] ) ? %{ $_[0] } : @_;
  36         126  
156              
157 36         66 foreach my $required ( 'name', 'description', 'set_by' ) {
158 87 100       286 confess "Attribute $required is required"
159             unless $params_ref{$required};
160             }
161              
162 22         30 my $self = \%params_ref;
163 22         26 my $minimum = $self->{'minimum'};
164 22         23 my $maximum = $self->{'maximum'};
165              
166 22 100 100     102 confess
      100        
167             "Provided maximum [$maximum] is less than the provided minimum [$minimum]"
168             if ( defined $minimum
169             and defined $maximum
170             and $maximum < $minimum );
171              
172 20         27 $self->{'calculatedValue'} = 1;
173              
174 20         123 my $obj = bless $self, $class;
175 20         42 return $obj;
176             }
177              
178             =head2 amount
179              
180             This is the final amount from this object, after applying all adjustments.
181              
182             =cut
183              
184             sub amount {
185 134     134 1 878 my $self = shift;
186              
187 134         154 my $value = $self->_verified_cached_value;
188 134 100       187 if ( not defined $value ) {
189 45         67 $value = $self->_apply_all_adjustments;
190 45         47 my $min = $self->{'minimum'};
191 45 100       77 $value = max( $min, $value ) if ( defined $min );
192 45         48 my $max = $self->{'maximum'};
193 45 100       63 $value = min( $max, $value ) if ( defined $max );
194              
195 45         50 $self->{_cached_amount} = $value;
196             }
197              
198 134         334 return $value;
199             }
200              
201             =head2 adjustments
202              
203             The ordered adjustments (if any) applied to arrive at the final value.
204              
205             =cut
206              
207             sub adjustments {
208 2     2 1 4 my ($self) = @_;
209 2   100     15 return $self->{'_adjustments'} || [];
210             }
211              
212             =head2 include_adjustment
213              
214             Creates the ordered adjustments as per the operation.
215              
216             =cut
217              
218             sub include_adjustment {
219 23     23 1 127 my ( $self, $operation, $adjustment ) = @_;
220              
221 23 100       101 confess 'Operation [' . $operation . '] is not supported by ' . __PACKAGE__
222             unless ( $available_adjustments{$operation} );
223 22 100       47 confess 'Supplied adjustment must be type of ' . __PACKAGE__
224             if !ref($adjustment);
225 21 100       54 confess 'Supplied adjustment must be type of' . __PACKAGE__
226             if !$adjustment->{calculatedValue};
227              
228 20         29 delete $self->{_cached_amount};
229 20   100     49 my $adjustments = $self->{'_adjustments'} || [];
230 20         14 push @{$adjustments}, [ $operation, $adjustment ];
  20         41  
231 20         80 $self->{'_adjustments'} = $adjustments;
232             }
233              
234             =head2 exclude_adjustment
235              
236             Remove an adjustment by name. Returns the number of instances found and excluded.
237              
238             Excluded items are changed into 'info' so that that still show up but are do not alter the parent value
239              
240             THis can be extremely dangerous, so make sure you know where and why you are doing it.
241              
242             =cut
243              
244             sub exclude_adjustment {
245 63     63 1 44 my ( $self, $adj_name ) = @_;
246              
247 63         51 my $excluded = 0;
248 63   100     109 my $adjustments = $self->{'_adjustments'} || [];
249 63         46 foreach my $sub_adj ( @{ $adjustments } ) {
  63         78  
250 60         43 my $obj = $sub_adj->[1];
251 60         62 $excluded += $obj->exclude_adjustment($adj_name);
252 60 100       63 if ( $obj->name eq $adj_name ) {
253 30         25 $sub_adj->[0] = 'info';
254 30         31 $excluded++;
255             }
256             }
257              
258 63 100       86 delete $self->{_cached_amount} if ($excluded);
259              
260 63         98 return $excluded;
261             }
262              
263             =head2 replace_adjustment
264              
265             Replace all instances of the same named adjustment with the provided adjustment
266              
267             Returns the number of instances replaced.
268              
269             =cut
270              
271             sub replace_adjustment {
272 30     30 1 68 my ( $self, $replacement ) = @_;
273              
274 30 100       58 confess 'Supplied replacement must be type of '. __PACKAGE__
275             if !ref($replacement);
276              
277 29 100       52 confess 'Supplied replacement must be type of' . __PACKAGE__
278             if !$replacement->{calculatedValue};
279              
280 28         23 my $replaced = 0;
281 28   100     44 my $adjustments = $self->{'_adjustments'} || [];
282 28         23 foreach my $sub_adj ( @{ $adjustments } ) {
  28         31  
283 43         32 my $obj = $sub_adj->[1];
284 43 100       80 $replaced += $obj->replace_adjustment($replacement)
285             if ( $obj != $replacement );
286 43 100       47 if ( $obj->name eq $replacement->name ) {
287 21         24 $sub_adj->[1] = $replacement;
288 21         26 $replaced++;
289             }
290             }
291              
292 28 100       47 delete $self->{_cached_amount} if ($replaced);
293              
294 28         34 return $replaced;
295             }
296              
297             # Loops through the ordered adjustments and performs the operation/adjustment
298             sub _apply_all_adjustments {
299 45     45   34 my ($self) = @_;
300 45   50     64 my $value = $self->{'base_amount'} || 0;
301 45   100     89 my $adjustments = $self->{'_adjustments'} || [];
302 45         32 foreach my $adjustment ( @{$adjustments} ) {
  45         63  
303 142         226 $value =
304             $available_adjustments{ $adjustment->[0] }
305             ->( $adjustment->[1], $value );
306             }
307 45         55 return $value;
308             }
309              
310             sub _verified_cached_value {
311 204     204   158 my ($self) = @_;
312 204         120 my $can;
313 204 100       298 if ( exists $self->{_cached_amount} ) {
314 154         117 $can = $self->{_cached_amount};
315 154   100     322 my $adjustments = $self->{'_adjustments'} || [];
316 154         116 foreach my $adjustment ( @{$adjustments} ) {
  154         158  
317 62 100       77 if ( not defined $adjustment->[-1]->_verified_cached_value ) {
318 4         6 delete $self->{_cached_amount};
319 4         6 $can = undef;
320 4         7 last;
321             }
322             }
323             }
324 204         285 return $can;
325             }
326              
327             =head2 peek
328              
329             Peek at an included adjustment by name.
330              
331             =cut
332              
333             sub peek {
334 20     20 1 17 my ( $self, $adj_name ) = @_;
335              
336 20         13 my $picked;
337              
338 20 100       22 if ( $self->name eq $adj_name ) {
339 3         4 $picked = $self;
340             }
341             else {
342             # Depth first traversal. We assume that if there are two things named the same
343             # in any given CV that they are, in fact, the same value. So we can just return the first one we find.
344 17   100     45 my $adjustments = $self->{'_adjustments'} || [];
345 17         11 foreach my $sub_adj ( @{$adjustments} ) {
  17         22  
346 14         12 my $obj = $sub_adj->[1];
347 14         18 $picked = $obj->peek($adj_name);
348 14 100       27 last if $picked;
349             }
350             }
351              
352 20         25 return $picked;
353             }
354              
355             =head2 peek_amount
356              
357             Peek at the value of an included adjustment by name.
358              
359             =cut
360              
361             sub peek_amount {
362 3     3 1 5 my ( $self, $adj_name ) = @_;
363 3         6 my $adj = $self->peek($adj_name);
364 3 100       11 return ($adj) ? $adj->amount : undef;
365             }
366              
367             =head1 AUTHOR
368              
369             binary.com, C<< <rakesh at binary.com> >>
370              
371             =head1 BUGS
372              
373             Please report any bugs or feature requests to C<bug-math-util-calculatedvalue at rt.cpan.org>, or through
374             the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Math-Util-CalculatedValue>. I will be notified, and then you'll
375             automatically be notified of progress on your bug as I make changes.
376              
377              
378             =head1 SUPPORT
379              
380             You can find documentation for this module with the perldoc command.
381              
382             perldoc Math::Util::CalculatedValue
383              
384              
385             You can also look for information at:
386              
387             =over 4
388              
389             =item * RT: CPAN's request tracker (report bugs here)
390              
391             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Math-Util-CalculatedValue>
392              
393             =item * AnnoCPAN: Annotated CPAN documentation
394              
395             L<http://annocpan.org/dist/Math-Util-CalculatedValue>
396              
397             =item * CPAN Ratings
398              
399             L<http://cpanratings.perl.org/d/Math-Util-CalculatedValue>
400              
401             =item * Search CPAN
402              
403             L<http://search.cpan.org/dist/Math-Util-CalculatedValue/>
404              
405             =back
406              
407              
408             =head1 ACKNOWLEDGEMENTS
409              
410              
411             =head1 LICENSE AND COPYRIGHT
412              
413             Copyright 2014 binary.com.
414              
415             This program is free software; you can redistribute it and/or modify it
416             under the terms of the the Artistic License (2.0). You may obtain a
417             copy of the full license at:
418              
419             L<http://www.perlfoundation.org/artistic_license_2_0>
420              
421             Any use, modification, and distribution of the Standard or Modified
422             Versions is governed by this Artistic License. By using, modifying or
423             distributing the Package, you accept this license. Do not use, modify,
424             or distribute the Package, if you do not accept this license.
425              
426             If your Modified Version has been derived from a Modified Version made
427             by someone other than you, you are nevertheless required to ensure that
428             your Modified Version complies with the requirements of this license.
429              
430             This license does not grant you the right to use any trademark, service
431             mark, tradename, or logo of the Copyright Holder.
432              
433             This license includes the non-exclusive, worldwide, free-of-charge
434             patent license to make, have made, use, offer to sell, sell, import and
435             otherwise transfer the Package with respect to any patent claims
436             licensable by the Copyright Holder that are necessarily infringed by the
437             Package. If you institute patent litigation (including a cross-claim or
438             counterclaim) against any party alleging that the Package constitutes
439             direct or contributory patent infringement, then this Artistic License
440             to you shall terminate on the date that such litigation is filed.
441              
442             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
443             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
444             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
445             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
446             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
447             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
448             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
449             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
450              
451              
452             =cut
453              
454             1; # End of Math::Util::CalculatedValue