File Coverage

blib/lib/DateTimeX/Lite/Duration.pm
Criterion Covered Total %
statement 141 144 97.9
branch 55 60 91.6
condition 10 15 66.6
subroutine 45 46 97.8
pod 33 33 100.0
total 284 298 95.3


line stmt bran cond sub pod time code
1              
2             package DateTimeX::Lite::Duration;
3 56     56   2913 use strict;
  56         106  
  56         2825  
4 56     56   298 use warnings;
  56         106  
  56         3888  
5 56     56   363 use Scalar::Util qw(blessed);
  56         100  
  56         9235  
6              
7 56     56   352 use Carp ();
  56         172  
  56         2495  
8              
9 56         487 use overload ( fallback => 1,
10             '+' => '_add_overload',
11             '-' => '_subtract_overload',
12             '*' => '_multiply_overload',
13             '<=>' => '_compare_overload',
14             'cmp' => '_compare_overload',
15 56     56   153511 );
  56         88809  
16              
17 56     56   7558 use constant MAX_NANOSECONDS => 1_000_000_000; # 1E9 = almost 32 bits
  56         107  
  56         147209  
18              
19             my @all_units = qw( months days minutes seconds nanoseconds );
20              
21             # XXX - need to reject non-integers but accept infinity, NaN, &
22             # 1.56e+18
23             sub new
24             {
25 4349     4349 1 28809 my ($class, %p) = @_;
26 4349         9823 foreach my $field (qw(years months weeks days hours minutes seconds nanoseconds)) {
27 34792 100       98254 $p{$field} = 0 unless defined $p{$field};
28             }
29            
30             =head1
31             my %p = validate( @_,
32             { years => { type => SCALAR, default => 0 },
33             months => { type => SCALAR, default => 0 },
34             weeks => { type => SCALAR, default => 0 },
35             days => { type => SCALAR, default => 0 },
36             hours => { type => SCALAR, default => 0 },
37             minutes => { type => SCALAR, default => 0 },
38             seconds => { type => SCALAR, default => 0 },
39             nanoseconds => { type => SCALAR, default => 0 },
40             end_of_month => { type => SCALAR, default => undef,
41             regex => qr/^(?:wrap|limit|preserve)$/ },
42             } );
43             =cut
44              
45 4349         29450 my $self = bless {}, $class;
46              
47 4349         17845 $self->{months} = ( $p{years} * 12 ) + $p{months};
48              
49 4349         9994 $self->{days} = ( $p{weeks} * 7 ) + $p{days};
50              
51 4349         8619 $self->{minutes} = ( $p{hours} * 60 ) + $p{minutes};
52              
53 4349         8078 $self->{seconds} = $p{seconds};
54              
55 4349 100       18708 if ( $p{nanoseconds} )
56             {
57 38         85 $self->{nanoseconds} = $p{nanoseconds};
58 38         174 $self->_normalize_nanoseconds;
59             }
60             else
61             {
62             # shortcut - if they don't need nanoseconds
63 4311         8850 $self->{nanoseconds} = 0;
64             }
65              
66 4349 100       18284 $self->{end_of_month} =
    100          
67             ( defined $p{end_of_month}
68             ? $p{end_of_month}
69             : $self->{months} < 0
70             ? 'preserve'
71             : 'wrap'
72             );
73              
74 4349         24407 return $self;
75             }
76              
77             # make the signs of seconds, nanos the same; 0 < abs(nanos) < MAX_NANOS
78             # NB this requires nanoseconds != 0 (callers check this already)
79             sub _normalize_nanoseconds
80             {
81 47     47   178 my $self = shift;
82              
83             return if
84 47 100 100     689 ( $self->{nanoseconds} == DateTimeX::Lite::INFINITY()
      100        
85             || $self->{nanoseconds} == DateTimeX::Lite::NEG_INFINITY()
86             || $self->{nanoseconds} eq DateTimeX::Lite::NAN()
87             );
88              
89 44         129 my $seconds = $self->{seconds} + $self->{nanoseconds} / MAX_NANOSECONDS;
90 44         92 $self->{seconds} = int( $seconds );
91 44         105 $self->{nanoseconds} = $self->{nanoseconds} % MAX_NANOSECONDS;
92 44 100       165 $self->{nanoseconds} -= MAX_NANOSECONDS if $seconds < 0;
93             }
94              
95 11     11 1 31 sub clone { bless { %{ $_[0] } }, ref $_[0] }
  11         153  
