File Coverage

blib/lib/Date/Gregorian.pm
Criterion Covered Total %
statement 405 411 98.5
branch 72 74 97.3
condition 95 97 97.9
subroutine 89 89 100.0
pod 33 33 100.0
total 694 704 98.5


line stmt bran cond sub pod time code
1             # Copyright (c) 1999-2019 by Martin Becker, Blaubeuren.
2             # This package is free software; you can distribute it and/or modify it
3             # under the terms of the Artistic License 2.0 (see LICENSE file).
4              
5             package Date::Gregorian;
6              
7 6     6   2371 use 5.006;
  6         34  
8 6     6   25 use strict;
  6         9  
  6         104  
9 6     6   22 use warnings;
  6         8  
  6         106  
10 6     6   2429 use integer;
  6         58  
  6         26  
11             require Exporter;
12              
13             our @ISA = qw(Exporter);
14             our %EXPORT_TAGS = (
15             'weekdays' => [qw(
16             MONDAY TUESDAY WEDNESDAY THURSDAY FRIDAY SATURDAY SUNDAY
17             )],
18             'months' => [qw(
19             JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY
20             AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER
21             )],
22             );
23             our @EXPORT_OK = map { @{$_} } values %EXPORT_TAGS;
24              
25             our $VERSION = '0.13';
26              
27             # ----- object definition -----
28              
29             # Date::Gregorian=ARRAY(...)
30              
31             # .......... index .......... # .......... value ..........
32 6     6   640 use constant F_DAYNO => 0; # continuos day number, "March ...th, 1 BC"
  6         11  
  6         574  
33 6     6   30 use constant F_TR_DATE => 1; # first Gregorian date in dayno format
  6         9  
  6         227  
34 6     6   25 use constant F_TR_EYR => 2; # first Gregorian easter year
  6         10  
  6         255  
35 6     6   29 use constant F_YMD => 3; # [year, month, day] (on demand, memoized)
  6         22  
  6         313  
36 6     6   29 use constant F_YDYW => 4; # [yearday, year, week] (on demand, memoized)
  6         16  
  6         545  
37 6     6   33 use constant F_SEC_NS => 5; # [seconds, nanoseconds] (optional)
  6         10  
  6         290  
38 6     6   29 use constant NFIELDS => 6;
  6         10  
  6         239  
39              
40             # ----- other constants -----
41              
42 6     6   28 use constant MONDAY => 0;
  6         250  
  6         254  
43 6     6   29 use constant TUESDAY => 1;
  6         9  
  6         284  
44 6     6   27 use constant WEDNESDAY => 2;
  6         10  
  6         248  
45 6     6   28 use constant THURSDAY => 3;
  6         8  
  6         296  
46 6     6   29 use constant FRIDAY => 4;
  6         9  
  6         232  
47 6     6   33 use constant SATURDAY => 5;
  6         15  
  6         230  
48 6     6   29 use constant SUNDAY => 6;
  6         27  
  6         228  
49              
50 6     6   30 use constant JANUARY => 1;
  6         8  
  6         209  
51 6     6   27 use constant FEBRUARY => 2;
  6         8  
  6         238  
52 6     6   27 use constant MARCH => 3;
  6         8  
  6         222  
53 6     6   27 use constant APRIL => 4;
  6         7  
  6         298  
54 6     6   31 use constant MAY => 5;
  6         9  
  6         232  
55 6     6   26 use constant JUNE => 6;
  6         8  
  6         232  
56 6     6   33 use constant JULY => 7;
  6         10  
  6         238  
57 6     6   26 use constant AUGUST => 8;
  6         7  
  6         224  
58 6     6   32 use constant SEPTEMBER => 9;
  6         21  
  6         247  
59 6     6   29 use constant OCTOBER => 10;
  6         8  
  6         229  
60 6     6   180 use constant NOVEMBER => 11;
  6         11  
  6         233  
61 6     6   27 use constant DECEMBER => 12;
  6         8  
  6         311  
62              
63 6     6   28 use constant _HALF_DAY => 12 * 60 * 60;
  6         21  
  6         891  
