File Coverage

blib/lib/DateTimeX/Lite/Util.pm
Criterion Covered Total %
statement 174 193 90.1
branch 78 90 86.6
condition 26 37 70.2
subroutine 24 25 96.0
pod 0 13 0.0
total 302 358 84.3


line stmt bran cond sub pod time code
1             # $Id: Util.pm 27589 2008-12-29 23:51:35Z daisuke $
2              
3             package DateTimeX::Lite::Util;
4 57     57   308 use strict;
  57         133  
  57         4976  
5 57     57   294 use warnings;
  57         1561  
  57         9593  
6              
7             my (@MonthLengths, @LeapYearMonthLengths);
8             my (@EndOfLastMonthDayOfYear, @EndOfLastMonthDayOfLeapYear);
9             BEGIN {
10 57     57   271 @MonthLengths = qw(31 28 31 30 31 30 31 31 30 31 30 31);
11 57         191 @LeapYearMonthLengths = @MonthLengths;
12 57         169 $LeapYearMonthLengths[1]++;
13              
14             {
15 57         99 my $x = 0;
  57         1658  
16 57         1864 foreach my $length (@MonthLengths)
17             {
18 684         2116 push @EndOfLastMonthDayOfYear, $x;
19 684         1004 $x += $length;
20             }
21             }
22              
23 57         202 @EndOfLastMonthDayOfLeapYear = @EndOfLastMonthDayOfYear;
24 57         8700 $EndOfLastMonthDayOfLeapYear[$_]++ for 2..11;
25             }
26              
27              
28             sub month_length {
29 41375     41375 0 78732 my ($year, $month) = @_;
30 41375 100       72839 return is_leap_year($year) ?
31             $LeapYearMonthLengths[$month - 1] :
32             $MonthLengths[$month - 1]
33             ;
34             }
35              
36             sub is_leap_year {
37 98466     98466 0 153088 my $year = shift;
38              
39             # According to Bjorn Tackmann, this line prevents an infinite loop
40             # when running the tests under Qemu. I cannot reproduce this on
41             # Ubuntu or with Strawberry Perl on Win2K.
42 98466 100 66     482859 return 0 if $year == DateTimeX::Lite::INFINITY() || $year == DateTimeX::Lite::NEG_INFINITY();
43 98465 100       330307 return 0 if $year % 4;
44 64802 100       149294 return 1 if $year % 100;
45 57822 100       104107 return 0 if $year % 400;
46              
47 57702         283762 return 1;
48             }
49              
50             sub ymd2rd {
51 57     57   77950 use integer;
  57         700  
  57         285  
52 260163     260163 0 1679197 my ( $y, $m, $d ) = @_;
53 260163         298365 my $adj;
54              
55             # make month in range 3..14 (treat Jan & Feb as months 13..14 of
56             # prev year)
57 260163 100       590811 if ( $m <= 2 ) {
    100          
58 41995         51506 $y -= ( $adj = ( 14 - $m ) / 12 );
59 41995         48689 $m += 12 * $adj;
60             } elsif ( $m > 14 ) {
61 406         656 $y += ( $adj = ( $m - 3 ) / 12 );
62 406         559 $m -= 12 * $adj;
63             }
64              
65             # make year positive (oh, for a use integer 'sane_div'!)
66 260163 100       521590 if ( $y < 0 ) {
67 115647         142296 $d -= 146097 * ( $adj = ( 399 - $y ) / 400 );
68 115647         136612 $y += 400 * $adj;
69             }
70              
71             # add: day of month, days of previous 0-11 month period that began
72             # w/March, days of previous 0-399 year period that began w/March
73             # of a 400-multiple year), days of any 400-year periods before
74             # that, and finally subtract 306 days to adjust from Mar 1, year
75             # 0-relative to Jan 1, year 1-relative (whew)
76              
77 260163         480043 $d += ( $m * 367 - 1094 ) / 12 + $y % 100 * 1461 / 4 +
78             ( $y / 100 * 36524 + $y / 400 ) - 306;
79 260163         536176 return $d;
80             }
81              
82             sub time_as_seconds {
83 27735     27735 0 75172 my ( $hour, $min, $sec ) = @_;
84              
85 27735   100     115733 $hour ||= 0;
86 27735   100     93646 $min ||= 0;
87 27735   100     104088 $sec ||= 0;
88              
89 27735         55208 my $secs = $hour * 3600 + $min * 60 + $sec;
90 27735         83604 return $secs;
91             }
92              
93             sub normalize_nanoseconds {
94 57     57   18482 use integer;
  57         132  
  57         246  
95              
96             # seconds, nanoseconds
97 27738 100   27738 0 136973 if ( $_[1] < 0 )
    100          
98             {
99 1         3 my $overflow = 1 + $_[1] / DateTimeX::Lite::MAX_NANOSECONDS();
100 1         3 $_[1] += $overflow * DateTimeX::Lite::MAX_NANOSECONDS();
101 1         4 $_[0] -= $overflow;
102             }
103             elsif ( $_[1] >= DateTimeX::Lite::MAX_NANOSECONDS() )
104             {
105 1         3 my $overflow = $_[1] / DateTimeX::Lite::MAX_NANOSECONDS();
106 1         3 $_[1] -= $overflow * DateTimeX::Lite::MAX_NANOSECONDS();
107 1         4 $_[0] += $overflow;
108             }
109             }
110              
111             sub normalize_seconds
112             {
113 2243     2243 0 3399 my $dt = shift;
114              
115 2243 100 100     13941 return if $dt->{utc_rd_secs} >= 0 && $dt->{utc_rd_secs} <= 86399;
116              
117 162 100       645 if ( $dt->{tz}->is_floating )
118             {
119 92         432 normalize_tai_seconds( $dt->{utc_rd_days}, $dt->{utc_rd_secs} );
120             }
121             else
122             {
123 70         265 normalize_leap_seconds( $dt->{utc_rd_days}, $dt->{utc_rd_secs} );
124             }
125             }
126              
127              
128             sub normalize_tai_seconds {
129 37877 100   37877 0 95209 return if grep { $_ == DateTimeX::Lite::INFINITY() || $_ == DateTimeX::Lite::NEG_INFINITY() } @_[0,1];
  75754 100       483228  
130            
131             # This must be after checking for infinity, because it breaks in
132             # presence of use integer !
133 57     57   15505 use integer;
  57         119  
  57         429  
134            
135 37873         48958 my $adj;
136            
137 37873 100       81285 if ( $_[1] < 0 )
138             {
139 101         184 $adj = ( $_[1] - 86399 ) / 86400;
140             }
141             else
142             {
143 37772         55644 $adj = $_[1] / 86400;
144             }
145            
146 37873         52211 $_[0] += $adj;
147            
148 37873         108540 $_[1] -= $adj * 86400;
149             }
150              
151             sub rd2ymd
152             {
153 57     57   6010 use integer;
  57         107  
  57         244  
154 265330     265330 0 889395 my $d = shift;
155 265330         282759 my $rd = $d;
156              
157 265330         290210 my $yadj = 0;
158 265330         273601 my ( $c, $y, $m );
159              
160             # add 306 days to make relative to Mar 1, 0; also adjust $d to be
161             # within a range (1..2**28-1) where our calculations will work
162             # with 32bit ints
163 265330 50       698461 if ( $d > 2**28 - 307 )
    100          
164             {
165             # avoid overflow if $d close to maxint $yadj = ( $d - 146097 + 306 ) / 146097 + 1;
166 0         0 $d -= $yadj * 146097 - 306;
167             }
168             elsif ( ( $d += 306 ) <= 0 )
169 115643         150944 { $yadj =
170             -( -$d / 146097 + 1 ); # avoid ambiguity in C division of negatives
171 115643         126050 $d -= $yadj * 146097;
172             }
173              
174 265330         298673 $c = ( $d * 4 - 1 ) / 146097; # calc # of centuries $d is after 29 Feb of yr 0
175 265330         283877 $d -= $c * 146097 / 4; # (4 centuries = 146097 days)
176 265330         277972 $y = ( $d * 4 - 1 ) / 1461; # calc number of years into the century,
177 265330         286437 $d -= $y * 1461 / 4; # again March-based (4 yrs =~ 146[01] days)
178 265330         319905 $m = ( $d * 12 + 1093 ) / 367; # get the month (3..14 represent March through
179 265330         346032 $d -= ( $m * 367 - 1094 ) / 12; # February of following year)
180 265330         304059 $y += $c * 100 + $yadj * 400; # get the real year, which is off by
181 265330 100       502896 ++$y, $m -= 12 if $m > 12; # one if month is January or February
182              
183 265330 100       473496 if ( $_[0] )
184             {
185 27978         29968 my $dow;
186              
187 27978 100       59049 if ( $rd < -6 )
188             {
189 731         796 $dow = ( $rd + 6 ) % 7;
190 731 100       1275 $dow += $dow ? 8 : 1;
191             }
192             else
193             {
194 27247         41669 $dow = ( ( $rd + 6 ) % 7 ) + 1;
195             }
196              
197 27978         73222 my $doy = end_of_last_month_day_of_year( $y, $m );
198              
199 27978         38259 $doy += $d;
200              
201 27978         29668 my $quarter;
202             {
203 57     57   13338 no integer;
  57         114  
  57         404  
  27978         47606  
204 27978         67287 $quarter = int( ( 1 / 3.1 ) * $m ) + 1;
205             }
206              
207 27978         63981 my $qm = ( 3 * $quarter ) - 2;
208              
209 27978         55232 my $doq = $doy - end_of_last_month_day_of_year( $y, $qm );
210              
211 27978         125920 return ( $y, $m, $d, $dow, $doy, $quarter, $doq );
212             }
213              
214 237352         663800 return ( $y, $m, $d );
215             }
216              
217             sub end_of_last_month_day_of_year
218             {
219 55956     55956 0 80395 my ($y, $m) = @_;
220 55956         76384 $m--;
221             return
222 55956 100       91310 ( is_leap_year($y) ?
223             $EndOfLastMonthDayOfLeapYear[$m] :
224             $EndOfLastMonthDayOfYear[$m]
225             );
226             }
227              
228             sub _seconds_as_components
229             {
230 0     0   0 shift;
231 0         0 my $secs = shift;
232 0         0 my $utc_secs = shift;
233 0   0     0 my $modifier = shift || 0;
234              
235 57     57   17484 use integer;
  57         124  
  57         244  
236              
237 0         0 $secs -= $modifier;
238              
239 0         0 my $hour = $secs / 3600;
240 0         0 $secs -= $hour * 3600;
241              
242 0         0 my $minute = $secs / 60;
243              
244 0         0 my $second = $secs - ( $minute * 60 );
245              
246 0 0 0     0 if ( $utc_secs && $utc_secs >= 86400 )
247             {
248             # there is no such thing as +3 or more leap seconds!
249 0 0       0 die "Invalid UTC RD seconds value: $utc_secs"
250             if $utc_secs > 86401;
251              
252 0         0 $second += $utc_secs - 86400 + 60;
253              
254 0         0 $minute = 59;
255              
256 0         0 $hour--;
257 0 0       0 $hour = 23 if $hour < 0;
258             }
259              
260 0         0 return ( $hour, $minute, $second );
261             }
262              
263             sub normalize_leap_seconds {
264             # args: 0 => days, 1 => seconds
265 70     70 0 80 my $delta_days;
266              
267 57     57   7630 use integer;
  57         121  
  57         247  
268              
269             # rough adjust - can adjust many days
270 70 100       187 if ( $_[1] < 0 )
271             {
272 52         97 $delta_days = ($_[1] - 86399) / 86400;
273             }
274             else
275             {
276 18         32 $delta_days = $_[1] / 86400;
277             }
278              
279 70         112 my $new_day = $_[0] + $delta_days;
280 70         2575 my $delta_seconds = ( 86400 * $delta_days ) +
281             DateTimeX::Lite::LeapSecond::leap_seconds( $new_day ) -
282             DateTimeX::Lite::LeapSecond::leap_seconds( $_[0] );
283              
284 70         126 $_[1] -= $delta_seconds;
285 70         89 $_[0] = $new_day;
286              
287             # fine adjust - up to 1 day
288 70         203 my $day_length = DateTimeX::Lite::LeapSecond::day_length( $new_day );
289 70 50       388 if ( $_[1] >= $day_length )
    100          
290             {
291 0         0 $_[1] -= $day_length;
292 0         0 $_[0]++;
293             }
294             elsif ( $_[1] < 0 )
295             {
296 3         12 $day_length = DateTimeX::Lite::LeapSecond::day_length( $new_day - 1 );
297 3         5 $_[1] += $day_length;
298 3         13 $_[0]--;
299             }
300             }
301              
302              
303             sub seconds_as_components
304             {
305 34316     34316 0 54113 my $secs = shift;
306 34316         41716 my $utc_secs = shift;
307 34316   100     136915 my $modifier = shift || 0;
308              
309 57     57   15281 use integer;
  57         240  
  57         244  
310              
311 34316         54487 $secs -= $modifier;
312              
313 34316         53645 my $hour = $secs / 3600;
314 34316         52717 $secs -= $hour * 3600;
315              
316 34316         42255 my $minute = $secs / 60;
317              
318 34316         51709 my $second = $secs - ( $minute * 60 );
319              
320 34316 100 100     91193 if ( $utc_secs && $utc_secs >= 86400 )
321             {
322             # there is no such thing as +3 or more leap seconds!
323 50 50       130 die "Invalid UTC RD seconds value: $utc_secs"
324             if $utc_secs > 86401;
325              
326 50         79 $second += $utc_secs - 86400 + 60;
327              
328 50         58 $minute = 59;
329              
330 50         53 $hour--;
331 50 100       115 $hour = 23 if $hour < 0;
332             }
333              
334 34316         129359 return ( $hour, $minute, $second );
335             }
336              
337             sub offset_as_seconds {
338 224     224 0 421 my $offset = shift;
339              
340 224 50       501 return undef unless defined $offset;
341              
342 224 100       492 return 0 if $offset eq '0';
343              
344 221         265 my ( $sign, $hours, $minutes, $seconds );
345 221 100       1367 if ( $offset =~ /^([\+\-])?(\d\d?):(\d\d)(?::(\d\d))?$/ )
    100          
346             {
347 38         152 ( $sign, $hours, $minutes, $seconds ) = ( $1, $2, $3, $4 );
348             }
349             elsif ( $offset =~ /^([\+\-])?(\d\d)(\d\d)(\d\d)?$/ )
350             {
351 50         220 ( $sign, $hours, $minutes, $seconds ) = ( $1, $2, $3, $4 );
352             }
353             else
354             {
355 133         410 return undef;
356             }
357              
358 88 100       240 $sign = '+' unless defined $sign;
359 88 50 33     487 return undef unless $hours >= 0 && $hours <= 99;
360 88 100 66     454 return undef unless $minutes >= 0 && $minutes <= 59;
361 70 100 66     318 return undef unless ! defined( $seconds ) || ( $seconds >= 0 && $seconds <= 59 );
      66        
362              
363 64         134 my $total = $hours * 3600 + $minutes * 60;
364 64 100       409 $total += $seconds if $seconds;
365 64 100       299 $total *= -1 if $sign eq '-';
366              
367 64         223 return $total;
368             }
369              
370             sub offset_as_string {
371 74     74 0 123 my $offset = shift;
372              
373 74 50       190 return undef unless defined $offset;
374 74 100 100     492 return undef unless $offset >= -359999 && $offset <= 359999;
375              
376 72 100       187 my $sign = $offset < 0 ? '-' : '+';
377              
378 72         107 $offset = abs($offset);
379              
380 72         179 my $hours = int( $offset / 3600 );
381 72         124 $offset %= 3600;
382 72         113 my $mins = int( $offset / 60 );
383 72         99 $offset %= 60;
384 72         105 my $secs = int( $offset );
385              
386 72 100       620 return ( $secs ?
387             sprintf( '%s%02d%02d%02d', $sign, $hours, $mins, $secs ) :
388             sprintf( '%s%02d%02d', $sign, $hours, $mins )
389             );
390             }
391            
392             1;