96              
97 4     4 1 40 sub years { abs( $_[0]->in_units( 'years' ) ) }
98 4     4 1 811 sub months { abs( $_[0]->in_units( 'months', 'years' ) ) }
99 4     4 1 6617 sub weeks { abs( $_[0]->in_units( 'weeks' ) ) }
100 4     4 1 751 sub days { abs( $_[0]->in_units( 'days', 'weeks' ) ) }
101 10     10 1 778 sub hours { abs( $_[0]->in_units( 'hours' ) ) }
102 7     7 1 2010 sub minutes { abs( $_[0]->in_units( 'minutes', 'hours' ) ) }
103 7     7 1 805 sub seconds { abs( $_[0]->in_units( 'seconds' ) ) }
104 4     4 1 1614 sub nanoseconds { abs( $_[0]->in_units( 'nanoseconds', 'seconds' ) ) }
105              
106 8 100   8 1 5748 sub is_positive { $_[0]->_has_positive && ! $_[0]->_has_negative }
107 10 100   10 1 55 sub is_negative { ! $_[0]->_has_positive && $_[0]->_has_negative }
108              
109 18 100   18   40 sub _has_positive { ( grep { $_ > 0 } @{ $_[0] }{@all_units} ) ? 1 : 0}
  90         314  
  18         97  
110 13 100   13   26 sub _has_negative { ( grep { $_ < 0 } @{ $_[0] }{@all_units} ) ? 1 : 0 }
  65         221  
  13         50  
