File Coverage

blib/lib/DateTime/Incomplete.pm
Criterion Covered Total %
statement 367 434 84.5
branch 149 202 73.7
condition 38 59 64.4
subroutine 58 77 75.3
pod 37 44 84.0
total 649 816 79.5


line stmt bran cond sub pod time code
1             package DateTime::Incomplete;
2              
3 6     6   2469048 use strict;
  6         14  
  6         241  
4              
5 6     6   7976 use DateTime::Set 0.0901;
  6         588174  
  6         175  
6 6     6   13927 use DateTime::Event::Recurrence;
  6         43659  
  6         256  
7 6     6   66 use Params::Validate qw( validate );
  6         11  
  6         410  
8              
9 6     6   30 use vars qw( $VERSION );
  6         13  
  6         903  
10              
11             my $UNDEF_CHAR;
12             my ( @FIELDS, %FIELD_LENGTH, @TIME_FIELDS, @FIELDS_SORTED );
13              
14             BEGIN
15             {
16 6     6   15 $VERSION = '0.07';
17              
18 6         10 $UNDEF_CHAR = 'x';
19              
20 6         25 @FIELDS = ( year => 0, month => 1, day => 1,
21             hour => 0, minute => 0, second => 0, nanosecond => 0 );
22 6         57 %FIELD_LENGTH = (
23             year => 4, month => 2, day => 2,
24             hour => 2, minute => 2, second => 2, nanosecond => 9,
25             time_zone => 0, locale => 0 );
26 6         19 @TIME_FIELDS = qw( hour minute second nanosecond );
27              
28 6         18 @FIELDS_SORTED = qw( year month day
29             hour minute second nanosecond
30             time_zone locale );
31              
32             # Generate named accessors
33              
34 6         14 for my $field ( @FIELDS_SORTED )
35             {
36 6     6   38 no strict 'refs';
  6         12  
  6         1229  
37 54     1850   173 *{$field} = sub { $_[0]->_get($field) };
  54         193  
  1850         4383  
38 54     231   147 *{"has_$field"} = sub { $_[0]->_has($field) };
  54         216  
  231         2026  
39              
40 54 100       132 next if $field eq 'nanosecond';
41              
42 48         76 my $length = $FIELD_LENGTH{$field};
43              
44 48 100       128 next unless $length;
45              
46 36 100   213   180 *{"_$field"} = sub { defined $_[0]->$field() ?
  213         546  
47             sprintf( "%0.${length}d", $_[0]->$field() ) :
48 36         317 $UNDEF_CHAR x $length };
49             }
50              
51             # Generate DateTime read-only functions
52              
53 6         14 for my $meth ( qw/
54             epoch
55             hires_epoch
56             is_dst
57             utc_rd_values
58             utc_rd_as_seconds
59             / )
60             {
61 6     6   28 no strict 'refs';
  6         10  
  6         491  
62 30         152 *{$meth} = sub
63             {
64             # to_datetime() dies if there is no "base"
65             # we get 'undef' if this happens
66 0     0   0 eval { (shift)->to_datetime( @_ )->$meth() };
  0         0  
67 30         96 };
68             }
69              
70 6         17 for my $meth ( qw/
71             week week_year week_number week_of_month
72             day_name day_abbr
73             day_of_week wday dow
74             day_of_year doy
75             quarter day_of_quarter doq
76             weekday_of_month
77             jd mjd
78             / )
79             {
80 6     6   28 no strict 'refs';
  6         12  
  6         571  
81 102     23   274 *{$meth} = sub { $_[0]->_datetime_method( $meth, 'year', 'month', 'day' ) };
  102         374  
  23         120  
82             }
83              
84 6         13 for my $meth ( qw/
85             is_leap_year ce_year era year_with_era
86             / )
87             {
88 6     6   29 no strict 'refs';
  6         30  
  6         435  
89 24     1   52 *{$meth} = sub { $_[0]->_datetime_method( $meth, 'year' ) };
  24         105  
  1         7  
90             }
91              
92 6         13 for my $meth ( qw/
93             month_name month_abbr
94             / )
95             {
96 6     6   92 no strict 'refs';
  6         12  
  6         397  
97 12     4   36 *{$meth} = sub { $_[0]->_datetime_method( $meth, 'month' ) };
  12         55  
  4         53  
98             }
99              
100 6         11 for my $meth ( qw/
101             hour_1 hour_12 hour_12_0
102             / )
103             {
104 6     6   26 no strict 'refs';
  6         10  
  6         398  
105 18     4   63 *{$meth} = sub { $_[0]->_datetime_method( $meth, 'hour' ) };
  18         71  
  4         21  
106             }
107              
108 6         13 for my $meth ( qw/
109             millisecond microsecond
110             / )
111             {
112 6     6   28 no strict 'refs';
  6         7  
  6         463  
113 12     0   33 *{$meth} = sub { $_[0]->_datetime_method( $meth, 'nanosecond' ) };
  12         39237  
  0         0  
114             }
115             }
116              
117             *_nanosecond = \&_format_nanosecs;
118              
119             *mon = \&month;
120             *day_of_month = \&day;
121             *mday = \&day;
122             *min = \&minute;
123             *sec = \&second;
124              
125             # Internal sub to call "DateTime" methods
126             sub _datetime_method
127             {
128 38     38   78 my ( $self, $method ) = ( shift, shift );
129 38         90 my @fields = @_; # list of required fields
130 38         53 my $date;
131 38         85 for ( @fields )
132             {
133 68 100       140 return undef unless ( $self->_has($_) )
134             }
135 32         64 my %param;
136              
137             # if we don't need 'year', then we can safely set it to whatever.
138 32 100 100     210 $param{year} = 1970 if ! @fields || $fields[0] ne 'year';
139              
140 32 100       91 $param{locale} = $self->locale if $self->has_locale;
141 32 100       102 $param{time_zone} = $self->time_zone if $self->has_time_zone;
142 32         127 $param{$_} = $self->$_() for @fields;
143 32         205 $date = DateTime->new( %param );
144            
145 32         7061 return $date->$method();
146             }
147              
148             # DATETIME-LIKE METHODS
149              
150             sub fractional_second {
151 0     0 0 0 $_[0]->_datetime_method( 'fractional_second', 'second', 'nanosecond' );
152             }
153              
154             sub offset {
155 4     4 0 24 $_[0]->_datetime_method( 'offset' );
156             }
157             sub time_zone_short_name {
158 2     2 0 10 $_[0]->_datetime_method( 'time_zone_short_name' );
159             }
160             sub time_zone_long_name {
161 0     0 0 0 $_[0]->_datetime_method( 'time_zone_long_name' );
162             }
163              
164             sub _from_datetime
165             {
166 2     2   428 my $class = shift;
167 2         3 my $dt = shift;
168 2         5 my %param;
169 2         8 $param{$_} = $dt->$_() for @FIELDS_SORTED;
170 2         112 return $class->new( %param );
171             }
172              
173             sub last_day_of_month {
174 0     0 0 0 my $self = shift;
175 0         0 my %param = @_;
176 0         0 my $result = $self->_from_datetime( DateTime->last_day_of_month( @_ ) );
177 0         0 for ( @TIME_FIELDS ) {
178 0 0       0 $result->set( $_, undef ) unless defined $param{$_};
179             }
180 0         0 return $result;
181             }
182              
183             sub from_epoch {
184 1     1 1 5 return (shift)->_from_datetime( DateTime->from_epoch( @_ ) );
185             }
186             sub now {
187 1     1 1 547 return (shift)->_from_datetime( DateTime->now( @_ ) );
188             }
189             sub from_object {
190 0     0 1 0 return (shift)->_from_datetime( DateTime->from_object( @_ ) );
191             }
192              
193             sub from_day_of_year {
194 0     0 1 0 my $self = shift;
195 0         0 my %param = @_;
196 0         0 my $result = $self->_from_datetime( DateTime->from_day_of_year( @_ ) );
197 0         0 for ( @TIME_FIELDS ) {
198 0 0       0 $result->set( $_, undef ) unless defined $param{$_};
199             }
200 0         0 return $result;
201             }
202              
203             sub today
204             {
205 1     1 1 2 my $class = shift;
206 1         4 my $now = DateTime->now( @_ );
207 1         191 my %param;
208 1         6 my %fields = ( %FIELD_LENGTH );
209 1         9 delete $fields{$_} for ( qw/ hour minute second nanosecond / );
210 1         6 $param{$_} = $now->$_() for ( keys %fields );
211 1         41 return $class->new( %param );
212             }
213              
214             sub new
215             {
216             # parameter checking is done in "set" method.
217 18     18 1 21205 my $class = shift;
218 18         108 my %param = @_;
219 18         46 my $base = delete $param{base};
220 18 50 66     101 die "base must be a datetime" if defined $base &&
221             ! UNIVERSAL::can( $base, 'utc_rd_values' );
222 18         98 my $self = bless {
223             has => \%param,
224             }, $class;
225 18         75 $self->set_base( $base );
226 18 100       103 $self->set( locale => $self->{has}{locale} ) if $self->{has}{locale};
227 18 100       99 $self->set_time_zone( $self->{has}{time_zone} ) if $self->{has}{time_zone};
228 18         205 return $self;
229             }
230              
231             sub set_base
232             {
233 20     20 1 42 my $self = shift;
234 20         83 $self->{base} = shift;
235 20 100       80 if ( defined $self->{base} )
236             {
237 3         5 my ($key, $value);
238 3         6 while (($key, $value) = each %{$self->{has}} ) {
  24         5880  
239 21 100       56 next unless defined $value;
240 15 50       35 if ( $key eq 'time_zone' )
241             {
242 0         0 $self->{base}->set_time_zone( $value );
243 0         0 next;
244             }
245 15         46 $self->{base}->set( $key => $value );
246             }
247             }
248             }
249              
250             sub base
251             {
252 0 0   0 1 0 return undef unless defined $_[0]->{base};
253 0         0 $_[0]->{base}->clone;
254             }
255              
256             sub has_base
257             {
258 0 0   0 1 0 return defined $_[0]->{base} ? 1 : 0;
259             }
260              
261             sub set
262             {
263 47     47 1 501592 my $self = shift;
264 47         125 my %p = @_;
265              
266 47         178 while ( my ( $k, $v ) = each %p )
267             {
268 49 100       127 if ( $k eq 'locale' )
269             {
270 7         27 $self->_set_locale($v);
271 7         33 next;
272             }
273              
274 42 100 100     139 $self->{base}->set( $k => $v ) if $self->{base} && defined $v;
275              
276 42         1291 $self->{has}{ $k } = $v;
277             }
278             }
279              
280             sub _get
281             {
282 1850     1850   13516 $_[0]->{has}{$_[1]};
283             }
284              
285             sub _has
286             {
287 340 100   340   2243 defined $_[0]->{has}{$_[1]} ? 1 : 0;
288             }
289              
290             sub has {
291             # returns true or false
292 12     12 1 553 my $self = shift;
293 12         25 foreach (@_) {
294 12 100       23 return 0 unless $self->_has( $_ )
295             }
296 3         34 return 1
297             }
298              
299             sub has_date {
300 0 0 0 0 1 0 $_[0]->has_year && $_[0]->has_month && $_[0]->has_day
301             }
302              
303             sub has_time {
304 0 0 0 0 1 0 $_[0]->has_hour && $_[0]->has_minute && $_[0]->has_second
305             }
306              
307             sub defined_fields {
308             # no params, returns a list of fields
309 1     1 1 6 my $self = shift;
310 1         3 my @has = ();
311 1         3 for ( @FIELDS_SORTED )
312             {
313 9 100       26 push @has, $_ if $self->_has( $_ );
314             }
315 1         7 return @has;
316             }
317              
318             sub can_be_datetime {
319 5     5 1 10 my $self = shift;
320 5 100       12 return 0 if ! $self->has_year;
321 4         5 my $can = 1;
322 4         8 for ( qw( month day hour minute second nanosecond ) )
323             {
324 20 100 100     44 return 0 if ! $can && $self->_has( $_ );
325 19 100 100     46 $can = 0 if $can && ! $self->_has( $_ );
326             }
327 3         14 return 1;
328             }
329              
330             #sub become_datetime {
331             # my $self = shift;
332             # return undef unless $self->has_year;
333             # # warn "param = @{[ %{$self->{has}} ]} ";
334             # # return DateTime->new( %{$self->{has}} );
335             # my @parm = map { ( $_, $self->$_() ) } $self->defined_fields;
336             # # warn "param = @parm";
337             # return DateTime->new( @parm );
338             #}
339              
340             sub set_time_zone
341             {
342 8 50   8 1 912017 die "set_time_zone() requires a time_zone value" unless $#_ == 1;
343 8         19 my $time_zone = $_[1];
344 8 50       27 if ( defined $time_zone )
345             {
346 8 100       69 $time_zone = DateTime::TimeZone->new( name => $time_zone ) unless ref $time_zone;
347 8 50       3020222 $_[0]->{base}->set_time_zone( $time_zone ) if defined $_[0]->{base};
348             }
349 8         29 $_[0]->{has}{time_zone} = $time_zone;
350             }
351              
352             sub _set_locale
353             {
354 7 50   7   28 die "set_locale() requires a locale value" unless $#_ == 1;
355 7         17 my $locale = $_[1];
356 7 50       22 if ( defined $locale )
357             {
358 7 100       53 $locale = DateTime::Locale->load( $locale ) unless ref $locale;
359 7 50       438 $_[0]->{base}->set( locale => $locale ) if defined $_[0]->{base};
360             }
361 7         19 $_[0]->{has}{locale} = $locale;
362             }
363              
364             sub clone
365             {
366 16     16 1 91975 my $base;
367 16 100       86 $base = $_[0]->{base}->clone if defined $_[0]->{base};
368 16         152 bless {
369 16         89 has => { %{ $_[0]->{has} } },
370             base => $base,
371             },
372             ref $_[0];
373             }
374              
375 0     0 1 0 sub is_finite { 1 }
376 0     0 1 0 sub is_infinite { 0 }
377              
378              
379             sub truncate
380             {
381 1     1 1 373 my $self = shift;
382 1         20 my %p = validate( @_,
383             { to =>
384             { regex => qr/^(?:year|month|day|hour|minute|second)$/ },
385             },
386             );
387              
388 1         19 my @fields = @FIELDS;
389 1         7 my $field;
390             my $value;
391 1         2 my $set = 0;
392              
393 1         3 while ( @fields )
394             {
395 7         13 ( $field, $value ) = ( shift @fields, shift @fields );
396 7 100       16 $self->set( $field => $value ) if $set;
397 7 100       22 $set = 1 if $p{to} eq $field;
398             }
399 1         4 return $self;
400             }
401              
402              
403             # Stringification methods
404              
405             sub ymd
406             {
407 27     27 1 58 my ( $self, $sep ) = ( @_, '-' );
408 27         66 return $self->_year . $sep. $self->_month . $sep . $self->_day;
409             }
410             *date = \&ymd;
411              
412             sub mdy
413             {
414 0     0 1 0 my ( $self, $sep ) = ( @_, '-' );
415 0         0 return $self->_month . $sep. $self->_day . $sep . $self->_year;
416             }
417              
418             sub dmy
419             {
420 0     0 1 0 my ( $self, $sep ) = ( @_, '-' );
421 0         0 return $self->_day . $sep. $self->_month . $sep . $self->_year;
422             }
423              
424             sub hms
425             {
426 28     28 1 51 my ( $self, $sep ) = ( @_, ':' );
427 28         63 return $self->_hour . $sep. $self->_minute . $sep . $self->_second;
428             }
429             # don't want to override CORE::time()
430             *DateTime::Incomplete::time = \&hms;
431              
432 25     25 1 108242 sub iso8601 { join 'T', $_[0]->ymd('-'), $_[0]->hms(':') }
433             *datetime = \&iso8601;
434              
435              
436             # "strftime"
437              
438             # Modified from DateTime::strftime %formats; many changes.
439             my %formats =
440             ( 'a' => sub { $_[0]->has_day ?
441             $_[0]->day_abbr :
442             $UNDEF_CHAR x 3 },
443             'A' => sub { $_[0]->has_day ?
444             $_[0]->day_name :
445             $UNDEF_CHAR x 5 },
446             'b' => sub { $_[0]->has_month ?
447             $_[0]->month_abbr :
448             $UNDEF_CHAR x 3 },
449             'B' => sub { $_[0]->has_month ?
450             $_[0]->month_name :
451             $UNDEF_CHAR x 5 },
452             'c' => sub { $_[0]->has_locale ?
453             $_[0]->strftime( $_[0]->locale->default_datetime_format ) :
454             $_[0]->datetime },
455             'C' => sub { $_[0]->has_year ?
456             int( $_[0]->year / 100 ) :
457             $UNDEF_CHAR x 2},
458             'd' => sub { $_[0]->_day },
459             'D' => sub { $_[0]->strftime( '%m/%d/%y' ) },
460             'e' => sub { $_[0]->has_month ?
461             sprintf( '%2d', $_[0]->day_of_month ) :
462             " $UNDEF_CHAR" },
463             'F' => sub { $_[0]->ymd('-') },
464             'g' => sub { substr( $_[0]->week_year, -2 ) },
465             'G' => sub { $_[0]->week_year },
466             'H' => sub { $_[0]->_hour },
467             'I' => sub { $_[0]->has_hour ?
468             sprintf( '%02d', $_[0]->hour_12 ) :
469             $UNDEF_CHAR x 2 },
470             'j' => sub { defined $_[0]->day_of_year ?
471             $_[0]->day_of_year :
472             $UNDEF_CHAR x 3 },
473             'k' => sub { $_[0]->_hour },
474             'l' => sub { $_[0]->has_hour ?
475             sprintf( '%2d', $_[0]->hour_12 ) :
476             " $UNDEF_CHAR" },
477             'm' => sub { $_[0]->_month },
478             'M' => sub { $_[0]->_minute },
479             'n' => sub { "\n" }, # should this be OS-sensitive?
480             'N' => sub { (shift)->_format_nanosecs( @_ ) },
481             'p' => sub { $_[0]->_format_am_pm },
482             'P' => sub { lc $_[0]->_format_am_pm },
483             'r' => sub { $_[0]->strftime( '%I:%M:%S %p' ) },
484             'R' => sub { $_[0]->strftime( '%H:%M' ) },
485             's' => sub { $_[0]->_format_epoch },
486             'S' => sub { $_[0]->_second },
487             't' => sub { "\t" },
488             'T' => sub { $_[0]->strftime( '%H:%M:%S' ) },
489             'u' => sub { $_[0]->day_of_week },
490             # algorithm from Date::Format::wkyr
491             'U' => sub { my $dow = $_[0]->day_of_week;
492             return $UNDEF_CHAR x 2 unless defined $dow;
493             $dow = 0 if $dow == 7; # convert to 0-6, Sun-Sat
494             my $doy = $_[0]->day_of_year - 1;
495             return int( ( $doy - $dow + 13 ) / 7 - 1 )
496             },
497             'w' => sub { my $dow = $_[0]->day_of_week;
498             return $UNDEF_CHAR unless defined $dow;
499             return $dow % 7;
500             },
501             'W' => sub { my $dow = $_[0]->day_of_week;
502             return $UNDEF_CHAR x 2 unless defined $dow;
503             my $doy = $_[0]->day_of_year - 1;
504             return int( ( $doy - $dow + 13 ) / 7 - 1 )
505             },
506             'x' => sub { $_[0]->has_locale ?
507             $_[0]->strftime( $_[0]->locale->default_date_format ) :
508             $_[0]->date },
509             'X' => sub { $_[0]->has_locale ?
510             $_[0]->strftime( $_[0]->locale->default_time_format ) :
511             $_[0]->time },
512             'y' => sub { $_[0]->has_year ?
513             sprintf( '%02d', substr( $_[0]->year, -2 ) ) :
514             $UNDEF_CHAR x 2 },
515             'Y' => sub { $_[0]->_year },
516             'z' => sub { defined $_[0]->time_zone ?
517             DateTime::TimeZone::offset_as_string( $_[0]->offset ) :
518             $UNDEF_CHAR x 5 },
519             'Z' => sub { defined $_[0]->time_zone ?
520             $_[0]->time_zone_short_name :
521             $UNDEF_CHAR x 5 },
522             '%' => sub { '%' },
523             );
524              
525             $formats{h} = $formats{b};
526              
527             sub _format_epoch {
528 0     0   0 my $epoch;
529 0         0 $epoch = $_[0]->epoch;
530 0 0       0 return $UNDEF_CHAR x 6 unless defined $epoch;
531 0         0 return $epoch;
532             }
533              
534             sub _format_am_pm {
535 0 0   0   0 defined $_[0]->locale ?
536             $_[0]->locale->am_pm( $_[0] ) :
537             $UNDEF_CHAR x 2
538             }
539              
540             sub _format_nanosecs
541             {
542 4     4   7 my $self = shift;
543 4   100     19 my $precision = shift || 9;
544              
545 4 50       9 return $UNDEF_CHAR x $precision unless defined $self->nanosecond;
546              
547             # rd_nanosecs can have a fractional separator
548 0         0 my ( $ret, $frac ) = split /[.,]/, $self->nanosecond;
549 0         0 $ret = sprintf "09d" => $ret; # unless length( $ret ) == 9;
550 0 0       0 $ret .= $frac if $frac;
551              
552 0         0 return substr( $ret, 0, $precision );
553             }
554              
555             sub strftime
556             {
557 108     108 1 59490 my $self = shift;
558             # make a copy or caller's scalars get munged
559 108         251 my @formats = @_;
560              
561 108         153 my @r;
562 108         239 foreach my $f (@formats)
563             {
564 109         207 $f =~ s/
565             %\{(\w+)\}
566             /
567 6 50       52 if ( $self->can($1) )
568             {
569 6         25 my $tmp = $self->$1();
570 6 50       43 defined $tmp ?
    100          
571             $tmp :
572             ( exists $FIELD_LENGTH{$1} ?
573             $UNDEF_CHAR x $FIELD_LENGTH{$1} :
574             $UNDEF_CHAR x 2 );
575             }
576             /sgex;
577              
578             # regex from Date::Format - thanks Graham!
579 109         516 $f =~ s/
580             %([%a-zA-Z])
581             /
582 115 50       635 $formats{$1} ? $formats{$1}->($self) : $1
583             /sgex;
584              
585             # %3N
586 109         716 $f =~ s/
587             %(\d+)N
588             /
589 3         11 $formats{N}->($self, $1)
590             /sgex;
591              
592 109 100       692 return $f unless wantarray;
593              
594 2         7 push @r, $f;
595             }
596              
597 1         5 return @r;
598             }
599              
600             # DATETIME::INCOMPLETE METHODS
601              
602              
603             sub is_undef
604             {
605 4     4 1 15 for ( values %{$_[0]->{has}} )
  4         19  
606             {
607 16 100       39 return 0 if defined $_;
608             }
609 2         9 return 1;
610             }
611              
612              
613             sub to_datetime
614             {
615 14     14 1 42 my $self = shift;
616 14         29 my %param = @_;
617 14 100 100     66 $param{base} = $self->{base} if defined $self->{base} &&
618             ! exists $param{base};
619 14         29 my $result;
620 14 100 66     77 if ( defined $param{base} &&
621             UNIVERSAL::can( $param{base}, 'utc_rd_values' ) )
622             {
623 4         16 $result = $param{base}->clone;
624             }
625             else
626             {
627 10         45 $result = DateTime->today;
628             }
629 14         5101 my @params;
630 14         32 for my $key ( @FIELDS_SORTED )
631             {
632 126         190 my $value = $self->{has}{$key};
633 126 100       272 next unless defined $value;
634 60 50       113 if ( $key eq 'time_zone' )
635             {
636 0         0 $result->set_time_zone( $value );
637 0         0 next;
638             }
639 60         168 push @params, ( $key => $value );
640             }
641 14         59 $result->set( @params );
642 14         4308 return $result;
643             }
644              
645             sub contains {
646 4     4 1 1526 my $self = shift;
647 4         7 my $dt = shift;
648 4 50 33     32 die "no datetime" unless defined $dt &&
649             UNIVERSAL::can( $dt, 'utc_rd_values' );
650              
651 4 50       19 if ( $self->has_time_zone )
652             {
653 0         0 $dt = $dt->clone;
654 0         0 $dt->set_time_zone( $self->time_zone );
655             }
656              
657 4         8 my ($key, $value);
658 4         5 while (($key, $value) = each %{$self->{has}} ) {
  26         368  
659 24 100       46 next unless defined $value;
660 14 50 33     52 if ( $key eq 'time_zone' ||
661             $key eq 'locale' )
662             {
663             # time_zone and locale are ignored.
664 0         0 next;
665             }
666 14 100       41 return 0 unless $dt->$key() == $value;
667             }
668 2         11 return 1;
669             }
670              
671             # _fix_time_zone
672             # internal method used by next, previous
673             #
674             sub _fix_time_zone {
675 50     50   104 my ($self, $base, $code) = @_;
676 50 50 66     256 $base = $self->{base} if defined $self->{base} &&
677             ! defined $base;
678 50 50 33     471 die "no base datetime" unless defined $base &&
679             UNIVERSAL::can( $base, 'utc_rd_values' );
680 50         158 my $base_tz = $base->time_zone;
681 50         325 my $result = $base->clone;
682 50 100       664 $result->set_time_zone( $self->time_zone )
683             if $self->has_time_zone;
684 50         562 $result = $code->($self, $result);
685             return undef
686 50 100       159 unless defined $result;
687 46 100       117 $result->set_time_zone( $self->time_zone )
688             if $self->has_time_zone;
689 46         172 $result->set_time_zone( $base_tz );
690 46         617 return $result;
691             }
692              
693             sub next
694             {
695             # returns 'next or equal'
696 28     28 1 83188 my $self = shift;
697 28         46 my $base = shift;
698              
699             return $self->_fix_time_zone( $base,
700             sub {
701 28     28   46 my ($self, $result) = @_;
702 28         61 REDO: for (1..10) {
703             # warn "next: self ".$self->datetime." base ".$result->datetime;
704              
705 57         210 my @fields = @FIELDS;
706 57         69 my ( $field, $overflow, $bigger_field );
707 57         137 while ( @fields )
708             {
709 272         525 ( $field, undef ) = ( shift @fields, shift @fields );
710 272 100       706 if ( defined $self->$field() )
711             {
712 160         313 $overflow = ( $self->$field() < $result->$field() );
713 160 50 66     980 return undef if $overflow && $field eq $FIELDS[0];
714              
715 160 100       431 if ( $self->$field() != $result->$field() )
716             {
717 65         325 eval { $result->set( $field => $self->$field() ) };
  65         130  
718 65 100       18780 if ( $@ )
719             {
720 12         40 $result->set( @fields );
721 12         3544 eval { $result->set( $field => $self->$field() ) };
  12         34  
722 12 100       3706 if ( $@ )
723             {
724 11         18 $overflow = 1;
725             }
726             }
727              
728 65 100       131 if ( $overflow )
729             {
730 31         133 $result->add( $bigger_field . 's' => 1 );
731 31         17763 next REDO;
732             }
733             else
734             {
735 34         114 $result->set( @fields );
736             }
737             }
738             }
739 241         11575 $bigger_field = $field;
740             }
741 26         75 return $result;
742             }
743 2         7 return undef;
744 28         206 } );
745             }
746              
747             sub previous
748             {
749             # returns 'previous or equal'
750 22     22 1 16862 my $self = shift;
751 22         42 my $base = shift;
752              
753             return $self->_fix_time_zone( $base,
754             sub {
755 22     22   37 my ($self, $result) = @_;
756             # warn "# previous: self ".$self->datetime." base ".$result->datetime." ".$result->time_zone->name;
757              
758 22         30 my ( $field, $value, $overflow, $bigger_field );
759              
760 22         53 REDO: for (1..10) {
761 52         193 my @fields = @FIELDS;
762 52         131 while ( @fields )
763             {
764 220         475 ( $field, $value ) = ( shift @fields, shift @fields );
765 220 100       598 if ( defined $self->$field() )
766             {
767 135         270 $overflow = ( $self->$field() > $result->$field() );
768 135 50 66     886 return undef if $overflow && $field eq $FIELDS[0];
769              
770 135 100       273 if ( $self->$field() != $result->$field() )
771             {
772 111 100       632 if ( $overflow )
773             {
774 32         115 $result->set( $field => $value, @fields );
775 32         10530 $result->subtract( nanoseconds => 1 );
776 32         23385 next REDO;
777             }
778 79         211 my $diff = $result->$field() - $self->$field() ;
779 79         109 $diff--;
780 79         272 $result->subtract( $field . 's' => $diff );
781 79         51304 $result->set( @fields );
782 79         27560 $result->subtract( nanoseconds => 1 );
783 79 50       58143 if ( $result->$field() != $self->$field() )
784             {
785 0         0 $result->set( @fields );
786 0         0 $result->subtract( nanoseconds => 1 );
787             }
788             }
789             }
790 188         589 $bigger_field = $field;
791             }
792 20         76 return $result;
793             }
794 2         7 return undef;
795 22         168 } );
796             }
797              
798             sub closest
799             {
800             # returns 'closest datetime'
801              
802 5     5 1 6545 my $self = shift;
803 5         11 my $base = shift;
804 5 50 66     123 $base = $self->{base} if defined $self->{base} &&
805             ! defined $base;
806 5 50 33     117 die "no base datetime" unless defined $base &&
807             UNIVERSAL::can( $base, 'utc_rd_values' );
808              
809 5         22 my $dt1 = $self->previous( $base );
810 5         80 my $dt2 = $self->next( $base );
811              
812 5 100       73 return $dt1 unless defined $dt2;
813 4 50       54 return $dt2 unless defined $dt1;
814              
815 4         25 my $delta = $base - $dt1;
816 4 100       1511 return $dt1 if ( $dt2 - $delta ) >= $base;
817 2         1926 return $dt2;
818             }
819              
820             sub start
821             {
822 7     7 1 16 my $self = shift;
823 7 100       54 return undef unless $self->has_year;
824 4         15 my $dt = $self->to_datetime;
825 4         17 $dt->subtract( years => 1 );
826 4         2846 return $self->next( $dt );
827             }
828              
829             sub end
830             {
831 8     8 1 1447 my $self = shift;
832 8 100       24 return undef unless $self->has_year;
833 5         16 my $dt = $self->to_datetime;
834 5         19 $dt->add( years => 1 );
835 5         2638 my $end = $self->previous( $dt );
836 5 100       71 $end->add( nanoseconds => 1 ) unless $self->has_nanosecond;
837 5         1336 return $end;
838             }
839              
840             sub to_span
841             {
842 5     5 1 1861 my $self = shift;
843 5         20 my $start = $self->start;
844 5         31 my $end = $self->end;
845              
846 5 50 66     46 return DateTime::Set->empty_set->complement->span
847             if ! $start && ! $end;
848              
849 2         65 my @start;
850 2 50       6 @start = ( 'start', $start ) if $start;
851              
852 2         131 my @end;
853 2 50       4 if ( $end )
854             {
855 2 100       61 if ( $self->has_nanosecond )
856             {
857 1         4 @end = ( 'end', $end );
858             }
859             else
860             {
861 1         3 @end = ( 'before', $end );
862             }
863             }
864              
865 2         20 return DateTime::Span->from_datetimes( @start, @end );
866             }
867              
868             sub to_recurrence
869             {
870 10     10 1 1663 my $self = shift;
871 10         22 my %param;
872              
873 10         47 my $freq = '';
874 10         16 my $year;
875 10         31 for ( qw( second minute hour day month year ) )
876             {
877 60         91 my $by = $_ . 's'; # months, hours
878 60 100 100     341 if ( exists $self->{has}{$_} && defined $self->{has}{$_} )
879             {
880 43 100       92 if ( $_ eq 'year' )
881             {
882 5         16 $year = $self->$_();
883 5         13 next;
884             }
885 38         109 $param{$by} = [ $self->$_() ];
886 38         107 next;
887             }
888 17 100       47 $freq = $_ unless $freq;
889             # TODO: use a hash
890 17 100       49 $param{$by} = [ 1 .. 12 ] if $_ eq 'month';
891 17 100       59 $param{$by} = [ 1 .. 31 ] if $_ eq 'day';
892 17 100       49 $param{$by} = [ 0 .. 23 ] if $_ eq 'hour';
893 17 100       77 $param{$by} = [ 0 .. 59 ] if $_ eq 'minute';
894 17 100       65 $param{$by} = [ 0 .. 59 ] if $_ eq 'second';
895             }
896 10 100       31 if ( $freq eq '' )
897             {
898             # it is a single date
899 2         9 my $dt = DateTime->new( %{$self->{has}} );
  2         13  
900 2         495 return DateTime::Set->from_datetimes( dates => [ $dt ] );
901             }
902              
903             # for ( keys %param ) { print STDERR " param $_ = @{$param{$_}} \n"; }
904              
905 8         91 my $r = DateTime::Event::Recurrence->yearly( %param );
906 8 100       15464 if ( defined $year ) {
907 3         18 my $span = DateTime::Span->from_datetimes(
908             start => DateTime->new( year => $year ),
909             before => DateTime->new( year => $year + 1 ) );
910 3         4824 $r = $r->intersection( $span );
911             }
912 8         615860 return $r;
913             }
914              
915             sub to_spanset
916             {
917 3     3 1 47680 my $self = shift;
918 3         9 my @reset;
919 3         11 for ( qw( second minute hour day month year ) )
920             {
921 10 100       28 if ( $self->has( $_ ) )
922             {
923 2         17 my %fields = @FIELDS;
924 2         8 @reset = map { $_ => $fields{$_} } @reset;
  2         7  
925 2         11 my $dti = $self->clone;
926 2 100       12 $dti->set( @reset ) if @reset;
927              
928 2         11 return DateTime::SpanSet->from_set_and_duration (
929             set => $dti->to_recurrence,
930             $_ . 's' => 1,
931             );
932             }
933 8         19 push @reset, $_;
934             }
935 1         5 return $self->to_span;
936             }
937              
938             sub STORABLE_freeze
939             {
940 0     0 0   my ( $self, $cloning ) = @_;
941 0 0         return if $cloning;
942              
943 0           my @data;
944 0           for my $key ( @FIELDS_SORTED )
945             {
946 0 0         next unless defined $self->{has}{$key};
947              
948 0 0         if ( $key eq 'locale' )
    0          
949             {
950 0           push @data, "locale:" . $self->{has}{locale}->id;
951             }
952             elsif ( $key eq 'time_zone' )
953             {
954 0           push @data, "tz:" . $self->{has}{time_zone}->name;
955             }
956             else
957             {
958 0           push @data, "$key:" . $self->{has}{$key};
959             }
960             }
961 0           return join( '|', @data ), [$self->base];
962             }
963              
964             sub STORABLE_thaw
965             {
966 0     0 0   my ( $self, $cloning, $data, $base ) = @_;
967 0           my %data = map { split /:/ } split /\|/, $data;
  0            
968 0           my $locale = delete $data{locale};
969 0           my $tz = delete $data{tz};
970 0           $self->{has} = \%data;
971 0           $self->set_time_zone( $tz );
972 0           $self->set( locale => $locale );
973 0           $self->{base} = $base->[0];
974 0           return $self;
975             }
976              
977             1;
978              
979             __END__