File Coverage

blib/lib/DateTime/Set.pm
Criterion Covered Total %
statement 305 337 90.5
branch 124 166 74.7
condition 15 30 50.0
subroutine 53 57 92.9
pod 29 29 100.0
total 526 619 84.9


line stmt bran cond sub pod time code
1             package DateTime::Set;
2              
3 23     23   5935891 use strict;
  23         35  
  23         634  
4 23     23   78 use Carp;
  23         25  
  23         1337  
5 23     23   10444 use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );
  23         60084  
  23         1601  
6 23     23   2285 use DateTime 0.12; # this is for version checking only
  23         878079  
  23         467  
7 23     23   90 use DateTime::Duration;
  23         30  
  23         343  
8 23     23   8243 use DateTime::Span;
  23         41  
  23         607  
9 23     23   12326 use Set::Infinite 0.59;
  23         452465  
  23         1042  
10 23     23   8952 use Set::Infinite::_recurrence;
  23         43  
  23         924  
11              
12 23     23   103 use vars qw( $VERSION );
  23         27  
  23         886  
13              
14 23     23   84 use constant INFINITY => 100 ** 100 ** 100 ;
  23         27  
  23         1148  
15 23     23   91 use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);
  23         28  
  23         901  
16              
17             BEGIN {
18 23     23   56563 $VERSION = '0.3900';
19             }
20              
21              
22             sub _fix_datetime {
23             # internal function -
24             # (not a class method)
25             #
26             # checks that the parameter is an object, and
27             # also protects the object against mutation
28            
29 7952 100   7952   15086 return $_[0]
30             unless defined $_[0]; # error
31 7940 100       20817 return $_[0]->clone
32             if ref( $_[0] ); # "immutable" datetime
33 89 100       284 return DateTime::Infinite::Future->new
34             if $_[0] == INFINITY; # Inf
35 10 50       51 return DateTime::Infinite::Past->new
36             if $_[0] == NEG_INFINITY; # -Inf
37 0         0 return $_[0]; # error
38             }
39              
40             sub _fix_return_datetime {
41 74     74   16303 my ( $dt, $dt_arg ) = @_;
42              
43             # internal function -
44             # (not a class method)
45             #
46             # checks that the returned datetime has the same
47             # time zone as the parameter
48              
49             # TODO: set locale
50              
51 74 100       233 return unless $dt;
52 61 50       1752 return unless $dt_arg;
53 61 100 66     1299 if ( $dt_arg->can('time_zone_long_name') &&
54             !( $dt_arg->time_zone_long_name eq 'floating' ) )
55             {
56 2         13 $dt->set_time_zone( $dt_arg->time_zone );
57             }
58 61         744 return $dt;
59             }
60              
61             sub iterate {
62             # deprecated method - use map() or grep() instead
63 0     0 1 0 my ( $self, $callback ) = @_;
64 0         0 my $class = ref( $self );
65 0         0 my $return = $class->empty_set;
66             $return->{set} = $self->{set}->iterate(
67             sub {
68 0     0   0 my $min = $_[0]->min;
69 0 0       0 $callback->( $min->clone ) if ref($min);
70             }
71 0         0 );
72 0         0 $return;
73             }
74              
75             sub map {
76 1     1 1 448 my ( $self, $callback ) = @_;
77 1         2 my $class = ref( $self );
78 1 50       5 die "The callback parameter to map() must be a subroutine reference"
79             unless ref( $callback ) eq 'CODE';
80 1         10 my $return = $class->empty_set;
81             $return->{set} = $self->{set}->iterate(
82             sub {
83 2     2   49 local $_ = $_[0]->min;
84 2 50       27 next unless ref( $_ );
85 2         5 $_ = $_->clone;
86 2         16 my @list = $callback->();
87 2         1460 my $set = Set::Infinite::_recurrence->new();
88 2         27 $set = $set->union( $_ ) for @list;
89 2         143 return $set;
90             }
91 1         18 );
92 1         89 $return;
93             }
94              
95             sub grep {
96 1     1 1 622 my ( $self, $callback ) = @_;
97 1         2 my $class = ref( $self );
98 1 50       4 die "The callback parameter to grep() must be a subroutine reference"
99             unless ref( $callback ) eq 'CODE';
100 1         3 my $return = $class->empty_set;
101             $return->{set} = $self->{set}->iterate(
102             sub {
103 2     2   46 local $_ = $_[0]->min;
104 2 50       28 next unless ref( $_ );
105 2         4 $_ = $_->clone;
106 2         15 my $result = $callback->();
107 2 100       417 return $_ if $result;
108 1         3 return;
109             }
110 1         16 );
111 1         74 $return;
112             }
113              
114 8     8 1 516 sub add { return shift->add_duration( DateTime::Duration->new(@_) ) }
115              
116 1     1 1 5 sub subtract { return shift->subtract_duration( DateTime::Duration->new(@_) ) }
117              
118 3     3 1 123 sub subtract_duration { return $_[0]->add_duration( $_[1]->inverse ) }
119              
120             sub add_duration {
121 18     18 1 841 my ( $self, $dur ) = @_;
122 18         43 $dur = $dur->clone; # $dur must be "immutable"
123              
124             $self->{set} = $self->{set}->iterate(
125             sub {
126 74     74   5329 my $min = $_[0]->min;
127 74 50       1271 $min->clone->add_duration( $dur ) if ref($min);
128             },
129             backtrack_callback => sub {
130 18     18   826 my ( $min, $max ) = ( $_[0]->min, $_[0]->max );
131 18 100       403 if ( ref($min) )
132             {
133 14         35 $min = $min->clone;
134 14         122 $min->subtract_duration( $dur );
135             }
136 18 100       7595 if ( ref($max) )
137             {
138 8         23 $max = $max->clone;
139 8         70 $max->subtract_duration( $dur );
140             }
141 18         3002 return Set::Infinite::_recurrence->new( $min, $max );
142             },
143 18         209 );
144 18         1086 $self;
145             }
146              
147             sub set_time_zone {
148 4     4 1 286 my ( $self, $tz ) = @_;
149              
150             $self->{set} = $self->{set}->iterate(
151             sub {
152 43     43   2388 my $min = $_[0]->min;
153 43 50       617 $min->clone->set_time_zone( $tz ) if ref($min);
154             },
155             backtrack_callback => sub {
156 8     8   364 my ( $min, $max ) = ( $_[0]->min, $_[0]->max );
157 8 100       186 if ( ref($min) )
158             {
159 6         13 $min = $min->clone;
160 6         50 $min->set_time_zone( $tz );
161             }
162 8 100       1006 if ( ref($max) )
163             {
164 2         4 $max = $max->clone;
165 2         15 $max->set_time_zone( $tz );
166             }
167 8         214 return Set::Infinite::_recurrence->new( $min, $max );
168             },
169 4         36 );
170 4         353 $self;
171             }
172              
173             sub set {
174 1     1 1 2 my $self = shift;
175 1         17 my %args = validate( @_,
176             { locale => { type => SCALAR | OBJECT,
177             default => undef },
178             }
179             );
180             $self->{set} = $self->{set}->iterate(
181             sub {
182 2     2   307 my $min = $_[0]->min;
183 2 50       32 $min->clone->set( %args ) if ref($min);
184             },
185 1         8 );
186 1         20 $self;
187             }
188              
189             sub from_recurrence {
190 37     37 1 16153 my $class = shift;
191              
192 37         92 my %args = @_;
193 37         43 my %param;
194            
195             # Parameter renaming, such that we can use either
196             # recurrence => xxx or next => xxx, previous => xxx
197 37   66     130 $param{next} = delete $args{recurrence} || delete $args{next};
198 37         62 $param{previous} = delete $args{previous};
199              
200 37         50 $param{span} = delete $args{span};
201             # they might be specifying a span using start / end
202 37 100       169 $param{span} = DateTime::Span->new( %args ) if keys %args;
203              
204 37         51 my $self = {};
205            
206             die "Not enough arguments in from_recurrence()"
207 37 50 66     98 unless $param{next} || $param{previous};
208              
209 37 100       80 if ( ! $param{previous} )
210             {
211 30         35 my $data = {};
212             $param{previous} =
213             sub {
214 1635     1635   7389 _callback_previous ( _fix_datetime( $_[0] ), $param{next}, $data );
215             }
216 30         115 }
217             else
218             {
219 7         8 my $previous = $param{previous};
220             $param{previous} =
221             sub {
222 28     28   176 $previous->( _fix_datetime( $_[0] ) );
223             }
224 7         21 }
225              
226 37 100       85 if ( ! $param{next} )
227             {
228 2         4 my $data = {};
229             $param{next} =
230             sub {
231 4     4   10 _callback_next ( _fix_datetime( $_[0] ), $param{previous}, $data );
232             }
233 2         7 }
234             else
235             {
236 35         44 my $next = $param{next};
237             $param{next} =
238             sub {
239 6055     6055   9687 $next->( _fix_datetime( $_[0] ) );
240             }
241 35         96 }
242              
243 37         36 my ( $min, $max );
244 37         196 $max = $param{previous}->( DateTime::Infinite::Future->new );
245 37         2197 $min = $param{next}->( DateTime::Infinite::Past->new );
246 37 100       6122 $max = INFINITY if $max->is_infinite;
247 37 100       211 $min = NEG_INFINITY if $min->is_infinite;
248            
249 37         320 my $base_set = Set::Infinite::_recurrence->new( $min, $max );
250             $base_set = $base_set->intersection( $param{span}->{set} )
251 37 100       1380 if $param{span};
252            
253             # warn "base set is $base_set\n";
254              
255 37         1493 my $data = {};
256             $self->{set} =
257             $base_set->_recurrence(
258             $param{next},
259             $param{previous},
260 37         317 $data,
261             );
262 37         275 bless $self, $class;
263            
264 37         141 return $self;
265             }
266              
267             sub from_datetimes {
268 83     83 1 24329 my $class = shift;
269 83         1650 my %args = validate( @_,
270             { dates =>
271             { type => ARRAYREF,
272             },
273             }
274             );
275 82         237 my $self = {};
276 82         358 $self->{set} = Set::Infinite::_recurrence->new;
277             # possible optimization: sort datetimes and use "push"
278 82         1037 for( @{ $args{dates} } )
  82         162  
279             {
280             # DateTime::Infinite objects are not welcome here,
281             # but this is not enforced (it does't hurt)
282              
283 113 50       3480 carp "The 'dates' argument to from_datetimes() must only contain ".
284             "datetime objects"
285             unless UNIVERSAL::can( $_, 'utc_rd_values' );
286              
287 113         286 $self->{set} = $self->{set}->union( $_->clone );
288             }
289              
290 82         8569 bless $self, $class;
291 82         212 return $self;
292             }
293              
294             sub empty_set {
295 79     79 1 260 my $class = shift;
296              
297 79         161 return bless { set => Set::Infinite::_recurrence->new }, $class;
298             }
299              
300             sub is_empty_set {
301 2     2 1 174 my $set = $_[0];
302 2         7 $set->{set}->is_null;
303             }
304              
305             sub clone {
306 54     54 1 5079 my $self = bless { %{ $_[0] } }, ref $_[0];
  54         195  
307 54         205 $self->{set} = $_[0]->{set}->copy;
308 54         1748 return $self;
309             }
310              
311             # default callback that returns the
312             # "previous" value in a callback recurrence.
313             #
314             # This is used to simulate a 'previous' callback,
315             # when then 'previous' argument in 'from_recurrence' is missing.
316             #
317             sub _callback_previous {
318 1635     1635   11558 my ($value, $callback_next, $callback_info) = @_;
319 1635         2381 my $previous = $value->clone;
320              
321 1635 100       9901 return $value if $value->is_infinite;
322              
323 1433         3848 my $freq = $callback_info->{freq};
324 1433 100       1926 unless (defined $freq)
325             {
326             # This is called just once, to setup the recurrence frequency
327 28         39 my $previous = $callback_next->( $value );
328 28         22091 my $next = $callback_next->( $previous );
329 28         21634 $freq = 2 * ( $previous - $next );
330             # save it for future use with this same recurrence
331 28         5550 $callback_info->{freq} = $freq;
332             }
333              
334 1433         2187 $previous->add_duration( $freq );
335 1433         679083 $previous = $callback_next->( $previous );
336 1433 50       997109 if ($previous >= $value)
337             {
338             # This error happens if the event frequency oscillates widely
339             # (more than 100% of difference from one interval to next)
340 0         0 my @freq = $freq->deltas;
341 0         0 print STDERR "_callback_previous: Delta components are: @freq\n";
342 0         0 warn "_callback_previous: iterator can't find a previous value, got ".
343             $previous->ymd." after ".$value->ymd;
344             }
345 1433         58086 my $previous1;
346 1433         1226 while (1)
347             {
348 1445         3282 $previous1 = $previous->clone;
349 1445         10013 $previous = $callback_next->( $previous );
350 1445 100       999970 return $previous1 if $previous >= $value;
351             }
352             }
353              
354             # default callback that returns the
355             # "next" value in a callback recurrence.
356             #
357             # This is used to simulate a 'next' callback,
358             # when then 'next' argument in 'from_recurrence' is missing.
359             #
360             sub _callback_next {
361 4     4   68 my ($value, $callback_previous, $callback_info) = @_;
362 4         8 my $next = $value->clone;
363              
364 4 100       29 return $value if $value->is_infinite;
365              
366 2         6 my $freq = $callback_info->{freq};
367 2 100       5 unless (defined $freq)
368             {
369             # This is called just once, to setup the recurrence frequency
370 1         2 my $next = $callback_previous->( $value );
371 1         717 my $previous = $callback_previous->( $next );
372 1         731 $freq = 2 * ( $next - $previous );
373             # save it for future use with this same recurrence
374 1         210 $callback_info->{freq} = $freq;
375             }
376              
377 2         5 $next->add_duration( $freq );
378 2         940 $next = $callback_previous->( $next );
379 2 50       1415 if ($next <= $value)
380             {
381             # This error happens if the event frequency oscillates widely
382             # (more than 100% of difference from one interval to next)
383 0         0 my @freq = $freq->deltas;
384 0         0 print STDERR "_callback_next: Delta components are: @freq\n";
385 0         0 warn "_callback_next: iterator can't find a previous value, got ".
386             $next->ymd." before ".$value->ymd;
387             }
388 2         82 my $next1;
389 2         27 while (1)
390             {
391 2         6 $next1 = $next->clone;
392 2         15 $next = $callback_previous->( $next );
393 2 50       1416 return $next1 if $next >= $value;
394             }
395             }
396              
397             sub iterator {
398 40     40 1 7669 my $self = shift;
399              
400 40         67 my %args = @_;
401 40         44 my $span;
402 40         53 $span = delete $args{span};
403 40 100       122 $span = DateTime::Span->new( %args ) if %args;
404              
405 40 100       94 return $self->intersection( $span ) if $span;
406 25         56 return $self->clone;
407             }
408              
409              
410             # next() gets the next element from an iterator()
411             # next( $dt ) returns the next element after a datetime.
412             sub next {
413 1367     1367 1 63316 my $self = shift;
414 1367 100       2702 return undef unless ref( $self->{set} );
415              
416 1355 100       2064 if ( @_ )
417             {
418 39 100       91 if ( $self->{set}->_is_recurrence )
419             {
420             return _fix_return_datetime(
421 20         348 $self->{set}->{param}[0]->( $_[0] ), $_[0] );
422             }
423             else
424             {
425 19         65 my $span = DateTime::Span->from_datetimes( after => $_[0] );
426 19         42 return _fix_return_datetime(
427             $self->intersection( $span )->next, $_[0] );
428             }
429             }
430              
431 1316         2487 my ($head, $tail) = $self->{set}->first;
432 1316         34212 $self->{set} = $tail;
433 1316 100       3882 return $head->min if defined $head;
434 3         9 return $head;
435             }
436              
437             # previous() gets the last element from an iterator()
438             # previous( $dt ) returns the previous element before a datetime.
439             sub previous {
440 126     126 1 17689 my $self = shift;
441 126 100       324 return undef unless ref( $self->{set} );
442              
443 111 100       199 if ( @_ )
444             {
445 35 100       76 if ( $self->{set}->_is_recurrence )
446             {
447             return _fix_return_datetime(
448 13         235 $self->{set}->{param}[1]->( $_[0] ), $_[0] );
449             }
450             else
451             {
452 22         73 my $span = DateTime::Span->from_datetimes( before => $_[0] );
453 22         38 return _fix_return_datetime(
454             $self->intersection( $span )->previous, $_[0] );
455             }
456             }
457              
458 76         172 my ($head, $tail) = $self->{set}->last;
459 76         3724 $self->{set} = $tail;
460 76 100       325 return $head->max if defined $head;
461 10         17 return $head;
462             }
463              
464             # "current" means less-or-equal to a datetime
465             sub current {
466 29     29 1 108 my $self = shift;
467              
468 29 50       66 return undef unless ref( $self->{set} );
469              
470 29 100       61 if ( $self->{set}->_is_recurrence )
471             {
472 9         144 my $tmp = $self->next( $_[0] );
473 9         25 return $self->previous( $tmp );
474             }
475              
476 20 50       36 return $_[0] if $self->contains( $_[0] );
477 20         8422 $self->previous( $_[0] );
478             }
479              
480             sub closest {
481 0     0 1 0 my $self = shift;
482             # return $_[0] if $self->contains( $_[0] );
483 0         0 my $dt1 = $self->current( $_[0] );
484 0         0 my $dt2 = $self->next( $_[0] );
485              
486 0 0       0 return $dt2 unless defined $dt1;
487 0 0       0 return $dt1 unless defined $dt2;
488              
489 0         0 my $delta = $_[0] - $dt1;
490 0 0       0 return $dt1 if ( $dt2 - $delta ) >= $_[0];
491              
492 0         0 return $dt2;
493             }
494              
495             sub as_list {
496 4     4 1 806 my $self = shift;
497 4 50       16 return undef unless ref( $self->{set} );
498              
499 4         7 my %args = @_;
500 4         8 my $span;
501 4         6 $span = delete $args{span};
502 4 100       12 $span = DateTime::Span->new( %args ) if %args;
503              
504 4         10 my $set = $self->clone;
505 4 100       10 $set = $set->intersection( $span ) if $span;
506              
507 4 100       21 return if $set->{set}->is_null; # nothing = empty
508              
509             # Note: removing this line means we may end up in an infinite loop!
510             ## return undef if $set->{set}->is_too_complex; # undef = no start/end
511            
512             return undef
513 3 100 66     30 if $set->max->is_infinite ||
514             $set->min->is_infinite;
515              
516 2         31 my @result;
517 2         6 my $next = $self->min;
518 2 50       15 if ( $span ) {
519 0         0 my $next1 = $span->min;
520 0 0 0     0 $next = $next1 if $next1 && $next1 > $next;
521 0         0 $next = $self->current( $next );
522             }
523 2         4 my $last = $self->max;
524 2 50       15 if ( $span ) {
525 0         0 my $last1 = $span->max;
526 0 0 0     0 $last = $last1 if $last1 && $last1 < $last;
527             }
528 2   66     2 do {
529 3 50 33     70 push @result, $next if !$span || $span->contains($next);
530 3         12 $next = $self->next( $next );
531             }
532             while $next && $next <= $last;
533 2         11 return @result;
534             }
535              
536             sub intersection {
537 65     65 1 1028 my ($set1, $set2) = ( shift, shift );
538 65         68 my $class = ref($set1);
539 65         122 my $tmp = $class->empty_set();
540 65 50       798 $set2 = $set2->as_set
541             if $set2->can( 'as_set' );
542 65 100       166 $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
543             unless $set2->can( 'union' );
544 65         163 $tmp->{set} = $set1->{set}->intersection( $set2->{set} );
545 65         26354 return $tmp;
546             }
547              
548             sub intersects {
549 10     10 1 2251 my ($set1, $set2) = ( shift, shift );
550 10         14 my $class = ref($set1);
551 10 50       37 $set2 = $set2->as_set
552             if $set2->can( 'as_set' );
553 10 100       26 unless ( $set2->can( 'union' ) )
554             {
555 9 100       22 if ( $set1->{set}->_is_recurrence )
556             {
557 3         48 for ( $set2, @_ )
558             {
559 4 100       67 return 1 if $set1->current( $_ ) == $_;
560             }
561 1         44 return 0;
562             }
563 6         162 $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
564             }
565 7         24 return $set1->{set}->intersects( $set2->{set} );
566             }
567              
568             sub contains {
569 30     30 1 2163 my ($set1, $set2) = ( shift, shift );
570 30         64 my $class = ref($set1);
571 30 50       113 $set2 = $set2->as_set
572             if $set2->can( 'as_set' );
573 30 100       70 unless ( $set2->can( 'union' ) )
574             {
575 29 100       57 if ( $set1->{set}->_is_recurrence )
576             {
577 3         61 for ( $set2, @_ )
578             {
579 3 100       6 return 0 unless $set1->current( $_ ) == $_;
580             }
581 1         44 return 1;
582             }
583 26         208 $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
584             }
585 27         74 return $set1->{set}->contains( $set2->{set} );
586             }
587              
588             sub union {
589 4     4 1 2776 my ($set1, $set2) = ( shift, shift );
590 4         8 my $class = ref($set1);
591 4         12 my $tmp = $class->empty_set();
592 4 50       85 $set2 = $set2->as_set
593             if $set2->can( 'as_set' );
594 4 50       12 $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
595             unless $set2->can( 'union' );
596 4         17 $tmp->{set} = $set1->{set}->union( $set2->{set} );
597 4 50 33     173 bless $tmp, 'DateTime::SpanSet'
598             if $set2->isa('DateTime::Span') or $set2->isa('DateTime::SpanSet');
599 4         10 return $tmp;
600             }
601              
602             sub complement {
603 2     2 1 23 my ($set1, $set2) = ( shift, shift );
604 2         4 my $class = ref($set1);
605 2         5 my $tmp = $class->empty_set();
606 2 50       29 if (defined $set2)
607             {
608 2 50       15 $set2 = $set2->as_set
609             if $set2->can( 'as_set' );
610 2 50       13 $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
611             unless $set2->can( 'union' );
612             # TODO: "compose complement";
613 2         14 $tmp->{set} = $set1->{set}->complement( $set2->{set} );
614             }
615             else
616             {
617 0         0 $tmp->{set} = $set1->{set}->complement;
618 0         0 bless $tmp, 'DateTime::SpanSet';
619             }
620 2         66 return $tmp;
621             }
622              
623             sub start {
624 54     54 1 6236 return _fix_datetime( $_[0]->{set}->min );
625             }
626              
627             *min = \&start;
628              
629             sub end {
630 34     34 1 6248 return _fix_datetime( $_[0]->{set}->max );
631             }
632              
633             *max = \&end;
634              
635             # returns a DateTime::Span
636             sub span {
637 0     0 1 0 my $set = $_[0]->{set}->span;
638 0         0 my $self = bless { set => $set }, 'DateTime::Span';
639 0         0 return $self;
640             }
641              
642             sub count {
643 9     9 1 4195 my ($self) = shift;
644 9 50       27 return undef unless ref( $self->{set} );
645              
646 9         14 my %args = @_;
647 9         12 my $span;
648 9         13 $span = delete $args{span};
649 9 100       44 $span = DateTime::Span->new( %args ) if %args;
650              
651 9         25 my $set = $self->clone;
652 9 100       22 $set = $set->intersection( $span ) if $span;
653              
654             return $set->{set}->count
655 9 100       24 unless $set->{set}->is_too_complex;
656              
657             return undef
658 4 100 100     22 if $set->max->is_infinite ||
659             $set->min->is_infinite;
660              
661 1         14 my $count = 0;
662 1         6 my $iter = $set->iterator;
663 1         3 $count++ while $iter->next;
664 1         1323 return $count;
665             }
666              
667             1;
668              
669             __END__
670              
671             =head1 NAME
672              
673             DateTime::Set - Datetime sets and set math
674              
675             =head1 SYNOPSIS
676              
677             use DateTime;
678             use DateTime::Set;
679              
680             $date1 = DateTime->new( year => 2002, month => 3, day => 11 );
681             $set1 = DateTime::Set->from_datetimes( dates => [ $date1 ] );
682             # set1 = 2002-03-11
683              
684             $date2 = DateTime->new( year => 2003, month => 4, day => 12 );
685             $set2 = DateTime::Set->from_datetimes( dates => [ $date1, $date2 ] );
686             # set2 = 2002-03-11, and 2003-04-12
687              
688             $date3 = DateTime->new( year => 2003, month => 4, day => 1 );
689             print $set2->next( $date3 )->ymd; # 2003-04-12
690             print $set2->previous( $date3 )->ymd; # 2002-03-11
691             print $set2->current( $date3 )->ymd; # 2002-03-11
692             print $set2->closest( $date3 )->ymd; # 2003-04-12
693              
694             # a 'monthly' recurrence:
695             $set = DateTime::Set->from_recurrence(
696             recurrence => sub {
697             return $_[0] if $_[0]->is_infinite;
698             return $_[0]->truncate( to => 'month' )->add( months => 1 )
699             },
700             span => $date_span1, # optional span
701             );
702              
703             $set = $set1->union( $set2 ); # like "OR", "insert", "both"
704             $set = $set1->complement( $set2 ); # like "delete", "remove"
705             $set = $set1->intersection( $set2 ); # like "AND", "while"
706             $set = $set1->complement; # like "NOT", "negate", "invert"
707              
708             if ( $set1->intersects( $set2 ) ) { ... # like "touches", "interferes"
709             if ( $set1->contains( $set2 ) ) { ... # like "is-fully-inside"
710              
711             # data extraction
712             $date = $set1->min; # first date of the set
713             $date = $set1->max; # last date of the set
714              
715             $iter = $set1->iterator;
716             while ( $dt = $iter->next ) {
717             print $dt->ymd;
718             };
719              
720             =head1 DESCRIPTION
721              
722             DateTime::Set is a module for datetime sets. It can be used to handle
723             two different types of sets.
724              
725             The first is a fixed set of predefined datetime objects. For example,
726             if we wanted to create a set of datetimes containing the birthdays of
727             people in our family for the current year.
728              
729             The second type of set that it can handle is one based on a
730             recurrence, such as "every Wednesday", or "noon on the 15th day of
731             every month". This type of set can have fixed starting and ending
732             datetimes, but neither is required. So our "every Wednesday set"
733             could be "every Wednesday from the beginning of time until the end of
734             time", or "every Wednesday after 2003-03-05 until the end of time", or
735             "every Wednesday between 2003-03-05 and 2004-01-07".
736              
737             This module also supports set math operations, so you do things like
738             create a new set from the union or difference of two sets, check
739             whether a datetime is a member of a given set, etc.
740              
741             This is different from a C<DateTime::Span>, which handles a continuous
742             range as opposed to individual datetime points. There is also a module
743             C<DateTime::SpanSet> to handle sets of spans.
744              
745             =head1 METHODS
746              
747             =over 4
748              
749             =item * from_datetimes
750              
751             Creates a new set from a list of datetimes.
752              
753             $dates = DateTime::Set->from_datetimes( dates => [ $dt1, $dt2, $dt3 ] );
754              
755             The datetimes can be objects from class C<DateTime>, or from a
756             C<DateTime::Calendar::*> class.
757              
758             C<DateTime::Infinite::*> objects are not valid set members.
759              
760             =item * from_recurrence
761              
762             Creates a new set specified via a "recurrence" callback.
763              
764             $months = DateTime::Set->from_recurrence(
765             span => $dt_span_this_year, # optional span
766             recurrence => sub {
767             return $_[0]->truncate( to => 'month' )->add( months => 1 )
768             },
769             );
770              
771             The C<span> parameter is optional. It must be a C<DateTime::Span> object.
772              
773             The span can also be specified using C<start> / C<after> and C<end> /
774             C<before> parameters, as in the C<DateTime::Span> constructor. In
775             this case, if there is a C<span> parameter it will be ignored.
776              
777             $months = DateTime::Set->from_recurrence(
778             after => $dt_now,
779             recurrence => sub {
780             return $_[0]->truncate( to => 'month' )->add( months => 1 );
781             },
782             );
783              
784             The recurrence function will be passed a single parameter, a datetime
785             object. The parameter can be an object from class C<DateTime>, or from
786             one of the C<DateTime::Calendar::*> classes. The parameter can also
787             be a C<DateTime::Infinite::Future> or a C<DateTime::Infinite::Past>
788             object.
789              
790             The recurrence must return the I<next> event after that object. There
791             is no guarantee as to what the returned object will be set to, only
792             that it will be greater than the object passed to the recurrence.
793              
794             If there are no more datetimes after the given parameter, then the
795             recurrence function should return C<DateTime::Infinite::Future>.
796              
797             It is ok to modify the parameter C<$_[0]> inside the recurrence
798             function. There are no side-effects.
799              
800             For example, if you wanted a recurrence that generated datetimes in
801             increments of 30 seconds, it would look like this:
802              
803             sub every_30_seconds {
804             my $dt = shift;
805             if ( $dt->second < 30 ) {
806             return $dt->truncate( to => 'minute' )->add( seconds => 30 );
807             } else {
808             return $dt->truncate( to => 'minute' )->add( minutes => 1 );
809             }
810             }
811              
812             Note that this recurrence takes leap seconds into account. Consider
813             using C<truncate()> in this manner to avoid complicated arithmetic
814             problems!
815              
816             It is also possible to create a recurrence by specifying either or both
817             of 'next' and 'previous' callbacks.
818              
819             The callbacks can return C<DateTime::Infinite::Future> and
820             C<DateTime::Infinite::Past> objects, in order to define I<bounded
821             recurrences>. In this case, both 'next' and 'previous' callbacks must
822             be defined:
823              
824             # "monthly from $dt until forever"
825              
826             my $months = DateTime::Set->from_recurrence(
827             next => sub {
828             return $dt if $_[0] < $dt;
829             $_[0]->truncate( to => 'month' );
830             $_[0]->add( months => 1 );
831             return $_[0];
832             },
833             previous => sub {
834             my $param = $_[0]->clone;
835             $_[0]->truncate( to => 'month' );
836             $_[0]->subtract( months => 1 ) if $_[0] == $param;
837             return $_[0] if $_[0] >= $dt;
838             return DateTime::Infinite::Past->new;
839             },
840             );
841              
842             Bounded recurrences are easier to write using C<span> parameters. See above.
843              
844             See also C<DateTime::Event::Recurrence> and the other
845             C<DateTime::Event::*> factory modules for generating specialized
846             recurrences, such as sunrise and sunset times, and holidays.
847              
848             =item * empty_set
849              
850             Creates a new empty set.
851              
852             $set = DateTime::Set->empty_set;
853             print "empty set" unless defined $set->max;
854              
855             =item * is_empty_set
856              
857             Returns true is the set is empty; false otherwise.
858              
859             print "nothing" if $set->is_empty_set;
860              
861             =item * clone
862              
863             This object method returns a replica of the given object.
864              
865             C<clone> is useful if you want to apply a transformation to a set,
866             but you want to keep the previous value:
867              
868             $set2 = $set1->clone;
869             $set2->add_duration( year => 1 ); # $set1 is unaltered
870              
871             =item * add_duration( $duration )
872              
873             This method adds the specified duration to every element of the set.
874              
875             $dt_dur = new DateTime::Duration( year => 1 );
876             $set->add_duration( $dt_dur );
877              
878             The original set is modified. If you want to keep the old values use:
879              
880             $new_set = $set->clone->add_duration( $dt_dur );
881              
882             =item * add
883              
884             This method is syntactic sugar around the C<add_duration()> method.
885              
886             $meetings_2004 = $meetings_2003->clone->add( years => 1 );
887              
888             =item * subtract_duration( $duration_object )
889              
890             When given a C<DateTime::Duration> object, this method simply calls
891             C<invert()> on that object and passes that new duration to the
892             C<add_duration> method.
893              
894             =item * subtract( DateTime::Duration->new parameters )
895              
896             Like C<add()>, this is syntactic sugar for the C<subtract_duration()>
897             method.
898              
899             =item * set_time_zone( $tz )
900              
901             This method will attempt to apply the C<set_time_zone> method to every
902             datetime in the set.
903              
904             =item * set( locale => .. )
905              
906             This method can be used to change the C<locale> of a datetime set.
907              
908              
909             =item * start, min
910              
911             =item * end, max
912              
913             The first and last C<DateTime> in the set.
914              
915             These methods may return C<undef> if the set is empty.
916              
917             It is also possible that these methods
918             may return a C<DateTime::Infinite::Past> or C<DateTime::Infinite::Future> object.
919              
920             These methods return just a I<copy> of the actual value.
921             If you modify the result, the set will not be modified.
922              
923              
924             =item * span
925              
926             Returns the total span of the set, as a C<DateTime::Span> object.
927              
928             =item * iterator / next / previous
929              
930             These methods can be used to iterate over the datetimes in a set.
931              
932             $iter = $set1->iterator;
933             while ( $dt = $iter->next ) {
934             print $dt->ymd;
935             }
936              
937             # iterate backwards
938             $iter = $set1->iterator;
939             while ( $dt = $iter->previous ) {
940             print $dt->ymd;
941             }
942              
943             The boundaries of the iterator can be limited by passing it a C<span>
944             parameter. This should be a C<DateTime::Span> object which delimits
945             the iterator's boundaries. Optionally, instead of passing an object,
946             you can pass any parameters that would work for one of the
947             C<DateTime::Span> class's constructors, and an object will be created
948             for you.
949              
950             Obviously, if the span you specify is not restricted both at the start
951             and end, then your iterator may iterate forever, depending on the
952             nature of your set. User beware!
953              
954             The C<next()> or C<previous()> method will return C<undef> when there
955             are no more datetimes in the iterator.
956              
957             =item * as_list
958              
959             Returns the set elements as a list of C<DateTime> objects. Just as
960             with the C<iterator()> method, the C<as_list()> method can be limited
961             by a span.
962              
963             my @dt = $set->as_list( span => $span );
964              
965             Applying C<as_list()> to a large recurrence set is a very expensive
966             operation, both in CPU time and in the memory used. If you I<really>
967             need to extract elements from a large set, you can limit the set with
968             a shorter span:
969              
970             my @short_list = $large_set->as_list( span => $short_span );
971              
972             For I<infinite> sets, C<as_list()> will return C<undef>. Please note
973             that this is explicitly not an empty list, since an empty list is a
974             valid return value for empty sets!
975              
976             =item * count
977              
978             Returns a count of C<DateTime> objects in the set. Just as with the
979             C<iterator()> method, the C<count()> method can be limited by a span.
980              
981             defined( my $n = $set->count) or die "can't count";
982              
983             my $n = $set->count( span => $span );
984             die "can't count" unless defined $n;
985              
986             Applying C<count()> to a large recurrence set is a very expensive
987             operation, both in CPU time and in the memory used. If you I<really>
988             need to count elements from a large set, you can limit the set with a
989             shorter span:
990              
991             my $count = $large_set->count( span => $short_span );
992              
993             For I<infinite> sets, C<count()> will return C<undef>. Please note
994             that this is explicitly not a scalar zero, since a zero count is a
995             valid return value for empty sets!
996              
997             =item * union
998              
999             =item * intersection
1000              
1001             =item * complement
1002              
1003             These set operation methods can accept a C<DateTime> list, a
1004             C<DateTime::Set>, a C<DateTime::Span>, or a C<DateTime::SpanSet>
1005             object as an argument.
1006              
1007             $set = $set1->union( $set2 ); # like "OR", "insert", "both"
1008             $set = $set1->complement( $set2 ); # like "delete", "remove"
1009             $set = $set1->intersection( $set2 ); # like "AND", "while"
1010             $set = $set1->complement; # like "NOT", "negate", "invert"
1011              
1012             The C<union> of a C<DateTime::Set> with a C<DateTime::Span> or a
1013             C<DateTime::SpanSet> object returns a C<DateTime::SpanSet> object.
1014              
1015             If C<complement> is called without any arguments, then the result is a
1016             C<DateTime::SpanSet> object representing the spans between each of the
1017             set's elements. If complement is given an argument, then the return
1018             value is a C<DateTime::Set> object representing the I<set difference>
1019             between the sets.
1020              
1021             All other operations will always return a C<DateTime::Set>.
1022              
1023             =item * intersects
1024              
1025             =item * contains
1026              
1027             These set operations result in a boolean value.
1028              
1029             if ( $set1->intersects( $set2 ) ) { ... # like "touches", "interferes"
1030             if ( $set1->contains( $dt ) ) { ... # like "is-fully-inside"
1031              
1032             These methods can accept a C<DateTime> list, a C<DateTime::Set>, a
1033             C<DateTime::Span>, or a C<DateTime::SpanSet> object as an argument.
1034              
1035             intersects() returns 1 for true, and 0 for false. In a few cases
1036             the algorithm can't decide if the sets intersect at all, and
1037             intersects() will return C<undef>.
1038              
1039             =item * previous
1040              
1041             =item * next
1042              
1043             =item * current
1044              
1045             =item * closest
1046              
1047             my $dt = $set->next( $dt );
1048             my $dt = $set->previous( $dt );
1049             my $dt = $set->current( $dt );
1050             my $dt = $set->closest( $dt );
1051              
1052             These methods are used to find a set member relative to a given
1053             datetime.
1054              
1055             The C<current()> method returns C<$dt> if $dt is an event, otherwise
1056             it returns the previous event.
1057              
1058             The C<closest()> method returns C<$dt> if $dt is an event, otherwise
1059             it returns the closest event (previous or next).
1060              
1061             All of these methods may return C<undef> if there is no matching
1062             datetime in the set.
1063              
1064             These methods will try to set the returned value to the same time zone
1065             as the argument, unless the argument has a 'floating' time zone.
1066              
1067             =item * map ( sub { ... } )
1068              
1069             # example: remove the hour:minute:second information
1070             $set = $set2->map(
1071             sub {
1072             return $_->truncate( to => day );
1073             }
1074             );
1075              
1076             # example: postpone or antecipate events which
1077             # match datetimes within another set
1078             $set = $set2->map(
1079             sub {
1080             return $_->add( days => 1 ) while $holidays->contains( $_ );
1081             }
1082             );
1083              
1084             This method is the "set" version of Perl "map".
1085              
1086             It evaluates a subroutine for each element of the set (locally setting
1087             "$_" to each datetime) and returns the set composed of the results of
1088             each such evaluation.
1089              
1090             Like Perl "map", each element of the set may produce zero, one, or
1091             more elements in the returned value.
1092              
1093             Unlike Perl "map", changing "$_" does not change the original
1094             set. This means that calling map in void context has no effect.
1095              
1096             The callback subroutine may be called later in the program, due to
1097             lazy evaluation. So don't count on subroutine side-effects. For
1098             example, a C<print> inside the subroutine may happen later than you
1099             expect.
1100              
1101             The callback return value is expected to be within the span of the
1102             C<previous> and the C<next> element in the original set. This is a
1103             limitation of the backtracking algorithm used in the C<Set::Infinite>
1104             library.
1105              
1106             For example: given the set C<[ 2001, 2010, 2015 ]>, the callback
1107             result for the value C<2010> is expected to be within the span C<[
1108             2001 .. 2015 ]>.
1109              
1110             =item * grep ( sub { ... } )
1111              
1112             # example: filter out any sundays
1113             $set = $set2->grep(
1114             sub {
1115             return ( $_->day_of_week != 7 );
1116             }
1117             );
1118              
1119             This method is the "set" version of Perl "grep".
1120              
1121             It evaluates a subroutine for each element of the set (locally setting
1122             "$_" to each datetime) and returns the set consisting of those
1123             elements for which the expression evaluated to true.
1124              
1125             Unlike Perl "grep", changing "$_" does not change the original
1126             set. This means that calling grep in void context has no effect.
1127              
1128             Changing "$_" does change the resulting set.
1129              
1130             The callback subroutine may be called later in the program, due to
1131             lazy evaluation. So don't count on subroutine side-effects. For
1132             example, a C<print> inside the subroutine may happen later than you
1133             expect.
1134              
1135             =item * iterate ( sub { ... } )
1136              
1137             I<deprecated method - please use "map" or "grep" instead.>
1138              
1139             =back
1140              
1141             =head1 SUPPORT
1142              
1143             Support is offered through the C<datetime@perl.org> mailing list.
1144              
1145             Please report bugs using rt.cpan.org
1146              
1147             =head1 AUTHOR
1148              
1149             Flavio Soibelmann Glock <fglock@gmail.com>
1150              
1151             The API was developed together with Dave Rolsky and the DateTime
1152             Community.
1153              
1154             =head1 COPYRIGHT
1155              
1156             Copyright (c) 2003-2006 Flavio Soibelmann Glock. All rights reserved.
1157             This program is free software; you can distribute it and/or modify it
1158             under the same terms as Perl itself.
1159              
1160             The full text of the license can be found in the LICENSE file included
1161             with this module.
1162              
1163             =head1 SEE ALSO
1164              
1165             Set::Infinite
1166              
1167             For details on the Perl DateTime Suite project please see
1168             L<http://datetime.perl.org>.
1169              
1170             =cut
1171