File Coverage

blib/lib/Time/Duration.pm
Criterion Covered Total %
statement 111 114 97.3
branch 33 36 91.6
condition 5 6 83.3
subroutine 21 24 87.5
pod 11 13 84.6
total 181 193 93.7


line stmt bran cond sub pod time code
1             package Time::Duration;
2             $Time::Duration::VERSION = '1.1_01';
3 2     2   7578 use 5.006;
  2         5  
  2         51  
4 2     2   6 use strict;
  2         2  
  2         39  
5 2     2   5 use warnings;
  2         5  
  2         39  
6 2     2   5 use constant DEBUG => 0;
  2         2  
  2         1115  
7              
8             require Exporter;
9              
10             our @ISA = ('Exporter');
11             our @EXPORT = qw( later later_exact earlier earlier_exact
12             ago ago_exact from_now from_now_exact
13             duration duration_exact
14             concise
15             );
16             our @EXPORT_OK = ('interval', @EXPORT);
17             our $MILLISECOND = 0;
18              
19             # ALL SUBS ARE PURE FUNCTIONS
20              
21             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
22              
23             sub concise ($) {
24 31     31 1 23 my $string = $_[0];
25 31         20 DEBUG and print "in : $string\n";
26 31         35 $string =~ tr/,//d;
27 31         70 $string =~ s/\band\b//;
28 31         147 $string =~ s/\b(year|day|hour|minute|second)s?\b/substr($1,0,1)/eg;
  46         98  
29 31         31 $string =~ s/\b(millisecond)s?\b/ms/g;
30 31         109 $string =~ s/\s*(\d+)\s*/$1/g;
31 31         61 return $string;
32             }
33              
34             sub later {
35 74     74 1 9172 interval( $_[0], $_[1], ' earlier', ' later', 'right then'); }
36             sub later_exact {
37 33     33 1 4076 interval_exact($_[0], $_[1], ' earlier', ' later', 'right then'); }
38             sub earlier {
39 8     8 1 865 interval( $_[0], $_[1], ' later', ' earlier', 'right then'); }
40             sub earlier_exact {
41 0     0 1 0 interval_exact($_[0], $_[1], ' later', ' earlier', 'right then'); }
42             sub ago {
43 8     8 1 824 interval( $_[0], $_[1], ' from now', ' ago', 'right now'); }
44             sub ago_exact {
45 0     0 1 0 interval_exact($_[0], $_[1], ' from now', ' ago', 'right now'); }
46             sub from_now {
47 8     8 1 824 interval( $_[0], $_[1], ' ago', ' from now', 'right now'); }
48             sub from_now_exact {
49 0     0 1 0 interval_exact($_[0], $_[1], ' ago', ' from now', 'right now'); }
50              
51             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
52             sub duration_exact {
53 2     2 1 255 my $span = $_[0]; # interval in seconds
54 2   50     335 my $precision = int($_[1] || 0) || 2; # precision (default: 2)
55 2 50       3 return '0 seconds' unless $span;
56 2         4 _render('',
57             _separate(abs $span));
58             }
59              
60             sub duration {
61 19     19 1 2558 my $span = $_[0]; # interval in seconds
62 19   100     81 my $precision = int($_[1] || 0) || 2; # precision (default: 2)
63 19 100       27 return '0 seconds' unless $span;
64 17         29 _render('',
65             _approximate($precision,
66             _separate(abs $span)));
67             }
68              
69             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
70              
71             sub interval_exact {
72 33     33 0 33 my $span = $_[0]; # interval, in seconds
73             # precision is ignored
74 33 100       64 my $direction = ($span < 0) ? $_[2] # what a neg number gets
    50          
75             : ($span > 0) ? $_[3] # what a pos number gets
76             : return $_[4]; # what zero gets
77 32         38 _render($direction,
78             _separate($span));
79             }
80              
81             sub interval {
82 98     98 0 81 my $span = $_[0]; # interval, in seconds
83 98   100     365 my $precision = int($_[1] || 0) || 2; # precision (default: 2)
84 98 100       173 my $direction = ($span < 0) ? $_[2] # what a neg number gets
    100          
85             : ($span > 0) ? $_[3] # what a pos number gets
86             : return $_[4]; # what zero gets
87 88         102 _render($direction,
88             _approximate($precision,
89             _separate($span)));
90             }
91              
92             #~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#~#
93             #
94             # The actual figuring is below here
95              
96 2     2   8 use constant MINUTE => 60;
  2         1  
  2         77  
97 2     2   6 use constant HOUR => 3600;
  2         2  
  2         77  
98 2     2   6 use constant DAY => 24 * HOUR;
  2         1  
  2         73  
99 2     2   5 use constant YEAR => 365 * DAY;
  2         2  
  2         941  