64              
65             # ----- predefined private variables -----
66              
67             my @M2D = map { ($_ * 153 + 2) / 5 } (0..11);
68             my $EPOCH = _ymd2dayno( 1970, 1, 1, 1, 1);
69             my @DEFAULTS = (
70             $EPOCH, # F_DAYNO
71             _ymd2dayno(1582, 10, 15, 1, 1), # F_TR_DATE
72             1583, # F_TR_EYR
73             undef, # F_YMD
74             undef, # F_YDYW
75             undef, # F_SEC_NS
76             );
77             my ($gmt_epoch, $gmt_correction) = _init_gmt();
78             my $datetime_epoch = 307;
79             my $default_sec_ns = [0, 0];
80             my %JG = ('J' => 0, 'G' => 1);
81             my $localtime_offset = 0;
82              
83             # ----- private functions -----
84              
85             # ($div, $mod) = _divmod($numerator, $denominator)
86             #
87             sub _divmod {
88 6     6   36 no integer; # use well defined percent operator
  6         8  
  6         17  
89 6587     6587   7682 my $mod = $_[0] % $_[1];
90 6587         12099 return (($_[0] - $mod) / $_[1], $mod);
91             }
92              
93             # $dayno = _ymd2dayno($year, $month, $day, $tr_date, $fixed)
94             # fixed == 1: tr_date == 0: force Julian, tr_date == 1: force Gregorian
95             # fixed == boolean false: normal operation
96             #
97             sub _ymd2dayno {
98 2751     2751   3755 my ($y, $m, $d, $s, $fixed) = @_;
99              
100 2751 100       4757 if (15 <= $m) { $m -= 3; $y += $m / 12; $m %= 12; }
  1 100       2  
  1 100       2  
  1         1  
101 2009         2245 elsif ( 3 <= $m) { $m -= 3; }
102 740         794 elsif (-9 <= $m) { $m += 9; $y --; }
  740         776  
103 1         2 else { $m = 14 - $m; $y -= $m / 12; $m = 11 - $m % 12; }
  1         1  
  1         2  
104              
105 2751         3801 $d += $M2D[$m] + $y * 365 + ($y >> 2) - 1;
106 2751 100 100     8290 if (!$fixed && $s <= $d || $fixed && $s) {
      100        
      100        
107 2709 100       3979 $y = 0 <= $y? $y / 100: -((99 - $y) / 100);
108 2709         3119 $d -= $y - ($y >> 2) - 2;
109             }
110 2751         3726 return $d;
111             }
112              
113             # ($year, $month, $day) = _dayno2ymd($dayno, $tr_date)
114             #
115             sub _dayno2ymd {
116 6587     6587   7978 my ($n, $s) = @_;
117 6587         9727 my ($d, $m, $y);
118 6587         0 my $c;
119 6587 100       8678 if ($s <= $n) {
120 6550         9434 ($c, $n) = _divmod($n - 2, 146097);
121 6550         8311 $c *= 400;
122 6550         7845 $n += (($n << 2) + 3) / 146097;
123             }
124             else {
125 37         49 ($c, $n) = _divmod($n, 1461);
126 37         54 $c <<= 2;
127             }
128 6587         6982 $y = (($n << 2) + 3) / 1461;
129 6587         7787 $n = ($n - $y * 365 - ($y >> 2)) * 5 + 2;
130 6587         6812 $m = $n / 153 + 3;
131 6587         6956 $d = $n % 153 / 5 + 1;
132 6587 100       9171 if (12 < $m) {
133 1409         1480 $y ++;
134 1409         1378 $m -= 12;
135             }
136 6587         14545 return ($c + $y, $m, $d);
137             }
138              
139             # ($dayno, $ymd) = _easter($year, $tr_date, $tr_eyr)
140             #
141             sub _easter {
142 32     32   51 my ($y, $s, $e) = @_;
143 32         37 my $m = 3;
144 32         32 my $d;
145 32         42 my $n = $y * 365 + ($y >> 2);
146 32 100       60 if ($e <= $y) {
147 27 100       42 my $g = 0 <= $y? $y / 100: -((99 - $y) / 100);
148 27         32 $n -= $g - ($g >> 2) - 2;
149 6     6   2190 { no integer; $g %= 3000 };
  6         10  
  6         17  
  27         32  
  27         39  
150 27         38 my $h = 15 + $g - (($g << 3) + 13) / 25 - ($g >> 2);
151 6     6   231 $g = do { no integer; $y % 19 };
  6         8  
  6         22  
  27         30  
  27         31  
152 27         41 $d = ($g * 19 + $h) % 30;
153 27 100 100     74 --$d if 28 <= $d && (28 < $d || 11 <= $g);
      100        
154             }
155             else {
156 6     6   356 $d = do { no integer; ($y % 19 * 19 + 15) % 30 };
  6         9  
  6         16  
  5         6  
  5         9  
157             }
158 6     6   211 $d += do { no integer; 28 - ($n + $d) % 7 };
  6         7  
  6         17  
  32         38  
  32         49  
159 32         38 $n += $d - 1;
160 32 100       47 if (31 < $d) {
161 21         23 $d -= 31;
162 21         22 $m = 4;
163             }
164 32 100 100     124 return ($n, ($s <= $n xor $e <= $y)? undef: [$y, $m, $d]);
165             }
166              
167             # $dayno = _dec31dayno($year, $tr_date)
168             # calculate day number of last day in year (usually December 31)
169             #
170             sub _dec31dayno {
171 10142     10142   12227 my ($y, $s) = @_;
172              
173 10142         12326 my $n = 306 + $y * 365 + ($y >> 2) - 1;
174 10142 100       13563 if ($s <= $n) {
175 10134 100       13121 $y = 0 <= $y? $y / 100: -((99 - $y) / 100);
176 10134         11266 $n -= $y - ($y >> 2) - 2;
177 10134 100       13551 if ($n < $s) {
178 4         8 return $s-1;
179             }
180             }
181 10138         11948 return $n;
182             }
183              
184             # $ydyw = _ydyw($dayno, $tr_date, $year)
185             #
186             sub _ydyw {
187 4604     4604   5869 my ($n, $s, $y) = @_;
188 4604         5810 my $base = _dec31dayno($y-1, $s);
189 4604         5150 my $yd = $n - $base;
190 4604         4828 $base += 4;
191 6     6   2150 { no integer; $base -= $base % 7 };
  6         11  
  6         17  
  4604         4565  
  4604         5238  
192 4604 100       5608 if ($n < $base) {
193 3         4 $y --;
194 3         6 $base = _dec31dayno($y-1, $s) + 4;
195 6     6   496 { no integer; $base -= $base % 7 };
  6         7  
  6         16  
  3         4  
  3         4  
196             }
197             else {
198 4601         5320 my $limit = _dec31dayno($y, $s) + 4;
199 6     6   247 { no integer; $limit -= $limit % 7 };
  6         10  
  6         16  
  4601         5047  
  4601         5126  
200 4601 100       6578 if ($limit <= $n) {
201 31         37 $base = $limit;
202 31         32 $y ++;
203             }
204             }
205 4604         5203 my $yw = ($n - $base) / 7 + 1;
206 4604         10090 return [$yd, $y, $yw];
207             }
208              
209             # ($gmt_epoch, $gmt_correction) = _init_gmt()
210             #
211             sub _init_gmt {
212 6     6   96 my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(0);
213             return (
214 6         25 _ymd2dayno(1900 + $year, 1 + $mon, $mday, 1, 1),
215             ($hour*60 + $min)*60 + $sec
216             );
217             }
218              
219             # ----- public methods -----
220              
221             sub new {
222 1248     1248 1 473785 my $class = $_[0];
223 1248         1313 my Date::Gregorian $self;
224 1248 100       2021 if (ref $class) { # called as obj method: clone it
225 1213         1283 $self = bless [@{$class}], ref($class);
  1213         2441  
226             }
227             else { # called as class method: create
228 35         87 $self = bless [@DEFAULTS], $class;
229             }
230 1248         2409 return $self;
231             }
232              
233             sub configure {
234 15     15 1 42 my Date::Gregorian $self = shift;
235 15         25 my ($y, $m, $d, $e) = @_;
236 15         28 @{$self}[F_TR_DATE, F_YMD, F_YDYW] =
  15         24  
237             ( _ymd2dayno($y, $m, $d, 1, 1), undef, undef );
238 15 100       28 $self->[F_TR_EYR] = $e if defined $e;
239 15         24 return $self;
240             }
241              
242             sub is_gregorian {
243 14     14 1 29 my Date::Gregorian $self = $_[0];
244 14         45 return $self->[F_TR_DATE] <= $self->[F_DAYNO];
245             }
246              
247             sub set_date {
248 31     31 1 131 my Date::Gregorian ($self, $ref) = @_;
249 31         45 @{$self}[F_DAYNO, F_YMD, F_YDYW] = ( $ref->[F_DAYNO], undef, undef );
  31         69  
250 31         63 return $self;
251             }
252              
253             sub set_ymd {
254 1648     1648 1 3215 my Date::Gregorian $self = shift;
255 1648         2069 my ($y, $m, $d) = @_;
256 1648         2407 @{$self}[F_DAYNO, F_YMD, F_YDYW] =
  1648         2239  
257             ( _ymd2dayno($y, $m, $d, $self->[F_TR_DATE]), undef, undef );
258 1648         2998 return $self;
259             }
260              
261             sub check_ymd {
262 216     216 1 301 my Date::Gregorian $self = shift;
263 216         282 my ($y, $m, $d) = @_;
264 216         250 my ($dayno, $yy, $mm, $dd);
265 216 100 100     1786 if (defined($d) && 1 <= $d && $d <= 31 &&
      100        
      100        
      100        
      100        
      100        
      100        
      100        
266             defined($m) && 1 <= $m && $m <= 12 &&
267             defined($y) && -1469871 <= $y && $y <= 5879489
268             ) {
269 205         362 $dayno = _ymd2dayno($y, $m, $d, $self->[F_TR_DATE]);
270 205         307 ($yy, $mm, $dd) = _dayno2ymd($dayno, $self->[F_TR_DATE]);
271 205 100 100     660 if ($dd == $d && $mm == $m && $yy == $y) {
      100        
272 192         352 @{$self}[F_DAYNO, F_YMD, F_YDYW] =
  192         260  
273             ( $dayno, [$yy, $mm, $dd], undef );
274 192         475 return $self;
275             }
276             }
277 24         92 return undef;
278             }
279              
280             sub get_ymd {
281 6497     6497 1 8787 my Date::Gregorian $self = $_[0];
282 6497   100     11988 my $ymd = $self->[F_YMD] ||=
283             [ _dayno2ymd($self->[F_DAYNO], $self->[F_TR_DATE]) ];
284 6497         7319 return @{$ymd};
  6497         11055  
285             }
286              
287             sub get_weekday {
288 6     6   3655 no integer;
  6         10  
  6         17  
289 1469     1469 1 1557 my Date::Gregorian $self = $_[0];
290 1469         2088 return $self->[F_DAYNO] % 7;
291             }
292              
293             sub set_yd {
294 531     531 1 689 my Date::Gregorian $self = shift;
295 531         675 my ($y, $d) = @_;
296 531         808 my $n = _dec31dayno($y-1, $self->[F_TR_DATE]) + $d;
297 531         709 @{$self}[F_DAYNO, F_YMD, F_YDYW] = ($n, undef, undef);
  531         777  
298 531         848 return $self;
299             }
300              
301             sub set_ywd {
302 6     6   714 no integer;
  6         10  
  6         16  
303 2     2 1 16 my Date::Gregorian $self = shift;
304 2         5 my ($y, $w, $d) = @_;
305 2         5 my $n = _dec31dayno($y-1, $self->[F_TR_DATE]) - 3;
306 2         4 $n += $w * 7 + $d - $n % 7;
307 2         5 @{$self}[F_DAYNO, F_YMD, F_YDYW] = ($n, undef, undef);
  2         3  
308 2         4 return $self;
309             }
310              
311             sub check_ywd {
312 6     6   728 no integer;
  6         8  
  6         28  
313 17     17 1 65 my Date::Gregorian $self = shift;
314 17         24 my ($y, $w, $d) = @_;
315 17 100 100     107 if (defined($d) && 0 <= $d && $d <= 6 &&
      100        
      100        
      100        
      100        
      100        
      100        
      100        
316             defined($w) && 1 <= $w && $w <= 53 &&
317             defined($y) && -1469871 <= $y && $y <= 5879489
318             ) {
319 5         12 my $n = _dec31dayno($y-1, $self->[F_TR_DATE]) - 3;
320 5         8 $n += $w * 7 + $d - $n % 7;
321 5         16 my $ymd = [_dayno2ymd($n, $self->[F_TR_DATE])];
322 5         10 my $ydyw = _ydyw($n, $self->[F_TR_DATE], $ymd->[0]);
323 5 100       12 if ($ydyw->[2] == $w) {
324 3         3 @{$self}[F_DAYNO, F_YMD, F_YDYW] = ($n, $ymd, $ydyw);
  3         4  
325 3         9 return $self;
326             }
327             }
328 14         70 return undef;
329             }
330              
331             sub get_yd {
332 5522     5522 1 5917 my Date::Gregorian $self = $_[0];
333 5522         6738 my ($y, $m, $d) = $self->get_ymd;
334 5522 100       8506 return ($y, $d) if 1 == $m;
335 4670   66     7134 my $ydyw = $self->[F_YDYW] ||= _ydyw(@{$self}[F_DAYNO, F_TR_DATE], $y);
  4590         6533  
336 4670         9070 return ($y, $ydyw->[0]);
337             }
338              
339             sub get_ywd {
340 6     6   1601 no integer;
  6         10  
  6         16  
341 12     12 1 58 my Date::Gregorian $self = $_[0];
342 12         20 my $y = ($self->get_ymd)[0];
343 12   66     23 my $ydyw = $self->[F_YDYW] ||= _ydyw(@{$self}[F_DAYNO, F_TR_DATE], $y);
  9         13  
344 12         16 return (@{$ydyw}[1, 2], $self->[F_DAYNO] % 7);
  12         28  
345             }
346              
347             sub add_days {
348 5263     5263 1 15081 my Date::Gregorian $self = $_[0];
349 5263         5470 $self->[F_DAYNO] += $_[1];
350 5263         5526 @{$self}[F_YMD, F_YDYW] = (undef, undef);
  5263         7865  
351 5263         7252 return $self;
352             }
353              
354             sub get_days_until {
355 5     5 1 10 my Date::Gregorian ($self, $then) = @_;
356 5         12 return $then->[F_DAYNO] - $self->[F_DAYNO];
357             }
358              
359             sub get_days_since {
360 1781     1781 1 2924 my Date::Gregorian ($self, $then) = @_;
361 1781         3006 return $self->[F_DAYNO] - $then->[F_DAYNO];
362             }
363              
364             sub compare {
365 11     11 1 95 my Date::Gregorian ($self, $then) = @_;
366 11         42 return $self->[F_DAYNO] <=> $then->[F_DAYNO];
367             }
368              
369             sub set_easter {
370 32     32 1 90 my Date::Gregorian $self = $_[0];
371 32         54 @{$self}[F_DAYNO, F_YMD, F_YDYW] =
372 32         42 ( _easter($_[1], @{$self}[F_TR_DATE, F_TR_EYR]), undef );
  32         60  
373 32         70 return $self;
374             }
375              
376             sub set_gmtime {
377 6     6   1987 no integer;
  6         9  
  6         18  
378 2     2 1 15 my Date::Gregorian $self = $_[0];
379 2         8 my $time = $_[1] + $gmt_correction;
380 2         4 $time -= $time % 86400;
381 2         11 @{$self}[F_DAYNO, F_YMD, F_YDYW] = (
  2         5  
382             $gmt_epoch + $time / 86400,
383             undef, undef,
384             );
385 2         4 return $self;
386             }
387              
388             sub get_gmtime {
389 6     6   646 no integer;
  6         9  
  6         34  
390 431     431 1 427 my Date::Gregorian $self = $_[0];
391 431         567 my $d = $self->[F_DAYNO] - $gmt_epoch;
392 431         623 return 86400 * $d - $gmt_correction;
393             }
394              
395             sub set_today {
396 2     2 1 41 my Date::Gregorian $self = shift;
397 2         28 return $self->set_localtime(time, @_);
398             }
399              
400             sub set_localtime {
401 432     432 1 543 my Date::Gregorian $self = shift;
402 432         540 my ($time) = @_;
403 432         5426 my ($d, $m, $y) = (localtime $time)[3..5];
404 432         1080 $y += 1900;
405 432         497 ++ $m;
406             # presuming localtime always to return Gregorian dates,
407             # while $self might be configured to interpret Julian,
408             # we must ignore $self->[F_TR_DATE] here
409 432         768 @{$self}[F_DAYNO, F_YMD, F_YDYW] =
  432         692  
410             ( _ymd2dayno($y, $m, $d, 1, 1), undef, undef );
411 432         906 return $self;
412             }
413              
414             sub get_localtime {
415 6     6   1131 no integer;
  6         12  
  6         21  
416 428     428 1 1065 my Date::Gregorian $self = shift;
417 428         609 my $time = $self->get_gmtime - $localtime_offset;
418 428         6583 my ($S, $M, $H, $d, $m, $y) = localtime $time;
419 428         1462 my $dd = _ymd2dayno(1900+$y, 1+$m, $d, 1, 1) - $self->[F_DAYNO];
420 428 50       721 return undef if 24855 < abs($dd);
421 428         559 my $delta = (($dd * 24 + $H) * 60 + $M) * 60 + $S;
422 428 50       1247 return $time if !$delta;
423              
424 0         0 $localtime_offset += $delta;
425 0         0 $time -= $delta;
426 0         0 ($S, $M, $H, $d, $m, $y) = localtime $time;
427 0         0 $dd = _ymd2dayno(1900+$y, 1+$m, $d, 1, 1) - $self->[F_DAYNO];
428 0         0 $delta = (($dd * 24 + $H) * 60 + $M) * 60 + $S;
429 0         0 return $time - $delta;
430             }
431              
432             sub set_weekday {
433 6     6   957 no integer;
  6         9  
  6         26  
434 16     16 1 30 my Date::Gregorian $self = shift;
435 16         22 my ($wd, $rel) = @_;
436 16         25 my $delta = ($wd - $self->[F_DAYNO]) % 7;
437 16 100 100     44 if (defined($rel) && '>=' ne $rel) {
438 11 100 100     24 $delta = 7 if !$delta && '>' eq $rel;
439 11 100 100     39 $delta -= 7 if '<' eq $rel || $delta && '<=' eq $rel;
      100        
440             }
441 16 100       24 if ($delta) {
442 12         15 $self->[F_DAYNO] += $delta;
443 12         15 @{$self}[F_YMD, F_YDYW] = (undef, undef);
  12         15  
444             }
445 16         29 return $self;
446             }
447              
448             sub get_days_in_year {
449 198     198 1 293 my ($self, $year) = @_;
450             return
451 198         283 _dec31dayno($year, $self->[F_TR_DATE]) -
452             _dec31dayno($year-1, $self->[F_TR_DATE]);
453             }
454              
455             sub iterate_days_upto {
456 18     18 1 62 my ($self, $limit, $rel, $step) = @_;
457 18         23 my $dayno = $self->[F_DAYNO];
458 18         27 my $final = $limit->[F_DAYNO] - ($rel ne '<=');
459 18   100     40 $step = abs($step || 1);
460             return sub {
461 523 100   523   13771 return undef if $dayno > $final;
462 505         742 @{$self}[F_DAYNO, F_YMD, F_YDYW] = ($dayno, undef, undef);
  505         834  
463 505         796 $dayno += $step;
464 505         712 return $self;
465 18         75 };
466             }
467              
468             sub iterate_days_downto {
469 6     6 1 16 my ($self, $limit, $rel, $step) = @_;
470 6         7 my $dayno = $self->[F_DAYNO];
471 6         17 my $final = $limit->[F_DAYNO] + ($rel eq '>');
472 6   100     16 $step = abs($step || 1);
473             return sub {
474 19 100   19   63 return undef if $dayno < $final;
475 13         18 @{$self}[F_DAYNO, F_YMD, F_YDYW] = ($dayno, undef, undef);
  13         17  
476 13         13 $dayno -= $step;
477 13         36 return $self;
478 6         36 };
479             }
480              
481             # --- DateTime interface ---
482              
483             sub set_datetime {
484 5     5 1 8 my ($self, $datetime) = @_;
485 5 100       14 if (!$datetime->time_zone->is_floating) {
486 3         34 $datetime = $datetime->clone->set_time_zone('floating');
487             }
488 5         518 my ($rd_days, @sec_ns) = $datetime->utc_rd_values;
489 5         33 @{$self}[F_DAYNO, F_YMD, F_YDYW, F_SEC_NS] =
  5         17  
490             ($rd_days + $datetime_epoch, undef, undef, \@sec_ns);
491 5         19 return $self;
492             }
493              
494             sub utc_rd_values {
495 8     8 1 1152 my $self = $_[0];
496             return (
497             $self->[F_DAYNO] - $datetime_epoch,
498 8 100       13 @{$self->[F_SEC_NS] || $default_sec_ns}
  8         40  
499             );
500             }
501              
502             sub truncate_to_day {
503 1     1 1 22 my $self = $_[0];
504 1         3 undef $self->[F_SEC_NS];
505 1         2 return $self;
506             }
507              
508             sub from_object {
509 3     3 1 1429 my ($class, %param) = @_;
510 3         8 return $class->new->set_datetime($param{'object'});
511             }
512              
513             # must not define time_zone and set_time_zone methods
514              
515             # --- stringification ---
516              
517             sub get_string {
518 2     2 1 8 my $self = $_[0];
519 2 100       5 my $suffix = $self->is_gregorian? 'G': 'J';
520 2         7 return sprintf "%d-%02d-%02d$suffix", $self->get_ymd;
521             }
522              
523             sub set_string {
524 7     7 1 13 my ($self, $string) = @_;
525 7 100       31 if ($string =~
526             m{
527             ^ # start of the string
528             (-?\d+) # signed integer
529             - # literal dash
530             (\d+) # unsigned integer
531             - # literal dash
532             (\d+) # unsigned integer
533             ([JG]?) # 'J' or 'G' or nothing
534             \z # end of the string
535             }x
536             ) {
537             $self->[F_DAYNO] =
538 5 100       25 _ymd2dayno($1, $2, $3, $4? ($JG{$4}, 1): $self->[F_TR_DATE]);
539 5         7 @{$self}[F_YMD, F_YDYW] = (undef, undef);
  5         7  
540 5         22 return $self;
541             }
542 2         4 return undef;
543             }
544              
545             # no DESTROY method, nothing to clean up
546              
547             1;
548              
549             __END__
550              
551             =encoding utf8
552              
553             =head1 NAME
554              
555             Date::Gregorian - Gregorian calendar
556              
557             =head1 VERSION
558              
559             This documentation refers to version 0.13 of Date::Gregorian.
560              
561             =head1 SYNOPSIS
562              
563             use Date::Gregorian;
564             use Date::Gregorian qw(:weekdays :months);
565              
566             $date = Date::Gregorian->new->set_ymd(1999, 12, 31);
567             $date2 = $date->new;
568              
569             if ($date->check_ymd($year, $month, $day)) {
570             # valid, $date has new value
571             }
572             else {
573             # not valid, $date remains unchanged
574             }
575              
576             ($year, $month, $day) = $date->get_ymd;
577              
578             $wd = (qw(Mon Tue Wed Thu Fri Sat Sun))[$date->get_weekday];
579             $date->set_yd(2000, 366); # Dec 31, 2000
580             ($year, $day_in_year) = $date->get_yd;
581             $date->set_ywd(1998, 53, 6); # Sun Jan 3, 1999
582             ($year, $week_in_year, $weekday) = $date->get_ywd;
583              
584             if ($date->check_ywd($year, $week, $weekday)) {
585             # valid, $date has new value
586             }
587             else {
588             # not valid, $date remains unchanged
589             }
590              
591             $date->add_days(-100);
592             $delta = $date->get_days_since($date2);
593             $delta = $date2->get_days_until($date);
594             $date->set_easter($y);
595             $date->set_today;
596             $date->set_localtime($time);
597             $date->set_gmtime($time);
598             $time = $date->get_gmtime;
599              
600             # compare two dates
601             $cmp = $date->compare($date2);
602             # sort dates
603             @sorted = sort {$a->compare($b)} @dates;
604              
605             $iterator = $date->iterate_days_upto($date2, '<');
606             $iterator = $date->iterate_days_upto($date2, '<', $step);
607             $iterator = $date->iterate_days_upto($date2, '<=');
608             $iterator = $date->iterate_days_upto($date2, '<=', $step);
609             $iterator = $date->iterate_days_downto($date2, '>');
610             $iterator = $date->iterate_days_downto($date2, '>', $step);
611             $iterator = $date->iterate_days_downto($date2, '>=');
612             $iterator = $date->iterate_days_downto($date2, '>=', $step);
613             while ($iterator->()) {
614             printf "%04d-%02d-%02d\n", $date->get_ymd;
615             }
616              
617             $date->configure(1752, 9, 14);
618             $date->configure(1752, 9, 14, 1753); # United Kingdom
619             $date2->configure(1918, 2, 14); # Russia
620              
621             $date2->set_ymd(1917, 10, 25); # pre-Gregorian Oct 25, 1917
622             $date->set_date($date2); # Gregorian Nov 7, 1917 (same day)
623              
624             if ($date->is_gregorian) {
625             # date is past configured calendar reformation,
626             # thus in Gregorian notation
627             }
628             else {
629             # date is before configured calendar reformation,
630             # thus in Julian notation
631             }
632              
633             # get the first sunday in October:
634             $date->set_ymd($year, 10, 1)->set_weekday(6, '>=');
635             # get the last sunday in October:
636             $date->set_ymd($year, 11, 1)->set_weekday(6, '<');
637              
638             # calculate number of days in 2000:
639             $days = $date->get_days_in_year(2000);
640              
641             # plaintext representation of dates
642             $str = $date->get_string;
643             $date->set_string($str) or warn "syntax error";
644              
645             # DateTime interface
646             use DateTime;
647             $dt = DateTime->now(time_zone => 'Europe/Berlin');
648             $date->set_datetime($dt);
649             $dt = DateTime->from_object(object => $date);
650             $date = Date::Gregorian->from_object($dt);
651             ($rata_die, $sec, $nanosec) = $date->utc_rd_values();
652             $date->truncate_to_day;
653              
654             =head1 DESCRIPTION
655              
656             Calendars define some notation to identify days in history. The
657             Gregorian calendar, now in wide use, was established by Pope
658             Gregory XIII in AD 1582 as an improvement over the less accurate
659             Julian calendar that had been in use before. Both of these calendars
660             also determine certain holidays. Unfortunately, the new one was
661             not adopted everywhere at the same time. Thus, the correct date
662             for a given historic event can depend on its location. Astronomers
663             usually expand the official Julian/Gregorian calendar backwards
664             beyond AD 1 using zero and negative numbers, so that year 0 is
665             1 BC, year -1 is 2 BC, etc.
666              
667             This module provides an object class representing days in history.
668             You can get earlier or later dates by way of adding days to them,
669             determine the difference in days between two of them, and read out
670             the day, month and year number as the (astronomic) Gregorian calendar
671             defines them (numbers 1 through 12 representing January through
672             December). Moreover, you can find out weekdays, easter sundays,
673             week in year and day in year numbers.
674              
675             For convenience, it is also possible to define the switching day
676             from Julian to Gregorian dates and the switching year from
677             pre-Gregorian to Gregorian easter schedule. Use configure with
678             the first valid date of the new calendar and optionally the first
679             year the new easter schedule was used (default 1583).
680              
681             The module is based on an algorithm devised by C. F. Gauss (1777-1855).
682             It is completely written in Perl for maximum portability.
683              
684             All methods except get_* and iterate_* return their object. This
685             allows for shortcuts like:
686              
687             $pentecost = Date::Gregorian->new->set_easter(2000)->add_days(49);
688              
689             Numbers 0 through 6 represent weekdays Monday through Sunday. Day
690             in month ranges from 1 to 31, day in year from 1 to 366, week in
691             year from 1 to 53. Weeks are supposed to start on Monday. The
692             first week of a year is the one containing January 4th. These
693             definitions are slightly closer to ISO 8601 than to Perl's builtin
694             time conversion functions. Weekday numbers, however, are zero-based
695             for ease of use as array indices.
696              
697             (Author's note: I wish now I had defined 1-based weekdays when the
698             module was young, to make things nice and consistent, but backwards
699             compatibility suggests not to revise that decision. If you prefer
700             consistent code, subtract JANUARY from a month value and MONDAY
701             from a weekday value to get a 0-based array index in any case.)
702              
703             Numeric parameters must be integer numbers throughout the module.
704              
705             For convenience, weekdays and months can be imported as constants
706             B<MONDAY>, B<TUESDAY>, B<WEDNESDAY>, B<THURSDAY>, B<FRIDAY>,
707             B<SATURDAY>, B<SUNDAY>, and B<JANUARY>, B<FEBRUARY>, B<MARCH>,
708             B<APRIL>, B<MAY>, B<JUNE>, B<JULY>, B<AUGUST>, B<SEPTEMBER>,
709             B<OCTOBER>, B<NOVEMBER>, B<DECEMBER>. The tag B<:weekdays> provides
710             all weekdays, as B<:months> does all month names. By default,
711             nothing is exported.
712              
713             =head2 new
714              
715             I<new> creates a Date::Gregorian object from scratch (if called as
716             a class method) or as a copy of an existing object. The latter is
717             more efficient than the former. I<new> does not take any arguments.
718              
719             =head2 set_date
720              
721             I<set_date> sets one Date::Gregorian object to the same day another
722             object represents. The objects do not need to share a common calendar
723             configuration.
724              
725             =head2 set_ymd
726              
727             I<set_ymd> sets year, month and day to new absolute values. Days
728             and months out of range are silently folded to standard dates, in
729             a way that is intended to preserve continuity: Month 13 is treated
730             as month 1 of the next year, month 14 as month 2 of the next year,
731             month 0 as month 12 of the previous year, day 0 as the last day of
732             the previous month, etc. Thus, e.g., the date 10000 days before
733             February 22, 2002 can be defined like this:
734              
735             $date->set_ymd(2002, 2, 22-10000)
736              
737             =head2 check_ymd
738              
739             I<check_ymd>, on the other hand, checks a given combination of
740             year, month and day for validity. Given a valid date, the object
741             is updated and the object itself is returned, evaluating to true
742             in boolean context. Otherwise, the object remains untouched and
743             B<undef> is returned.
744              
745             =head2 get_ymd
746              
747             I<get_ymd> returns year, month and day as a three-item list.
748              
749             =head2 get_weekday
750              
751             I<get_weekday> returns the weekday as a number in the range of 0
752             to 6, with 0 representing Monday, 1 Tuesday, 2 Wednesday, 3 Thursday,
753             4 Friday, 5 Saturday and 6 representing Sunday.
754              
755             =head2 set_yd get_yd
756              
757             I<set_yd> and I<get_yd> set or get dates as a pair of year and day
758             in year numbers, day 1 representing January 1, day 32 February 1 etc.
759              
760             =head2 set_ywd get_ywd
761              
762             I<set_ywd> and I<get_ywd> set or get dates as a tuple of year, week
763             in year and day in week numbers. As noted above, weeks are supposed
764             to start on Mondays. Weeks containing days of both December and
765             January belong to the year containing more days of them. Because
766             of this, get_ywd and get_ymd may return different year numbers.
767             Week numbers range from 1 to 53 (max).
768              
769             =head2 check_ywd
770              
771             I<check_ywd> checks a given combination of year, week in year and
772             weekday for validity. Given a valid date, the object is updated
773             and the object itself is returned, evaluating to true in boolean
774             context. Otherwise, the object remains untouched and B<undef> is
775             returned.
776              
777             Note that year 1582 (or whatever year was configured to have the
778             Gregorian calendar reformation) was considerably shorter than a
779             normal year. Such a year has some invalid dates that otherwise
780             might seem utterly inconspicuos.
781              
782             =head2 add_days
783              
784             I<add_days> increases, or, given a negative argument, decreases, a
785             date by a number of days. Its new value represents a day that many
786             days later in history if a positive number of days was added. Adding
787             a negative number of days consequently shifts a date back towards
788             the past.
789              
790             =head2 get_days_since
791              
792             I<get_days_since> computes the difference of two dates as a number
793             of days. The result is positive if the given date is an earlier
794             date than the one whose method is called, negative if it is a later
795             one. Look at it as a subtraction operation, yielding a positive
796             result if something smaller is subtracted from something larger,
797             "smaller" meaning "earlier" in this context.
798              
799             =head2 get_days_until
800              
801             I<get_days_until> computes the same value as I<get_days_since>,
802             only with opposite sign.
803              
804             =head2 compare
805              
806             I<compare> compares two dates chronologically. Result is zero
807             if the dates refer to the same day, -1 if the method invocant
808             refers to an earlier day than the parameter and 1 otherwise.
809              
810             =head2 iterate_days_upto iterate_days_downto
811              
812             I<iterate_days_upto> and I<iterate_days_downto> provide convenient
813             methods to iterate over a range of dates. They return a reference
814             to a subroutine that can be called without argument in a while
815             condition to set the given date iteratively to each one of a sequence
816             of dates. The current date is always the first one to be visited
817             (unless the sequence is all empty). The limit parameter determines
818             the end of the sequence, together with the relation parameter: '<'
819             excludes the upper limit from the sequence, '<=' includes the upper
820             limit, '>=' includes the lower limit and '>' excludes the lower
821             limit. The step parameter is optional. It must be greater than
822             zero and defines how many days the dates in the sequence lie apart.
823             It defaults to one.
824              
825             Each iterator maintains its own state; therefore it is legal to run
826             more than one iterator in parallel or even create new iterators
827             within iterations.
828              
829             =head2 set_easter
830              
831             I<set_easter> computes the date of Easter sunday of a given year,
832             taking into account how the date object was configured.
833              
834             =head2 set_weekday
835              
836             I<set_weekday> computes a date matching a given weekday that is
837             close to the date it is applied to. The optional relation parameter
838             may be one of '>=', '>', '<=' or '<', and determines if the resulting
839             date should be "equal or later", later, "equal or earlier", or
840             earlier, respectively, than the initial date. Default is '>='.
841              
842             =head2 set_today
843              
844             I<set_today> computes a date value equivalent to the system's notion
845             of the current date in the local timezone. System time is assumed
846             to run in Gregorian mode.
847              
848             =head2 set_localtime
849              
850             I<set_localtime> likewise computes a date value equivalent to a
851             given arbitrary time value in the local timezone.
852              
853             =head2 set_gmtime
854              
855             I<set_gmtime> computes a date value equivalent to a given time value
856             in the "GMT" system timezone. This timezone represents a time scale
857             counting a constant number of seconds per day since an OS- and
858             implementation dependent starting point -- the epoch -- and not
859             counting leap seconds. This makes arithmetic on timestamps easy
860             but forces clocks to be frequently adjusted to the earth rotation.
861             On POSIX-like systems this timezone is used for timestamps.
862             On systems using the gmtime call in any other fashion I<set_gmtime>
863             and I<get_gmtime> are not guaranteed to comply with it.
864              
865             =head2 get_gmtime
866              
867             I<get_gmtime> converts a date value back to a timestamp in the "GMT"
868             timezone explained above. This method may return undef if the date
869             seems to be out of range. Note that the precision of timestamps
870             represented by Date::Gregorian objects is normally limited to days.
871             Thus, converting a timestamp to a date and back again usually
872             truncates the timestamp to midnight. Extension classes may behave
873             differently, however.
874              
875             =head2 get_localtime
876              
877             I<get_localtime> converts a date value back to a system timestamp
878             in the current local timezone. Undef is returned if the date seems
879             to be out of range. As with I<get_gmtime>, the precision is normally
880             limited to days. However, values returned by I<get_localtime> for
881             successive days need not follow a simple arithmetic progression,
882             as they interpolate actual localtime calls, and the local timezone
883             may incorporate oddities like daylight saving time changes.
884              
885             Note also that timestamps are not portable. While the conversion
886             functions described here make an effort to cover the local clock
887             behaviour, mostly in order to make set_today work, they depend on
888             the Perl builtin functions I<localtime> and I<gmtime>, which in
889             turn are OS- and implementation-specific. I<localtime> may also
890             depend on the environment and other dynamic configuration settings.
891              
892             =head2 get_days_in_year
893              
894             I<get_days_in_year> computes the number of days in a given year
895             (independent of the year stored in the date object, but taking
896             into account its configuration).
897              
898             =head2 configure
899              
900             I<configure> defines the way the Gregorian calendar reformation
901             should be handled in calculations with the date object and any new
902             ones later cloned with I<new> from this one. The first three
903             arguments specify the year, month and day of the first day the new
904             calendar was in use. The optional fourth argument defines the first
905             year the new easter schedule has to be used in easter calculations.
906             Re-configuring a date object is legal and does not change the day
907             in history it represents while possibly changing the year, month
908             and day values related to it.
909              
910             =head2 is_gregorian
911              
912             I<is_gregorian> returns a boolean value telling whether a date is
913             past the configured calendar reformation and thus will yield year,
914             month and day values in Gregorian mode.
915              
916             =head2 get_string
917              
918             I<get_string> returns a plaintext representation of the date represented
919             by an object.
920              
921             =head2 set_string
922              
923             I<set_string> restores a date value from a string returned by I<get_string>.
924             Strings of the form "YYYY-MM-DD" are also accepted. The return value
925             is B<undef> if the syntax could not be recognized, otherwise the object.
926             I<set_string> handles values out of range the same way I<set_ymd> does.
927              
928             =head2 DateTime interoperability
929              
930             Date::Gregorian objects can be converted to DateTime objects and
931             vice versa. From the view of DateTime, Date::Gregorian implements
932             a calendar operating in the floating timezone. From the view of
933             Date::Gregorian, DateTime objects represent days in history in a
934             way suitable for object initialization. Higher precision
935             components of DateTime objects, i.e. seconds and nanoseconds,
936             are preserved for reverse conversion but otherwise ignored.
937              
938             =over 4
939              
940             =item set_datetime
941              
942             I<set_datetime> sets a Date::Gregorian object to the day represented
943             by a given DateTime object. It returns the updated object.
944              
945             =item from_object
946              
947             I<from_object> is a DateTime compatible constructor. Arguments are
948             mapped to a hash. The value in the 'object' slot is taken to be a
949             DateTime object. The result is a Date::Gregorian object. Note
950             that Date::Gregorian is not a subclass of DateTime.
951              
952             =item utc_rd_values
953              
954             I<utc_rd_values> returns a list of rata die, seconds and nanoseconds
955             values corresponding to the date currently represented by the object.
956             Seconds and nanoseconds will default to zero if not initialized from
957             some DateTime object, and will be ignored by all other Date::Gregorian
958             methods. In particular, date objects differing only in their hidden
959             seconds or nanoseconds values are considered equivalent by I<compare>.
960              
961             =item truncate_to_day
962              
963             I<truncate_to_day> drops seconds and nanoseconds from a date. This
964             will have an effect on DateTime objects subsequently initialized
965             from that object. Return value is the object.
966              
967             =back
968              
969             =head1 EXPORTS
970              
971             By default, nothing is exported into the caller's namespace. Optionally,
972             uppercase English weekday and month names may be imported individually
973             or using the C<:weekdays> and C<:months> tags. These constants should be
974             preferred over their numerical values as documented above for readability
975             and in order not to depend on zero or one being the smallest value.
976              
977             =head1 BUGS AND LIMITATIONS
978              
979             This library works with integer arithmetic only. Do not call methods
980             expecting days, months, years, etc. with non-integer values.
981              
982             Bug reports and suggestions are always welcome
983             E<8212> please submit them through the CPAN RT,
984             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Date-Gregorian>.
985              
986             =head1 ROADMAP
987              
988             The author intends to re-factor this library and combine its
989             algorithms with a better API, addressing these issues:
990              
991             =over 4
992              
993             =item *
994              
995             Make date objects immutable.
996              
997             =item *
998              
999             Add time arguments to gmtime and localtime conversions.
1000              
1001             =item *
1002              
1003             Add more business calendars.
1004              
1005             =item *
1006              
1007             Name days and holidays.
1008              
1009             =item *
1010              
1011             Unify simple date arithmetic and business day arithmetic.
1012              
1013             =item *
1014              
1015             Comply more strictly with ISO 8601. Notably, use 1-based weekday numbers.
1016              
1017             =back
1018              
1019             The new API will live in the Date::Gregorian namespace but use different
1020             module names. That way, old and new APIs can co-exist while downstream
1021             applications prepare for the transition.
1022              
1023             =head1 SEE ALSO
1024              
1025             The sci.astro Calendar FAQ, L<Date::Calc>, L<Date::Gregorian::Business>,
1026             L<DateTime>.
1027              
1028             =head1 AUTHOR
1029              
1030             Martin Becker C<< <becker-cpan-mp (at) cozap.com> >>
1031              
1032             =head1 LICENSE AND COPYRIGHT
1033              
1034             Copyright (c) 1999-2019 by Martin Becker, Blaubeuren.
1035              
1036             This library is free software; you can distribute it and/or modify it
1037             under the terms of the Artistic License 2.0 (see the LICENSE file).
1038              
1039             =head1 DISCLAIMER OF WARRANTY
1040              
1041             This library is distributed in the hope that it will be useful,
1042             but without any warranty; without even the implied warranty of
1043             merchantability or fitness for a particular purpose.
1044              
1045             =cut