File Coverage

blib/lib/DateTime/Span.pm
Criterion Covered Total %
statement 114 143 79.7
branch 41 76 53.9
condition 7 12 58.3
subroutine 21 27 77.7
pod 16 19 84.2
total 199 277 71.8


line stmt bran cond sub pod time code
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.
4              
5             package DateTime::Span;
6              
7 23     23   90 use strict;
  23         25  
  23         519  
8              
9 23     23   68 use DateTime::Set;
  23         20  
  23         425  
10 23     23   7558 use DateTime::SpanSet;
  23         50  
  23         570  
11              
12 23     23   103 use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );
  23         20  
  23         1142  
13 23     23   84 use vars qw( $VERSION );
  23         27  
  23         767  
14              
15 23     23   75 use constant INFINITY => DateTime::INFINITY;
  23         22  
  23         1028  
16 23     23   75 use constant NEG_INFINITY => DateTime::NEG_INFINITY;
  23         18  
  23         27990  
17             $VERSION = $DateTime::Set::VERSION;
18              
19             sub set_time_zone {
20 2     2 1 39 my ( $self, $tz ) = @_;
21              
22             $self->{set} = $self->{set}->iterate(
23             sub {
24 2     2   71 my %tmp = %{ $_[0]->{list}[0] };
  2         9  
25 2 50       12 $tmp{a} = $tmp{a}->clone->set_time_zone( $tz ) if ref $tmp{a};
26 2 50       2977 $tmp{b} = $tmp{b}->clone->set_time_zone( $tz ) if ref $tmp{b};
27 2         428 \%tmp;
28             }
29 2         55 );
30 2         89 return $self;
31             }
32              
33             # note: the constructor must clone its DateTime parameters, such that
34             # the set elements become immutable
35             sub from_datetimes {
36 115     115 1 8160 my $class = shift;
37 115         2188 my %args = validate( @_,
38             { start =>
39             { type => OBJECT,
40             optional => 1,
41             },
42             end =>
43             { type => OBJECT,
44             optional => 1,
45             },
46             after =>
47             { type => OBJECT,
48             optional => 1,
49             },
50             before =>
51             { type => OBJECT,
52             optional => 1,
53             },
54             }
55             );
56 115         419 my $self = {};
57 115         101 my $set;
58              
59 115 50       280 die "No arguments given to DateTime::Span->from_datetimes\n"
60             unless keys %args;
61              
62 115 50 66     292 if ( exists $args{start} && exists $args{after} ) {
63 0         0 die "Cannot give both start and after arguments to DateTime::Span->from_datetimes\n";
64             }
65 115 50 66     246 if ( exists $args{end} && exists $args{before} ) {
66 0         0 die "Cannot give both end and before arguments to DateTime::Span->from_datetimes\n";
67             }
68              
69 115         100 my ( $start, $open_start, $end, $open_end );
70 115         157 ( $start, $open_start ) = ( NEG_INFINITY, 0 );
71 115 100       232 ( $start, $open_start ) = ( $args{start}, 0 ) if exists $args{start};
72 115 100       200 ( $start, $open_start ) = ( $args{after}, 1 ) if exists $args{after};
73 115         141 ( $end, $open_end ) = ( INFINITY, 0 );
74 115 100       208 ( $end, $open_end ) = ( $args{end}, 0 ) if exists $args{end};
75 115 100       194 ( $end, $open_end ) = ( $args{before}, 1 ) if exists $args{before};
76              
77 115 50       514 if ( $start > $end ) {
78 0         0 die "Span cannot start after the end in DateTime::Span->from_datetimes\n";
79             }
80 115         2557 $set = Set::Infinite::_recurrence->new( $start, $end );
81 115 100       4442 if ( $start != $end ) {
82             # remove start, such that we have ">" instead of ">="
83 105 100       1709 $set = $set->complement( $start ) if $open_start;
84             # remove end, such that we have "<" instead of "<="
85 105 100       6716 $set = $set->complement( $end ) if $open_end;
86             }
87              
88 115         3625 $self->{set} = $set;
89 115         123 bless $self, $class;
90 115         377 return $self;
91             }
92              
93             sub from_datetime_and_duration {
94 3     3 1 1320 my $class = shift;
95 3         6 my %args = @_;
96              
97 3         3 my $key;
98             my $dt;
99             # extract datetime parameters
100 3         5 for ( qw( start end before after ) ) {
101 12 100       23 if ( exists $args{$_} ) {
102 3         3 $key = $_;
103 3         4 $dt = delete $args{$_};
104             }
105             }
106              
107             # extract duration parameters
108 3         2 my $dt_duration;
109 3 50       5 if ( exists $args{duration} ) {
110 0         0 $dt_duration = $args{duration};
111             }
112             else {
113 3         12 $dt_duration = DateTime::Duration->new( %args );
114             }
115             # warn "Creating span from $key => ".$dt->datetime." and $dt_duration";
116 3         150 my $other_date;
117             my $other_key;
118 3 100       8 if ( $dt_duration->is_positive ) {
119 2 100 66     40 if ( $key eq 'end' || $key eq 'before' ) {
120 1         1 $other_key = 'start';
121 1         3 $other_date = $dt->clone->subtract_duration( $dt_duration );
122             }
123             else {
124 1         2 $other_key = 'before';
125 1         4 $other_date = $dt->clone->add_duration( $dt_duration );
126             }
127             }
128             else {
129 1 50 33     12 if ( $key eq 'end' || $key eq 'before' ) {
130 1         2 $other_key = 'start';
131 1         2 $other_date = $dt->clone->add_duration( $dt_duration );
132             }
133             else {
134 0         0 $other_key = 'before';
135 0         0 $other_date = $dt->clone->subtract_duration( $dt_duration );
136             }
137             }
138             # warn "Creating span from $key => ".$dt->datetime." and ".$other_date->datetime;
139 3         1103 return $class->new( $key => $dt, $other_key => $other_date );
140             }
141              
142             # This method is intentionally not documented. It's really only for
143             # use by ::Set and ::SpanSet's as_list() and iterator() methods.
144             sub new {
145 32     32 0 1289 my $class = shift;
146 32         62 my %args = @_;
147              
148             # If we find anything _not_ appropriate for from_datetimes, we
149             # assume it must be for durations, and call this constructor.
150             # This way, we don't need to hardcode the DateTime::Duration
151             # parameters.
152 32         73 foreach ( keys %args )
153             {
154 43 50       212 return $class->from_datetime_and_duration(%args)
155             unless /^(?:before|after|start|end)$/;
156             }
157              
158 32         101 return $class->from_datetimes(%args);
159             }
160              
161             sub is_empty_set {
162 0     0 0 0 my $set = $_[0];
163 0         0 $set->{set}->is_null;
164             }
165              
166             sub clone {
167             bless {
168             set => $_[0]->{set}->copy,
169 1     1 1 20 }, ref $_[0];
170             }
171              
172             # Set::Infinite methods
173              
174             sub intersection {
175 3     3 1 14 my ($set1, $set2) = @_;
176 3         5 my $class = ref($set1);
177 3         3 my $tmp = {}; # $class->new();
178 3 50       19 $set2 = $set2->as_spanset
179             if $set2->can( 'as_spanset' );
180 3 50       14 $set2 = $set2->as_set
181             if $set2->can( 'as_set' );
182 3 50       15 $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
183             unless $set2->can( 'union' );
184 3         13 $tmp->{set} = $set1->{set}->intersection( $set2->{set} );
185              
186             # intersection() can generate something more complex than a span.
187 3         6115 bless $tmp, 'DateTime::SpanSet';
188              
189 3         12 return $tmp;
190             }
191              
192             sub intersects {
193 9     9 1 8 my ($set1, $set2) = @_;
194 9         11 my $class = ref($set1);
195 9 50       21 $set2 = $set2->as_spanset
196             if $set2->can( 'as_spanset' );
197 9 50       20 $set2 = $set2->as_set
198             if $set2->can( 'as_set' );
199 9 50       39 $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
200             unless $set2->can( 'union' );
201 9         23 return $set1->{set}->intersects( $set2->{set} );
202             }
203              
204             sub contains {
205 1     1 1 4 my ($set1, $set2) = @_;
206 1         1 my $class = ref($set1);
207 1 50       6 $set2 = $set2->as_spanset
208             if $set2->can( 'as_spanset' );
209 1 50       4 $set2 = $set2->as_set
210             if $set2->can( 'as_set' );
211 1 50       15 $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
212             unless $set2->can( 'union' );
213 1         6 return $set1->{set}->contains( $set2->{set} );
214             }
215              
216             sub union {
217 5     5 1 7 my ($set1, $set2) = @_;
218 5         6 my $class = ref($set1);
219 5         7 my $tmp = {}; # $class->new();
220 5 50       16 $set2 = $set2->as_spanset
221             if $set2->can( 'as_spanset' );
222 5 50       39 $set2 = $set2->as_set
223             if $set2->can( 'as_set' );
224 5 50       12 $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
225             unless $set2->can( 'union' );
226 5         13 $tmp->{set} = $set1->{set}->union( $set2->{set} );
227            
228             # union() can generate something more complex than a span.
229 5         945 bless $tmp, 'DateTime::SpanSet';
230              
231             # # We have to check it's internal structure to find out.
232             # if ( $#{ $tmp->{set}->{list} } != 0 ) {
233             # bless $tmp, 'Date::SpanSet';
234             # }
235              
236 5         9 return $tmp;
237             }
238              
239             sub complement {
240 0     0 1 0 my ($set1, $set2) = @_;
241 0         0 my $class = ref($set1);
242 0         0 my $tmp = {}; # $class->new;
243 0 0       0 if (defined $set2) {
244 0 0       0 $set2 = $set2->as_spanset
245             if $set2->can( 'as_spanset' );
246 0 0       0 $set2 = $set2->as_set
247             if $set2->can( 'as_set' );
248 0 0       0 $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
249             unless $set2->can( 'union' );
250 0         0 $tmp->{set} = $set1->{set}->complement( $set2->{set} );
251             }
252             else {
253 0         0 $tmp->{set} = $set1->{set}->complement;
254             }
255              
256             # complement() can generate something more complex than a span.
257 0         0 bless $tmp, 'DateTime::SpanSet';
258              
259             # # We have to check it's internal structure to find out.
260             # if ( $#{ $tmp->{set}->{list} } != 0 ) {
261             # bless $tmp, 'Date::SpanSet';
262             # }
263              
264 0         0 return $tmp;
265             }
266              
267             sub start {
268 53     53 1 1735 return DateTime::Set::_fix_datetime( $_[0]->{set}->min );
269             }
270              
271             *min = \&start;
272              
273             sub end {
274 53     53 1 3835 return DateTime::Set::_fix_datetime( $_[0]->{set}->max );
275             }
276              
277             *max = \&end;
278              
279             sub start_is_open {
280             # min_a returns info about the set boundary
281 3     3 1 10 my ($min, $open) = $_[0]->{set}->min_a;
282 3         19 return $open;
283             }
284              
285 0 0   0 1 0 sub start_is_closed { $_[0]->start_is_open ? 0 : 1 }
286              
287             sub end_is_open {
288             # max_a returns info about the set boundary
289 3     3 1 857 my ($max, $open) = $_[0]->{set}->max_a;
290 3         19 return $open;
291             }
292              
293 0 0   0 1   sub end_is_closed { $_[0]->end_is_open ? 0 : 1 }
294              
295              
296             # span == $self
297 0     0 0   sub span { @_ }
298              
299             sub duration {
300 0     0 1   my $dur;
301              
302 0           local $@;
303 0           eval {
304 0           local $SIG{__DIE__}; # don't want to trap this (rt ticket 5434)
305 0           $dur = $_[0]->end->subtract_datetime_absolute( $_[0]->start )
306             };
307            
308 0 0         return $dur if defined $dur;
309              
310 0           return DateTime::Infinite::Future->new -
311             DateTime::Infinite::Past->new;
312             }
313             *size = \&duration;
314              
315             1;
316              
317             __END__