Filename | /usr/share/perl5/Date/Manip/Recur.pm |
Statements | Executed 41 statements in 10.7ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 46µs | 66µs | _init | Date::Manip::Recur::
1 | 1 | 1 | 21µs | 21µs | BEGIN@14 | Date::Manip::Recur::
1 | 1 | 1 | 19µs | 306µs | BEGIN@20 | Date::Manip::Recur::
1 | 1 | 1 | 15µs | 25µs | BEGIN@22 | Date::Manip::Recur::
1 | 1 | 1 | 15µs | 77µs | BEGIN@17 | Date::Manip::Recur::
1 | 1 | 1 | 15µs | 56µs | BEGIN@25 | Date::Manip::Recur::
1 | 1 | 1 | 14µs | 35µs | BEGIN@18 | Date::Manip::Recur::
1 | 1 | 1 | 11µs | 20µs | BEGIN@21 | Date::Manip::Recur::
1 | 1 | 1 | 10µs | 19µs | BEGIN@19 | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | __rtime_values | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | _date | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | _easter | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | _field_add_values | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | _field_empty | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | _init_args | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | _int_values | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | _parse_lang | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | _rtime_values | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | _rx | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | base | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | dates | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | end | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | frequency | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | is_recur | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | modifiers | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | parse | Date::Manip::Recur::
0 | 0 | 0 | 0s | 0s | start | Date::Manip::Recur::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
0 | 1 | 77µs | Profile data that couldn't be associated with a specific line: # spent 77µs making 1 call to Date::Manip::Recur::BEGIN@17 | ||
1 | 1 | 16µs | package Date::Manip::Recur; | ||
2 | # Copyright (c) 1998-2010 Sullivan Beck. All rights reserved. | ||||
3 | # This program is free software; you can redistribute it and/or modify | ||||
4 | # it under the same terms as Perl itself. | ||||
5 | |||||
6 | ######################################################################## | ||||
7 | # Any routine that starts with an underscore (_) is NOT intended for | ||||
8 | # public use. They are for internal use in the the Date::Manip | ||||
9 | # modules and are subject to change without warning or notice. | ||||
10 | # | ||||
11 | # ABSOLUTELY NO USER SUPPORT IS OFFERED FOR THESE ROUTINES! | ||||
12 | ######################################################################## | ||||
13 | |||||
14 | 3 | 70µs | 1 | 21µs | # spent 21µs within Date::Manip::Recur::BEGIN@14 which was called:
# once (21µs+0s) by Date::Manip::Obj::new_recur at line 14 # spent 21µs making 1 call to Date::Manip::Recur::BEGIN@14 |
15 | 1 | 21µs | @ISA = ('Date::Manip::Obj'); | ||
16 | |||||
17 | 4 | 86µs | 1 | 62µs | # spent 77µs (15+62) within Date::Manip::Recur::BEGIN@17 which was called:
# once (15µs+62µs) by Date::Manip::Obj::new_recur at line 0 # spent 62µs making 1 call to feature::import |
18 | 3 | 35µs | 2 | 57µs | # spent 35µs (14+21) within Date::Manip::Recur::BEGIN@18 which was called:
# once (14µs+21µs) by Date::Manip::Obj::new_recur at line 18 # spent 35µs making 1 call to Date::Manip::Recur::BEGIN@18
# spent 21µs making 1 call to warnings::import |
19 | 3 | 25µs | 2 | 27µs | # spent 19µs (10+8) within Date::Manip::Recur::BEGIN@19 which was called:
# once (10µs+8µs) by Date::Manip::Obj::new_recur at line 19 # spent 19µs making 1 call to Date::Manip::Recur::BEGIN@19
# spent 8µs making 1 call to strict::import |
20 | 3 | 46µs | 2 | 593µs | # spent 306µs (19+287) within Date::Manip::Recur::BEGIN@20 which was called:
# once (19µs+287µs) by Date::Manip::Obj::new_recur at line 20 # spent 306µs making 1 call to Date::Manip::Recur::BEGIN@20
# spent 287µs making 1 call to Exporter::import |
21 | 3 | 27µs | 2 | 29µs | # spent 20µs (11+9) within Date::Manip::Recur::BEGIN@21 which was called:
# once (11µs+9µs) by Date::Manip::Obj::new_recur at line 21 # spent 20µs making 1 call to Date::Manip::Recur::BEGIN@21
# spent 9µs making 1 call to feature::import |
22 | 3 | 38µs | 2 | 35µs | # spent 25µs (15+10) within Date::Manip::Recur::BEGIN@22 which was called:
# once (15µs+10µs) by Date::Manip::Obj::new_recur at line 22 # spent 25µs making 1 call to Date::Manip::Recur::BEGIN@22
# spent 10µs making 1 call to integer::import |
23 | #use re 'debug'; | ||||
24 | |||||
25 | 3 | 10.3ms | 2 | 97µs | # spent 56µs (15+41) within Date::Manip::Recur::BEGIN@25 which was called:
# once (15µs+41µs) by Date::Manip::Obj::new_recur at line 25 # spent 56µs making 1 call to Date::Manip::Recur::BEGIN@25
# spent 41µs making 1 call to vars::import |
26 | 1 | 800ns | $VERSION='6.11'; | ||
27 | |||||
28 | ######################################################################## | ||||
29 | # BASE METHODS | ||||
30 | ######################################################################## | ||||
31 | |||||
32 | sub is_recur { | ||||
33 | return 1; | ||||
34 | } | ||||
35 | |||||
36 | # Call this every time a new recur is put in to make sure everything is | ||||
37 | # correctly initialized. | ||||
38 | # | ||||
39 | # spent 66µs (46+20) within Date::Manip::Recur::_init which was called:
# once (46µs+20µs) by Date::Manip::Obj::new at line 152 of Date/Manip/Obj.pm | ||||
40 | 10 | 33µs | my($self) = @_; | ||
41 | my $dmb = $$self{'objs'}{'base'}; | ||||
42 | |||||
43 | $$self{'err'} = ''; | ||||
44 | $$self{'data'}{'interval'} = []; # (Y, M, ...) | ||||
45 | $$self{'data'}{'rtime'} = []; # ( [ VAL_OR_RANGE, VAL_OR_RANGE, ... ], | ||||
46 | # [ VAL_OR_RANGE, VAL_OR_RANGE, ... ], | ||||
47 | # ... ) | ||||
48 | $$self{'data'}{'base'} = undef; | ||||
49 | |||||
50 | # Get the default start/end dates | ||||
51 | |||||
52 | 1 | 3µs | 1 | 20µs | given ($dmb->_config('recurrange')) { # spent 20µs making 1 call to Date::Manip::Base::_config |
53 | |||||
54 | 2 | 4µs | when ('none') { | ||
55 | $$self{'data'}{'start'} = undef; | ||||
56 | $$self{'data'}{'end'} = undef; | ||||
57 | } | ||||
58 | |||||
59 | when ('year') { | ||||
60 | my ($y) = $dmb->_now('y',1); | ||||
61 | my $start = $self->new_date(); | ||||
62 | my $end = $self->new_date(); | ||||
63 | $start->set('date',[$y, 1, 1,00,00,00]); | ||||
64 | $end->set ('date',[$y,12,31,23,59,59]); | ||||
65 | } | ||||
66 | |||||
67 | when ('month') { | ||||
68 | my ($y,$m) = $dmb->_now('now',1); | ||||
69 | my $dim = $dmb->days_in_month($y,$m); | ||||
70 | my $start = $self->new_date(); | ||||
71 | my $end = $self->new_date(); | ||||
72 | $start->set('date',[$y,$m, 1,00,00,00]); | ||||
73 | $end->set ('date',[$y,$m,$dim,23,59,59]); | ||||
74 | } | ||||
75 | |||||
76 | when ('week') { | ||||
77 | my($y,$m,$d) = $dmb->_now('now',1); | ||||
78 | my $w; | ||||
79 | ($y,$w) = $dmb->week_of_year([$y,$m,$d]); | ||||
80 | ($y,$m,$d) = @{ $dmb->week_of_year($y,$w) }; | ||||
81 | my($yy,$mm,$dd) | ||||
82 | = @{ $dmb->_calc_date_ymwd([$y,$m,$d], [0,0,0,6], 0) }; | ||||
83 | |||||
84 | my $start = $self->new_date(); | ||||
85 | my $end = $self->new_date(); | ||||
86 | $start->set('date',[$y, $m, $d, 00,00,00]); | ||||
87 | $end->set ('date',[$yy,$mm,$dd,23,59,59]); | ||||
88 | } | ||||
89 | |||||
90 | when ('day') { | ||||
91 | my($y,$m,$d) = $dmb->_now('now',1); | ||||
92 | my $start = $self->new_date(); | ||||
93 | my $end = $self->new_date(); | ||||
94 | $start->set('date',[$y,$m,$d,00,00,00]); | ||||
95 | $end->set ('date',[$y,$m,$d,23,59,59]); | ||||
96 | } | ||||
97 | |||||
98 | when ('all') { | ||||
99 | my $start = $self->new_date(); | ||||
100 | my $end = $self->new_date(); | ||||
101 | $start->set('date',[0001,02,01,00,00,00]); | ||||
102 | $end->set ('date',[9999,11,30,23,59,59]); | ||||
103 | } | ||||
104 | } | ||||
105 | |||||
106 | # Based on the modifiers, this is what we have to add to the | ||||
107 | # start/end time in order to get a range which will produce | ||||
108 | # modified dates guaranteed to fall within the start/end date | ||||
109 | # range. | ||||
110 | # | ||||
111 | # The rtime values can automatically change things by up to one | ||||
112 | # day. | ||||
113 | |||||
114 | $$self{'data'}{'flags'} = []; | ||||
115 | $$self{'data'}{'startm'} = [0,0,0,-1,0,0,0]; | ||||
116 | $$self{'data'}{'endm'} = [0,0,0, 1,0,0,0]; | ||||
117 | } | ||||
118 | |||||
119 | sub _init_args { | ||||
120 | my($self) = @_; | ||||
121 | |||||
122 | my @args = @{ $$self{'args'} }; | ||||
123 | if (@args) { | ||||
124 | $self->parse(@args); | ||||
125 | } | ||||
126 | } | ||||
127 | |||||
128 | ######################################################################## | ||||
129 | # METHODS | ||||
130 | ######################################################################## | ||||
131 | |||||
132 | sub parse { | ||||
133 | my($self,$string,@args) = @_; | ||||
134 | |||||
135 | # Test if $string = FREQ | ||||
136 | |||||
137 | my $err = $self->frequency($string); | ||||
138 | if (! $err) { | ||||
139 | $string = ''; | ||||
140 | } | ||||
141 | |||||
142 | # Test if $string = "FREQ*..." and FREQ contains an '*'. | ||||
143 | |||||
144 | if ($err) { | ||||
145 | $self->err(1); | ||||
146 | |||||
147 | $string =~ s/\s*\*\s*/\*/g; | ||||
148 | |||||
149 | if ($string =~ /^([^*]*\*[^*]*)\*/) { | ||||
150 | my $freq = $1; | ||||
151 | $err = $self->frequency($freq); | ||||
152 | if (! $err) { | ||||
153 | $string =~ s/^\Q$freq\E\*//; | ||||
154 | } | ||||
155 | } else { | ||||
156 | $err = 1; | ||||
157 | } | ||||
158 | } | ||||
159 | |||||
160 | # Test if $string = "FREQ*..." and FREQ does NOT contains an '*'. | ||||
161 | |||||
162 | if ($err) { | ||||
163 | $self->err(1); | ||||
164 | |||||
165 | if ($string =~ s/^([^*]*)\*//) { | ||||
166 | my $freq = $1; | ||||
167 | $err = $self->frequency($freq); | ||||
168 | if (! $err) { | ||||
169 | $string =~ s/^\Q$freq\E\*//; | ||||
170 | } | ||||
171 | } else { | ||||
172 | $err = 1; | ||||
173 | } | ||||
174 | } | ||||
175 | |||||
176 | if ($err) { | ||||
177 | $$self{'err'} = "[frequency] Invalid frequency string"; | ||||
178 | return 1; | ||||
179 | } | ||||
180 | |||||
181 | # Handle MODIFIERS from string and arguments | ||||
182 | |||||
183 | my @tmp = split(/\*/,$string); | ||||
184 | |||||
185 | if (@tmp) { | ||||
186 | my $tmp = shift(@tmp); | ||||
187 | $err = $self->modifiers($tmp) if ($tmp); | ||||
188 | return 1 if ($err); | ||||
189 | } | ||||
190 | if (@args) { | ||||
191 | my $tmp = $args[0]; | ||||
192 | if ($tmp && ! ref($tmp)) { | ||||
193 | $err = $self->modifiers($tmp); | ||||
194 | if ($err) { | ||||
195 | $self->err(1); | ||||
196 | $err = 0; | ||||
197 | } else { | ||||
198 | shift(@args); | ||||
199 | } | ||||
200 | } | ||||
201 | } | ||||
202 | |||||
203 | # Handle BASE | ||||
204 | |||||
205 | if (@tmp) { | ||||
206 | my $tmp = shift(@tmp); | ||||
207 | if (defined($tmp) && $tmp) { | ||||
208 | my $base = $self->new_date(); | ||||
209 | $err = $base->parse($tmp); | ||||
210 | return 1 if ($err); | ||||
211 | $err = $self->base($tmp); | ||||
212 | return 1 if ($err); | ||||
213 | } | ||||
214 | } | ||||
215 | if (@args) { | ||||
216 | my $tmp = shift(@args); | ||||
217 | $err = $self->base($tmp) if (defined($tmp) && $tmp); | ||||
218 | return 1 if ($err); | ||||
219 | } | ||||
220 | |||||
221 | # Handle START | ||||
222 | |||||
223 | if (@tmp) { | ||||
224 | my $tmp = shift(@tmp); | ||||
225 | if (defined($tmp) && $tmp) { | ||||
226 | my $start = $self->new_date(); | ||||
227 | $err = $start->parse($tmp); | ||||
228 | return 1 if ($err); | ||||
229 | $err = $self->start($tmp); | ||||
230 | return 1 if ($err); | ||||
231 | } | ||||
232 | } | ||||
233 | if (@args) { | ||||
234 | my $tmp = shift(@args); | ||||
235 | $err = $self->start($tmp) if (defined($tmp) && $tmp); | ||||
236 | return 1 if ($err); | ||||
237 | } | ||||
238 | |||||
239 | # END | ||||
240 | |||||
241 | if (@tmp) { | ||||
242 | my $tmp = shift(@tmp); | ||||
243 | if (defined($tmp) && $tmp) { | ||||
244 | my $end = $self->new_date(); | ||||
245 | $err = $end->parse($tmp); | ||||
246 | return 1 if ($err); | ||||
247 | $err = $self->end($tmp); | ||||
248 | return 1 if ($err); | ||||
249 | } | ||||
250 | } | ||||
251 | if (@args) { | ||||
252 | my $tmp = shift(@args); | ||||
253 | $err = $self->end($tmp) if (defined($tmp) && $tmp); | ||||
254 | return 1 if ($err); | ||||
255 | } | ||||
256 | |||||
257 | if (@tmp) { | ||||
258 | $$self{'err'} = "[frequency] String contains invalid elements"; | ||||
259 | return 1; | ||||
260 | } | ||||
261 | if (@args) { | ||||
262 | $$self{'err'} = "[frequency] Unknown arguments"; | ||||
263 | return 1; | ||||
264 | } | ||||
265 | |||||
266 | return 0; | ||||
267 | } | ||||
268 | |||||
269 | sub frequency { | ||||
270 | my($self,$string) = @_; | ||||
271 | $self->_init(); | ||||
272 | |||||
273 | my (@int,@rtime); | ||||
274 | |||||
275 | PARSE: { | ||||
276 | |||||
277 | # Standard frequency notation | ||||
278 | |||||
279 | my $stdrx = $self->_rx('std'); | ||||
280 | if ($string =~ $stdrx) { | ||||
281 | my($l,$r) = @+{qw(l r)}; | ||||
282 | |||||
283 | if (defined($l)) { | ||||
284 | $l =~ s/^\s*:/0:/; | ||||
285 | $l =~ s/:\s*$/:0/; | ||||
286 | $l =~ s/::/:0:/g; | ||||
287 | |||||
288 | @int = split(/:/,$l); | ||||
289 | } | ||||
290 | |||||
291 | if (defined($r)) { | ||||
292 | $r =~ s/^\s*:/0:/; | ||||
293 | $r =~ s/:\s*$/:0/; | ||||
294 | $r =~ s/::/:0:/g; | ||||
295 | |||||
296 | @rtime = split(/:/,$r); | ||||
297 | } | ||||
298 | |||||
299 | last PARSE; | ||||
300 | } | ||||
301 | |||||
302 | # Other frequency strings | ||||
303 | |||||
304 | # Strip out some words to ignore | ||||
305 | |||||
306 | my $ignrx = $self->_rx('ignore'); | ||||
307 | $string =~ s/$ignrx/ /g; | ||||
308 | |||||
309 | my $eachrx = $self->_rx('each'); | ||||
310 | my $each = 0; | ||||
311 | if ($string =~ s/$eachrx/ /g) { | ||||
312 | $each = 1; | ||||
313 | } | ||||
314 | |||||
315 | $string =~ s/\s*$//; | ||||
316 | |||||
317 | if (! $string) { | ||||
318 | $$self{'err'} = "[frequency] Invalid frequency string"; | ||||
319 | return 1; | ||||
320 | } | ||||
321 | |||||
322 | my($l,$r); | ||||
323 | my $err = $self->_parse_lang($string); | ||||
324 | if ($err) { | ||||
325 | $$self{'err'} = "[frequency] Invalid frequency string"; | ||||
326 | return 1; | ||||
327 | } | ||||
328 | return 0; | ||||
329 | } | ||||
330 | |||||
331 | # If the interval consists only of zeros, the last entry is changed | ||||
332 | # to 1. | ||||
333 | |||||
334 | if (@int) { | ||||
335 | TEST_INT: { | ||||
336 | for my $i (@int) { | ||||
337 | last TEST_INT if ($i); | ||||
338 | } | ||||
339 | $int[$#int] = 1; | ||||
340 | } | ||||
341 | } | ||||
342 | |||||
343 | # If @int contains 2 or 3 elements, move a trailing 0 to the start | ||||
344 | # of @rtime. | ||||
345 | |||||
346 | while (@int && | ||||
347 | ($#int == 1 || $#int == 2) && | ||||
348 | ($int[$#int] == 0)) { | ||||
349 | pop(@int); | ||||
350 | unshift(@rtime,0); | ||||
351 | } | ||||
352 | |||||
353 | # Test the format of @rtime. | ||||
354 | # | ||||
355 | # Turn it to: | ||||
356 | # @rtime = ( NUM|RANGE, NUM|RANGE, ...) | ||||
357 | # where | ||||
358 | # NUM is an integer | ||||
359 | # RANGE is [NUM1,NUM2] | ||||
360 | |||||
361 | my $rfieldrx = $self->_rx('rfield'); | ||||
362 | my $rrangerx = $self->_rx('rrange'); | ||||
363 | my @type = qw(y m w d h mn s); | ||||
364 | while ($#type > $#rtime) { | ||||
365 | shift(@type); | ||||
366 | } | ||||
367 | |||||
368 | foreach my $rfield (@rtime) { | ||||
369 | my $type = shift(@type); | ||||
370 | |||||
371 | if ($rfield !~ $rfieldrx) { | ||||
372 | $$self{'err'} = "[parse] Invalid rtime string"; | ||||
373 | return 1; | ||||
374 | } | ||||
375 | |||||
376 | my @rfield = split(/,/,$rfield); | ||||
377 | my @val; | ||||
378 | |||||
379 | foreach my $vals (@rfield) { | ||||
380 | if ($vals =~ $rrangerx) { | ||||
381 | my ($num1,$num2) = ($1,$2); | ||||
382 | |||||
383 | if ( ($num1 < 0 || $num2 < 0) && | ||||
384 | ($type ne 'w' && $type ne 'd') ) { | ||||
385 | $$self{'err'} = "[parse] Negative values allowed for day/week"; | ||||
386 | return 1; | ||||
387 | } | ||||
388 | |||||
389 | if ( ($num1 > 0 && $num2 > 0) || | ||||
390 | ($num1 < 0 && $num2 < 0) ) { | ||||
391 | if ($num1 > $num2) { | ||||
392 | $$self{'err'} = "[parse] Invalid rtime range string"; | ||||
393 | return 1; | ||||
394 | } | ||||
395 | push(@val,$num1..$num2); | ||||
396 | } else { | ||||
397 | push(@val,[$num1,$num2]); | ||||
398 | } | ||||
399 | |||||
400 | } else { | ||||
401 | if ($vals < 0 && | ||||
402 | ($type ne 'w' && $type ne 'd') ) { | ||||
403 | $$self{'err'} = "[parse] Negative values allowed for day/week"; | ||||
404 | return 1; | ||||
405 | } | ||||
406 | push(@val,$vals); | ||||
407 | } | ||||
408 | } | ||||
409 | |||||
410 | $rfield = [ @val ]; | ||||
411 | } | ||||
412 | |||||
413 | # Store it (also, get the default range modifiers). | ||||
414 | |||||
415 | $$self{'data'}{'interval'} = [ @int ]; | ||||
416 | $$self{'data'}{'rtime'} = [ @rtime ]; | ||||
417 | $self->modifiers(); | ||||
418 | |||||
419 | return 0; | ||||
420 | } | ||||
421 | |||||
422 | sub _parse_lang { | ||||
423 | my($self,$string) = @_; | ||||
424 | my $dmb = $$self{'objs'}{'base'}; | ||||
425 | |||||
426 | # Test the regular expression | ||||
427 | |||||
428 | my $rx = $self->_rx('every'); | ||||
429 | |||||
430 | return 1 if ($string !~ $rx); | ||||
431 | my($month,$week,$day,$last,$nth,$day_name,$day_abb,$mon_name,$mon_abb,$n,$y) = | ||||
432 | @+{qw(month week day last nth day_name day_abb mon_name mon_abb n y)}; | ||||
433 | |||||
434 | # Convert wordlist values to calendar values | ||||
435 | |||||
436 | my $dow; | ||||
437 | if (defined($day_name) || defined($day_abb)) { | ||||
438 | if (defined($day_name)) { | ||||
439 | $dow = $$dmb{'data'}{'wordmatch'}{'day_name'}{lc($day_name)}; | ||||
440 | } else { | ||||
441 | $dow = $$dmb{'data'}{'wordmatch'}{'day_abb'}{lc($day_abb)}; | ||||
442 | } | ||||
443 | } | ||||
444 | |||||
445 | my $mmm; | ||||
446 | if (defined($mon_name) || defined($mon_abb)) { | ||||
447 | if (defined($mon_name)) { | ||||
448 | $mmm = $$dmb{'data'}{'wordmatch'}{'month_name'}{lc($mon_name)}; | ||||
449 | } else { | ||||
450 | $mmm = $$dmb{'data'}{'wordmatch'}{'month_abb'}{lc($mon_abb)}; | ||||
451 | } | ||||
452 | } | ||||
453 | |||||
454 | if (defined($nth)) { | ||||
455 | $nth = $$dmb{'data'}{'wordmatch'}{'nth'}{lc($nth)}; | ||||
456 | } | ||||
457 | |||||
458 | # Get the frequencies | ||||
459 | |||||
460 | my($freq); | ||||
461 | if (defined($dow)) { | ||||
462 | if (defined($mmm)) { | ||||
463 | if (defined($last)) { | ||||
464 | # last DoW in MMM [YY] | ||||
465 | $freq = "1*$mmm:-1:$dow:0:0:0"; | ||||
466 | |||||
467 | } elsif (defined($nth)) { | ||||
468 | # Nth DoW in MMM [YY] | ||||
469 | $freq = "1*$mmm:$nth:$dow:0:0:0"; | ||||
470 | |||||
471 | } else { | ||||
472 | # every DoW in MMM [YY] | ||||
473 | $freq = "1*$mmm:1-5:$dow:0:0:0"; | ||||
474 | } | ||||
475 | |||||
476 | } else { | ||||
477 | if (defined($last)) { | ||||
478 | # last DoW in every month [in YY] | ||||
479 | $freq = "0:1*-1:$dow:0:0:0"; | ||||
480 | |||||
481 | } elsif (defined($nth)) { | ||||
482 | # Nth DoW in every month [in YY] | ||||
483 | $freq = "0:1*$nth:$dow:0:0:0"; | ||||
484 | |||||
485 | } else { | ||||
486 | # every DoW in every month [in YY] | ||||
487 | $freq = "0:1*1-5:$dow:0:0:0"; | ||||
488 | } | ||||
489 | } | ||||
490 | |||||
491 | } elsif (defined($day)) { | ||||
492 | if (defined($month)) { | ||||
493 | if (defined($nth)) { | ||||
494 | # Nth day of every month [YY] | ||||
495 | $freq = "0:1*0:$nth:0:0:0"; | ||||
496 | |||||
497 | } elsif (defined($last)) { | ||||
498 | # last day of every month [YY] | ||||
499 | $freq = "0:1*0:-1:0:0:0"; | ||||
500 | |||||
501 | } else { | ||||
502 | # every day of every month [YY] | ||||
503 | $freq = "0:0:0:1*0:0:0"; | ||||
504 | } | ||||
505 | |||||
506 | } else { | ||||
507 | if (defined($nth)) { | ||||
508 | # every Nth day [YY] | ||||
509 | $freq = "0:0:0:$nth*0:0:0"; | ||||
510 | |||||
511 | } elsif (defined($n)) { | ||||
512 | # every N days [YY] | ||||
513 | $freq = "0:0:0:$n*0:0:0"; | ||||
514 | |||||
515 | } else { | ||||
516 | # every day [YY] | ||||
517 | $freq = "0:0:0:1*0:0:0"; | ||||
518 | } | ||||
519 | } | ||||
520 | } | ||||
521 | |||||
522 | # Get the range (if YY is included) | ||||
523 | |||||
524 | if (defined($y)) { | ||||
525 | $y = $dmb->_fix_year($y); | ||||
526 | my $start = "${y}010100:00:00"; | ||||
527 | my $end = "${y}123123:59:59"; | ||||
528 | |||||
529 | return $self->parse($freq,undef,$start,$end); | ||||
530 | } | ||||
531 | |||||
532 | return $self->frequency($freq) | ||||
533 | } | ||||
534 | |||||
535 | sub _date { | ||||
536 | my($self,$op,$date_or_string) = @_; | ||||
537 | |||||
538 | # Make sure the argument is a date | ||||
539 | |||||
540 | if (ref($date_or_string) eq 'Date::Manip::Date') { | ||||
541 | $$self{'data'}{$op} = $date_or_string; | ||||
542 | |||||
543 | } elsif (ref($date_or_string)) { | ||||
544 | $$self{'err'} = "Invalid $op date object"; | ||||
545 | return 1; | ||||
546 | |||||
547 | } else { | ||||
548 | my $date = $self->new_date(); | ||||
549 | my $err = $date->parse($date_or_string); | ||||
550 | if ($err) { | ||||
551 | $$self{'err'} = "Invalid $op date string"; | ||||
552 | return 1; | ||||
553 | } | ||||
554 | $$self{'data'}{$op} = $date; | ||||
555 | } | ||||
556 | |||||
557 | return 0; | ||||
558 | } | ||||
559 | |||||
560 | sub start { | ||||
561 | my($self,$start) = @_; | ||||
562 | $self->_date('start',$start); | ||||
563 | } | ||||
564 | |||||
565 | sub end { | ||||
566 | my($self,$end) = @_; | ||||
567 | $self->_date('end',$end); | ||||
568 | } | ||||
569 | |||||
570 | sub base { | ||||
571 | my($self,$base) = @_; | ||||
572 | $self->_date('base',$base); | ||||
573 | } | ||||
574 | |||||
575 | sub modifiers { | ||||
576 | my($self,@flags) = @_; | ||||
577 | my $dmb = $$self{'objs'}{'base'}; | ||||
578 | if ($#flags == 0) { | ||||
579 | @flags = split(/,/,lc($flags[0])); | ||||
580 | } | ||||
581 | |||||
582 | # Add these flags to the list | ||||
583 | |||||
584 | if (@flags && $flags[0] eq "+") { | ||||
585 | shift(@flags); | ||||
586 | my @tmp = @{ $$self{'data'}{'flags'} }; | ||||
587 | @flags = (@tmp,@flags) if (@tmp); | ||||
588 | } | ||||
589 | |||||
590 | # Set up a base modifier: | ||||
591 | # @int = () : +/- 1 year | ||||
592 | # @int = (y) : +/- 1 year | ||||
593 | # @int = (y,m) : +/- 1 month | ||||
594 | # @int = (y,m,w) : +/- 1 month | ||||
595 | # @int = (y,m,w,d) : +/- 1 week | ||||
596 | # @int = (y...h) : +/- 1 day | ||||
597 | # @int = (y...mn) : +/- 1 hour | ||||
598 | # @int = (y...s) : +/- 1 minute | ||||
599 | |||||
600 | my @int = @{ $$self{'data'}{'interval'} }; | ||||
601 | my(@startm,@endm); | ||||
602 | my $n = $#int + 1; | ||||
603 | |||||
604 | given($n) { | ||||
605 | |||||
606 | when ([0,1]) { | ||||
607 | @endm = (1,0,0,0,0,0,0); | ||||
608 | } | ||||
609 | |||||
610 | when ([2,3]) { | ||||
611 | @endm = (0,1,0,0,0,0,0); | ||||
612 | } | ||||
613 | |||||
614 | when (4) { | ||||
615 | @endm = (0,0,0,7,0,0,0); | ||||
616 | } | ||||
617 | |||||
618 | when (5) { | ||||
619 | @endm = (0,0,0,1,0,0,0); | ||||
620 | } | ||||
621 | |||||
622 | when (6) { | ||||
623 | @endm = (0,0,0,0,1,0,0); | ||||
624 | } | ||||
625 | |||||
626 | when (7) { | ||||
627 | @endm = (0,0,0,0,0,1,0); | ||||
628 | } | ||||
629 | } | ||||
630 | @startm = map { -1*$_ } @endm; | ||||
631 | |||||
632 | # Examine each modifier to see how it impacts the range | ||||
633 | |||||
634 | foreach my $flag (@flags) { | ||||
635 | |||||
636 | given($flag) { | ||||
637 | |||||
638 | when (/^pd([1-7])$/) { | ||||
639 | $startm[3] -= 7; | ||||
640 | $endm[3] -= 1; | ||||
641 | } | ||||
642 | |||||
643 | when (/^pt([1-7])$/) { | ||||
644 | $startm[3] -= 6; | ||||
645 | $endm[3] -= 0; | ||||
646 | } | ||||
647 | |||||
648 | when (/^nd([1-7])$/) { | ||||
649 | $startm[3] += 1; | ||||
650 | $endm[3] += 7; | ||||
651 | } | ||||
652 | |||||
653 | when (/^nt([1-7])$/) { | ||||
654 | $startm[3] += 0; | ||||
655 | $endm[3] += 6; | ||||
656 | } | ||||
657 | |||||
658 | when (/^fd(\d+)$/) { | ||||
659 | my $n = $1; | ||||
660 | $startm[3] += $n; | ||||
661 | $endm[3] += $n; | ||||
662 | } | ||||
663 | |||||
664 | when (/^bd(\d+)$/) { | ||||
665 | my $n = $1; | ||||
666 | $startm[3] -= $n; | ||||
667 | $endm[3] -= $n; | ||||
668 | } | ||||
669 | |||||
670 | # | ||||
671 | # The business day flags are imperfectly handled... it's quite possible to | ||||
672 | # make so many holidays that moving forward 1 working day could correspond | ||||
673 | # to moving forward many days. | ||||
674 | # | ||||
675 | |||||
676 | when (/^(fw|bw)(\d+)$/) { | ||||
677 | my ($t,$n) = ($1,$2); | ||||
678 | |||||
679 | my $wwbeg = $dmb->_config('workweekbeg'); | ||||
680 | my $wwend = $dmb->_config('workweekend'); | ||||
681 | my $wwlen = $wwend - $wwbeg + 1; | ||||
682 | my $wkend = 7 - $wwlen; | ||||
683 | my $fudge = $dmb->_config('recurnumfudgedays'); | ||||
684 | # How many weekends likely in the interval? Take best guess for maximum | ||||
685 | # number of weeks and add 1 for a fudge factor. | ||||
686 | my $num = int($n/$wwlen) + 2; | ||||
687 | |||||
688 | if ($t eq 'fw') { | ||||
689 | $startm[3] += $n; | ||||
690 | $endm[3] += $n + $num*$wkend + $fudge; | ||||
691 | } else { | ||||
692 | $startm[3] -= $n + $num*$wkend + $fudge; | ||||
693 | $endm[3] -= $n; | ||||
694 | } | ||||
695 | } | ||||
696 | |||||
697 | when ([qw( cwd cwn cwp nwd pwd dwd )]) { | ||||
698 | # For closest work day, we'll move backwards/forwards 1 | ||||
699 | # weekend (+ 1 day) plus the fudge factor. | ||||
700 | my $wwbeg = $dmb->_config('workweekbeg'); | ||||
701 | my $wwend = $dmb->_config('workweekend'); | ||||
702 | my $wwlen = $wwend - $wwbeg + 1; | ||||
703 | my $wkend = 7 - $wwlen; | ||||
704 | my $fudge = $dmb->_config('recurnumfudgedays'); | ||||
705 | |||||
706 | if ($flag eq 'pwd') { | ||||
707 | $startm[3] -= $wkend+1 + $fudge; | ||||
708 | $endm[3] -= 1; | ||||
709 | |||||
710 | } elsif ($flag eq 'nwd') { | ||||
711 | $startm[3] += 1; | ||||
712 | $endm[3] += $wkend+1 + $fudge; | ||||
713 | |||||
714 | } else { | ||||
715 | $startm[3] -= $wkend+1 + $fudge; | ||||
716 | $endm[3] += $wkend+1 + $fudge; | ||||
717 | } | ||||
718 | } | ||||
719 | |||||
720 | when ('easter') { | ||||
721 | $startm[0]--; | ||||
722 | $endm[0]++; | ||||
723 | } | ||||
724 | |||||
725 | default { | ||||
726 | $$self{'err'} = "[modifiers]: invalid modifier: $flag"; | ||||
727 | return 1; | ||||
728 | } | ||||
729 | } | ||||
730 | } | ||||
731 | |||||
732 | $$self{'data'}{'startm'} = [ @startm ]; | ||||
733 | $$self{'data'}{'endm'} = [ @endm ]; | ||||
734 | $$self{'data'}{'flags'} = [ @flags ]; | ||||
735 | return 0; | ||||
736 | } | ||||
737 | |||||
738 | sub dates { | ||||
739 | my($self,$start2,$end2) = @_; | ||||
740 | $self->err(1); | ||||
741 | |||||
742 | my $dmb = $$self{'objs'}{'base'}; | ||||
743 | $dmb->_update_now(); # Update NOW | ||||
744 | my @int = @{ $$self{'data'}{'interval'} }; | ||||
745 | my @rtime = @{ $$self{'data'}{'rtime'} }; | ||||
746 | my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime); | ||||
747 | |||||
748 | # | ||||
749 | # Get the start and end dates based on the dates store in the | ||||
750 | # recurrence and the dates passed in as arguments. | ||||
751 | # | ||||
752 | |||||
753 | if (defined($start2) && | ||||
754 | (! ref($start2) || ref($start2) ne 'Date::Manip::Date' || | ||||
755 | $start2->err())) { | ||||
756 | $$self{'err'} = 'Start argument must be a date object.'; | ||||
757 | return (); | ||||
758 | } | ||||
759 | if (defined($end2) && | ||||
760 | (! ref($end2) || ref($end2) ne 'Date::Manip::Date' || | ||||
761 | $end2->err())) { | ||||
762 | $$self{'err'} = 'End argument must be a date object.'; | ||||
763 | return (); | ||||
764 | } | ||||
765 | |||||
766 | my $start = $$self{'data'}{'start'}; | ||||
767 | my $end = $$self{'data'}{'end'}; | ||||
768 | |||||
769 | if (defined($start) && defined($start2)) { | ||||
770 | # Choose the later of the two | ||||
771 | if ($start->cmp($start2) == -1) { | ||||
772 | $start = $start2; | ||||
773 | } | ||||
774 | } elsif (defined($start2)) { | ||||
775 | $start = $start2; | ||||
776 | } | ||||
777 | |||||
778 | if (defined($end) && defined($end2)) { | ||||
779 | # Choose the earlier of the two | ||||
780 | if ($end->cmp($end2) == 1) { | ||||
781 | $end = $end2; | ||||
782 | } | ||||
783 | } elsif (defined($end2)) { | ||||
784 | $end = $end2; | ||||
785 | } | ||||
786 | |||||
787 | # | ||||
788 | # Make sure that basedate, start, and end are set as needed | ||||
789 | # | ||||
790 | # Start/end are required unless *Y:M:W:D:H:MN:S | ||||
791 | # Basedate required unless *Y:M:W:D:H:MN:S or @int = (0*,1) | ||||
792 | # | ||||
793 | |||||
794 | |||||
795 | if ($#int != -1) { | ||||
796 | if (! defined $start) { | ||||
797 | $$self{'err'} = 'Start date required'; | ||||
798 | return (); | ||||
799 | } | ||||
800 | if ($$start{'err'}) { | ||||
801 | $$self{'err'} = 'Start date invalid'; | ||||
802 | return (); | ||||
803 | } | ||||
804 | |||||
805 | if (! defined $end) { | ||||
806 | $$self{'err'} = 'End date required'; | ||||
807 | return (); | ||||
808 | } | ||||
809 | if ($$end{'err'}) { | ||||
810 | $$self{'err'} = 'End date invalid'; | ||||
811 | return (); | ||||
812 | } | ||||
813 | |||||
814 | if ($start->cmp($end) == 1) { | ||||
815 | return (); | ||||
816 | } | ||||
817 | } | ||||
818 | |||||
819 | my $every = 0; | ||||
820 | my $tmp = join('',@int); | ||||
821 | |||||
822 | if ($tmp eq '' || $tmp =~ /^0*1$/) { | ||||
823 | $$self{'data'}{'base'} = $start; | ||||
824 | $every = 1 if ($tmp ne ''); | ||||
825 | |||||
826 | } else { | ||||
827 | if (! defined $$self{'data'}{'base'}) { | ||||
828 | $$self{'err'} = 'Base date required'; | ||||
829 | return (); | ||||
830 | } | ||||
831 | my $date = $$self{'data'}{'base'}; | ||||
832 | if ($$date{'err'}) { | ||||
833 | $$self{'err'} = 'Base date invalid'; | ||||
834 | return (); | ||||
835 | } | ||||
836 | } | ||||
837 | |||||
838 | # | ||||
839 | # Handle the Y/M/W/D portion. | ||||
840 | # | ||||
841 | |||||
842 | my (@date,@tmp); | ||||
843 | my ($err,@y,@m,@w,@d,@h,@mn,@s,@doy,@woy,@dow,@n); | ||||
844 | my $n = $#int + 1; | ||||
845 | |||||
846 | my $m_empty = $self->_field_empty($mf); | ||||
847 | my $w_empty = $self->_field_empty($wf); | ||||
848 | my $d_empty = $self->_field_empty($df); | ||||
849 | |||||
850 | given($n) { | ||||
851 | |||||
852 | when ([0,1]) { | ||||
853 | # | ||||
854 | # *Y:M:W:D:H:MN:S | ||||
855 | # Y*M:W:D:H:MN:S | ||||
856 | # | ||||
857 | |||||
858 | if ($#int == -1) { | ||||
859 | ($err,@y) = $self->_rtime_values('y',$yf); | ||||
860 | return () if ($err); | ||||
861 | } else { | ||||
862 | my @tmp = $self->_int_values($every,$yf,$start,$end); | ||||
863 | @y = map { $$_[0] } @tmp; | ||||
864 | } | ||||
865 | |||||
866 | if ( ($m_empty && $w_empty && $d_empty) || | ||||
867 | (! $m_empty && $w_empty) ) { | ||||
868 | |||||
869 | # *0:0:0:0 Jan 1 of the current year | ||||
870 | # *1:0:0:0 Jan 1, 0001 | ||||
871 | # *0:2:0:0 Feb 1 of the current year | ||||
872 | # *1:2:0:0 Feb 1, 0001 | ||||
873 | # *0:2:0:4 Feb 4th of the current year | ||||
874 | # *1:2:0:4 Feb 4th, 0001 | ||||
875 | # 1*0:0:0 every year on Jan 1 | ||||
876 | # 1*2:0:0 every year on Feb 1 | ||||
877 | # 1*2:0:4 every year on Feb 4th | ||||
878 | |||||
879 | $mf = [1] if ($m_empty); | ||||
880 | $df = [1] if ($d_empty); | ||||
881 | |||||
882 | ($err,@m) = $self->_rtime_values('m',$mf); | ||||
883 | return () if ($err); | ||||
884 | |||||
885 | foreach my $y (@y) { | ||||
886 | foreach my $m (@m) { | ||||
887 | ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m); | ||||
888 | return () if ($err); | ||||
889 | foreach my $d (@d) { | ||||
890 | push(@date,[$y,$m,$d,0,0,0]); | ||||
891 | } | ||||
892 | } | ||||
893 | } | ||||
894 | |||||
895 | } elsif ($m_empty) { | ||||
896 | |||||
897 | if ($w_empty) { | ||||
898 | |||||
899 | # *0:0:0:4 the 4th day of the current year | ||||
900 | # *1:0:0:4 the 4th day of 0001 | ||||
901 | # 1*0:0:4 every year on the 4th day of the year | ||||
902 | |||||
903 | foreach my $y (@y) { | ||||
904 | ($err,@doy) = $self->_rtime_values('day_of_year',$df,$y); | ||||
905 | return () if ($err); | ||||
906 | foreach my $doy (@doy) { | ||||
907 | my($yy,$mm,$dd) = @{ $dmb->day_of_year($y,$doy) }; | ||||
908 | push(@date,[$yy,$mm,$dd,0,0,0]); | ||||
909 | } | ||||
910 | } | ||||
911 | |||||
912 | } elsif ($d_empty) { | ||||
913 | |||||
914 | # *0:0:3:0 the first day of the 3rd week of the curr year | ||||
915 | # *1:0:3:0 the first day of the 3rd week of 0001 | ||||
916 | # 1*0:3:0 every year on the first day of 3rd week of year | ||||
917 | |||||
918 | foreach my $y (@y) { | ||||
919 | ($err,@woy) = $self->_rtime_values('week_of_year',$wf,$y); | ||||
920 | return () if ($err); | ||||
921 | foreach my $woy (@woy) { | ||||
922 | my ($yy,$mm,$dd) = @{ $dmb->week_of_year($y,$woy) }; | ||||
923 | push(@date,[$yy,$mm,$dd,0,0,0]); | ||||
924 | } | ||||
925 | } | ||||
926 | |||||
927 | } else { | ||||
928 | |||||
929 | # *1:0:3:4 in 0001 on the 3rd Thur of the year | ||||
930 | # *0:0:3:4 on the 3rd Thur of the current year | ||||
931 | # 1*0:3:4 every year on the 3rd Thur of the year | ||||
932 | |||||
933 | ($err,@dow) = $self->_rtime_values('day_of_week',$df); | ||||
934 | return () if ($err); | ||||
935 | foreach my $y (@y) { | ||||
936 | foreach my $dow (@dow) { | ||||
937 | ($err,@n) = $self->_rtime_values('dow_of_year',$wf,$y,$dow); | ||||
938 | return () if ($err); | ||||
939 | foreach my $n (@n) { | ||||
940 | my $ymd = $dmb->nth_day_of_week($y,$n,$dow); | ||||
941 | my($yy,$mm,$dd) = @$ymd; | ||||
942 | push(@date,[$yy,$mm,$dd,0,0,0]); | ||||
943 | } | ||||
944 | } | ||||
945 | } | ||||
946 | } | ||||
947 | |||||
948 | } else { | ||||
949 | |||||
950 | # *1:2:3:4 in Feb 0001 on the 3rd Thur of the month | ||||
951 | # *0:2:3:4 on the 3rd Thur of Feb in the curr year | ||||
952 | # *1:2:3:0 the 3rd occurence of FirstDay in Feb 0001 | ||||
953 | # *0:2:3:0 the 3rd occurence of FirstDay in Feb of curr year | ||||
954 | # 1*2:3:4 every year in Feb on the 3rd Thur | ||||
955 | # 1*2:3:0 every year on the 3rd occurence of FirstDay in Feb | ||||
956 | |||||
957 | ($err,@m) = $self->_rtime_values('m',$mf); | ||||
958 | return () if ($err); | ||||
959 | if ($d_empty) { | ||||
960 | @dow = ($dmb->_config('firstday')); | ||||
961 | } else { | ||||
962 | ($err,@dow) = $self->_rtime_values('day_of_week',$df); | ||||
963 | return () if ($err); | ||||
964 | } | ||||
965 | |||||
966 | foreach my $y (@y) { | ||||
967 | foreach my $m (@m) { | ||||
968 | foreach my $dow (@dow) { | ||||
969 | ($err,@n) = $self->_rtime_values('dow_of_month', | ||||
970 | $wf,$y,$m,$dow); | ||||
971 | return () if ($err); | ||||
972 | foreach my $n (@n) { | ||||
973 | my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m); | ||||
974 | my($yy,$mm,$dd) = @$ymd; | ||||
975 | push(@date,[$yy,$mm,$dd,0,0,0]); | ||||
976 | } | ||||
977 | } | ||||
978 | } | ||||
979 | } | ||||
980 | } | ||||
981 | } | ||||
982 | |||||
983 | when (2) { | ||||
984 | # | ||||
985 | # Y:M*W:D:H:MN:S | ||||
986 | # | ||||
987 | |||||
988 | my @tmp = $self->_int_values($every,$yf,$mf,$start,$end); | ||||
989 | |||||
990 | if ($w_empty) { | ||||
991 | |||||
992 | # 0:2*0:0 every 2 months on the first day of the month | ||||
993 | # 0:2*0:4 every 2 months on the 4th day of the month | ||||
994 | # 1:2*0:0 every 1 year, 2 months on the first day of the month | ||||
995 | # 1:2*0:4 every 1 year, 2 months on the 4th day of the month | ||||
996 | |||||
997 | $df = [1] if ($d_empty); | ||||
998 | |||||
999 | foreach my $date (@tmp) { | ||||
1000 | my($y,$m) = @$date; | ||||
1001 | ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m); | ||||
1002 | return () if ($err); | ||||
1003 | foreach my $d (@d) { | ||||
1004 | push(@date,[$y,$m,$d,0,0,0]); | ||||
1005 | } | ||||
1006 | } | ||||
1007 | |||||
1008 | } else { | ||||
1009 | |||||
1010 | # 0:2*3:0 every 2 months on the 3rd occurence of FirstDay | ||||
1011 | # 0:2*3:4 every 2 months on the 3rd Thur of the month | ||||
1012 | # 1:2*3:0 every 1 year, 2 months on 3rd occurence of FirstDay | ||||
1013 | # 1:2*3:4 every 1 year, 2 months on the 3rd Thur of the month | ||||
1014 | |||||
1015 | if ($d_empty) { | ||||
1016 | @dow = ($dmb->_config('firstday')); | ||||
1017 | } else { | ||||
1018 | ($err,@dow) = $self->_rtime_values('day_of_week',$df); | ||||
1019 | return () if ($err); | ||||
1020 | } | ||||
1021 | |||||
1022 | foreach my $date (@tmp) { | ||||
1023 | my($y,$m) = @$date; | ||||
1024 | foreach my $dow (@dow) { | ||||
1025 | ($err,@n) = $self->_rtime_values('dow_of_month', | ||||
1026 | $wf,$y,$m,$dow); | ||||
1027 | return () if ($err); | ||||
1028 | foreach my $n (@n) { | ||||
1029 | my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m); | ||||
1030 | my($yy,$mm,$dd) = @$ymd; | ||||
1031 | push(@date,[$yy,$mm,$dd,0,0,0]); | ||||
1032 | } | ||||
1033 | } | ||||
1034 | } | ||||
1035 | } | ||||
1036 | } | ||||
1037 | |||||
1038 | when (3) { | ||||
1039 | # | ||||
1040 | # Y:M:W*D:H:MN:S | ||||
1041 | # | ||||
1042 | |||||
1043 | # 0:0:3*0 every 3 weeks on FirstDay | ||||
1044 | # 0:0:3*4 every 3 weeks on Thur | ||||
1045 | # 0:2:3*0 every 2 months, 3 weeks on FirstDay | ||||
1046 | # 0:2:3*4 every 2 months, 3 weeks on Thur | ||||
1047 | # 1:0:3*0 every 1 year, 3 weeks on FirstDay | ||||
1048 | # 1:0:3*4 every 1 year, 3 weeks on Thur | ||||
1049 | # 1:2:3*0 every 1 year, 2 months, 3 weeks on FirstDay | ||||
1050 | # 1:2:3*4 every 1 year, 2 months, 3 weeks on Thur | ||||
1051 | |||||
1052 | my @tmp = $self->_int_values($every,$yf,$mf,$wf,$start,$end); | ||||
1053 | |||||
1054 | my $fdow = $dmb->_config('firstday'); | ||||
1055 | if ($d_empty) { | ||||
1056 | @dow = ($fdow); | ||||
1057 | } else { | ||||
1058 | ($err,@dow) = $self->_rtime_values('day_of_week',$df); | ||||
1059 | return () if ($err); | ||||
1060 | } | ||||
1061 | |||||
1062 | foreach my $date (@tmp) { | ||||
1063 | my($y,$m,$d) = @$date; | ||||
1064 | my ($mm,$dd); | ||||
1065 | my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]); | ||||
1066 | ($yy,$mm,$dd) = @{ $dmb->week_of_year($yy,$ww) }; | ||||
1067 | |||||
1068 | foreach my $dow (@dow) { | ||||
1069 | $dow += 7 if ($dow < $fdow); | ||||
1070 | my($yyy,$mmm,$ddd) = @{ $dmb->calc_date_days([$yy,$mm,$dd],$dow-$fdow) }; | ||||
1071 | push(@date,[$yyy,$mmm,$ddd]); | ||||
1072 | } | ||||
1073 | } | ||||
1074 | } | ||||
1075 | |||||
1076 | when (4) { | ||||
1077 | # | ||||
1078 | # Y:M:W:D*H:MN:S | ||||
1079 | # | ||||
1080 | |||||
1081 | @date = $self->_int_values($every,$yf,$mf,$wf,$df,$start,$end); | ||||
1082 | } | ||||
1083 | |||||
1084 | when (5) { | ||||
1085 | # | ||||
1086 | # Y:M:W:D:H*MN:S | ||||
1087 | # | ||||
1088 | |||||
1089 | @date = $self->_int_values($every,$yf,$mf,$wf,$df,$hf,$start,$end); | ||||
1090 | } | ||||
1091 | |||||
1092 | when (6) { | ||||
1093 | # | ||||
1094 | # Y:M:W:D:H:MN*S | ||||
1095 | # | ||||
1096 | |||||
1097 | @date = $self->_int_values($every,$yf,$mf,$wf,$df,$hf,$mnf,$start,$end); | ||||
1098 | } | ||||
1099 | |||||
1100 | when (7) { | ||||
1101 | # | ||||
1102 | # Y:M:W:D:H:MN:S | ||||
1103 | # | ||||
1104 | |||||
1105 | @date = $self->_int_values($every,$yf,$mf,$wf,$df,$hf,$mnf,$sf,$start,$end); | ||||
1106 | } | ||||
1107 | } | ||||
1108 | |||||
1109 | # | ||||
1110 | # Handle the H/MN/S portion. | ||||
1111 | # | ||||
1112 | |||||
1113 | # Do seconds | ||||
1114 | if (@rtime) { | ||||
1115 | pop(@rtime); | ||||
1116 | |||||
1117 | ($err,@s) = $self->_rtime_values('s',$sf); | ||||
1118 | return () if ($err); | ||||
1119 | $self->_field_add_values(\@date,5,@s); | ||||
1120 | } | ||||
1121 | |||||
1122 | # Do minutes | ||||
1123 | if (@rtime) { | ||||
1124 | pop(@rtime); | ||||
1125 | |||||
1126 | ($err,@mn) = $self->_rtime_values('mn',$mnf); | ||||
1127 | return () if ($err); | ||||
1128 | $self->_field_add_values(\@date,4,@mn); | ||||
1129 | } | ||||
1130 | |||||
1131 | # Do hours | ||||
1132 | if (@rtime) { | ||||
1133 | pop(@rtime); | ||||
1134 | |||||
1135 | ($err,@h) = $self->_rtime_values('h',$hf); | ||||
1136 | return () if ($err); | ||||
1137 | $self->_field_add_values(\@date,3,@h); | ||||
1138 | } | ||||
1139 | |||||
1140 | # | ||||
1141 | # Apply modifiers | ||||
1142 | # | ||||
1143 | |||||
1144 | my @flags = @{ $$self{'data'}{'flags'} }; | ||||
1145 | if (@flags) { | ||||
1146 | my $obj = $self->new_date(); | ||||
1147 | |||||
1148 | foreach my $date (@date) { | ||||
1149 | my ($y,$m,$d,$h,$mn,$s) = @$date; | ||||
1150 | |||||
1151 | foreach my $flag (@flags) { | ||||
1152 | |||||
1153 | my(@wd,$today); | ||||
1154 | given($flag) { | ||||
1155 | |||||
1156 | when ('easter') { | ||||
1157 | ($m,$d) = $self->_easter($y); | ||||
1158 | } | ||||
1159 | |||||
1160 | when (/^([pn])([dt])([1-7])$/) { | ||||
1161 | my($forw,$today,$dow) = ($1,$2,$3); | ||||
1162 | $forw = ($forw eq 'p' ? 0 : 1); | ||||
1163 | $today = ($today eq 'd' ? 0 : 1); | ||||
1164 | ($y,$m,$d,$h,$mn,$s) = | ||||
1165 | @{ $obj->__next_prev([$y,$m,$d,$h,$mn,$s],$forw,$dow,$today) }; | ||||
1166 | } | ||||
1167 | |||||
1168 | when (/^([fb])([dw])(\d+)$/) { | ||||
1169 | my($prev,$business,$n) = ($1,$2,$3); | ||||
1170 | $prev = ($prev eq 'b' ? 1 : 0); | ||||
1171 | $business = ($business eq 'w' ? 1 : 0); | ||||
1172 | |||||
1173 | if ($business) { | ||||
1174 | ($y,$m,$d,$h,$mn,$s) = | ||||
1175 | @{ $obj->__nextprev_business_day($prev,$n,0,[$y,$m,$d,$h,$mn,$s]) }; | ||||
1176 | } else { | ||||
1177 | ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],$n,$prev) }; | ||||
1178 | } | ||||
1179 | } | ||||
1180 | |||||
1181 | when ('nwd') { | ||||
1182 | if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) { | ||||
1183 | ($y,$m,$d,$h,$mn,$s) = | ||||
1184 | @{ $obj->__nextprev_business_day(0,0,0,[$y,$m,$d,$h,$mn,$s]) }; | ||||
1185 | } | ||||
1186 | } | ||||
1187 | |||||
1188 | when ('pwd') { | ||||
1189 | if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) { | ||||
1190 | ($y,$m,$d,$h,$mn,$s) = | ||||
1191 | @{ $obj->__nextprev_business_day(1,1,0,[$y,$m,$d,$h,$mn,$s]) }; | ||||
1192 | } | ||||
1193 | } | ||||
1194 | |||||
1195 | when ('dwd') { | ||||
1196 | if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) { | ||||
1197 | continue; | ||||
1198 | } | ||||
1199 | } | ||||
1200 | |||||
1201 | when (['cwd','dwd']) { | ||||
1202 | if ($dmb->_config('tomorrowfirst')) { | ||||
1203 | @wd = ([$y,$m,$d,$h,$mn,$s],+1, [$y,$m,$d,$h,$mn,$s],-1); | ||||
1204 | } else { | ||||
1205 | @wd = ([$y,$m,$d,$h,$mn,$s],-1, [$y,$m,$d,$h,$mn,$s],+1); | ||||
1206 | } | ||||
1207 | continue; | ||||
1208 | } | ||||
1209 | |||||
1210 | when ('cwn') { | ||||
1211 | @wd = ([$y,$m,$d,$h,$mn,$s],+1, [$y,$m,$d,$h,$mn,$s],-1); | ||||
1212 | $today = 0; | ||||
1213 | continue; | ||||
1214 | } | ||||
1215 | |||||
1216 | when ('cwp') { | ||||
1217 | @wd = ([$y,$m,$d,$h,$mn,$s],-1, [$y,$m,$d,$h,$mn,$s],+1); | ||||
1218 | $today = 0; | ||||
1219 | continue; | ||||
1220 | } | ||||
1221 | |||||
1222 | default { | ||||
1223 | while (1) { | ||||
1224 | my(@d,$off); | ||||
1225 | |||||
1226 | # Test in the first direction | ||||
1227 | |||||
1228 | @d = @{ $wd[0] }; | ||||
1229 | $off = $wd[1]; | ||||
1230 | @d = @{ $dmb->calc_date_days(\@d,$off) }; | ||||
1231 | |||||
1232 | if ($obj->__is_business_day(\@d,0)) { | ||||
1233 | ($y,$m,$d,$h,$mn,$s) = @d; | ||||
1234 | last; | ||||
1235 | } | ||||
1236 | |||||
1237 | $wd[0] = [@d]; | ||||
1238 | |||||
1239 | # Test in the other direction | ||||
1240 | |||||
1241 | @d = @{ $wd[2] }; | ||||
1242 | $off = $wd[3]; | ||||
1243 | @d = @{ $dmb->calc_date_days(\@d,$off) }; | ||||
1244 | |||||
1245 | if ($obj->__is_business_day(\@d,0)) { | ||||
1246 | ($y,$m,$d,$h,$mn,$s) = @d; | ||||
1247 | last; | ||||
1248 | } | ||||
1249 | |||||
1250 | $wd[2] = [@d]; | ||||
1251 | } | ||||
1252 | } | ||||
1253 | |||||
1254 | } | ||||
1255 | } | ||||
1256 | |||||
1257 | @$date = ($y,$m,$d,$h,$mn,$s); | ||||
1258 | } | ||||
1259 | } | ||||
1260 | |||||
1261 | # | ||||
1262 | # Convert the dates (which fall into the valid range) to objects. | ||||
1263 | # | ||||
1264 | |||||
1265 | my(@ret,@start,@end); | ||||
1266 | if (defined $start) { | ||||
1267 | @start = @{ $$start{'data'}{'date'} }; | ||||
1268 | } | ||||
1269 | if (defined $end) { | ||||
1270 | @end = @{ $$end{'data'}{'date'} }; | ||||
1271 | } | ||||
1272 | |||||
1273 | foreach my $date (@date) { | ||||
1274 | my @d = @$date; | ||||
1275 | if (@start) { | ||||
1276 | next if ($dmb->cmp(\@start,\@d) > 0); | ||||
1277 | } | ||||
1278 | if (@end) { | ||||
1279 | next if ($dmb->cmp(\@d,\@end) > 0); | ||||
1280 | } | ||||
1281 | |||||
1282 | my $obj = $self->new_date(); | ||||
1283 | $obj->set('date',\@d); | ||||
1284 | push(@ret,$obj); | ||||
1285 | } | ||||
1286 | |||||
1287 | # | ||||
1288 | # Sort the dates | ||||
1289 | # | ||||
1290 | |||||
1291 | @ret = sort { $a->cmp($b) } @ret; | ||||
1292 | return @ret; | ||||
1293 | } | ||||
1294 | |||||
1295 | ######################################################################## | ||||
1296 | # MISC | ||||
1297 | ######################################################################## | ||||
1298 | |||||
1299 | sub _rx { | ||||
1300 | my($self,$rx) = @_; | ||||
1301 | my $dmb = $$self{'objs'}{'base'}; | ||||
1302 | |||||
1303 | return $$dmb{'data'}{'rx'}{'recur'}{$rx} | ||||
1304 | if (exists $$dmb{'data'}{'rx'}{'recur'}{$rx}); | ||||
1305 | |||||
1306 | if ($rx eq 'std') { | ||||
1307 | |||||
1308 | my $l = '[0-9]*'; | ||||
1309 | my $r = '[-,0-9]*'; | ||||
1310 | my $stdrx = "(?<l>$l:$l:$l:$l:$l:$l:$l)(?<r>)|" . | ||||
1311 | "(?<l>$l:$l:$l:$l:$l:$l)\\*(?<r>$r)|" . | ||||
1312 | "(?<l>$l:$l:$l:$l:$l)\\*(?<r>$r:$r)|" . | ||||
1313 | "(?<l>$l:$l:$l:$l)\\*(?<r>$r:$r:$r)|" . | ||||
1314 | "(?<l>$l:$l:$l)\\*(?<r>$r:$r:$r:$r)|" . | ||||
1315 | "(?<l>$l:$l)\\*(?<r>$r:$r:$r:$r:$r)|" . | ||||
1316 | "(?<l>$l)\\*(?<r>$r:$r:$r:$r:$r:$r)|" . | ||||
1317 | "(?<l>)\\*(?<r>$r:$r:$r:$r:$r:$r:$r)"; | ||||
1318 | $$dmb{'data'}{'rx'}{'recur'}{$rx} = qr/^\s*(?:$stdrx)\s*$/; | ||||
1319 | |||||
1320 | } elsif ($rx eq 'rfield' || | ||||
1321 | $rx eq 'rnum' || | ||||
1322 | $rx eq 'rrange') { | ||||
1323 | |||||
1324 | my $num = '\-?\d+'; | ||||
1325 | my $range = "$num\-$num"; | ||||
1326 | my $val = "(?:$range|$num)"; | ||||
1327 | my $vals = "$val(?:,$val)*"; | ||||
1328 | |||||
1329 | $$dmb{'data'}{'rx'}{'recur'}{'rfield'} = qr/^($vals)$/; | ||||
1330 | $$dmb{'data'}{'rx'}{'recur'}{'rnum'} = qr/^($num)$/; | ||||
1331 | $$dmb{'data'}{'rx'}{'recur'}{'rrange'} = qr/^($num)\-($num)$/; | ||||
1332 | |||||
1333 | } elsif ($rx eq 'each') { | ||||
1334 | |||||
1335 | my $each = $$dmb{'data'}{'rx'}{'each'}; | ||||
1336 | |||||
1337 | my $eachrx = qr/(?:^|\s+)(?:$each)(\s+|$)/i; | ||||
1338 | $$dmb{'data'}{'rx'}{'recur'}{$rx} = $eachrx; | ||||
1339 | |||||
1340 | } elsif ($rx eq 'ignore') { | ||||
1341 | |||||
1342 | my $of = $$dmb{'data'}{'rx'}{'of'}; | ||||
1343 | my $on = $$dmb{'data'}{'rx'}{'on'}; | ||||
1344 | |||||
1345 | my $ignrx = qr/(?:^|\s+)(?:$on|$of)(\s+|$)/i; | ||||
1346 | $$dmb{'data'}{'rx'}{'recur'}{$rx} = $ignrx; | ||||
1347 | |||||
1348 | } elsif ($rx eq 'every') { | ||||
1349 | |||||
1350 | my $month = $$dmb{'data'}{'rx'}{'fields'}[2]; | ||||
1351 | my $week = $$dmb{'data'}{'rx'}{'fields'}[3]; | ||||
1352 | my $day = $$dmb{'data'}{'rx'}{'fields'}[4]; | ||||
1353 | |||||
1354 | my $last = $$dmb{'data'}{'rx'}{'last'}; | ||||
1355 | my $nth = $$dmb{'data'}{'rx'}{'nth'}[0]; | ||||
1356 | my $nth_wom = $$dmb{'data'}{'rx'}{'nth_wom'}[0]; | ||||
1357 | my $nth_dom = $$dmb{'data'}{'rx'}{'nth_dom'}[0]; | ||||
1358 | |||||
1359 | my $day_abb = $$dmb{'data'}{'rx'}{'day_abb'}[0]; | ||||
1360 | my $day_name = $$dmb{'data'}{'rx'}{'day_name'}[0]; | ||||
1361 | my $mon_abb = $$dmb{'data'}{'rx'}{'month_abb'}[0]; | ||||
1362 | my $mon_name = $$dmb{'data'}{'rx'}{'month_name'}[0]; | ||||
1363 | |||||
1364 | my $beg = '(?:^|\s+)'; | ||||
1365 | my $end = '(?:\s*$)'; | ||||
1366 | |||||
1367 | $month = "$beg(?<month>$month)"; # months | ||||
1368 | $week = "$beg(?<week>$week)"; # weeks | ||||
1369 | $day = "$beg(?<day>$day)"; # days | ||||
1370 | |||||
1371 | $last = "$beg(?<last>$last)"; # last | ||||
1372 | $nth = "$beg(?<nth>$nth)"; # 1st,2nd,... | ||||
1373 | $nth_wom = "$beg(?<nth>$nth_wom)"; # 1st - 5th | ||||
1374 | $nth_dom = "$beg(?<nth>$nth_dom)"; # 1st - 31st | ||||
1375 | my $n = "$beg(?<n>\\d+)"; # 1,2,... | ||||
1376 | |||||
1377 | my $dow = "$beg(?:(?<day_name>$day_name)|(?<day_abb>$day_abb))"; # Sun|Sunday | ||||
1378 | my $mmm = "$beg(?:(?<mon_name>$mon_name)|(?<mon_abb>$mon_abb))"; # Jan|January | ||||
1379 | |||||
1380 | my $y = "(?:$beg(?:(?<y>\\d\\d\\d\\d)|(?<y>\\d\\d)))?"; | ||||
1381 | |||||
1382 | my $freqrx = | ||||
1383 | "$nth_wom?$dow$mmm$y|" . # every DoW in MMM [YY] | ||||
1384 | "$last$dow$mmm$y|" . # Nth DoW in MMM [YY] | ||||
1385 | # last DoW in MMM [YY] | ||||
1386 | # day_name|day_abb | ||||
1387 | # mon_name|mon_abb | ||||
1388 | # last*|nth* | ||||
1389 | # y* | ||||
1390 | "$nth_wom?$dow$month$y|" . # every DoW of every month [YY] | ||||
1391 | "$last$dow$month$y|" . # Nth DoW of every month [YY] | ||||
1392 | # last DoW of every month [YY] | ||||
1393 | # day_name|day_abb | ||||
1394 | # last*|nth* | ||||
1395 | # y* | ||||
1396 | "$nth_dom?$day$month$y|" . # every day of every month [YY] | ||||
1397 | "$last$day$month$y|" . # Nth day of every month [YY] | ||||
1398 | # last day of every month [YY] | ||||
1399 | # day | ||||
1400 | # month | ||||
1401 | # nth*|last* | ||||
1402 | # y* | ||||
1403 | "$nth*$day$y|" . # every day [YY] | ||||
1404 | "$n$day$y"; # every Nth day [YY] | ||||
1405 | # every N days [YY] | ||||
1406 | # day | ||||
1407 | # nth*|n* | ||||
1408 | # y* | ||||
1409 | |||||
1410 | $freqrx = qr/^(?:$freqrx)\s*$/i; | ||||
1411 | $$dmb{'data'}{'rx'}{'recur'}{$rx} = $freqrx; | ||||
1412 | } | ||||
1413 | |||||
1414 | return $$dmb{'data'}{'rx'}{'recur'}{$rx}; | ||||
1415 | } | ||||
1416 | |||||
1417 | ######################################################################## | ||||
1418 | # MISC | ||||
1419 | ######################################################################## | ||||
1420 | |||||
1421 | # This returns the date easter occurs on for a given year as ($month,$day). | ||||
1422 | # This is from the Calendar FAQ. | ||||
1423 | # | ||||
1424 | sub _easter { | ||||
1425 | my($self,$y) = @_; | ||||
1426 | |||||
1427 | my($c) = $y/100; | ||||
1428 | my($g) = $y % 19; | ||||
1429 | my($k) = ($c-17)/25; | ||||
1430 | my($i) = ($c - $c/4 - ($c-$k)/3 + 19*$g + 15) % 30; | ||||
1431 | $i = $i - ($i/28)*(1 - ($i/28)*(29/($i+1))*((21-$g)/11)); | ||||
1432 | my($j) = ($y + $y/4 + $i + 2 - $c + $c/4) % 7; | ||||
1433 | my($l) = $i-$j; | ||||
1434 | my($m) = 3 + ($l+40)/44; | ||||
1435 | my($d) = $l + 28 - 31*($m/4); | ||||
1436 | return ($m,$d); | ||||
1437 | } | ||||
1438 | |||||
1439 | # This returns 1 if a field is empty. | ||||
1440 | # | ||||
1441 | sub _field_empty { | ||||
1442 | my($self,$val) = @_; | ||||
1443 | |||||
1444 | if (ref($val)) { | ||||
1445 | my @tmp = @$val; | ||||
1446 | return 1 if ($#tmp == -1 || | ||||
1447 | ($#tmp == 0 && ! ref($tmp[0]) && ! $tmp[0])); | ||||
1448 | return 0; | ||||
1449 | |||||
1450 | } else { | ||||
1451 | return $val; | ||||
1452 | } | ||||
1453 | } | ||||
1454 | |||||
1455 | # This returns a list of values as determined by the interval value, | ||||
1456 | # the base date, and the range. | ||||
1457 | # | ||||
1458 | # Usage: | ||||
1459 | # _int_values($every,$y,$m,$w,$d,$h,$mn,$s,$start,$end); | ||||
1460 | # | ||||
1461 | # Every argument is optional (except $every and $y), so the following | ||||
1462 | # are valid: | ||||
1463 | # _int_values($every,$y,$m,$start,$end); | ||||
1464 | # _int_values($every,$y,$m,$w,$d,$start,$end); | ||||
1465 | # | ||||
1466 | sub _int_values { | ||||
1467 | my($self,$every,@args) = @_; | ||||
1468 | my $end = pop(@args); | ||||
1469 | my $start = pop(@args); | ||||
1470 | my $dmb = $$self{'objs'}{'base'}; | ||||
1471 | my @vals; | ||||
1472 | |||||
1473 | # Get the start, end, and base dates. | ||||
1474 | # | ||||
1475 | # Also, get the range of dates to search (which is the start and end | ||||
1476 | # dates adjusted due to various modifiers. | ||||
1477 | |||||
1478 | my $base = $$self{'data'}{'base'}; | ||||
1479 | my @base = @{ $$base{'data'}{'date'} }; | ||||
1480 | |||||
1481 | my @start = @{ $$start{'data'}{'date'} }; | ||||
1482 | my @startm = @{ $$self{'data'}{'startm'} }; | ||||
1483 | |||||
1484 | my @end = @{ $$end{'data'}{'date'} }; | ||||
1485 | my @endm = @{ $$self{'data'}{'endm'} }; | ||||
1486 | |||||
1487 | my @date0 = @{ $dmb->calc_date_delta(\@start,\@startm) }; | ||||
1488 | my @date1 = @{ $dmb->calc_date_delta(\@end,\@endm) }; | ||||
1489 | |||||
1490 | # Get the delta which will be used to adjust the base date | ||||
1491 | # from one recurrence to the next. | ||||
1492 | |||||
1493 | my @delta = @args; | ||||
1494 | while ($#delta < 6) { | ||||
1495 | push(@delta,0); | ||||
1496 | } | ||||
1497 | |||||
1498 | # The base date will be used as the date for one recurrence. | ||||
1499 | # | ||||
1500 | # To begin with, move it so that it is before date0 (we have to | ||||
1501 | # use the $subtract=2 form so we make sure that each step backward | ||||
1502 | # results in a date which can step forward to the base date. | ||||
1503 | |||||
1504 | while ($dmb->cmp(\@base,\@date0) > -1) { | ||||
1505 | @base = @{ $start->__calc_date_delta_inverse([@base],[@delta]) }; | ||||
1506 | } | ||||
1507 | |||||
1508 | # Now, move the base date to be on or after date0 | ||||
1509 | |||||
1510 | while ($dmb->cmp(\@base,\@date0) == -1) { | ||||
1511 | @base = @{ $dmb->calc_date_delta(\@base,\@delta) }; | ||||
1512 | } | ||||
1513 | |||||
1514 | # While the base date is on or before date1, add it to the | ||||
1515 | # list and move forward. | ||||
1516 | |||||
1517 | while ($dmb->cmp(\@base,\@date1) < 1) { | ||||
1518 | push(@vals,[@base]); | ||||
1519 | @base = @{ $dmb->calc_date_delta(\@base,\@delta) }; | ||||
1520 | } | ||||
1521 | |||||
1522 | return @vals; | ||||
1523 | } | ||||
1524 | |||||
1525 | # This returns a list of values that appear in a field in the rtime. | ||||
1526 | # | ||||
1527 | # $val is a listref, with each element being a value or a range. | ||||
1528 | # | ||||
1529 | # Usage: | ||||
1530 | # _rtime_values('y' ,$y); | ||||
1531 | # _rtime_values('m' ,$m); | ||||
1532 | # _rtime_values('week_of_year' ,$w ,$y); | ||||
1533 | # _rtime_values('dow_of_year' ,$w ,$y,$dow); | ||||
1534 | # _rtime_values('dow_of_month' ,$w ,$y,$m,$dow); | ||||
1535 | # _rtime_values('day_of_year' ,$d ,$y); | ||||
1536 | # _rtime_values('day_of_month' ,$d ,$y,$m); | ||||
1537 | # _rtime_values('day_of_week' ,$d); | ||||
1538 | # _rtime_values('h' ,$h); | ||||
1539 | # _rtime_values('mn' ,$mn); | ||||
1540 | # _rtime_values('s' ,$s); | ||||
1541 | # | ||||
1542 | # Returns ($err,@vals) | ||||
1543 | # | ||||
1544 | sub _rtime_values { | ||||
1545 | my($self,$type,$val,@args) = @_; | ||||
1546 | my $dmb = $$self{'objs'}{'base'}; | ||||
1547 | |||||
1548 | given($type) { | ||||
1549 | |||||
1550 | when ('h') { | ||||
1551 | @args = (0,0,23,23); | ||||
1552 | } | ||||
1553 | |||||
1554 | when ('mn') { | ||||
1555 | @args = (0,0,59,59); | ||||
1556 | } | ||||
1557 | |||||
1558 | when ('s') { | ||||
1559 | @args = (0,0,59,59); | ||||
1560 | } | ||||
1561 | |||||
1562 | when ('y') { | ||||
1563 | my ($curry) = $dmb->_now('y',1); | ||||
1564 | foreach my $y (@$val) { | ||||
1565 | $y = $curry if (! ref($y) && $y==0); | ||||
1566 | } | ||||
1567 | |||||
1568 | @args = (0,1,9999,9999); | ||||
1569 | } | ||||
1570 | |||||
1571 | when ('m') { | ||||
1572 | @args = (0,1,12,12); | ||||
1573 | } | ||||
1574 | |||||
1575 | when ('week_of_year') { | ||||
1576 | my($y) = @args; | ||||
1577 | my $wiy = $dmb->weeks_in_year($y); | ||||
1578 | @args = (1,1,$wiy,53); | ||||
1579 | } | ||||
1580 | |||||
1581 | when ('dow_of_year') { | ||||
1582 | my($y,$dow) = @args; | ||||
1583 | |||||
1584 | # Get the 1st occurence of $dow | ||||
1585 | my $d0 = 1; | ||||
1586 | my $dow0 = $dmb->day_of_week([$y,1,$d0]); | ||||
1587 | if ($dow > $dow0) { | ||||
1588 | $d0 += ($dow-$dow0); | ||||
1589 | } elsif ($dow < $dow0) { | ||||
1590 | $d0 += 7-($dow0-$dow); | ||||
1591 | } | ||||
1592 | |||||
1593 | # Get the last occurrence of $dow | ||||
1594 | my $d1 = 31; | ||||
1595 | my $dow1 = $dmb->day_of_week([$y,12,$d1]); | ||||
1596 | if ($dow1 > $dow) { | ||||
1597 | $d1 -= ($dow1-$dow); | ||||
1598 | } elsif ($dow1 < $dow) { | ||||
1599 | $d1 -= 7-($dow-$dow1); | ||||
1600 | } | ||||
1601 | |||||
1602 | # Find out the number of occurrenced of $dow | ||||
1603 | my $doy1 = $dmb->day_of_year([$y,12,$d1]); | ||||
1604 | my $n = ($doy1 - $d0)/7 + 1; | ||||
1605 | |||||
1606 | # Get the list of @w | ||||
1607 | @args = (1,1,$n,53); | ||||
1608 | } | ||||
1609 | |||||
1610 | when ('dow_of_month') { | ||||
1611 | my($y,$m,$dow) = @args; | ||||
1612 | |||||
1613 | # Get the 1st occurence of $dow in the month | ||||
1614 | my $d0 = 1; | ||||
1615 | my $dow0 = $dmb->day_of_week([$y,$m,$d0]); | ||||
1616 | if ($dow > $dow0) { | ||||
1617 | $d0 += ($dow-$dow0); | ||||
1618 | } elsif ($dow < $dow0) { | ||||
1619 | $d0 += 7-($dow0-$dow); | ||||
1620 | } | ||||
1621 | |||||
1622 | # Get the last occurrence of $dow | ||||
1623 | my $d1 = $dmb->days_in_month($y,$m); | ||||
1624 | my $dow1 = $dmb->day_of_week([$y,$m,$d1]); | ||||
1625 | if ($dow1 > $dow) { | ||||
1626 | $d1 -= ($dow1-$dow); | ||||
1627 | } elsif ($dow1 < $dow) { | ||||
1628 | $d1 -= 7-($dow-$dow1); | ||||
1629 | } | ||||
1630 | |||||
1631 | # Find out the number of occurrenced of $dow | ||||
1632 | my $n = ($d1 - $d0)/7 + 1; | ||||
1633 | |||||
1634 | # Get the list of @w | ||||
1635 | @args = (1,1,$n,5); | ||||
1636 | } | ||||
1637 | |||||
1638 | when ('day_of_year') { | ||||
1639 | my($y) = @args; | ||||
1640 | my $diy = $dmb->days_in_year($y); | ||||
1641 | @args = (1,1,$diy,366); | ||||
1642 | } | ||||
1643 | |||||
1644 | when ('day_of_month') { | ||||
1645 | my($y,$m) = @args; | ||||
1646 | my $dim = $dmb->days_in_month($y,$m); | ||||
1647 | @args = (1,1,$dim,31); | ||||
1648 | } | ||||
1649 | |||||
1650 | when ('day_of_week') { | ||||
1651 | @args = (0,1,7,7); | ||||
1652 | } | ||||
1653 | } | ||||
1654 | |||||
1655 | my($err,@vals) = $self->__rtime_values($val,@args); | ||||
1656 | if ($err) { | ||||
1657 | $$self{'err'} = "[dates] $err [$type]"; | ||||
1658 | return (1); | ||||
1659 | } | ||||
1660 | return(0,@vals); | ||||
1661 | } | ||||
1662 | |||||
1663 | # This returns the raw values for a list. | ||||
1664 | # | ||||
1665 | # If $allowneg is 0, only positive numbers are allowed, and they must be | ||||
1666 | # in the range [$min,$absmax]. If $allowneg is 1, positive numbers in the | ||||
1667 | # range [$min,$absmax] and negative numbers in the range [-$absmax,-$min] | ||||
1668 | # are allowed. An error occurs if a value falls outside the range. | ||||
1669 | # | ||||
1670 | # Only values in the range of [$min,$max] are actually kept. This allows | ||||
1671 | # a recurrence for day_of_month to be 1-31 and not fail for a month that | ||||
1672 | # has fewer than 31 days. Any value outside the [$min,$max] are silently | ||||
1673 | # discarded. | ||||
1674 | # | ||||
1675 | # Returns: | ||||
1676 | # ($err,@vals) | ||||
1677 | # | ||||
1678 | sub __rtime_values { | ||||
1679 | my($self,$vals,$allowneg,$min,$max,$absmax) = @_; | ||||
1680 | my(@ret); | ||||
1681 | |||||
1682 | foreach my $val (@$vals) { | ||||
1683 | |||||
1684 | if (ref($val)) { | ||||
1685 | my($val1,$val2) = @$val; | ||||
1686 | |||||
1687 | if ($allowneg) { | ||||
1688 | return ('Value outside range') | ||||
1689 | if ( ($val1 >= 0 && ($val1 < $min || $val1 > $absmax) ) || | ||||
1690 | ($val2 >= 0 && ($val2 < $min || $val2 > $absmax) ) ); | ||||
1691 | return ('Negative value outside range') | ||||
1692 | if ( ($val1 <= 0 && ($val1 < -$absmax || $val1 > -$min) ) || | ||||
1693 | ($val2 <= 0 && ($val2 < -$absmax || $val2 > -$min) ) ); | ||||
1694 | |||||
1695 | } else { | ||||
1696 | return ('Value outside range') | ||||
1697 | if ( ($val1 < $min || $val1 > $absmax) || | ||||
1698 | ($val2 < $min || $val2 > $absmax) ); | ||||
1699 | |||||
1700 | } | ||||
1701 | |||||
1702 | return ('Range values reversed') | ||||
1703 | if ( ($val1 <= 0 && $val2 <= 0 && $val1 > $val2) || | ||||
1704 | ($val1 >= 0 && $val2 >= 0 && $val1 > $val2) ); | ||||
1705 | |||||
1706 | # Use $max instead of $absmax when converting negative numbers to | ||||
1707 | # positive ones. | ||||
1708 | |||||
1709 | $val1 = $max + $val1 + 1 if ($val1 < 0); # day -10 | ||||
1710 | $val2 = $max + $val2 + 1 if ($val2 < 0); | ||||
1711 | |||||
1712 | $val1 = $min if ($val1 < $min); # day -31 in a 30 day month | ||||
1713 | $val2 = $max if ($val2 > $max); | ||||
1714 | |||||
1715 | next if ($val1 > $val2); | ||||
1716 | |||||
1717 | push(@ret,$val1..$val2); | ||||
1718 | |||||
1719 | } else { | ||||
1720 | |||||
1721 | if ($allowneg) { | ||||
1722 | return ('Value outside range') | ||||
1723 | if ($val >= 0 && ($val < $min || $val > $absmax)); | ||||
1724 | return ('Negative value outside range') | ||||
1725 | if ($val <= 0 && ($val < -$absmax || $val > -$min)); | ||||
1726 | } else { | ||||
1727 | return ('Value outside range') | ||||
1728 | if ($val < $min || $val > $absmax); | ||||
1729 | } | ||||
1730 | |||||
1731 | # Use $max instead of $absmax when converting negative numbers to | ||||
1732 | # positive ones. | ||||
1733 | |||||
1734 | my $ret; | ||||
1735 | if ($val < 0 ) { | ||||
1736 | $ret = $max + $val + 1; | ||||
1737 | } else { | ||||
1738 | $ret = $val; | ||||
1739 | } | ||||
1740 | |||||
1741 | next if ($ret > $max || $ret < $min); | ||||
1742 | push(@ret,$ret); | ||||
1743 | } | ||||
1744 | } | ||||
1745 | |||||
1746 | return ('',@ret); | ||||
1747 | } | ||||
1748 | |||||
1749 | # This takes a list of dates (each a listref of [y,m,d,h,mn,s]) and replaces | ||||
1750 | # the Nth field with all of the possible values passed in, creating a new | ||||
1751 | # list with all the dates. | ||||
1752 | # | ||||
1753 | sub _field_add_values { | ||||
1754 | my($self,$datesref,$n,@val) = @_; | ||||
1755 | |||||
1756 | my @dates = @$datesref; | ||||
1757 | my @tmp; | ||||
1758 | |||||
1759 | foreach my $date (@dates) { | ||||
1760 | my @d = @$date; | ||||
1761 | foreach my $val (@val) { | ||||
1762 | $d[$n] = $val; | ||||
1763 | push(@tmp,[@d]); | ||||
1764 | } | ||||
1765 | } | ||||
1766 | |||||
1767 | @$datesref = @tmp; | ||||
1768 | } | ||||
1769 | |||||
1770 | 1 | 5µs | 1; | ||
1771 | # Local Variables: | ||||
1772 | # mode: cperl | ||||
1773 | # indent-tabs-mode: nil | ||||
1774 | # cperl-indent-level: 3 | ||||
1775 | # cperl-continued-statement-offset: 2 | ||||
1776 | # cperl-continued-brace-offset: 0 | ||||
1777 | # cperl-brace-offset: 0 | ||||
1778 | # cperl-brace-imaginary-offset: 0 | ||||
1779 | # cperl-label-offset: -2 | ||||
1780 | # End: |