1 # Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
2 # This program is free software; you can redistribute it and/or
3 # modify it under the same terms as Perl itself.
5 package DateTime::SpanSet;
10 use DateTime::Infinite;
13 use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );
14 use vars qw( $VERSION );
16 use constant INFINITY => 100 ** 100 ** 100 ;
17 use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);
18 $VERSION = $DateTime::Set::VERSION;
21 my ( $self, $callback ) = @_;
22 my $class = ref( $self );
23 my $return = $class->empty_set;
24 $return->{set} = $self->{set}->iterate(
26 my $span = bless { set => $_[0] }, 'DateTime::Span';
27 $callback->( $span->clone );
29 if UNIVERSAL::can( $span, 'union' );
37 my ( $self, $callback ) = @_;
38 my $class = ref( $self );
39 die "The callback parameter to map() must be a subroutine reference"
40 unless ref( $callback ) eq 'CODE';
41 my $return = $class->empty_set;
42 $return->{set} = $self->{set}->iterate(
44 local $_ = bless { set => $_[0]->clone }, 'DateTime::Span';
45 my @list = $callback->();
46 my $set = $class->empty_set;
47 $set = $set->union( $_ ) for @list;
55 my ( $self, $callback ) = @_;
56 my $class = ref( $self );
57 die "The callback parameter to grep() must be a subroutine reference"
58 unless ref( $callback ) eq 'CODE';
59 my $return = $class->empty_set;
60 $return->{set} = $self->{set}->iterate(
62 local $_ = bless { set => $_[0]->clone }, 'DateTime::Span';
63 my $result = $callback->();
72 my ( $self, $tz ) = @_;
74 # TODO - use iterate() instead
76 my $result = $self->{set}->iterate(
78 my %tmp = %{ $_[0]->{list}[0] };
79 $tmp{a} = $tmp{a}->clone->set_time_zone( $tz ) if ref $tmp{a};
80 $tmp{b} = $tmp{b}->clone->set_time_zone( $tz ) if ref $tmp{b};
83 backtrack_callback => sub {
84 my ( $min, $max ) = ( $_[0]->min, $_[0]->max );
88 $min->set_time_zone( 'floating' );
93 $max->set_time_zone( 'floating' );
95 return Set::Infinite::_recurrence->new( $min, $max );
99 ### this code enables 'subroutine method' behaviour
100 $self->{set} = $result;
106 my %args = validate( @_,
114 my $set = Set::Infinite::_recurrence->new();
115 $set = $set->union( $_->{set} ) for @{ $args{spans} };
121 sub from_set_and_duration {
122 # set => $dt_set, days => 1
125 my $set = delete $args{set} ||
126 carp "from_set_and_duration needs a 'set' parameter";
129 if UNIVERSAL::can( $set, 'as_set' );
130 unless ( UNIVERSAL::can( $set, 'union' ) ) {
131 carp "'set' must be a set" };
133 my $duration = delete $args{duration} ||
134 new DateTime::Duration( %args );
135 my $end_set = $set->clone->add_duration( $duration );
136 return $class->from_sets( start_set => $set,
137 end_set => $end_set );
142 my %args = validate( @_,
153 my $start_set = delete $args{start_set};
154 my $end_set = delete $args{end_set};
156 $start_set = $start_set->as_set
157 if UNIVERSAL::can( $start_set, 'as_set' );
158 $end_set = $end_set->as_set
159 if UNIVERSAL::can( $end_set, 'as_set' );
161 unless ( UNIVERSAL::can( $start_set, 'union' ) ) {
162 carp "'start_set' must be a set" };
163 unless ( UNIVERSAL::can( $end_set, 'union' ) ) {
164 carp "'end_set' must be a set" };
167 $self->{set} = $start_set->{set}->until(
174 if ( exists $_[0]->{set}{method} &&
175 $_[0]->{set}{method} eq 'until' )
177 return bless { set => $_[0]->{set}{parent}[0] }, 'DateTime::Set';
179 my $return = DateTime::Set->empty_set;
180 $return->{set} = $_[0]->{set}->start_set;
185 if ( exists $_[0]->{set}{method} &&
186 $_[0]->{set}{method} eq 'until' )
188 return bless { set => $_[0]->{set}{parent}[1] }, 'DateTime::Set';
190 my $return = DateTime::Set->empty_set;
191 $return->{set} = $_[0]->{set}->end_set;
198 return bless { set => Set::Infinite::_recurrence->new }, $class;
203 set => $_[0]->{set}->copy,
213 $span = delete $args{span};
214 $span = DateTime::Span->new( %args ) if %args;
216 return $self->intersection( $span ) if $span;
221 # next() gets the next element from an iterator()
225 # TODO: this is fixing an error from elsewhere
226 # - find out what's going on! (with "sunset.pl")
227 return undef unless ref $self->{set};
232 $max = $_[0]->max if UNIVERSAL::can( $_[0], 'union' );
233 $max = $_[0] if ! defined $max;
235 return undef if ! ref( $max ) && $max == INFINITY;
237 my $span = DateTime::Span->from_datetimes( start => $max );
238 my $iterator = $self->intersection( $span );
239 my $return = $iterator->next;
241 return $return if ! defined $return;
242 return $return if ! $return->intersects( $max );
244 return $iterator->next;
247 my ($head, $tail) = $self->{set}->first;
248 $self->{set} = $tail;
249 return $head unless ref $head;
253 bless $return, 'DateTime::Span';
257 # previous() gets the last element from an iterator()
261 return undef unless ref $self->{set};
266 $min = $_[0]->min if UNIVERSAL::can( $_[0], 'union' );
267 $min = $_[0] if ! defined $min;
269 return undef if ! ref( $min ) && $min == INFINITY;
271 my $span = DateTime::Span->from_datetimes( end => $min );
272 my $iterator = $self->intersection( $span );
273 my $return = $iterator->previous;
275 return $return if ! defined $return;
276 return $return if ! $return->intersects( $min );
278 return $iterator->previous;
281 my ($head, $tail) = $self->{set}->last;
282 $self->{set} = $tail;
283 return $head unless ref $head;
287 bless $return, 'DateTime::Span';
291 # "current" means less-or-equal to a DateTime
299 $min = $_[0]->min if UNIVERSAL::can( $_[0], 'union' );
300 $min = $_[0] if ! defined $min;
301 return undef if ! ref( $min ) && $min == INFINITY;
302 my $span = DateTime::Span->from_datetimes( end => $min );
303 my $iterator = $self->intersection( $span );
304 $previous = $iterator->previous;
305 $span = DateTime::Span->from_datetimes( start => $min );
306 $iterator = $self->intersection( $span );
307 $next = $iterator->next;
309 return $previous unless defined $next;
311 my $dt1 = defined $previous
312 ? $next->union( $previous )
315 my $return = $dt1->intersected_spans( $_[0] );
318 if !defined $return->max;
320 bless $return, 'DateTime::SpanSet'
329 my $dt1 = $self->current( $dt );
330 my $dt2 = $self->next( $dt );
331 bless $dt2, 'DateTime::SpanSet'
334 return $dt2 unless defined $dt1;
335 return $dt1 unless defined $dt2;
337 $dt = DateTime::Set->from_datetimes( dates => [ $dt ] )
338 unless UNIVERSAL::can( $dt, 'union' );
340 return $dt1 if $dt1->contains( $dt );
342 my $delta = $dt->min - $dt1->max;
343 return $dt1 if ( $dt2->min - $delta ) >= $dt->max;
350 return undef unless ref( $self->{set} );
354 $span = delete $args{span};
355 $span = DateTime::Span->new( %args ) if %args;
357 my $set = $self->clone;
358 $set = $set->intersection( $span ) if $span;
360 # Note: removing this line means we may end up in an infinite loop!
361 return undef if $set->{set}->is_too_complex; # undef = no begin/end
363 # return if $set->{set}->is_null; # nothing = empty
365 # we should extract _copies_ of the set elements,
366 # such that the user can't modify the set indirectly
368 my $iter = $set->iterator;
369 while ( my $dt = $iter->next )
372 if ref( $dt ); # we don't want to return INFINITY value
378 # Set::Infinite methods
381 my ($set1, $set2) = ( shift, shift );
382 my $class = ref($set1);
383 my $tmp = $class->empty_set();
384 $set2 = $set2->as_spanset
385 if $set2->can( 'as_spanset' );
386 $set2 = $set2->as_set
387 if $set2->can( 'as_set' );
388 $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
389 unless $set2->can( 'union' );
390 $tmp->{set} = $set1->{set}->intersection( $set2->{set} );
394 sub intersected_spans {
395 my ($set1, $set2) = ( shift, shift );
396 my $class = ref($set1);
397 my $tmp = $class->empty_set();
398 $set2 = $set2->as_spanset
399 if $set2->can( 'as_spanset' );
400 $set2 = $set2->as_set
401 if $set2->can( 'as_set' );
402 $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
403 unless $set2->can( 'union' );
404 $tmp->{set} = $set1->{set}->intersected_spans( $set2->{set} );
409 my ($set1, $set2) = ( shift, shift );
411 unless ( $set2->can( 'union' ) )
415 return 1 if $set1->contains( $_ );
420 my $class = ref($set1);
421 $set2 = $set2->as_spanset
422 if $set2->can( 'as_spanset' );
423 $set2 = $set2->as_set
424 if $set2->can( 'as_set' );
425 $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
426 unless $set2->can( 'union' );
427 return $set1->{set}->intersects( $set2->{set} );
431 my ($set1, $set2) = ( shift, shift );
433 unless ( $set2->can( 'union' ) )
435 if ( exists $set1->{set}{method} &&
436 $set1->{set}{method} eq 'until' )
438 my $start_set = $set1->start_set;
439 my $end_set = $set1->end_set;
443 my $start = $start_set->next( $set2 );
444 my $end = $end_set->next( $set2 );
446 goto ABORT unless defined $start && defined $end;
448 return 0 if $start < $end;
457 my $class = ref($set1);
458 $set2 = $set2->as_spanset
459 if $set2->can( 'as_spanset' );
460 $set2 = $set2->as_set
461 if $set2->can( 'as_set' );
462 $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
463 unless $set2->can( 'union' );
464 return $set1->{set}->contains( $set2->{set} );
468 my ($set1, $set2) = ( shift, shift );
469 my $class = ref($set1);
470 my $tmp = $class->empty_set();
471 $set2 = $set2->as_spanset
472 if $set2->can( 'as_spanset' );
473 $set2 = $set2->as_set
474 if $set2->can( 'as_set' );
475 $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
476 unless $set2->can( 'union' );
477 $tmp->{set} = $set1->{set}->union( $set2->{set} );
482 my ($set1, $set2) = ( shift, shift );
483 my $class = ref($set1);
484 my $tmp = $class->empty_set();
486 $set2 = $set2->as_spanset
487 if $set2->can( 'as_spanset' );
488 $set2 = $set2->as_set
489 if $set2->can( 'as_set' );
490 $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
491 unless $set2->can( 'union' );
492 $tmp->{set} = $set1->{set}->complement( $set2->{set} );
495 $tmp->{set} = $set1->{set}->complement;
501 return DateTime::Set::_fix_datetime( $_[0]->{set}->min );
505 return DateTime::Set::_fix_datetime( $_[0]->{set}->max );
508 # returns a DateTime::Span
510 my $set = $_[0]->{set}->span;
511 my $self = bless { set => $set }, 'DateTime::Span';
515 # returns a DateTime::Duration
519 return DateTime::Duration->new( seconds => 0 )
520 if $_[0]->{set}->is_empty;
524 local $SIG{__DIE__}; # don't want to trap this (rt ticket 5434)
525 $dur = $_[0]->{set}->size
528 return $dur if defined $dur && ref( $dur );
529 return DateTime::Infinite::Future->new -
530 DateTime::Infinite::Past->new;
541 DateTime::SpanSet - set of DateTime spans
545 $spanset = DateTime::SpanSet->from_spans( spans => [ $dt_span, $dt_span ] );
547 $set = $spanset->union( $set2 ); # like "OR", "insert", "both"
548 $set = $spanset->complement( $set2 ); # like "delete", "remove"
549 $set = $spanset->intersection( $set2 ); # like "AND", "while"
550 $set = $spanset->complement; # like "NOT", "negate", "invert"
552 if ( $spanset->intersects( $set2 ) ) { ... # like "touches", "interferes"
553 if ( $spanset->contains( $set2 ) ) { ... # like "is-fully-inside"
556 $date = $spanset->min; # first date of the set
557 $date = $spanset->max; # last date of the set
559 $iter = $spanset->iterator;
560 while ( $dt = $iter->next ) {
561 # $dt is a DateTime::Span
562 print $dt->start->ymd; # first date of span
563 print $dt->end->ymd; # last date of span
568 C<DateTime::SpanSet> is a class that represents sets of datetime
569 spans. An example would be a recurring meeting that occurs from
570 13:00-15:00 every Friday.
572 This is different from a C<DateTime::Set>, which is made of individual
573 datetime points as opposed to ranges.
581 Creates a new span set from one or more C<DateTime::Span> objects.
583 $spanset = DateTime::SpanSet->from_spans( spans => [ $dt_span ] );
585 =item * from_set_and_duration
587 Creates a new span set from one or more C<DateTime::Set> objects and a
590 The duration can be a C<DateTime::Duration> object, or the parameters
591 to create a new C<DateTime::Duration> object, such as "days",
595 DateTime::SpanSet->from_set_and_duration
596 ( set => $dt_set, days => 1 );
600 Creates a new span set from two C<DateTime::Set> objects.
602 One set defines the I<starting dates>, and the other defines the I<end
606 DateTime::SpanSet->from_sets
607 ( start_set => $dt_set1, end_set => $dt_set2 );
609 The spans have the starting date C<closed>, and the end date C<open>,
610 like in C<[$dt1, $dt2)>.
612 If an end date comes without a starting date before it, then it
613 defines a span like C<(-inf, $dt)>.
615 If a starting date comes without an end date after it, then it defines
616 a span like C<[$dt, inf)>.
620 Creates a new empty set.
624 This object method returns a replica of the given object.
626 =item * set_time_zone( $tz )
628 This method accepts either a time zone object or a string that can be
629 passed as the "name" parameter to C<< DateTime::TimeZone->new() >>.
630 If the new time zone's offset is different from the old time zone,
631 then the I<local> time is adjusted accordingly.
633 If the old time zone was a floating time zone, then no adjustments to
634 the local time are made, except to account for leap seconds. If the
635 new time zone is floating, then the I<UTC> time is adjusted in order
636 to leave the local time untouched.
642 First or last dates in the set. These methods may return C<undef> if
643 the set is empty. It is also possible that these methods may return a
644 scalar containing infinity or negative infinity.
648 The total size of the set, as a C<DateTime::Duration> object.
650 The duration may be infinite.
652 Also available as C<size()>.
656 The total span of the set, as a C<DateTime::Span> object.
660 my $span = $set->next( $dt );
662 This method is used to find the next span in the set,
663 after a given datetime or span.
665 The return value is a C<DateTime::Span>, or C<undef> if there is no matching
670 my $span = $set->previous( $dt );
672 This method is used to find the previous span in the set,
673 before a given datetime or span.
675 The return value is a C<DateTime::Span>, or C<undef> if there is no matching
681 my $span = $set->current( $dt );
683 This method is used to find the "current" span in the set,
684 that intersects a given datetime or span. If no current span
685 is found, then the "previous" span is returned.
687 The return value is a C<DateTime::SpanSet>, or C<undef> if there is no
688 matching span in the set.
690 If a span parameter is given, it may happen that "current" returns
693 See also: C<intersected_spans()> method.
697 my $span = $set->closest( $dt );
699 This method is used to find the "closest" span in the set, given a
702 The return value is a C<DateTime::SpanSet>, or C<undef> if the set is
705 If a span parameter is given, it may happen that "closest" returns
710 Returns a list of C<DateTime::Span> objects.
712 my @dt_span = $set->as_list( span => $span );
714 Just as with the C<iterator()> method, the C<as_list()> method can be
717 Applying C<as_list()> to a large recurring spanset is a very expensive
718 operation, both in CPU time and in the memory used.
720 For this reason, when C<as_list()> operates on large recurrence sets,
721 it will return at most approximately 200 spans. For larger sets, and
722 for I<infinite> sets, C<as_list()> will return C<undef>.
724 Please note that this is explicitly not an empty list, since an empty
725 list is a valid return value for empty sets!
727 If you I<really> need to extract spans from a large set, you can:
729 - limit the set with a shorter span:
731 my @short_list = $large_set->as_list( span => $short_span );
736 my $iter = $large_set->iterator;
737 push @large_list, $dt while $dt = $iter->next;
745 Set operations may be performed not only with C<DateTime::SpanSet>
746 objects, but also with C<DateTime>, C<DateTime::Set> and
747 C<DateTime::Span> objects. These set operations always return a
748 C<DateTime::SpanSet> object.
750 $set = $spanset->union( $set2 ); # like "OR", "insert", "both"
751 $set = $spanset->complement( $set2 ); # like "delete", "remove"
752 $set = $spanset->intersection( $set2 ); # like "AND", "while"
753 $set = $spanset->complement; # like "NOT", "negate", "invert"
755 =item * intersected_spans
757 This method can accept a C<DateTime> list, a C<DateTime::Set>, a
758 C<DateTime::Span>, or a C<DateTime::SpanSet> object as an argument.
760 $set = $set1->intersected_spans( $set2 );
762 The method always returns a C<DateTime::SpanSet> object, containing
763 all spans that are intersected by the given set.
765 Unlike the C<intersection> method, the spans are not modified. See
768 set1 [....] [....] [....] [....]
769 set2 [................]
771 intersection [.] [....] [.]
773 intersected_spans [....] [....] [....]
779 These set functions return a boolean value.
781 if ( $spanset->intersects( $set2 ) ) { ... # like "touches", "interferes"
782 if ( $spanset->contains( $dt ) ) { ... # like "is-fully-inside"
784 These methods can accept a C<DateTime>, C<DateTime::Set>,
785 C<DateTime::Span>, or C<DateTime::SpanSet> object as an argument.
787 =item * iterator / next / previous
789 This method can be used to iterate over the spans in a set.
791 $iter = $spanset->iterator;
792 while ( $dt = $iter->next ) {
793 # $dt is a DateTime::Span
794 print $dt->min->ymd; # first date of span
795 print $dt->max->ymd; # last date of span
798 The boundaries of the iterator can be limited by passing it a C<span>
799 parameter. This should be a C<DateTime::Span> object which delimits
800 the iterator's boundaries. Optionally, instead of passing an object,
801 you can pass any parameters that would work for one of the
802 C<DateTime::Span> class's constructors, and an object will be created
805 Obviously, if the span you specify does is not restricted both at the
806 start and end, then your iterator may iterate forever, depending on
807 the nature of your set. User beware!
809 The C<next()> or C<previous()> methods will return C<undef> when there
810 are no more spans in the iterator.
816 These methods do the inverse of the C<from_sets> method:
818 C<start_set> retrieves a DateTime::Set with the start datetime of each
821 C<end_set> retrieves a DateTime::Set with the end datetime of each
824 =item * map ( sub { ... } )
826 # example: enlarge the spans
829 my $start = $_->start;
831 return DateTime::Span->from_datetimes(
838 This method is the "set" version of Perl "map".
840 It evaluates a subroutine for each element of the set (locally setting
841 "$_" to each DateTime::Span) and returns the set composed of the
842 results of each such evaluation.
844 Like Perl "map", each element of the set may produce zero, one, or
845 more elements in the returned value.
847 Unlike Perl "map", changing "$_" does not change the original
848 set. This means that calling map in void context has no effect.
850 The callback subroutine may not be called immediately. Don't count on
851 subroutine side-effects. For example, a C<print> inside the subroutine
852 may happen later than you expect.
854 The callback return value is expected to be within the span of the
855 C<previous> and the C<next> element in the original set.
857 For example: given the set C<[ 2001, 2010, 2015 ]>, the callback
858 result for the value C<2010> is expected to be within the span C<[
861 =item * grep ( sub { ... } )
863 # example: filter out all spans happening today
864 my $today = DateTime->today;
867 return ( ! $_->contains( $today ) );
871 This method is the "set" version of Perl "grep".
873 It evaluates a subroutine for each element of the set (locally setting
874 "$_" to each DateTime::Span) and returns the set consisting of those
875 elements for which the expression evaluated to true.
877 Unlike Perl "grep", changing "$_" does not change the original
878 set. This means that calling grep in void context has no effect.
880 Changing "$_" does change the resulting set.
882 The callback subroutine may not be called immediately. Don't count on
883 subroutine side-effects. For example, a C<print> inside the subroutine
884 may happen later than you expect.
888 I<Internal method - use "map" or "grep" instead.>
890 This function apply a callback subroutine to all elements of a set and
891 returns the resulting set.
893 The parameter C<$_[0]> to the callback subroutine is a
894 C<DateTime::Span> object.
896 If the callback returns C<undef>, the datetime is removed from the
900 $_[0] unless $_[0]->start->day_of_week == 7;
903 The callback return value is expected to be within the span of the
904 C<previous> and the C<next> element in the original set.
906 For example: given the set C<[ 2001, 2010, 2015 ]>, the callback
907 result for the value C<2010> is expected to be within the span C<[
910 The callback subroutine may not be called immediately. Don't count on
911 subroutine side-effects. For example, a C<print> inside the subroutine
912 may happen later than you expect.
918 Support is offered through the C<datetime@perl.org> mailing list.
920 Please report bugs using rt.cpan.org
924 Flavio Soibelmann Glock <fglock@pucrs.br>
926 The API was developed together with Dave Rolsky and the DateTime Community.
930 Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
931 This program is free software; you can distribute it and/or
932 modify it under the same terms as Perl itself.
934 The full text of the license can be found in the LICENSE file
935 included with this module.
941 For details on the Perl DateTime Suite project please see
942 L<http://datetime.perl.org>.