100              
101             sub _separate {
102             # Breakdown of seconds into units, starting with the most significant
103            
104 139     139   106 my $remainder = abs $_[0]; # remainder
105 139         81 my $this; # scratch
106             my @wheel; # retval
107            
108             # Years:
109 139         160 $this = int($remainder / (365 * 24 * 60 * 60));
110 139         177 push @wheel, ['year', $this, 1_000_000_000];
111 139         142 $remainder -= $this * (365 * 24 * 60 * 60);
112            
113             # Days:
114 139         85 $this = int($remainder / (24 * 60 * 60));
115 139         133 push @wheel, ['day', $this, 365];
116 139         104 $remainder -= $this * (24 * 60 * 60);
117            
118             # Hours:
119 139         95 $this = int($remainder / (60 * 60));
120 139         124 push @wheel, ['hour', $this, 24];
121 139         86 $remainder -= $this * (60 * 60);
122            
123             # Minutes:
124 139         94 $this = int($remainder / 60);
125 139         122 push @wheel, ['minute', $this, 60];
126 139         106 $remainder -= $this * 60;
127            
128 139         138 push @wheel, ['second', int($remainder), 60];
129              
130             # Thanks to Steven Haryanto (http://search.cpan.org/~sharyanto/) for the basis of this change.
131 139 100       166 if ($MILLISECOND) {
132 18         12 $remainder -= int($remainder);
133 18         119 push @wheel, ['millisecond', sprintf("%0.f", $remainder * 1000), 1000];
134             }
135              
136 139         244 return @wheel;
137             }
138              
139             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
140             sub _approximate {
141             # Now nudge the wheels into an acceptably (im)precise configuration
142 105     105   122 my($precision, @wheel) = @_;
143              
144 169         111 Fix:
145             {
146             # Constraints for leaving this block:
147             # 1) number of nonzero wheels must be <= $precision
148             # 2) no wheels can be improperly expressed (like having "60" for mins)
149            
150 105         60 my $nonzero_count = 0;
151 169         103 my $improperly_expressed;
152              
153 169         90 DEBUG and print join ' ', '#', (map "${$_}[1] ${$_}[0]", @wheel), "\n";
154 169         225 for(my $i = 0; $i < @wheel; $i++) {
155 834         524 my $this = $wheel[$i];
156 834 100       1237 next if $this->[1] == 0; # Zeros require no attention.
157 377         208 ++$nonzero_count;
158 377 100       426 next if $i == 0; # the years wheel is never improper or over any limit; skip
159            
160 315 100       646 if($nonzero_count > $precision) {
    100          
161             # This is one nonzero wheel too many!
162 44         26 DEBUG and print '', $this->[0], " is one nonzero too many!\n";
163              
164             # Incr previous wheel if we're big enough:
165 44 100       70 if($this->[1] >= ($this->[-1] / 2)) {
166 26         20 DEBUG and printf "incrementing %s from %s to %s\n",
167             $wheel[$i-1][0], $wheel[$i-1][1], 1 + $wheel[$i-1][1], ;
168 26         27 ++$wheel[$i-1][1];
169             }
170              
171             # Reset this and subsequent wheels to 0:
172 44         53 for(my $j = $i; $j < @wheel; $j++) { $wheel[$j][1] = 0 }
  75         96  
173 44         48 redo Fix; # Start over.
174             } elsif($this->[1] >= $this->[-1]) {
175             # It's an improperly expressed wheel. (Like "60" on the mins wheel)
176 20         36 $improperly_expressed = $i;
177 20         28 DEBUG and print '', $this->[0], ' (', $this->[1],
178             ") is improper!\n";
179             }
180             }
181            
182 125 100       163 if(defined $improperly_expressed) {
183             # Only fix the least-significant improperly expressed wheel (at a time).
184 20         15 DEBUG and printf "incrementing %s from %s to %s\n",
185             $wheel[$improperly_expressed-1][0], $wheel[$improperly_expressed-1][1],
186             1 + $wheel[$improperly_expressed-1][1], ;
187 20         16 ++$wheel[ $improperly_expressed - 1][1];
188 20         13 $wheel[ $improperly_expressed][1] = 0;
189             # We never have a "150" in the minutes slot -- if it's improper,
190             # it's only by having been rounded up to the limit.
191 20         17 redo Fix; # Start over.
192             }
193            
194             # Otherwise there's not too many nonzero wheels, and there's no
195             # improperly expressed wheels, so fall thru...
196             }
197              
198 105         165 return @wheel;
199             }
200              
201             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
202             sub _render {
203             # Make it into English
204              
205 139     139   112 my $direction = shift @_;
206             my @wheel = map
207 139         125 {;
208 713 100       800 ( $_->[1] == 0) ? () # zero wheels
    100          
209 119         130 : ($_->[1] == 1) ? "${$_}[1] ${$_}[0]" # singular
  119         164  
210 169         177 : "${$_}[1] ${$_}[0]s" # plural
  169         255  
211             }
212             @_
213             ;
214 139 50       197 return "just now" unless @wheel; # sanity
215 139         148 $wheel[-1] .= $direction;
216 139 100       240 return $wheel[0] if @wheel == 1;
217 90 100       209 return "$wheel[0] and $wheel[1]" if @wheel == 2;
218 41         43 $wheel[-1] = "and $wheel[-1]";
219 41         121 return join q{, }, @wheel;
220             }
221              
222             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
223             1;
224              
225             __END__