111              
112 6330 100   6330 1 8631 sub is_zero { return 0 if grep { $_ != 0 } @{ $_[0] }{@all_units};
  31650         85365  
  6330         20708  
113 3         13 return 1 }
114              
115 30     30 1 999 sub delta_months { $_[0]->{months} }
116 36     36 1 415 sub delta_days { $_[0]->{days} }
117 26     26 1 204 sub delta_minutes { $_[0]->{minutes} }
118 45     45 1 328 sub delta_seconds { $_[0]->{seconds} }
119 33     33 1 373 sub delta_nanoseconds { $_[0]->{nanoseconds} }
120              
121             sub deltas
122             {
123 6347     6347 1 9434 map { $_ => $_[0]->{$_} } @all_units;
  31735         93793  
124             }
125              
126             sub in_units
127             {
128 64     64 1 153 my $self = shift;
129 64         161 my @units = @_;
130              
131 64         118 my %units = map { $_ => 1 } @units;
  95         312  
132              
133 64         384 my %ret;
134              
135 64         348 my ( $months, $days, $minutes, $seconds ) =
136 64         91 @{ $self }{qw( months days minutes seconds )};
137              
138 64 100       201 if ( $units{years} )
139             {
140 12         42 $ret{years} = int( $months / 12 );
141 12         29 $months -= $ret{years} * 12;
142             }
143              
144 64 100       150 if ( $units{months} )
145             {
146 8         23 $ret{months} = $months;
147             }
148              
149 64 100       143 if ( $units{weeks} )
150             {
151 11         35 $ret{weeks} = int( $days / 7 );
152 11         205 $days -= $ret{weeks} * 7;
153             }
154              
155 64 100       165 if ( $units{days} )
156             {
157 8         24 $ret{days} = $days;
158             }
159              
160 64 100       154 if ( $units{hours} )
161             {
162 21         63 $ret{hours} = int( $minutes / 60 );
163 21         49 $minutes -= $ret{hours} * 60;
164             }
165              
166 64 100       134 if ( $units{minutes} )
167             {
168 11         24 $ret{minutes} = $minutes
169             }
170              
171 64 100       136 if ( $units{seconds} )
172             {
173 16         38 $ret{seconds} = $seconds;
174 16         27 $seconds = 0;
175             }
176              
177 64 100       138 if ( $units{nanoseconds} )
178             {
179 8         32 $ret{nanoseconds} = $seconds * MAX_NANOSECONDS + $self->{nanoseconds};
180             }
181              
182 64 100       579 wantarray ? @ret{@units} : $ret{ $units[0] };
183             }
184              
185 576 100   576 1 3768 sub is_wrap_mode { $_[0]->{end_of_month} eq 'wrap' ? 1 : 0 }
186 3 50   3 1 229 sub is_limit_mode { $_[0]->{end_of_month} eq 'limit' ? 1 : 0 }
187 1151 100   1151 1 6755 sub is_preserve_mode { $_[0]->{end_of_month} eq 'preserve' ? 1 : 0 }
188              
189 0     0 1 0 sub end_of_month_mode { $_[0]->{end_of_month} }
190              
191             sub calendar_duration
192             {
193 3     3 1 12 my $self = shift;
194              
195             return
196 3         11 (ref $self)->new( map { $_ => $self->{$_} } qw( months days end_of_month ) )
  9         33  
197             }
198              
199             sub clock_duration
200             {
201 3     3 1 8 my $self = shift;
202              
203             return
204 3         14 (ref $self)->new( map { $_ => $self->{$_} } qw( minutes seconds nanoseconds end_of_month ) )
  12         38  
205             }
206              
207             sub inverse
208             {
209 1290     1290 1 1961 my $self = shift;
210              
211 1290         4570 my %new;
212 1290         3246 foreach my $u (@all_units)
213             {
214 6450         12376 $new{$u} = $self->{$u};
215             # avoid -0 bug
216 6450 100       16783 $new{$u} *= -1 if $new{$u};
217             }
218              
219 1290         17999 return (ref $self)->new(%new);
220             }
221              
222             sub add_duration
223             {
224 15     15 1 31 my ( $self, $dur ) = @_;
225              
226 15         39 foreach my $u (@all_units)
227             {
228 75         149 $self->{$u} += $dur->{$u};
229             }
230              
231 15 100       81 $self->_normalize_nanoseconds if $self->{nanoseconds};
232              
233 15         420 return $self;
234             }
235              
236             sub add
237             {
238 4     4 1 15 my $self = shift;
239              
240 4         15 return $self->add_duration( (ref $self)->new(@_) );
241             }
242              
243 10     10 1 41 sub subtract_duration { return $_[0]->add_duration( $_[1]->inverse ) }
244              
245             sub subtract
246             {
247 4     4 1 8 my $self = shift;
248              
249 4         19 return $self->subtract_duration( (ref $self)->new(@_) )
250             }
251              
252             sub multiply
253             {
254 3     3 1 11 my $self = shift;
255 3         26 my $multiplier = shift;
256              
257 3         12 foreach my $u (@all_units)
258             {
259 15         39 $self->{$u} *= $multiplier;
260             }
261              
262 3 100       21 $self->_normalize_nanoseconds if $self->{nanoseconds};
263              
264 3         13 return $self;
265             }
266              
267             sub compare
268             {
269 5     5 1 1034 my ( $class, $dur1, $dur2, $dt ) = @_;
270              
271 5   66     52 $dt ||= DateTimeX::Lite->now;
272              
273             return
274 5         19 DateTimeX::Lite->compare( $dt->clone->add_duration($dur1), $dt->clone->add_duration($dur2) );
275             }
276              
277             sub _add_overload
278             {
279 1     1   21 my ( $d1, $d2, $rev ) = @_;
280              
281 1 50       11 ($d1, $d2) = ($d2, $d1) if $rev;
282              
283 1 50 33     34 if ( blessed $d2 && $d2->isa( 'DateTimeX::Lite' ) )
284             {
285 0         0 $d2->add_duration($d1);
286 0         0 return;
287             }
288              
289             # will also work if $d1 is a DateTimeX::Lite.pm object
290 1         7 return $d1->clone->add_duration($d2);
291             }
292              
293             sub _subtract_overload
294             {
295 6     6   29 my ( $d1, $d2, $rev ) = @_;
296              
297 6 50       26 ($d1, $d2) = ($d2, $d1) if $rev;
298              
299 6 50 33     1242 Carp::croak( "Cannot subtract a DateTimeX::Lite object from a DateTimeX::Lite::Duration object" )
300             if blessed $d2 && $d2->isa( 'DateTimeX::Lite' );
301              
302 6         31 return $d1->clone->subtract_duration($d2);
303             }
304              
305             sub _multiply_overload
306             {
307 2     2   11 my $self = shift;
308              
309 2         10 my $new = $self->clone;
310              
311 2         14 return $new->multiply(@_);
312             }
313              
314             sub _compare_overload
315             {
316 1     1   222 Carp::croak( 'DateTimeX::Lite::Duration does not overload comparison.'
317             . ' See the documentation on the compare() method for details.' );
318             }
319              
320              
321             1;
322              
323             __END__