File Coverage

lib/Date/Manip/Recur.pm
Criterion Covered Total %
statement 1154 1308 88.2
branch 649 818 79.3
condition 182 279 65.2
subroutine 37 37 100.0
pod 11 11 100.0
total 2033 2453 82.8


line stmt bran cond sub pod time code
1             package Date::Manip::Recur;
2             # Copyright (c) 1998-2023 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 168     168   1051 use Date::Manip::Obj;
  168         320  
  168         6956  
15             @ISA = ('Date::Manip::Obj');
16              
17             require 5.010000;
18 168     168   814 use warnings;
  168         274  
  168         3973  
19 168     168   782 use strict;
  168         304  
  168         3225  
20 168     168   768 use integer;
  168         325  
  168         5971  
21 168     168   4352 use utf8;
  168         343  
  168         882  
22 168     168   3957 use IO::File;
  168         359  
  168         22607  
23             #use re 'debug';
24              
25 168     168   1016 use Date::Manip::Base;
  168         315  
  168         4862  
26 168     168   876 use Date::Manip::TZ;
  168         317  
  168         1921528  
27              
28             our $VERSION;
29             $VERSION='6.92';
30 168     168   2207 END { undef $VERSION; }
31              
32             ########################################################################
33             # BASE METHODS
34             ########################################################################
35              
36             sub is_recur {
37 1     1 1 92 return 1;
38             }
39              
40             # Call this every time a new recur is put in to make sure everything is
41             # correctly initialized.
42             #
43             sub _init {
44 1718     1718   2942 my($self) = @_;
45 1718         5776 my $dmt = $$self{'tz'};
46 1718         2524 my $dmb = $$dmt{'base'};
47              
48 1718         2559 $$self{'err'} = '';
49              
50 1718         2716 $$self{'data'}{'freq'} = ''; # The frequency
51 1718         3101 $$self{'data'}{'flags'} = []; # Modifiers
52 1718         3586 $$self{'data'}{'base'} = undef; # The specified base date
53 1718         2476 $$self{'data'}{'BASE'} = undef; # The actual base date
54 1718         3336 $$self{'data'}{'start'} = undef; # Start and end date
55 1718         3100 $$self{'data'}{'end'} = undef;
56 1718         4110 $$self{'data'}{'unmod_range'} = 0; # If this is 1, the start/end range
57             # refer to the unmodified dates, not the
58             # final dates.
59              
60 1718         2999 $$self{'data'}{'interval'} = []; # (Y, M, ...)
61 1718         3258 $$self{'data'}{'rtime'} = []; # ( [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
62             # [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
63             # ... )
64 1718         2392 $$self{'data'}{'slow'} = 0; # 1 if a range of the form 2--2 is
65             # included.
66 1718         2358 $$self{'data'}{'ev_per_d'} = 0; # The number of events per interval date.
67 1718         4326 $$self{'data'}{'delta'} = undef; # The offset based on the interval.
68 1718         2537 $$self{'data'}{'noint'} = 1; # 0 if an interval is present
69             # 1 if no interval is present and dates
70             # not done
71             # 2 if no interval is present and dates
72             # done
73              
74 1718         6754 $$self{'data'}{'idate'} = {}; # Non-slow:
75             # { N => Nth interval date }
76             # Slow:
77             # { N => [Nth interval date,X,Y] }
78             # [X,Y] are the first/last event indices
79             # generated by this interval date.
80 1718         5931 $$self{'data'}{'dates'} = {}; # { N => Nth recurring event }
81             # N is relative to the base date and is
82             # not affected by start/end
83 1718         2711 $$self{'data'}{'curr'} = undef; # Iterator pointer
84 1718         2424 $$self{'data'}{'first'} = undef; # N : the first date in a range
85 1718         2412 $$self{'data'}{'last'} = undef; # N : the last date in a range
86              
87             # Get the default start/end dates
88              
89 1718         4529 my $range = $dmb->_config('recurrange');
90              
91 1718 50       3522 if ($range eq 'none') {
    0          
    0          
    0          
    0          
    0          
92 1718         2411 $$self{'data'}{'start'} = undef;
93 1718         2837 $$self{'data'}{'end'} = undef;
94              
95             } elsif ($range eq 'year') {
96 0         0 my $y = $dmt->_now('y',1);
97 0         0 my $start = $self->new_date();
98 0         0 my $end = $self->new_date();
99 0         0 $start->set('date',[$y, 1, 1,00,00,00]);
100 0         0 $end->set ('date',[$y,12,31,23,59,59]);
101 0         0 $$self{'data'}{'start'} = $start;
102 0         0 $$self{'data'}{'end'} = $end;
103              
104             } elsif ($range eq 'month') {
105 0         0 my ($y,$m) = $dmt->_now('now',1);
106 0         0 my $dim = $dmb->days_in_month($y,$m);
107 0         0 my $start = $self->new_date();
108 0         0 my $end = $self->new_date();
109 0         0 $start->set('date',[$y,$m, 1,00,00,00]);
110 0         0 $end->set ('date',[$y,$m,$dim,23,59,59]);
111 0         0 $$self{'data'}{'start'} = $start;
112 0         0 $$self{'data'}{'end'} = $end;
113              
114             } elsif ($range eq 'week') {
115 0         0 my($y,$m,$d) = $dmt->_now('now',1);
116 0         0 my $w;
117 0         0 ($y,$w) = $dmb->week_of_year([$y,$m,$d]);
118 0         0 ($y,$m,$d) = @{ $dmb->week_of_year($y,$w) };
  0         0  
119             my($yy,$mm,$dd)
120 0         0 = @{ $dmb->_calc_date_ymwd([$y,$m,$d], [0,0,0,6], 0) };
  0         0  
121              
122 0         0 my $start = $self->new_date();
123 0         0 my $end = $self->new_date();
124 0         0 $start->set('date',[$y, $m, $d, 00,00,00]);
125 0         0 $end->set ('date',[$yy,$mm,$dd,23,59,59]);
126 0         0 $$self{'data'}{'start'} = $start;
127 0         0 $$self{'data'}{'end'} = $end;
128              
129             } elsif ($range eq 'day') {
130 0         0 my($y,$m,$d) = $dmt->_now('now',1);
131 0         0 my $start = $self->new_date();
132 0         0 my $end = $self->new_date();
133 0         0 $start->set('date',[$y,$m,$d,00,00,00]);
134 0         0 $end->set ('date',[$y,$m,$d,23,59,59]);
135 0         0 $$self{'data'}{'start'} = $start;
136 0         0 $$self{'data'}{'end'} = $end;
137              
138             } elsif ($range eq 'all') {
139 0         0 my $start = $self->new_date();
140 0         0 my $end = $self->new_date();
141 0         0 $start->set('date',[0001,02,01,00,00,00]);
142 0         0 $end->set ('date',[9999,11,30,23,59,59]);
143 0         0 $$self{'data'}{'start'} = $start;
144 0         0 $$self{'data'}{'end'} = $end;
145             }
146             }
147              
148             # If $keep is 1, it will keep any existing base date and cached
149             # dates, but it will reset other things.
150             #
151             sub _init_dates {
152 1603     1603   3018 my($self,$keep) = @_;
153              
154 1603 100       3143 if (! $keep) {
155 1097         2417 $$self{'data'}{'base'} = undef;
156 1097         1824 $$self{'data'}{'BASE'} = undef;
157 1097         13637 $$self{'data'}{'idate'} = {};
158 1097         9767 $$self{'data'}{'dates'} = {};
159             }
160 1603         2663 $$self{'data'}{'curr'} = undef;
161 1603         2526 $$self{'data'}{'first'} = undef;
162 1603         2862 $$self{'data'}{'last'} = undef;
163             }
164              
165             sub _init_args {
166 2     2   5 my($self) = @_;
167              
168 2         4 my @args = @{ $$self{'args'} };
  2         7  
169 2         8 $self->parse(@args);
170             }
171              
172             ########################################################################
173             # METHODS
174             ########################################################################
175              
176             sub parse {
177 487     487 1 316210 my($self,$string,@args) = @_;
178 487         1801 $self->_init();
179              
180             # Test if $string = FREQ
181              
182 487         1644 my $err = $self->frequency($string);
183 487 100       1066 if (! $err) {
184 364         557 $string = '';
185             }
186              
187             # Test if $string = "FREQ*..." and FREQ contains an '*'.
188              
189 487 100       1109 if ($err) {
190 123         460 $self->err(1);
191              
192 123         702 $string =~ s/\s*\*\s*/\*/g;
193              
194 123 50       501 if ($string =~ /^([^*]*\*[^*]*)\*/) {
195             # Everything up to the 2nd '*'
196 123         323 my $freq = $1;
197 123         319 $err = $self->frequency($freq);
198 123 50       264 if (! $err) {
199 123         1774 $string =~ s/^\Q$freq\E\*//;
200             }
201             } else {
202 0         0 $err = 1;
203             }
204             }
205              
206             # Test if $string = "FREQ*..." and FREQ does NOT contains an '*'.
207              
208 487 50       1147 if ($err) {
209 0         0 $self->err(1);
210              
211 0 0       0 if ($string =~ s/^([^*]*)\*//) {
212             # Everything up to he 1st '*'
213 0         0 my $freq = $1;
214 0         0 $err = $self->frequency($freq);
215 0 0       0 if (! $err) {
216 0         0 $string =~ s/^\Q$freq\E\*//;
217             }
218             } else {
219 0         0 $err = 1;
220             }
221             }
222              
223 487 50       1126 if ($err) {
224 0         0 $$self{'err'} = "[parse] Invalid frequency string";
225 0         0 return 1;
226             }
227              
228             # Handle MODIFIERS from string and arguments
229              
230 487         1176 my @string = split(/\*/,$string);
231              
232 487 100       1092 if (@string) {
233 123         225 my $tmp = shift(@string);
234 123 100       408 $err = $self->modifiers($tmp) if ($tmp);
235 123 50       260 return 1 if ($err);
236             }
237              
238 487 100       1058 if (@args) {
239 266         416 my $tmp = $args[0];
240 266 100 66     1013 if ($tmp && ! ref($tmp)) {
241 207         739 $err = $self->modifiers($tmp);
242 207 100       575 shift(@args) if (! $err);
243             }
244             }
245              
246             # Handle BASE
247              
248 487 100       1147 if (@string) {
249 25         50 my $tmp = shift(@string);
250 25 100 66     129 $err = $self->basedate($tmp) if (defined($tmp) && $tmp);
251 25 50       66 return 1 if ($err);
252             }
253 487 100       1080 if (@args) {
254 265         402 my $tmp = shift(@args);
255 265 100 66     1121 $err = $self->basedate($tmp) if (defined($tmp) && $tmp);
256 265 50       524 return 1 if ($err);
257             }
258              
259             # Handle START, END, UNMOD
260              
261 487 100       954 if (@string) {
262 24         56 my($start) = shift(@string);
263 24         48 my($end) = shift(@string);
264 24         49 my($unmod) = shift(@string);
265              
266 24 50 33     189 $err = $self->start($start,$unmod) if (defined($start) && $start);
267 24 50       68 return 1 if ($err);
268              
269 24 50 33     164 $err = $self->end($end) if (defined($end) && $end);
270 24 50       83 return 1 if ($err);
271             }
272 487 100       988 if (@args) {
273 265         505 my($start) = shift(@args);
274 265         498 my($end) = shift(@args);
275 265         506 my($unmod) = shift(@args);
276              
277 265 100 66     1414 $err = $self->start($start,$unmod) if (defined($start) && $start);
278 265 50       699 return 1 if ($err);
279              
280 265 100 66     1271 $err = $self->end($end) if (defined($end) && $end);
281 265 50       793 return 1 if ($err);
282             }
283              
284             # Remaining arguments are invalid.
285              
286 487 50       1072 if (@string) {
287 0         0 $$self{'err'} = "[parse] String contains invalid elements";
288 0         0 return 1;
289             }
290 487 50       1035 if (@args) {
291 0         0 $$self{'err'} = "[parse] Unknown arguments";
292 0         0 return 1;
293             }
294              
295 487         1227 return 0;
296             }
297              
298             sub frequency {
299 942     942 1 296792 my($self,$string) = @_;
300 942 50       1982 return $$self{'data'}{'freq'} if (! defined $string);
301              
302 942         2065 $self->_init();
303 942         1224 my (@int,@rtime);
304              
305             PARSE: {
306              
307             # Standard frequency notation
308              
309 942         1178 my $stdrx = $self->_rx('std');
  942         2312  
310 942 100       8984 if ($string =~ $stdrx) {
311 782         7233 my($l,$r) = @+{qw(l r)};
312              
313 782 50       2535 if (defined($l)) {
314 782         1701 $l =~ s/^\s*:/0:/;
315 782         1484 $l =~ s/:\s*$/:0/;
316 782         1140 $l =~ s/::/:0:/g;
317              
318 782         1909 @int = split(/:/,$l);
319             }
320              
321 782 50       1612 if (defined($r)) {
322 782         1746 $r =~ s/^\s*:/0:/;
323 782         2056 $r =~ s/:\s*$/:0/;
324 782         1255 $r =~ s/::/:0:/g;
325              
326 782         1968 @rtime = split(/:/,$r);
327             }
328              
329 782         1659 last PARSE;
330             }
331              
332             # Other frequency strings
333              
334             # Strip out some words to ignore
335              
336 160         409 my $ignrx = $self->_rx('ignore');
337 160         1147 $string =~ s/$ignrx/ /g;
338              
339 160         365 my $eachrx = $self->_rx('each');
340 160         266 my $each = 0;
341 160 100       1033 if ($string =~ s/$eachrx/ /g) {
342 28         61 $each = 1;
343             }
344              
345 160         900 $string =~ s/\s*$//;
346              
347 160 50       414 if (! $string) {
348 0         0 $$self{'err'} = "[frequency] Invalid frequency string";
349 0         0 return 1;
350             }
351              
352 160         486 my $err = $self->_parse_lang($string);
353 160 100       390 if ($err) {
354 128         236 $$self{'err'} = "[frequency] Invalid frequency string";
355 128         272 return 1;
356             }
357 32         70 return 0;
358             }
359              
360             # If the interval consists only of zeros, the last entry is changed
361             # to 1.
362              
363 782 100       1808 if (@int) {
364 552         1044 for my $i (@int) {
365 1078         1674 $i += 0;
366             }
367              
368             TEST_INT: {
369 552         719 for my $i (@int) {
  552         872  
370 787 100       1635 last TEST_INT if ($i);
371             }
372 75         145 $int[$#int] = 1;
373             }
374             }
375              
376             # If @int contains 2 or 3 elements and ends in 0, move the trailing
377             # 0 to the start of @rtime.
378             #
379             # Y:M:0 * D:H:MN:S => Y:M * 0:D:H:MN:S
380              
381 782   100     4301 while (@int &&
      100        
      100        
382             ($#int == 1 || $#int == 2) &&
383             ($int[$#int] == 0)) {
384 101         162 pop(@int);
385 101         461 unshift(@rtime,0);
386             }
387              
388             # We need to know what the valid values of M, W, and D are.
389             #
390             # Month can be:
391             # moy : 1 to 12 (month of the year)
392             #
393             # Week can be:
394             # woy : 1 to 53 or -1 to -53 (week of the year)
395             # wom : 1 to 5 or -1 to -5 (week of the month)
396             #
397             # Day can be:
398             # doy : 1 to 366 or -1 to -366 (day of the year)
399             # dom : 1 to DiM or -1 to -31 (day of the month)
400             # dow : 1 to 7 (day of the week)
401             #
402             # Other values must be zero or positive.
403              
404 782         2314 my @ftype = ('y','m','w','d','h','mn','s');
405 782         1802 my @vtype = ('' ,'' ,'' ,'' ,'' ,'' ,'');
406              
407 782         2574 my ($y,$m,$w,$d,$h,$mn,$s) = (@int,@rtime);
408              
409 782 100       1619 if (@rtime == 7) {
410 230         342 $vtype[0] = 'y';
411             }
412              
413 782 100       1656 if (@rtime >= 6) {
414 547 100       949 if ($m) {
415 371         874 $vtype[1] = 'moy';
416             } else {
417 176         256 $vtype[1] = 'zero';
418             }
419             }
420              
421 782 100       1600 if (@rtime >= 5) {
422 685 100       1168 if ($w) {
423 329 100       539 if ($m) {
424 226         361 $vtype[2] = 'wom';
425             } else {
426 103         166 $vtype[2] = 'woy';
427             }
428             } else {
429 356         535 $vtype[2] = 'zero';
430             }
431             }
432              
433 782 100       1682 if (@rtime >= 4) {
434 727 100       1319 if ($d) {
435 528 100       1152 if ($w) {
    100          
436 226         361 $vtype[3] = 'dow';
437             } elsif ($m) {
438 247         401 $vtype[3] = 'dom';
439             } else {
440 55         101 $vtype[3] = 'doy';
441             }
442             } else {
443 199         300 $vtype[3] = 'zero';
444             }
445             }
446              
447 782 100       1547 if (@rtime >= 3) {
448 766         985 $vtype[4] = 'time';
449             }
450 782 100       1603 if (@rtime >= 2) {
451 771         945 $vtype[5] = 'time';
452             }
453 782 100       1494 if (@rtime) {
454 771         1033 $vtype[6] = 'time';
455             }
456              
457             # Test the format of @rtime.
458             #
459             # Turn it to:
460             # @rtime = ( NUM|RANGE, NUM|RANGE, ...)
461             # where
462             # NUM is an integer
463             # RANGE is [NUM1,NUM2]
464              
465 782         1647 my $rfieldrx = $self->_rx('rfield');
466 782         1512 my $rrangerx = $self->_rx('rrange');
467              
468 782         1097 my $i = -1;
469 782         1393 foreach my $f (@int,@rtime) {
470 4772         5040 $i++;
471 4772         5764 my $vtype = $vtype[$i];
472 4772         5231 my $type = $ftype[$i];
473              
474             # $f 3 -6 2-3 1,5-6
475             # $type y m w d h mn s
476             # $vtype '' dom woy time ('' is a frequency field)
477              
478             # Ignore the frequency part
479 4772 100       7024 next if (! $vtype);
480              
481 3795 100 100     15282 if ($f && $f !~ $rfieldrx) {
482 1         4 $$self{'err'} = "[frequency] Invalid rtime string";
483 1         6 return 1;
484             }
485              
486 3794         6981 my @rfield = split(/,/,$f);
487 3794         4252 my @val;
488              
489 3794         4590 foreach my $vals (@rfield) {
490 3858 100       8626 if ($vals =~ $rrangerx) {
491 73         282 my ($num1,$num2) = ($1+0,$2+0);
492              
493 73         181 my $err = $self->_frequency_values($num1,$type,$vtype);
494 73 100       166 return $err if ($err);
495              
496 72         159 $err = $self->_frequency_values($num2,$type,$vtype);
497 72 50       161 return $err if ($err);
498              
499 72 100 100     354 if ( ($num1 > 0 && $num2 > 0) ||
      66        
      100        
500             ($num1 < 0 && $num2 < 0) ) {
501 66 100       143 if ($num1 > $num2) {
502 2         4 $$self{'err'} = "[frequency] Invalid rtime range string";
503 2         10 return 1;
504             }
505 64         187 push(@val,$num1..$num2);
506             } else {
507 6         18 push(@val,[$num1,$num2]);
508             }
509              
510             } else {
511 3785         5359 $vals += 0;
512              
513 3785         6352 my $err = $self->_frequency_values($vals,$type,$vtype);
514 3785 100       6176 return $err if ($err);
515              
516 3609         5511 push(@val,$vals);
517             }
518             }
519              
520 3615         7215 $f = [ @val ];
521             }
522              
523             # Store it
524              
525 602         1541 $$self{'data'}{'interval'} = [ @int ];
526 602         1358 $$self{'data'}{'rtime'} = [ @rtime ];
527              
528             # Analyze the rtime to see if it's slow, and to get the number of
529             # events per interval date.
530              
531 602         1366 my $freq = join(':',@int);
532 602         820 my $slow = 0;
533 602         740 my $n = 1;
534 602 100       1237 if (@rtime) {
535 591         823 $freq .= '*';
536 591         718 my (@tmp);
537              
538 591         906 foreach my $rtime (@rtime) {
539 3418         3528 my @t2;
540 3418         4009 foreach my $tmp (@$rtime) {
541 3694 100       4530 if (ref($tmp)) {
542 6         15 my($a,$b) = @$tmp;
543 6         19 push(@t2,"$a-$b");
544 6         12 $slow = 1;
545             } else {
546 3688         4920 push(@t2,$tmp);
547             }
548             }
549 3418         4869 my $tmp = join(',',@t2);
550 3418         4141 push(@tmp,$tmp);
551 3418         3502 my $nn = @t2;
552 3418         4674 $n *= $nn;
553             }
554 591         1513 $freq .= join(':',@tmp);
555             }
556 602         1146 $$self{'data'}{'freq'} = $freq;
557 602         944 $$self{'data'}{'slow'} = $slow;
558 602 100       1354 $$self{'data'}{'ev_per_d'} = $n if (! $slow);
559              
560 602 100       1072 if (@int) {
561 436         710 $$self{'data'}{'noint'} = 0;
562              
563 436         926 while (@int < 7) {
564 2256         3679 push(@int,0);
565             }
566 436         1584 my $delta = $self->new_delta();
567 436         2086 $delta->set('delta',[@int]);
568 436         1028 $$self{'data'}{'delta'} = $delta;
569              
570             } else {
571 166         259 $$self{'data'}{'noint'} = 1;
572             }
573              
574 602         2345 return 0;
575             }
576              
577             sub _frequency_values {
578 3930     3930   6040 my($self,$num,$type,$vtype) = @_;
579 3930         3902 my $err;
580              
581 3930 100       9655 if ($type eq 'y') {
    100          
    100          
    100          
    100          
582 248 50       432 if ($vtype eq 'y') {
583 248 100 100     792 if ($num < 0 || $num > 9999) {
584 16         30 $$self{'err'} = "[frequency] Year must be in the range 1-9999";
585 16         28 return 1;
586             }
587             }
588              
589             } elsif ($type eq 'm') {
590 572 100       1148 if ($vtype eq 'moy') {
591 404 100 100     1496 if ($num < 1 || $num > 12) {
592 34         52 $$self{'err'} = "[frequency] Month of year must be 1-12";
593 34         347 return 1;
594             }
595             }
596              
597             } elsif ($type eq 'w') {
598 670 100       1825 if ($vtype eq 'woy') {
    100          
599 103 100 66     993 if ($num == 0 || $num > 53 || $num < -53) {
      100        
600 22         36 $$self{'err'} = "[frequency] Week of year must be 1-53 or -1 to -53";
601 22         35 return 1;
602             }
603              
604             } elsif ($vtype eq 'wom') {
605 235 100 66     1309 if ($num == 0 || $num > 5 || $num < -5) {
      100        
606 31         97 $$self{'err'} = "[frequency] Week of month must be 1-5 or -1 to -5";
607 31         58 return 1;
608             }
609              
610             }
611              
612             } elsif ($type eq 'd') {
613 635 100       1901 if ($vtype eq 'dow') {
    100          
    100          
614 190 100 100     754 if ($num < 1 || $num > 7) {
615 36         55 $$self{'err'} = "[frequency] Day of week must be 1-7";
616 36         70 return 1;
617             }
618              
619             } elsif ($vtype eq 'dom') {
620 245 100 66     1291 if ($num == 0 || $num > 31 || $num < -31) {
      100        
621 20         29 $$self{'err'} = "[frequency] Day of month must be 1-31 or -1 to -31";
622 20         37 return 1;
623             }
624              
625             } elsif ($vtype eq 'doy') {
626 55 100 66     316 if ($num == 0 || $num > 366 || $num < -366) {
      100        
627 14         27 $$self{'err'} = "[frequency] Day of year must be 1-366 or -1 to -366";
628 14         20 return 1;
629             }
630             }
631              
632             } elsif ($type eq 'h') {
633 614 50       1232 if ($vtype eq 'time') {
634 614 100 66     2222 if ($num < 0 || $num > 23) {
635 1         2 $$self{'err'} = "[frequency] Hour must be 0-23";
636 1         3 return 1;
637             }
638             }
639              
640             } else {
641 1191 50       2103 if ($vtype eq 'time') {
642 1191 100 66     3482 if ($num < 0 || $num > 59) {
643 3         7 $$self{'err'} = "[frequency] Minute/second must be 0-59";
644 3         4 return 1;
645             }
646             }
647             }
648              
649 3753         5519 return 0;
650             }
651              
652             sub _parse_lang {
653 160     160   325 my($self,$string) = @_;
654 160         273 my $dmt = $$self{'tz'};
655 160         235 my $dmb = $$dmt{'base'};
656              
657             # Test the regular expression
658              
659 160         307 my $rx = $self->_rx('every');
660              
661 160 100       2583 return 1 if ($string !~ $rx);
662             my($month,$week,$day,$last,$nth,$day_name,$day_abb,$mon_name,$mon_abb,$n,$y) =
663 32         759 @+{qw(month week day last nth day_name day_abb mon_name mon_abb n y)};
664              
665             # Convert wordlist values to calendar values
666              
667 32         125 my $dow;
668 32 100 66     121 if (defined($day_name) || defined($day_abb)) {
669 16 50       40 if (defined($day_name)) {
670 16         69 $dow = $$dmb{'data'}{'wordmatch'}{'day_name'}{lc($day_name)};
671             } else {
672 0         0 $dow = $$dmb{'data'}{'wordmatch'}{'day_abb'}{lc($day_abb)};
673             }
674             }
675              
676 32         46 my $mmm;
677 32 100 66     133 if (defined($mon_name) || defined($mon_abb)) {
678 8 50       21 if (defined($mon_name)) {
679 8         28 $mmm = $$dmb{'data'}{'wordmatch'}{'month_name'}{lc($mon_name)};
680             } else {
681 0         0 $mmm = $$dmb{'data'}{'wordmatch'}{'month_abb'}{lc($mon_abb)};
682             }
683             }
684              
685 32 100       72 if (defined($nth)) {
686 14         55 $nth = $$dmb{'data'}{'wordmatch'}{'nth'}{lc($nth)};
687             }
688              
689             # Get the frequencies
690              
691 32         41 my($freq);
692 32 100       89 if (defined($dow)) {
    50          
693 16 100       42 if (defined($mmm)) {
694 8 100       27 if (defined($last)) {
    100          
695             # last DoW in MMM [YY]
696 2         7 $freq = "1*$mmm:-1:$dow:0:0:0";
697              
698             } elsif (defined($nth)) {
699             # Nth DoW in MMM [YY]
700 4         19 $freq = "1*$mmm:$nth:$dow:0:0:0";
701              
702             } else {
703             # every DoW in MMM [YY]
704 2         7 $freq = "1*$mmm:1-5:$dow:0:0:0";
705             }
706              
707             } else {
708 8 100       25 if (defined($last)) {
    100          
709             # last DoW in every month [in YY]
710 2         8 $freq = "0:1*-1:$dow:0:0:0";
711              
712             } elsif (defined($nth)) {
713             # Nth DoW in every month [in YY]
714 4         26 $freq = "0:1*$nth:$dow:0:0:0";
715              
716             } else {
717             # every DoW in every month [in YY]
718 2         7 $freq = "0:1*1-5:$dow:0:0:0";
719             }
720             }
721              
722             } elsif (defined($day)) {
723 16 100       35 if (defined($month)) {
724 8 100       21 if (defined($nth)) {
    100          
725             # Nth day of every month [YY]
726 4         14 $freq = "0:1*0:$nth:0:0:0";
727              
728             } elsif (defined($last)) {
729             # last day of every month [YY]
730 2         4 $freq = "0:1*0:-1:0:0:0";
731              
732             } else {
733             # every day of every month [YY]
734 2         5 $freq = "0:0:0:1*0:0:0";
735             }
736              
737             } else {
738 8 100       22 if (defined($nth)) {
    100          
739             # every Nth day [YY]
740 2         7 $freq = "0:0:0:$nth*0:0:0";
741              
742             } elsif (defined($n)) {
743             # every N days [YY]
744 4         10 $freq = "0:0:0:$n*0:0:0";
745              
746             } else {
747             # every day [YY]
748 2         3 $freq = "0:0:0:1*0:0:0";
749             }
750             }
751             }
752              
753             # Get the range (if YY is included)
754              
755 32 100       83 if (defined($y)) {
756 18         76 $y = $dmt->_fix_year($y);
757 18         45 my $start = "${y}010100:00:00";
758 18         38 my $end = "${y}123123:59:59";
759              
760 18         114 return $self->parse($freq,undef,$start,$end);
761             }
762              
763 14         45 return $self->frequency($freq)
764             }
765              
766             sub _date {
767 679     679   1358 my($self,$op,$date_or_string) = @_;
768              
769             # Make sure the argument is a date
770              
771 679 50       1746 if (ref($date_or_string) eq 'Date::Manip::Date') {
    50          
772 0         0 $$self{'data'}{$op} = $date_or_string;
773              
774             } elsif (ref($date_or_string)) {
775 0         0 $$self{'err'} = "[$op] Invalid date object";
776 0         0 return 1;
777              
778             } else {
779 679         1799 my $date = $self->new_date();
780 679         1802 my $err = $date->parse($date_or_string);
781 679 50       1260 if ($err) {
782 0         0 $$self{'err'} = "[$op] Invalid date string";
783 0         0 return 1;
784             }
785 679         1565 $$self{'data'}{$op} = $date;
786             }
787              
788 679         1412 return 0;
789             }
790              
791             sub start {
792 1019     1019 1 2423 my($self,$start,$unmod) = @_;
793 1019 100       4691 return $$self{'data'}{'start'} if (! defined $start);
794              
795 253         754 $self->_init_dates(1);
796 253         462 $$self{'data'}{'unmod_range'} = $unmod;
797 253         574 $self->_date('start',$start);
798             }
799              
800             sub end {
801 337     337 1 1128 my($self,$end) = @_;
802 337 100       1061 return $$self{'data'}{'end'} if (! defined $end);
803              
804 253         722 $self->_init_dates(1);
805 253         570 $self->_date('end',$end);
806             }
807              
808             sub basedate {
809 173     173 1 1707 my($self,$base) = @_;
810 173 50       434 return ($$self{'data'}{'base'},$$self{'data'}{'BASE'}) if (! defined $base);
811              
812 173         563 $self->_init_dates();
813 173         578 $self->_date('base',$base);
814             }
815              
816             sub modifiers {
817 309     309 1 809 my($self,@flags) = @_;
818 309 50       694 return @{ $$self{'data'}{'flags'} } if (! @flags);
  0         0  
819              
820 309         546 my $dmt = $$self{'tz'};
821 309         547 my $dmb = $$dmt{'base'};
822 309 50       736 if (@flags == 1) {
823 309         824 @flags = split(/,/,lc($flags[0]));
824             }
825              
826             # Add these flags to the list
827              
828 309 50 33     1319 if (@flags && $flags[0] eq "+") {
829 0         0 shift(@flags);
830 0         0 my @tmp = @{ $$self{'data'}{'flags'} };
  0         0  
831 0 0       0 @flags = (@tmp,@flags) if (@tmp);
832             }
833              
834             # Return an error if any modifier is unknown
835              
836 309         634 foreach my $flag (@flags) {
837 322 100       1456 next if ($flag =~ /^([pn][dt][1-7]|wd[1-7]|[fb][dw]\d+|cw[dnp]|[npd]wd|[in]bd|[in]w[1-7]|easter)$/);
838 151         490 $$self{'err'} = "[modifiers] Invalid modifier: $flag";
839 151         364 return 1;
840             }
841              
842 158         453 $$self{'data'}{'flags'} = [ @flags ];
843 158         466 $self->_init_dates();
844              
845 158         271 return 0;
846             }
847              
848             sub nth {
849 2097     2097 1 6330 my($self,$n) = @_;
850 2097 100       3811 $n = 0 if (! $n);
851             return ($$self{'data'}{'dates'}{$n},0)
852 2097 100       6213 if (exists $$self{'data'}{'dates'}{$n});
853              
854 86         179 my ($err) = $self->_error();
855 86 50       169 return (undef,$err) if ($err);
856              
857             return ($$self{'data'}{'dates'}{$n},0)
858 86 100       182 if (exists $$self{'data'}{'dates'}{$n});
859              
860             # If there is no interval, then we've found every date that
861             # can be found.
862 84 100       172 if ($$self{'data'}{'noint'}) {
863 4         9 return (undef,0);
864             }
865              
866 80 100       151 if ($$self{'data'}{'slow'}) {
867 2         4 my $nn = 0;
868 2         4 while (1) {
869 4         12 $self->_nth_interval($nn);
870             return ($$self{'data'}{'dates'}{$n},0)
871 4 100       16 if (exists $$self{'data'}{'dates'}{$n});
872 2 50       6 if ($n >= 0) {
873 2         12 $nn++;
874             } else {
875 0         0 $nn--;
876             }
877             }
878              
879             } else {
880 78         93 my $nn;
881 78 100       151 if ($n >= 0) {
882 74         129 $nn = int($n/$$self{'data'}{'ev_per_d'});
883             } else {
884 4         12 $nn = int(($n+1)/$$self{'data'}{'ev_per_d'}) -1;
885             }
886 78         186 $self->_nth_interval($nn);
887 78         198 return ($$self{'data'}{'dates'}{$n},0);
888             }
889             }
890              
891             sub next {
892 8     8 1 858 my($self) = @_;
893              
894 8         21 my ($err) = $self->_error();
895 8 50       20 return (undef,$err) if ($err);
896              
897             # If curr is not set, we have to get it.
898              
899 8 100       18 if (! defined $$self{'data'}{'curr'}) {
900              
901             CURR:
902 5         8 while (1) {
903              
904             # If no interval then
905             # return base date
906              
907 5 100       14 if ($$self{'data'}{'noint'}) {
908 1         2 $$self{'data'}{'curr'} = -1;
909 1         3 last CURR;
910             }
911              
912             # If a range is defined
913             # find first event in range and return it
914              
915 4 100 66     33 if (defined $$self{'data'}{'start'} &&
916             defined $$self{'data'}{'end'}) {
917              
918 2         18 my $n = $self->_locate_n('first');
919 2 100 66     14 return (undef,'Not found') if ($$self{'err'} || ! defined($n));
920 1         4 $$self{'data'}{'curr'} = $n-1;
921              
922             } else {
923 2         6 $$self{'data'}{'curr'} = -1;
924             }
925 3         21 last CURR;
926             }
927             }
928              
929             # With curr set, find the next defined one
930              
931 7         13 while (1) {
932 9         15 $$self{'data'}{'curr'}++;
933 9 100       17 if ($$self{'data'}{'noint'}) {
934             return (undef,0)
935 3 100       10 if (! exists $$self{'data'}{'dates'}{$$self{'data'}{'curr'}});
936             }
937 8         23 my ($d,$e) = $self->nth($$self{'data'}{'curr'});
938 8 50       17 return (undef,$e) if ($e);
939 8 100       24 return ($d,0) if (defined $d);
940             }
941             }
942              
943             sub prev {
944 11     11 1 1143 my($self) = @_;
945              
946 11         21 my ($err) = $self->_error();
947 11 50       20 return (undef,$err) if ($err);
948              
949             # If curr is not set, we have to get it.
950              
951 11 100       33 if (! defined $$self{'data'}{'curr'}) {
952              
953             CURR:
954 5         9 while (1) {
955              
956             # If no interval then
957             # return last one
958              
959 5 100       15 if ($$self{'data'}{'noint'}) {
960 1         1 my @n = sort { $a <=> $b } keys %{ $$self{'data'}{'dates'} };
  1         4  
  1         6  
961 1         3 $$self{'data'}{'curr'} = pop(@n) + 1;
962 1         3 last CURR;
963             }
964              
965             # If a range is defined
966             # find last event in range and return it
967              
968 4 100 66     19 if (defined $$self{'data'}{'start'} &&
969             defined $$self{'data'}{'end'}) {
970              
971 2         9 my $n = $self->_locate_n('last');
972 2 100 66     15 return (undef,'Not found') if ($$self{'err'} || ! defined($n));
973 1         5 $$self{'data'}{'curr'} = $n+1;
974              
975             } else {
976 2         5 $$self{'data'}{'curr'} = 0;
977             }
978 3         6 last CURR;
979             }
980             }
981              
982             # With curr set, find the previous defined one
983              
984 10         14 while (1) {
985 11         15 $$self{'data'}{'curr'}--;
986 11 100       22 if ($$self{'data'}{'noint'}) {
987             return (undef,0)
988 6 100       16 if (! exists $$self{'data'}{'dates'}{$$self{'data'}{'curr'}});
989             }
990 9         22 my ($d,$e) = $self->nth($$self{'data'}{'curr'});
991 9 50       17 return (undef,$e) if ($e);
992 9 100       27 return ($d,0) if (defined $d);
993             }
994             }
995              
996             sub dates {
997 1181     1181 1 3771 my($self,$start2,$end2,$unmod) = @_;
998 1181         3870 $self->err(1);
999              
1000             # If $start2 or $end2 are provided, make sure they are valid.
1001             # If either are provided, make a note of it ($tmp_limits).
1002              
1003 1181         1631 my $tmp_limits = 0;
1004 1181 100 100     3637 $tmp_limits = 1 if ($start2 || $end2);
1005 1181 100       2276 $unmod = 0 if (! $unmod);
1006              
1007             # Check the recurrence for errors. If both $start2 and $end2 are
1008             # provided, it's not necessary for a range to be in the recurrence.
1009              
1010 1181         1466 my $range_required;
1011 1181 100 100     3585 if (defined($start2) && defined($end2)) {
1012 735         1073 $range_required = 0;
1013             } else {
1014 446         689 $range_required = 1;
1015             }
1016              
1017 1181         1489 my($err);
1018 1181         3331 ($err,$start2,$end2) = $self->_error($range_required,$start2,$end2);
1019 1181 100       2460 return () if ($err);
1020              
1021             # If $start2 or $end2 were provided, back up the data that applies
1022             # to the current date range, and store the new date range in it's place.
1023              
1024 1174         1808 my ($old_start, $old_end, $old_first, $old_last, $old_unmod);
1025              
1026 1174 100       2166 if ($tmp_limits) {
1027 737         1269 $old_start = $$self{'data'}{'start'};
1028 737         1192 $old_end = $$self{'data'}{'end'};
1029 737         1196 $old_first = $$self{'data'}{'first'};
1030 737         1144 $old_last = $$self{'data'}{'last'};
1031 737         1183 $old_unmod = $$self{'data'}{'unmod_range'};
1032              
1033 737         1144 $$self{'data'}{'start'} = $start2;
1034 737         1099 $$self{'data'}{'end'} = $end2;
1035 737         1142 $$self{'data'}{'first'} = undef;
1036 737         1082 $$self{'data'}{'last'} = undef;
1037 737         1089 $$self{'data'}{'unmod_range'} = $unmod;
1038             }
1039              
1040             # Get all of the dates
1041              
1042 1174         1745 my($end,$first,$last,@dates);
1043              
1044 1174         2942 $first = $self->_locate_n('first');
1045 1174 100       3389 return () if ($$self{'err'});
1046 1173         3371 $last = $self->_locate_n('last');
1047 1173 50       2933 return () if ($$self{'err'});
1048              
1049 1173 100 66     4261 if (defined($first) && defined($last)) {
1050 1068         2806 for (my $n = $first; $n <= $last; $n++) {
1051 2050         4636 my($date,$err) = $self->nth($n);
1052 2050 100       5937 push(@dates,$date) if (defined $date);
1053             }
1054             }
1055              
1056             # Restore the original date range values.
1057              
1058 1173 100       2416 if ($tmp_limits) {
1059 737         1369 $$self{'data'}{'start'} = $old_start;
1060 737         1291 $$self{'data'}{'end'} = $old_end;
1061 737         1102 $$self{'data'}{'first'} = $old_first;
1062 737         1128 $$self{'data'}{'last'} = $old_last;
1063 737         1183 $$self{'data'}{'unmod_range'} = $old_unmod;
1064             }
1065              
1066 1173         8380 return @dates;
1067             }
1068              
1069             ########################################################################
1070             # MISC
1071             ########################################################################
1072              
1073             # This checks a recurrence for errors and completeness prior to
1074             # extracting a date or dates from it.
1075             #
1076             sub _error {
1077 1286     1286   2636 my($self,$range_required,$start2,$end2) = @_;
1078              
1079 1286 50       2572 return ('Invalid recurrence') if ($self->err());
1080              
1081             # All dates entered must be valid.
1082              
1083 1286         2233 my($start,$end);
1084 1286 100       3110 if (defined $start2) {
    100          
1085 736 100       2421 if (ref($start2) eq 'Date::Manip::Date') {
    50          
1086 54         72 $start = $start2;
1087             } elsif (! ref($start2)) {
1088 682         1489 $start = $self->new_date();
1089 682         2051 $start->parse($start2);
1090             } else {
1091 0         0 return ('Invalid start argument');
1092             }
1093 736 50       2108 return ('Start invalid') if ($start->err());
1094             } elsif (defined $$self{'data'}{'start'}) {
1095 369         657 $start = $$self{'data'}{'start'};
1096 369 50       905 return ('Start invalid') if ($start->err());
1097             }
1098              
1099 1286 100       3418 if (defined $end2) {
    100          
1100 736 100       2125 if (ref($end2) eq 'Date::Manip::Date') {
    50          
1101 54         81 $end = $end2;
1102             } elsif (! ref($end2)) {
1103 682         1666 $end = $self->new_date();
1104 682         1680 $end->parse($end2);
1105             } else {
1106 0         0 return ('Invalid end argument');
1107             }
1108 736 50       2142 return ('End invalid') if ($end->err());
1109             } elsif (defined $$self{'data'}{'end'}) {
1110 369         621 $end = $$self{'data'}{'end'};
1111 369 50       757 return ('End invalid') if ($end->err());
1112             }
1113              
1114 1286 100       3437 if (defined $$self{'data'}{'base'}) {
1115 227         430 my $base = $$self{'data'}{'base'};
1116 227 50       454 return ('Base invalid') if ($base->err());
1117             }
1118              
1119             # *Y:M:W:D:H:MN:S is complete.
1120              
1121 1286 100       3172 if ($$self{'data'}{'noint'}) {
1122 148 100       315 if ($$self{'data'}{'noint'} == 1) {
1123 137         280 my @dates = $self->_apply_rtime_mods();
1124 137         272 $$self{'data'}{'noint'} = 2;
1125              
1126 137         176 my $n = 0;
1127 137         205 foreach my $date (@dates) {
1128 230 50       395 next if (! defined $date);
1129 230         559 $$self{'data'}{'dates'}{$n++} = $date;
1130             }
1131              
1132 137 50       275 return (0,$start,$end) if ($n == 0);
1133              
1134 137 100 66     337 if (defined $start && defined $end) {
1135 5         9 my ($first,$last);
1136 5         19 for (my $i=0; $i<$n; $i++) {
1137 7         16 my $date = $$self{'data'}{'dates'}{$i};
1138 7 100 66     26 if ($start->cmp($date) <= 0 &&
1139             $end->cmp($date) >= 0) {
1140 4         10 $first = $i;
1141 4         8 last;
1142             }
1143             }
1144 5         31 for (my $i=$n-1; $i>=0; $i--) {
1145 8         21 my $date = $$self{'data'}{'dates'}{$i};
1146 8 100 100     21 if ($start->cmp($date) <= 0 &&
1147             $end->cmp($date) >= 0) {
1148 4         10 $last = $i;
1149 4         10 last;
1150             }
1151             }
1152              
1153 5         12 $$self{'data'}{'first'} = $first;
1154 5         17 $$self{'data'}{'last'} = $last;
1155             } else {
1156 132         221 $$self{'data'}{'first'} = 0;
1157 132         258 $$self{'data'}{'last'} = $n-1;
1158             }
1159             }
1160 148         354 return (0,$start,$end);
1161             }
1162              
1163             # If a range is entered, it must be valid. Also
1164             # a range is required if $range_required is given.
1165              
1166 1138 100 66     3896 if ($start && $end) {
    100          
1167 1100 50       3282 return ('Range invalid') if ($start->cmp($end) == 1);
1168             } elsif ($range_required) {
1169 7         17 return ('Incomplete recurrence');
1170             }
1171              
1172             # Check that the base date is available.
1173              
1174 1131         3726 $self->_actual_base($start);
1175              
1176 1131 50       2843 if (defined $$self{'data'}{'BASE'}) {
1177 1131         2088 my $base = $$self{'data'}{'BASE'};
1178 1131 50       2930 return ('Base invalid') if ($base->err());
1179 1131         3120 return (0,$start,$end);
1180             }
1181              
1182 0         0 return ('Incomplete recurrence');
1183             }
1184              
1185             # This determines the actual base date from a specified base date (or
1186             # start date). If a base date cannot be set, then
1187             # $$self{'data'}{'BASE'} is NOT defined.
1188             #
1189             sub _actual_base {
1190 1131     1131   2329 my($self,$start2) = @_;
1191              
1192             # Is the actual base date already defined?
1193              
1194 1131 100       2942 return if (defined $$self{'data'}{'BASE'});
1195              
1196             # Use the specified base date or start date.
1197              
1198 1011         1573 my $base = undef;
1199 1011 100       2749 if (defined $$self{'data'}{'base'}) {
    50          
    0          
1200 171         344 $base = $$self{'data'}{'base'};
1201             } elsif (defined $start2) {
1202 840         1603 $base = $start2;
1203             } elsif (defined $$self{'data'}{'start'}) {
1204 0         0 $base = $$self{'data'}{'start'};
1205             } else {
1206 0         0 return;
1207             }
1208              
1209             # Determine the actual base date from the specified base date.
1210              
1211 1011         1689 my $dmt = $$self{'tz'};
1212 1011         1630 my $dmb = $$dmt{'base'};
1213 1011         3279 $dmt->_update_now(); # Update NOW
1214 1011         1359 my @int = @{ $$self{'data'}{'interval'} };
  1011         2619  
1215 1011         1419 my @rtime = @{ $$self{'data'}{'rtime'} };
  1011         2864  
1216 1011         2401 my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime);
1217 1011         2356 my ($y,$m,$d,$h,$mn,$s) = $base->value();
1218 1011         2627 my $BASE = $self->new_date();
1219 1011         1748 my $n = @int;
1220              
1221 1011 50       3326 if ($n == 0) {
    100          
    100          
    100          
    100          
    100          
    50          
1222             # *Y:M:W:D:H:MN:S
1223 0         0 return;
1224              
1225             } elsif ($n == 1) {
1226             # Y*M:W:D:H:MN:S
1227 872         2895 $BASE->set('date',[$y,1,1,0,0,0]);
1228              
1229             } elsif ($n == 2) {
1230             # Y:M*W:D:H:MN:S
1231 78         325 $BASE->set('date',[$y,$m,1,0,0,0]);
1232              
1233             } elsif ($n == 3) {
1234             # Y:M:W*D:H:MN:S
1235 19         120 my($yy,$w) = $dmb->week_of_year([$y,$m,$d,$h,$mn,$s]);
1236 19         63 my($ymd) = $dmb->week_of_year($yy,$w);
1237 19         88 $BASE->set('date',[@$ymd,0,0,0]);
1238              
1239             } elsif ($n == 4) {
1240             # Y:M:W:D*H:MN:S
1241 31         129 $BASE->set('date',[$y,$m,$d,0,0,0]);
1242              
1243             } elsif ($n == 5) {
1244             # Y:M:W:D:H*MN:S
1245 5         24 $BASE->set('date',[$y,$m,$d,$h,0,0]);
1246              
1247             } elsif ($n == 6) {
1248             # Y:M:W:D:H:MN*S
1249 0         0 $BASE->set('date',[$y,$m,$d,$h,$mn,0]);
1250              
1251             } else {
1252             # Y:M:W:D:H:MN:S
1253 6         26 $BASE->set('date',[$y,$m,$d,$h,$mn,$s]);
1254             }
1255              
1256 1011         3409 $$self{'data'}{'BASE'} = $BASE;
1257             }
1258              
1259             sub _rx {
1260 2986     2986   4411 my($self,$rx) = @_;
1261 2986         3826 my $dmt = $$self{'tz'};
1262 2986         3556 my $dmb = $$dmt{'base'};
1263              
1264             return $$dmb{'data'}{'rx'}{'recur'}{$rx}
1265 2986 100       8088 if (exists $$dmb{'data'}{'rx'}{'recur'}{$rx});
1266              
1267 122 100 66     738 if ($rx eq 'std') {
    100 66        
    100          
    100          
    50          
1268              
1269 28         57 my $l = '[0-9]*';
1270 28         55 my $r = '[-,0-9]*';
1271 28         773 my $stdrx = "(?<l>$l:$l:$l:$l:$l:$l:$l)(?<r>)|" .
1272             "(?<l>$l:$l:$l:$l:$l:$l)\\*(?<r>$r)|" .
1273             "(?<l>$l:$l:$l:$l:$l)\\*(?<r>$r:$r)|" .
1274             "(?<l>$l:$l:$l:$l)\\*(?<r>$r:$r:$r)|" .
1275             "(?<l>$l:$l:$l)\\*(?<r>$r:$r:$r:$r)|" .
1276             "(?<l>$l:$l)\\*(?<r>$r:$r:$r:$r:$r)|" .
1277             "(?<l>$l)\\*(?<r>$r:$r:$r:$r:$r:$r)|" .
1278             "(?<l>)\\*(?<r>$r:$r:$r:$r:$r:$r:$r)";
1279 28         2762 $$dmb{'data'}{'rx'}{'recur'}{$rx} = qr/^\s*(?:$stdrx)\s*$/;
1280              
1281             } elsif ($rx eq 'rfield' ||
1282             $rx eq 'rnum' ||
1283             $rx eq 'rrange') {
1284              
1285 28         67 my $num = '[+-]?\d+';
1286 28         83 my $range = "$num\-$num";
1287 28         235 my $val = "(?:$range|$num)";
1288 28         113 my $vals = "$val(?:,$val)*";
1289              
1290 28         997 $$dmb{'data'}{'rx'}{'recur'}{'rfield'} = qr/^($vals)$/;
1291 28         405 $$dmb{'data'}{'rx'}{'recur'}{'rnum'} = qr/^($num)$/;
1292 28         633 $$dmb{'data'}{'rx'}{'recur'}{'rrange'} = qr/^($num)\-($num)$/;
1293              
1294             } elsif ($rx eq 'each') {
1295              
1296 22         70 my $each = $$dmb{'data'}{'rx'}{'each'};
1297              
1298 22         504 my $eachrx = qr/(?:^|\s+)(?:$each)(\s+|$)/i;
1299 22         91 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $eachrx;
1300              
1301             } elsif ($rx eq 'ignore') {
1302              
1303 22         72 my $of = $$dmb{'data'}{'rx'}{'of'};
1304 22         65 my $on = $$dmb{'data'}{'rx'}{'on'};
1305              
1306 22         584 my $ignrx = qr/(?:^|\s+)(?:$on|$of)(\s+|$)/i;
1307 22         89 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $ignrx;
1308              
1309             } elsif ($rx eq 'every') {
1310              
1311 22         72 my $month = $$dmb{'data'}{'rx'}{'fields'}[2];
1312 22         64 my $week = $$dmb{'data'}{'rx'}{'fields'}[3];
1313 22         52 my $day = $$dmb{'data'}{'rx'}{'fields'}[4];
1314              
1315 22         55 my $last = $$dmb{'data'}{'rx'}{'last'};
1316 22         71 my $nth = $$dmb{'data'}{'rx'}{'nth'}[0];
1317 22         61 my $nth_wom = $$dmb{'data'}{'rx'}{'nth_wom'}[0];
1318 22         71 my $nth_dom = $$dmb{'data'}{'rx'}{'nth_dom'}[0];
1319              
1320 22         66 my $day_abb = $$dmb{'data'}{'rx'}{'day_abb'}[0];
1321 22         69 my $day_name = $$dmb{'data'}{'rx'}{'day_name'}[0];
1322 22         57 my $mon_abb = $$dmb{'data'}{'rx'}{'month_abb'}[0];
1323 22         52 my $mon_name = $$dmb{'data'}{'rx'}{'month_name'}[0];
1324              
1325 22         47 my $beg = '(?:^|\s+)';
1326 22         45 my $end = '(?:\s*$)';
1327              
1328 22         83 $month = "$beg(?<month>$month)"; # months
1329 22         77 $week = "$beg(?<week>$week)"; # weeks
1330 22         57 $day = "$beg(?<day>$day)"; # days
1331              
1332 22         58 $last = "$beg(?<last>$last)"; # last
1333 22         95 $nth = "$beg(?<nth>$nth)"; # 1st,2nd,...
1334 22         66 $nth_wom = "$beg(?<nth>$nth_wom)"; # 1st - 5th
1335 22         81 $nth_dom = "$beg(?<nth>$nth_dom)"; # 1st - 31st
1336 22         68 my $n = "$beg(?<n>\\d+)"; # 1,2,...
1337              
1338 22         82 my $dow = "$beg(?:(?<day_name>$day_name)|(?<day_abb>$day_abb))"; # Sun|Sunday
1339 22         83 my $mmm = "$beg(?:(?<mon_name>$mon_name)|(?<mon_abb>$mon_abb))"; # Jan|January
1340              
1341 22         58 my $y = "(?:$beg(?:(?<y>\\d\\d\\d\\d)|(?<y>\\d\\d)))?";
1342              
1343 22         570 my $freqrx =
1344             "$nth_wom?$dow$mmm$y|" . # every DoW in MMM [YY]
1345             "$last$dow$mmm$y|" . # Nth DoW in MMM [YY]
1346             # last DoW in MMM [YY]
1347             # day_name|day_abb
1348             # mon_name|mon_abb
1349             # last*|nth*
1350             # y*
1351             "$nth_wom?$dow$month$y|" . # every DoW of every month [YY]
1352             "$last$dow$month$y|" . # Nth DoW of every month [YY]
1353             # last DoW of every month [YY]
1354             # day_name|day_abb
1355             # last*|nth*
1356             # y*
1357             "$nth_dom?$day$month$y|" . # every day of every month [YY]
1358             "$last$day$month$y|" . # Nth day of every month [YY]
1359             # last day of every month [YY]
1360             # day
1361             # month
1362             # nth*|last*
1363             # y*
1364             "$nth*$day$y|" . # every day [YY]
1365             "$n$day$y"; # every Nth day [YY]
1366             # every N days [YY]
1367             # day
1368             # nth*|n*
1369             # y*
1370              
1371 22         31748 $freqrx = qr/^(?:$freqrx)\s*$/i;
1372 22         618 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $freqrx;
1373             }
1374              
1375 122         481 return $$dmb{'data'}{'rx'}{'recur'}{$rx};
1376             }
1377              
1378             # @dates = $self->_apply_rtime_mods();
1379             #
1380             # Should only be called if there is no interval (*Y:M:W:D:H:MN:S).
1381             #
1382             # It will use rtime/modifiers to get a list of all events
1383             # specified by the recurrence. This only needs to be done once.
1384             #
1385             # @dates = $self->_apply_rtime_mods($date);
1386             #
1387             # For all other types of recurrences, this will take a single
1388             # date and apply all rtime/modifiers to it to get a list of
1389             # events.
1390             #
1391             sub _apply_rtime_mods {
1392 4050     4050   6271 my($self,$date) = @_;
1393 4050         5760 my $dmt = $$self{'tz'};
1394 4050         5307 my $dmb = $$dmt{'base'};
1395 4050         4648 my @int = @{ $$self{'data'}{'interval'} };
  4050         7821  
1396 4050         5012 my @rtime = @{ $$self{'data'}{'rtime'} };
  4050         8084  
1397 4050         5084 my $n = @int;
1398              
1399 4050         7255 my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime);
1400 4050         7603 my $m_empty = $self->_field_empty($mf);
1401 4050         6465 my $w_empty = $self->_field_empty($wf);
1402 4050         6486 my $d_empty = $self->_field_empty($df);
1403 4050         6543 my ($err,$y,$m,$d,$h,$mn,$s,@y,@m,@w,@d,@h,@mn,@s,@doy,@woy,@dow,@n);
1404 4050 100       12105 ($y,$m,$d,$h,$mn,$s) = $date->value() if (defined $date);
1405 4050         5599 my(@date);
1406              
1407 4050 100       7377 if ($n <= 1) {
    100          
    100          
    100          
    100          
    50          
    50          
1408             #
1409             # *Y:M:W:D:H:MN:S
1410             # Y*M:W:D:H:MN:S
1411             #
1412              
1413 3281 100       5260 if (@int == 0) {
1414 137         281 ($err,@y) = $self->_rtime_values('y',$yf);
1415 137 50       272 return () if ($err);
1416             } else {
1417 3144         4703 @y = ($y);
1418             }
1419              
1420 3281 100 100     15270 if ( ($m_empty && $w_empty && $d_empty) ||
    100 100        
      100        
      100        
1421             (! $m_empty && $w_empty) ) {
1422              
1423             # *0:0:0:0 Jan 1 of the current year
1424             # *1:0:0:0 Jan 1, 0001
1425             # *0:2:0:0 Feb 1 of the current year
1426             # *1:2:0:0 Feb 1, 0001
1427             # *0:2:0:4 Feb 4th of the current year
1428             # *1:2:0:4 Feb 4th, 0001
1429             # 1*0:0:0 every year on Jan 1
1430             # 1*2:0:0 every year on Feb 1
1431             # 1*2:0:4 every year on Feb 4th
1432              
1433 2480 100       4181 $mf = [1] if ($m_empty);
1434 2480 100       3888 $df = [1] if ($d_empty);
1435              
1436 2480         4825 ($err,@m) = $self->_rtime_values('m',$mf);
1437 2480 50       4135 return () if ($err);
1438              
1439 2480         3396 foreach my $y (@y) {
1440 2496         3114 foreach my $m (@m) {
1441 2549         4319 ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
1442 2549 50       4121 return () if ($err);
1443 2549         3248 foreach my $d (@d) {
1444 2429         6594 push(@date,[$y,$m,$d,0,0,0]);
1445             }
1446             }
1447             }
1448              
1449             } elsif ($m_empty) {
1450              
1451 328 100       669 if ($w_empty) {
    100          
1452              
1453             # *0:0:0:4 the 4th day of the current year
1454             # *1:0:0:4 the 4th day of 0001
1455             # 1*0:0:4 every year on the 4th day of the year
1456              
1457 151         237 foreach my $y (@y) {
1458 171         367 ($err,@doy) = $self->_rtime_values('day_of_year',$df,$y);
1459 171 50       300 return () if ($err);
1460 171         280 foreach my $doy (@doy) {
1461 137         155 my($yy,$mm,$dd) = @{ $dmb->day_of_year($y,$doy) };
  137         357  
1462 137         399 push(@date,[$yy,$mm,$dd,0,0,0]);
1463             }
1464             }
1465              
1466             } elsif ($d_empty) {
1467              
1468             # *0:0:3:0 the first day of the 3rd week of the curr year
1469             # *1:0:3:0 the first day of the 3rd week of 0001
1470             # 1*0:3:0 every year on the first day of 3rd week of year
1471              
1472 49         86 foreach my $y (@y) {
1473 49         97 ($err,@woy) = $self->_rtime_values('week_of_year',$wf,$y);
1474 49 50       100 return () if ($err);
1475 49         66 foreach my $woy (@woy) {
1476 51         59 my ($yy,$mm,$dd) = @{ $dmb->week_of_year($y,$woy) };
  51         123  
1477 51         143 push(@date,[$yy,$mm,$dd,0,0,0]);
1478             }
1479             }
1480              
1481             } else {
1482              
1483             # *1:0:3:4 in 0001 on the 3rd Thur of the year
1484             # *0:0:3:4 on the 3rd Thur of the current year
1485             # 1*0:3:4 every year on the 3rd Thur of the year
1486              
1487 128         272 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1488 128 50       252 return () if ($err);
1489 128         193 foreach my $y (@y) {
1490 164         218 foreach my $dow (@dow) {
1491 164         281 ($err,@n) = $self->_rtime_values('dow_of_year',$wf,$y,$dow);
1492 164 50       312 return () if ($err);
1493 164         258 foreach my $n (@n) {
1494 82         209 my $ymd = $dmb->nth_day_of_week($y,$n,$dow);
1495 82         152 my($yy,$mm,$dd) = @$ymd;
1496 82         261 push(@date,[$yy,$mm,$dd,0,0,0]);
1497             }
1498             }
1499             }
1500             }
1501              
1502             } else {
1503              
1504             # *1:2:3:4 in Feb 0001 on the 3rd Thur of the month
1505             # *0:2:3:4 on the 3rd Thur of Feb in the curr year
1506             # *1:2:3:0 the 3rd occurrence of FirstDay in Feb 0001
1507             # *0:2:3:0 the 3rd occurrence of FirstDay in Feb of curr year
1508             # 1*2:3:4 every year in Feb on the 3rd Thur
1509             # 1*2:3:0 every year on the 3rd occurrence of FirstDay in Feb
1510              
1511 473         1090 ($err,@m) = $self->_rtime_values('m',$mf);
1512 473 50       907 return () if ($err);
1513              
1514 473 100       788 if ($d_empty) {
1515 76         236 @dow = ($dmb->_config('firstday'));
1516             } else {
1517 397         818 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1518 397 50       793 return () if ($err);
1519             }
1520              
1521 473         1036 foreach my $y (@y) {
1522 477         687 foreach my $m (@m) {
1523 639         835 foreach my $dow (@dow) {
1524 639         1177 ($err,@n) = $self->_rtime_values('dow_of_month',
1525             $wf,$y,$m,$dow);
1526 639 50       1085 return () if ($err);
1527 639         883 foreach my $n (@n) {
1528 629         1592 my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
1529 629         1143 my($yy,$mm,$dd) = @$ymd;
1530 629         2021 push(@date,[$yy,$mm,$dd,0,0,0]);
1531             }
1532             }
1533             }
1534             }
1535             }
1536              
1537             } elsif ($n == 2) {
1538              
1539             #
1540             # Y:M*W:D:H:MN:S
1541             #
1542              
1543 448 100       805 if ($w_empty) {
1544              
1545             # 0:2*0:0 every 2 months on the first day of the month
1546             # 0:2*0:4 every 2 months on the 4th day of the month
1547             # 1:2*0:0 every 1 year, 2 months on the first day of the month
1548             # 1:2*0:4 every 1 year, 2 months on the 4th day of the month
1549              
1550 261 100       526 $df = [1] if ($d_empty);
1551              
1552 261         554 ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
1553 261 50       492 return () if ($err);
1554 261         379 foreach my $d (@d) {
1555 271         699 push(@date,[$y,$m,$d,0,0,0]);
1556             }
1557              
1558             } else {
1559              
1560             # 0:2*3:0 every 2 months on the 3rd occurrence of FirstDay
1561             # 0:2*3:4 every 2 months on the 3rd Thur of the month
1562             # 1:2*3:0 every 1 year, 2 months on 3rd occurrence of FirstDay
1563             # 1:2*3:4 every 1 year, 2 months on the 3rd Thur of the month
1564              
1565 187 100       338 if ($d_empty) {
1566 51         141 @dow = ($dmb->_config('firstday'));
1567             } else {
1568 136         260 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1569 136 50       284 return () if ($err);
1570             }
1571              
1572 187         325 foreach my $dow (@dow) {
1573 187         340 ($err,@n) = $self->_rtime_values('dow_of_month',
1574             $wf,$y,$m,$dow);
1575 187 50       362 return () if ($err);
1576 187         279 foreach my $n (@n) {
1577 237         525 my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
1578 237         380 my($yy,$mm,$dd) = @$ymd;
1579 237         631 push(@date,[$yy,$mm,$dd,0,0,0]);
1580             }
1581             }
1582             }
1583              
1584             } elsif ($n == 3) {
1585              
1586             #
1587             # Y:M:W*D:H:MN:S
1588             #
1589              
1590             # 0:0:3*0 every 3 weeks on FirstDay
1591             # 0:0:3*4 every 3 weeks on Thur
1592             # 0:2:3*0 every 2 months, 3 weeks on FirstDay
1593             # 0:2:3*4 every 2 months, 3 weeks on Thur
1594             # 1:0:3*0 every 1 year, 3 weeks on FirstDay
1595             # 1:0:3*4 every 1 year, 3 weeks on Thur
1596             # 1:2:3*0 every 1 year, 2 months, 3 weeks on FirstDay
1597             # 1:2:3*4 every 1 year, 2 months, 3 weeks on Thur
1598              
1599 100         255 my $fdow = $dmb->_config('firstday');
1600 100 100       210 if ($d_empty) {
1601 35         61 @dow = ($fdow);
1602             } else {
1603 65         139 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1604 65 50       121 return () if ($err);
1605             }
1606              
1607 100         135 my($mm,$dd);
1608 100         323 my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]);
1609 100         151 ($yy,$mm,$dd) = @{ $dmb->week_of_year($yy,$ww) };
  100         200  
1610              
1611 100         179 foreach my $dow (@dow) {
1612 112 50       210 $dow += 7 if ($dow < $fdow);
1613 112         140 my($yyy,$mmm,$ddd) = @{ $dmb->calc_date_days([$yy,$mm,$dd],$dow-$fdow) };
  112         302  
1614 112         308 push(@date,[$yyy,$mmm,$ddd,0,0,0]);
1615             }
1616              
1617             } elsif ($n == 4) {
1618              
1619             #
1620             # Y:M:W:D*H:MN:S
1621             #
1622              
1623 133         288 push(@date,[$y,$m,$d,0,0,0]);
1624              
1625             } elsif ($n == 5) {
1626              
1627             #
1628             # Y:M:W:D:H*MN:S
1629             #
1630              
1631 33         79 push(@date,[$y,$m,$d,$h,0,0]);
1632              
1633             } elsif ($n == 6) {
1634              
1635             #
1636             # Y:M:W:D:H:MN*S
1637             #
1638              
1639 0         0 push(@date,[$y,$m,$d,$h,$mn,0]);
1640              
1641             } elsif ($n == 7) {
1642              
1643             #
1644             # Y:M:W:D:H:MN:S
1645             #
1646              
1647 55         114 push(@date,[$y,$m,$d,$h,$mn,$s]);
1648             }
1649              
1650             #
1651             # Handle the H/MN/S portion.
1652             #
1653              
1654             # Do hours
1655 4050 100       7394 if ($n <= 4 ) {
1656 3962         6716 ($err,@h) = $self->_rtime_values('h',$hf);
1657 3962 50       6187 return () if ($err);
1658 3962         8326 $self->_field_add_values(\@date,3,@h);
1659             }
1660              
1661             # Do minutes
1662 4050 100       6806 if ($n <= 5) {
1663 3995         6584 ($err,@mn) = $self->_rtime_values('mn',$mnf);
1664 3995 50       6302 return () if ($err);
1665 3995         6963 $self->_field_add_values(\@date,4,@mn);
1666             }
1667              
1668             # Do seconds
1669 4050 100       6908 if ($n <= 6) {
1670 3995         6139 ($err,@s) = $self->_rtime_values('s',$sf);
1671 3995 50       6901 return () if ($err);
1672 3995         6694 $self->_field_add_values(\@date,5,@s);
1673             }
1674              
1675             # Sort the dates... just to be sure.
1676              
1677 4050 100       10353 @date = sort { $dmb->cmp($a,$b) } @date if (@date);
  507         1215  
1678              
1679             #
1680             # Apply modifiers
1681             #
1682              
1683 4050         5000 my @flags = @{ $$self{'data'}{'flags'} };
  4050         8221  
1684 4050 100       7099 if (@flags) {
1685 2156         5822 my $obj = $self->new_date();
1686              
1687 2156         2881 my @keep;
1688 2156         3576 foreach my $date (@date) {
1689 2192         4256 my ($y,$m,$d,$h,$mn,$s) = @$date;
1690              
1691 2192         2738 my $keep = 1;
1692              
1693             MODIFIER:
1694 2192         2958 foreach my $flag (@flags) {
1695 2343         2886 my(@wd,$today);
1696              
1697 2343 100 100     22342 if ($flag =~ /^([pn])([dt])([1-7])$/) {
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
1698 56         155 my($forw,$today,$dow) = ($1,$2,$3);
1699 56 100       112 $forw = ($forw eq 'p' ? 0 : 1);
1700 56 100       91 $today = ($today eq 'd' ? 0 : 1);
1701             ($y,$m,$d,$h,$mn,$s) =
1702 56         63 @{ $obj->__next_prev([$y,$m,$d,$h,$mn,$s],$forw,$dow,$today) };
  56         181  
1703              
1704             } elsif ($flag =~ /^([fb])([dw])(\d+)$/) {
1705 427         1474 my($prev,$business,$n) = ($1,$2,$3);
1706 427 100       975 $prev = ($prev eq 'b' ? 1 : 0);
1707 427 100       834 $business = ($business eq 'w' ? 1 : 0);
1708              
1709 427 100       714 if ($business) {
1710             ($y,$m,$d,$h,$mn,$s) =
1711 18         27 @{ $obj->__nextprev_business_day($prev,$n,0,[$y,$m,$d,$h,$mn,$s]) };
  18         76  
1712             } else {
1713 409         556 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],$n,$prev) };
  409         1459  
1714             }
1715              
1716             } elsif ($flag eq 'ibd' ||
1717             $flag eq 'nbd') {
1718 243         901 my $bd = $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0);
1719              
1720 243 100 100     1219 if ( ($flag eq 'ibd' && ! $bd) ||
      100        
      100        
1721             ($flag eq 'nbd' && $bd) ) {
1722 113         140 $keep = 0;
1723 113         220 last MODIFIER;
1724             }
1725              
1726             } elsif ($flag =~ /^([in])w([1-7])$/) {
1727 99         283 my($is,$dow) = ($1,$2);
1728 99 50       205 $is = ($is eq 'i' ? 1 : 0);
1729 99         331 my $currdow = $dmb->day_of_week([$y,$m,$d]); # Current dow
1730 99 100 66     487 if ( ($is && $dow != $currdow) ||
      33        
      66        
1731             (! $is && $dow == $currdow) ) {
1732 85         114 $keep = 0;
1733 85         172 last MODIFIER;
1734             }
1735              
1736             } elsif ($flag =~ /^wd([1-7])$/) {
1737 9         23 my $dow = $1; # Dow wanted
1738 9         43 my $currdow = $dmb->day_of_week([$y,$m,$d]); # Current dow
1739 9 100       26 if ($dow != $currdow) {
1740 7         24 my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]); # What week is this
1741 7         17 my $tmp = $dmb->week_of_year($yy,$ww); # First day of week
1742 7         12 ($y,$m,$d) = @$tmp;
1743 7         17 $currdow = $dmb->_config('firstday');
1744 7 50       16 if ($dow > $currdow) {
    0          
1745 7         19 $tmp = $dmb->calc_date_days([$y,$m,$d],$dow-$currdow);
1746 7         25 ($y,$m,$d) = @$tmp;
1747             } elsif ($dow < $currdow) {
1748 0         0 $tmp = $dmb->calc_date_days([$y,$m,$d],$dow-$currdow+7);
1749 0         0 ($y,$m,$d) = @$tmp;
1750             }
1751             }
1752              
1753             } elsif ($flag eq 'nwd') {
1754 166 100       636 if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1755             ($y,$m,$d,$h,$mn,$s) =
1756 78         113 @{ $obj->__nextprev_business_day(0,0,0,[$y,$m,$d,$h,$mn,$s]) };
  78         336  
1757             }
1758              
1759             } elsif ($flag eq 'pwd') {
1760 10 100       41 if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1761             ($y,$m,$d,$h,$mn,$s) =
1762 5         10 @{ $obj->__nextprev_business_day(1,1,0,[$y,$m,$d,$h,$mn,$s]) };
  5         21  
1763             }
1764              
1765             } elsif ($flag eq 'easter') {
1766 21         60 ($m,$d) = $self->_easter($y);
1767              
1768             } elsif ($flag eq 'dwd' &&
1769             $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1770             # nothing
1771              
1772             } else {
1773              
1774 626 100 100     2483 if ($flag eq 'cwd' || $flag eq 'dwd') {
    100          
    50          
1775 608 50       1355 if ($dmb->_config('tomorrowfirst')) {
1776 608         2764 @wd = ([$y,$m,$d,$h,$mn,$s],+1, [$y,$m,$d,$h,$mn,$s],-1);
1777             } else {
1778 0         0 @wd = ([$y,$m,$d,$h,$mn,$s],-1, [$y,$m,$d,$h,$mn,$s],+1);
1779             }
1780              
1781             } elsif ($flag eq 'cwn') {
1782 9         34 @wd = ([$y,$m,$d,$h,$mn,$s],+1, [$y,$m,$d,$h,$mn,$s],-1);
1783 9         16 $today = 0;
1784              
1785             } elsif ($flag eq 'cwp') {
1786 9         39 @wd = ([$y,$m,$d,$h,$mn,$s],-1, [$y,$m,$d,$h,$mn,$s],+1);
1787 9         15 $today = 0;
1788             }
1789              
1790 626         1069 while (1) {
1791 739         1102 my(@d,$off);
1792              
1793             # Test in the first direction
1794              
1795 739         967 @d = @{ $wd[0] };
  739         1962  
1796 739         1088 $off = $wd[1];
1797 739         926 @d = @{ $dmb->calc_date_days(\@d,$off) };
  739         2125  
1798              
1799 739 100       2339 if ($obj->__is_business_day(\@d,0)) {
1800 396         905 ($y,$m,$d,$h,$mn,$s) = @d;
1801 396         1353 last;
1802             }
1803              
1804 343         880 $wd[0] = [@d];
1805              
1806             # Test in the other direction
1807              
1808 343         523 @d = @{ $wd[2] };
  343         753  
1809 343         526 $off = $wd[3];
1810 343         518 @d = @{ $dmb->calc_date_days(\@d,$off) };
  343         823  
1811              
1812 343 100       990 if ($obj->__is_business_day(\@d,0)) {
1813 230         489 ($y,$m,$d,$h,$mn,$s) = @d;
1814 230         860 last;
1815             }
1816              
1817 113         345 $wd[2] = [@d];
1818             }
1819              
1820             }
1821             }
1822              
1823 2192 100       3985 if ($keep) {
1824 1994         4939 push(@keep,[$y,$m,$d,$h,$mn,$s]);
1825             }
1826             }
1827 2156         9556 @date = @keep;
1828             }
1829              
1830             #
1831             # Convert the dates to objects.
1832             #
1833              
1834 4050         5133 my(@ret);
1835              
1836 4050         5755 foreach my $date (@date) {
1837 4039         7854 my @d = @$date;
1838              
1839 4039         9625 my $obj = $self->new_date();
1840 4039         11765 $obj->set('date',\@d);
1841 4039 100       11329 if ($obj->err()) {
1842 1         4 push(@ret,undef);
1843             } else {
1844 4038         8167 push(@ret,$obj);
1845             }
1846             }
1847              
1848 4050         17175 return @ret;
1849             }
1850              
1851             # This calculates the Nth interval date (0 is the base date) and then
1852             # calculates the recurring events produced by it.
1853             #
1854             sub _nth_interval {
1855 7768     7768   12146 my($self,$n) = @_;
1856 7768 100       16451 return if (exists $$self{'data'}{'idate'}{$n});
1857 3913         5529 my $base = $$self{'data'}{'BASE'};
1858 3913         4397 my $date;
1859              
1860             # Get the interval date.
1861              
1862 3913 100       6204 if ($n == 0) {
1863 999         1482 $date = $base;
1864              
1865             } else {
1866 2914         8714 my @delta = $$self{'data'}{'delta'}->value;
1867 2914         4704 my $absn = abs($n);
1868 2914         4859 @delta = map { $absn*$_ } @delta;
  20398         25393  
1869 2914         7516 my $delta = $self->new_delta;
1870 2914         9922 $delta->set('delta',[@delta]);
1871 2914 100       11824 $date = $base->calc($delta, ($n>0 ? 0 : 2));
1872             }
1873              
1874             # For 'slow' recursion, we need to make sure we've got
1875             # the n-1 or n+1 interval as appropriate.
1876              
1877 3913 100       9374 if ($$self{'data'}{'slow'}) {
1878              
1879 24 100       61 if ($n > 0) {
    100          
1880 14         43 $self->_nth_interval($n-1);
1881             } elsif ($n < 0) {
1882 5         30 $self->_nth_interval($n+1);
1883             }
1884             }
1885              
1886             # Get the list of events associated with this interval date.
1887              
1888 3913         9382 my @date = $self->_apply_rtime_mods($date);
1889              
1890             # Determine the index of the earliest event associated with
1891             # this interval date.
1892             #
1893             # Events are numbered [$n0...$n1]
1894              
1895 3913         5888 my($n0,$n1);
1896 3913 100       8036 if ($$self{'data'}{'slow'}) {
1897              
1898 24 100       87 if (! @date) {
    100          
    100          
1899 4         9 $n0 = undef;
1900 4         6 $n1 = undef;
1901              
1902             } elsif ($n == 0) {
1903 4         9 $n0 = 0;
1904 4         16 $n1 = $#date;
1905              
1906             } elsif ($n > 0) {
1907 11         83 foreach (my $i = $n-1; $i >= 0; $i--) {
1908 14 100       43 next if (! defined $$self{'data'}{'idate'}{$i}[2]);
1909 10         18 $n0 = $$self{'data'}{'idate'}{$i}[2] + 1;
1910 10         15 last;
1911             }
1912 11 100       23 $n0 = 0 if (! defined $n0);
1913 11         21 $n1 = $n0 + $#date;
1914              
1915             } else {
1916 5         17 foreach (my $i = $n+1; $i <= 0; $i++) {
1917 5 100       17 next if (! defined $$self{'data'}{'idate'}{$i}[1]);
1918 4         7 $n1 = $$self{'data'}{'idate'}{$i}[1] - 1;
1919 4         8 last;
1920             }
1921 5 100       13 $n1 = -1 if (! defined $n1);
1922 5         8 $n0 = $n1 - $#date;
1923             }
1924              
1925             } else {
1926              
1927             # ev_per_d = 3
1928             # idate = 0 1 2
1929             # events = 0 1 2 3 4 5 6 7 8
1930              
1931             # ev_per_d = 3
1932             # idate = -1 -2 -3
1933             # events = -3 -2 -1 -6 -5 -4 -9 -8 -7
1934              
1935 3889         5563 $n0 = $n * $$self{'data'}{'ev_per_d'};
1936 3889         5790 $n1 = $n0 + $$self{'data'}{'ev_per_d'} - 1;
1937             }
1938              
1939             # Store the dates.
1940              
1941 3913         8144 for (my $i=0; $i<=$#date; $i++) {
1942 3809         12650 $$self{'data'}{'dates'}{$n0+$i} = $date[$i];
1943             }
1944              
1945             # Store the idate.
1946              
1947 3913 100       6962 if ($$self{'data'}{'slow'}) {
1948 24         70 $$self{'data'}{'idate'}{$n} = [$date,$n0,$n1];
1949             } else {
1950 3889         8946 $$self{'data'}{'idate'}{$n} = $date;
1951             }
1952             }
1953              
1954             # This locates the first/last event in the range and returns $n. It
1955             # returns undef if there is no date in the range.
1956             #
1957             sub _locate_n {
1958 2351     2351   4203 my($self,$op) = @_;
1959              
1960 2351 100       6544 return $$self{'data'}{$op} if (defined $$self{'data'}{$op});
1961              
1962 1152         2021 my $start = $$self{'data'}{'start'};
1963 1152         1813 my $end = $$self{'data'}{'end'};
1964 1152         1937 my $unmod = $$self{'data'}{'unmod_range'};
1965 1152         1761 my $dmt = $$self{'tz'};
1966 1152         1684 my $dmb = $$dmt{'base'};
1967 1152         3037 my $maxatt = $dmb->_config('maxrecurattempts');
1968              
1969 1152 100       3028 if ($$self{'data'}{'noint'} == 2) {
1970             # If there is no interval, then we have calculated all the dates
1971             # possible. Work with them only.
1972              
1973 3         5 my($i,$first,$last);
1974              
1975             # Find the first date in the interval
1976              
1977 3         5 $i = 0;
1978 3         4 while (1) {
1979 7 100       17 last if (! exists $$self{'data'}{'dates'}{$i});
1980 5         9 my $date = $$self{'data'}{'dates'}{$i};
1981 5 100       11 if ($date->cmp($start) == -1) {
    50          
1982             # date < start : move to the next one
1983 4         7 $i++;
1984 4         6 next;
1985             } elsif ($date->cmp($end) == 1) {
1986             # date > end : we're done
1987 0         0 last;
1988             } else {
1989             # start <= date <= end : this is the first one
1990 1         3 $first = $i;
1991 1         3 last;
1992             }
1993             }
1994              
1995             # If we found one, find the last one
1996              
1997 3 100       10 if (defined($first)) {
1998 1         3 $i = $first;
1999 1         2 $last = $i;
2000 1         1 while (1) {
2001 4 50       10 last if (! exists $$self{'data'}{'dates'}{$i});
2002 4         7 my $date = $$self{'data'}{'dates'}{$i};
2003 4 100       7 if ($date->cmp($end) == 1) {
2004             # date > end : we're done
2005 1         2 last;
2006             } else {
2007             # date <= end : this might be the last one
2008 3         6 $last = $i;
2009 3         5 $i++;
2010 3         4 next;
2011             }
2012             }
2013             }
2014              
2015 3         6 $$self{'data'}{'first'} = $first;
2016 3         5 $$self{'data'}{'last'} = $last;
2017 3         8 return $$self{'data'}{$op}
2018             }
2019              
2020              
2021             # Given interval date Idate(n) produces event dates: Date(f)..Date(l)
2022             #
2023             # If we're looking at unmodified dates:
2024             # Find smallest n such that:
2025             # Idate(n) >= start
2026             # first=f
2027             # Then find largest n such that:
2028             # Idate(n) <= end
2029             # last=l
2030             # Otherwise
2031             # Find smallest n such that
2032             # Date(y) >= start
2033             # first=z (smallest z)
2034             # Where x <= z <= y and
2035             # Date(z) >= start
2036             # Then find largest n such that
2037             # Date(x) <= end
2038             # last=z (largest z)
2039             # Where x <= z <= y and
2040             # Date(z) <= end
2041              
2042 1149         2064 my($first_int,$last_int,$first,$last);
2043              
2044 1149 100       2651 if ($$self{'data'}{'slow'}) {
2045              
2046             #
2047             # For a 'slow' recurrence, we have to start at 0 and work forwards
2048             # or backwards.
2049             #
2050              
2051             # Move backwards until we're completely before start
2052              
2053 4         9 $first_int = 0;
2054 4 50       10 if ($unmod) {
2055 0         0 my $n = 0;
2056 0         0 while (1) {
2057 0 0       0 if ($n > $maxatt) {
2058 0         0 $$self{'err'} =
2059             "[_locate_n] Unable to find an interval in $maxatt attempts";
2060 0         0 return;
2061             }
2062 0         0 $self->_nth_interval($first_int);
2063 0         0 my $date = $$self{'data'}{'idate'}{$first_int}[0];
2064 0 0       0 if (defined($date)) {
2065 0         0 $n = 0;
2066 0 0       0 last if ($date->cmp($start) < 0);
2067             } else {
2068 0         0 $n++;
2069             }
2070 0         0 $first_int--;
2071             }
2072              
2073             } else {
2074 4         8 my $n = 0;
2075 4         6 while (1) {
2076 9 50       21 if ($n > $maxatt) {
2077 0         0 $$self{'err'} =
2078             "[_locate_n] Unable to find an interval in $maxatt attempts";
2079 0         0 return;
2080             }
2081 9         24 $self->_nth_interval($first_int);
2082 9         19 my $ptr = $$self{'data'}{'idate'}{$first_int}[2];
2083 9 100       21 if (defined $ptr) {
2084 8         13 my $date = $$self{'data'}{'dates'}{$ptr};
2085 8 50       20 if (defined($date)) {
2086 8         10 $n = 0;
2087 8 100       21 last if ($date->cmp($start) < 0);
2088             } else {
2089 0         0 $n++;
2090             }
2091             } else {
2092 1         1 $n++;
2093             }
2094 5         10 $first_int--;
2095             }
2096             }
2097              
2098             # Then move forwards until we're after start
2099             # i.e. Date(y) >= start for modified dates
2100              
2101 4 50       14 if ($unmod) {
2102 0         0 my $n = 0;
2103 0         0 while (1) {
2104 0 0       0 if ($n > $maxatt) {
2105 0         0 $$self{'err'} =
2106             "[_locate_n] Unable to find an interval in $maxatt attempts";
2107 0         0 return;
2108             }
2109 0         0 $self->_nth_interval($first_int);
2110 0         0 my $date = $$self{'data'}{'idate'}{$first_int}[0];
2111 0 0       0 if (defined($date)) {
2112 0         0 $n = 0;
2113 0 0       0 last if ($date->cmp($start) >= 0);
2114             } else {
2115 0         0 $n++;
2116             }
2117 0         0 $first_int++;
2118             }
2119 0         0 $first = $$self{'data'}{'idate'}{$first_int}[1];
2120              
2121             } else {
2122 4         8 my $n = 0;
2123 4         8 while (1) {
2124 11 50       20 if ($n > $maxatt) {
2125 0         0 $$self{'err'} =
2126             "[_locate_n] Unable to find an interval in $maxatt attempts";
2127 0         0 return;
2128             }
2129 11         31 $self->_nth_interval($first_int);
2130 11         23 my $ptr = $$self{'data'}{'idate'}{$first_int}[2];
2131 11 100       21 if (defined $ptr) {
2132 10         17 my $date = $$self{'data'}{'dates'}{$ptr};
2133 10 50       20 if (defined($date)) {
2134 10         15 $n = 0;
2135 10 100       20 last if ($date->cmp($start) >= 0);
2136             } else {
2137 0         0 $n++;
2138             }
2139             } else {
2140 1         2 $n++;
2141             }
2142 7         20 $first_int++;
2143             }
2144              
2145 4         19 foreach my $i ($$self{'data'}{'idate'}{$first_int}[1] ..
2146             $$self{'data'}{'idate'}{$first_int}[2]) {
2147 4         12 my $date = $$self{'data'}{'dates'}{$i};
2148 4 50 33     20 if (defined $date && $date->cmp($start) >= 0) {
2149 4         8 $first = $i;
2150 4         6 last;
2151             }
2152             }
2153             }
2154              
2155             # Then move forwards until we're after end
2156             # i.e. Date(x) > end for modified dates
2157              
2158 4         8 $last_int = $first_int;
2159              
2160 4 50       10 if ($unmod) {
2161 0         0 my $n = 0;
2162 0         0 while (1) {
2163 0 0       0 if ($n > $maxatt) {
2164 0         0 $$self{'err'} =
2165             "[_locate_n] Unable to find an interval in $maxatt attempts";
2166 0         0 return;
2167             }
2168 0         0 $self->_nth_interval($last_int);
2169 0         0 my $date = $$self{'data'}{'idate'}{$last_int}[0];
2170 0 0       0 if (defined($date)) {
2171 0         0 $n = 0;
2172 0 0       0 last if ($date->cmp($end) > 0);
2173             } else {
2174 0         0 $n++;
2175             }
2176 0         0 $last_int++;
2177             }
2178 0         0 $last_int--;
2179              
2180 0         0 for (my $i=$$self{'data'}{'idate'}{$last_int}[2];
2181             $i >= $$self{'data'}{'idate'}{$last_int}[1]; $i--) {
2182 0         0 my $date = $$self{'data'}{'dates'}{$i};
2183 0 0       0 if (defined $date) {
2184 0         0 $last = $i;
2185 0         0 last;
2186             }
2187             }
2188              
2189             } else {
2190 4         8 my $n = 0;
2191 4         7 while (1) {
2192 14 50       32 if ($n > $maxatt) {
2193 0         0 $$self{'err'} =
2194             "[_locate_n] Unable to find an interval in $maxatt attempts";
2195 0         0 return;
2196             }
2197 14         44 $self->_nth_interval($last_int);
2198 14         30 my $ptr = $$self{'data'}{'idate'}{$last_int}[1];
2199 14 100       27 if (defined $ptr) {
2200 12         20 my $date = $$self{'data'}{'dates'}{$ptr};
2201 12 50       21 if (defined($date)) {
2202 12         18 $n = 0;
2203 12 100       29 last if ($date->cmp($end) > 0);
2204             } else {
2205 0         0 $n++;
2206             }
2207             } else {
2208 2         3 $n++;
2209             }
2210 10         17 $last_int++;
2211             }
2212 4         9 $last_int--;
2213              
2214 4         9 $last = undef;
2215 4         6 my $i = $first;
2216 4         6 while (1) {
2217 17 50       35 last if (! exists $$self{'data'}{'dates'}{$i});
2218 17         28 my $date = $$self{'data'}{'dates'}{$i};
2219 17 50       27 next if (! defined $date);
2220 17 100       32 last if ($date->cmp($end) > 0);
2221 13         19 $last = $i;
2222 13         20 $i++;
2223             }
2224             }
2225              
2226 4 50 33     21 return undef if (! defined $last ||
2227             $last < $first);
2228 4         9 $$self{'data'}{'first'} = $first;
2229 4         7 $$self{'data'}{'last'} = $last;
2230 4         16 return $$self{'data'}{$op}
2231             }
2232              
2233             #
2234             # For a normal recurrence, we can estimate which interval date we're
2235             # interested in and then move forward/backward from it.
2236             #
2237             # Calculate the interval date index ($nn) based on the length of
2238             # the delta.
2239             #
2240             # For the Nth interval, the dates produced are:
2241             # N*EV_PER_DAY to (N+1)EV_PER_DAY-1
2242             #
2243              
2244 1145         2244 my $base = $$self{'data'}{'BASE'};
2245 1145         1801 my $delta = $$self{'data'}{'delta'};
2246             # $len = 0 is when a recur contains no delta (i.e. *Y:M:W:D:H:Mn:S)
2247 1145 50       4856 my $len = ($delta ? $delta->printf('%sys') : 0);
2248              
2249 1145 100       2508 my $targ = ($op eq 'first' ? $start : $end);
2250 1145         3436 my $diff = $base->calc($targ);
2251 1145         3074 my $tot = $diff->printf('%sys');
2252 1145 50       3361 my $nn = ($len ? int($tot/$len) : 1);
2253 1145         2537 my $ev = $$self{'data'}{'ev_per_d'};
2254              
2255             # Move backwards until we're completely before start
2256              
2257 1145         1710 $first_int = $nn;
2258 1145 100       2252 if ($unmod) {
2259 739         1003 my $n = 0;
2260 739         906 while (1) {
2261 1492 50       2789 if ($n > $maxatt) {
2262 0         0 $$self{'err'} =
2263             "[_locate_n] Unable to find an interval in $maxatt attempts";
2264 0         0 return;
2265             }
2266 1492         3971 $self->_nth_interval($first_int);
2267 1492         2799 my $date = $$self{'data'}{'idate'}{$first_int};
2268 1492 50       2529 if (defined($date)) {
2269 1492         1789 $n = 0;
2270 1492 100       3773 last if ($date->cmp($start) < 0);
2271             } else {
2272 0         0 $n++;
2273             }
2274 753         1301 $first_int--;
2275             }
2276              
2277             } else {
2278 406         684 my $n = 0;
2279             LOOP:
2280 406         611 while (1) {
2281 885 100       1739 if ($n > $maxatt) {
2282 1         6 $$self{'err'} =
2283             "[_locate_n] Unable to find an interval in $maxatt attempts";
2284 1         17 return;
2285             }
2286 884         2527 $self->_nth_interval($first_int);
2287 884         2605 for (my $i=($first_int+1)*$ev - 1; $i >= $first_int*$ev; $i--) {
2288 1012 100       2202 if (exists $$self{'data'}{'dates'}{$i}) {
2289 816         1378 my $date = $$self{'data'}{'dates'}{$i};
2290 816 50       1384 if (defined($date)) {
2291 816         1037 $n = 0;
2292 816 100       2016 last LOOP if ($date->cmp($start) < 0);
2293             } else {
2294 0         0 $n++;
2295             }
2296             } else {
2297 196         355 $n++;
2298             }
2299             }
2300 479         690 $first_int--;
2301             }
2302             }
2303              
2304             # Then move forwards until we're after start
2305             # i.e. Date(y) >= start for modified dates
2306              
2307 1144 100       2684 if ($unmod) {
2308 739         1160 my $n = 0;
2309 739         1008 while (1) {
2310 1478 50       2822 if ($n > $maxatt) {
2311 0         0 $$self{'err'} =
2312             "[_locate_n] Unable to find an interval in $maxatt attempts";
2313 0         0 return;
2314             }
2315 1478         3482 $self->_nth_interval($first_int);
2316 1478         2338 my $date = $$self{'data'}{'idate'}{$first_int};
2317 1478 50       2452 if (defined($date)) {
2318 1478         1832 $n = 0;
2319 1478 100       2876 last if ($date->cmp($start) >= 0);
2320             } else {
2321 0         0 $n++;
2322             }
2323 739         1220 $first_int++;
2324             }
2325              
2326             } else {
2327 405         699 my $n = 0;
2328             LOOP:
2329 405         536 while (1) {
2330 839 50       1834 if ($n > $maxatt) {
2331 0         0 $$self{'err'} =
2332             "[_locate_n] Unable to find an interval in $maxatt attempts";
2333 0         0 return;
2334             }
2335 839         2049 $self->_nth_interval($first_int);
2336 839         2292 for (my $i=($first_int+1)*$ev - 1; $i >= $first_int*$ev; $i--) {
2337 963 100       1923 if (exists $$self{'data'}{'dates'}{$i}) {
2338 872         1306 my $date = $$self{'data'}{'dates'}{$i};
2339 872 50       1457 if (defined($date)) {
2340 872         1230 $n = 0;
2341 872 100       1825 last LOOP if ($date->cmp($start) >= 0);
2342             } else {
2343 0         0 $n++;
2344             }
2345             } else {
2346 91         145 $n++;
2347             }
2348             }
2349 434         614 $first_int++;
2350             }
2351             }
2352 1144         1937 $first = $first_int*$ev;
2353              
2354             # Then move forwards until we're after end
2355             # i.e. Date(y) > end for modified dates
2356              
2357 1144         1706 $last_int = $first_int;
2358              
2359 1144 100       2141 if ($unmod) {
2360 739         1009 my $n = 0;
2361 739         949 while (1) {
2362 1478 50       2543 if ($n > $maxatt) {
2363 0         0 $$self{'err'} =
2364             "[_locate_n] Unable to find an interval in $maxatt attempts";
2365 0         0 return;
2366             }
2367 1478         3109 $self->_nth_interval($last_int);
2368 1478         2460 my $date = $$self{'data'}{'idate'}{$last_int};
2369 1478 50       2355 if (defined($date)) {
2370 1478         1744 $n = 0;
2371 1478 100       3248 last if ($date->cmp($end) > 0);
2372             } else {
2373 0         0 $n++;
2374             }
2375 739         1309 $last_int++;
2376             }
2377 739         1363 $last_int--;
2378              
2379             } else {
2380 405         633 my $n = 0;
2381             LOOP:
2382 405         545 while (1) {
2383 1462 50       2644 if ($n > $maxatt) {
2384 0         0 $$self{'err'} =
2385             "[_locate_n] Unable to find an interval in $maxatt attempts";
2386 0         0 return;
2387             }
2388 1462         3428 $self->_nth_interval($last_int);
2389 1462         3811 for (my $i=($last_int+1)*$ev - 1; $i >= $last_int*$ev; $i--) {
2390 1701 100       3802 next if (! exists $$self{'data'}{'dates'}{$i});
2391 1544         2365 my $date = $$self{'data'}{'dates'}{$i};
2392 1544 50       2402 if (defined($date)) {
2393 1544         1896 $n = 0;
2394 1544 100       3449 last LOOP if ($date->cmp($end) >= 0);
2395             } else {
2396 0         0 $n++;
2397             }
2398             }
2399 1057         1646 $last_int++;
2400             }
2401             }
2402              
2403 1144         2388 $last = ($last_int+1)*$ev - 1;
2404              
2405             # Now get the actual first/last dates
2406              
2407 1144 100       2444 if ($unmod) {
2408 739         972 while (1) {
2409             last if (exists $$self{'data'}{'dates'}{$first} &&
2410 739 100 66     3608 defined $$self{'data'}{'dates'}{$first});
2411 112         165 $first++;
2412 112 50       1000 return undef if ($first > $last);
2413             }
2414              
2415 627         963 while (1) {
2416             last if (exists $$self{'data'}{'dates'}{$last} &&
2417 627 50 33     2784 defined $$self{'data'}{'dates'}{$last});
2418 0         0 $last--;
2419             }
2420              
2421             } else {
2422 405         657 while (1) {
2423             last if (exists $$self{'data'}{'dates'}{$first} &&
2424             defined $$self{'data'}{'dates'}{$first} &&
2425 407 100 33     3010 $$self{'data'}{'dates'}{$first}->cmp($start) >= 0);
      66        
2426 2         5 $first++;
2427 2 50       10 return undef if ($first > $last);
2428             }
2429              
2430 405         631 while (1) {
2431             last if (exists $$self{'data'}{'dates'}{$last} &&
2432             defined $$self{'data'}{'dates'}{$last} &&
2433 954 100 66     4641 $$self{'data'}{'dates'}{$last}->cmp($end) <= 0);
      100        
2434 549         939 $last--;
2435             }
2436             }
2437              
2438 1032 100 66     4526 return undef if (! defined $last ||
2439             $last < $first);
2440 934         1940 $$self{'data'}{'first'} = $first;
2441 934         1652 $$self{'data'}{'last'} = $last;
2442 934         10488 return $$self{'data'}{$op}
2443             }
2444              
2445             # This returns the date easter occurs on for a given year as ($month,$day).
2446             # This is from the Calendar FAQ.
2447             #
2448             sub _easter {
2449 21     21   40 my($self,$y) = @_;
2450              
2451 21         35 my($c) = $y/100;
2452 21         38 my($g) = $y % 19;
2453 21         35 my($k) = ($c-17)/25;
2454 21         49 my($i) = ($c - $c/4 - ($c-$k)/3 + 19*$g + 15) % 30;
2455 21         46 $i = $i - ($i/28)*(1 - ($i/28)*(29/($i+1))*((21-$g)/11));
2456 21         43 my($j) = ($y + $y/4 + $i + 2 - $c + $c/4) % 7;
2457 21         33 my($l) = $i-$j;
2458 21         34 my($m) = 3 + ($l+40)/44;
2459 21         31 my($d) = $l + 28 - 31*($m/4);
2460 21         58 return ($m,$d);
2461             }
2462              
2463             # This returns 1 if a field is empty.
2464             #
2465             sub _field_empty {
2466 12150     12150   15695 my($self,$val) = @_;
2467              
2468 12150 100       17428 if (ref($val)) {
2469 10839         14443 my @tmp = @$val;
2470 10839 100 100     45811 return 1 if ($#tmp == -1 ||
      100        
      66        
2471             ($#tmp == 0 && ! ref($tmp[0]) && ! $tmp[0]));
2472 7289         12174 return 0;
2473              
2474             } else {
2475 1311         1878 return $val;
2476             }
2477             }
2478              
2479             # This returns a list of values that appear in a field in the rtime.
2480             #
2481             # $val is a listref, with each element being a value or a range.
2482             #
2483             # Usage:
2484             # _rtime_values('y' ,$y);
2485             # _rtime_values('m' ,$m);
2486             # _rtime_values('week_of_year' ,$w ,$y);
2487             # _rtime_values('dow_of_year' ,$w ,$y,$dow);
2488             # _rtime_values('dow_of_month' ,$w ,$y,$m,$dow);
2489             # _rtime_values('day_of_year' ,$d ,$y);
2490             # _rtime_values('day_of_month' ,$d ,$y,$m);
2491             # _rtime_values('day_of_week' ,$d);
2492             # _rtime_values('h' ,$h);
2493             # _rtime_values('mn' ,$mn);
2494             # _rtime_values('s' ,$s);
2495             #
2496             # Returns ($err,@vals)
2497             #
2498             sub _rtime_values {
2499 19788     19788   29509 my($self,$type,$val,@args) = @_;
2500 19788         24114 my $dmt = $$self{'tz'};
2501 19788         22224 my $dmb = $$dmt{'base'};
2502              
2503 19788 100       49630 if ($type eq 'h') {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
2504 3962         6050 @args = (0,0,23,23);
2505              
2506             } elsif ($type eq 'mn') {
2507 3995         5767 @args = (0,0,59,59);
2508              
2509             } elsif ($type eq 's') {
2510 3995         5622 @args = (0,0,59,59);
2511              
2512             } elsif ($type eq 'y') {
2513 137         389 my $curry = $dmt->_now('y',1);
2514 137         251 foreach my $y (@$val) {
2515 213 100 66     644 $y = $curry if (! ref($y) && $y==0);
2516             }
2517              
2518 137         252 @args = (0,1,9999,9999);
2519              
2520             } elsif ($type eq 'm') {
2521 2953         4599 @args = (0,1,12,12);
2522              
2523             } elsif ($type eq 'week_of_year') {
2524 49         75 my($y) = @args;
2525 49         139 my $wiy = $dmb->weeks_in_year($y);
2526 49         106 @args = (1,1,$wiy,53);
2527              
2528             } elsif ($type eq 'dow_of_year') {
2529 164         291 my($y,$dow) = @args;
2530              
2531             # Get the 1st occurrence of $dow
2532 164         198 my $d0 = 1;
2533 164         560 my $dow0 = $dmb->day_of_week([$y,1,$d0]);
2534 164 100       472 if ($dow > $dow0) {
    100          
2535 15         55 $d0 += ($dow-$dow0);
2536             } elsif ($dow < $dow0) {
2537 119         166 $d0 += 7-($dow0-$dow);
2538             }
2539              
2540             # Get the last occurrence of $dow
2541 164         222 my $d1 = 31;
2542 164         392 my $dow1 = $dmb->day_of_week([$y,12,$d1]);
2543 164 100       363 if ($dow1 > $dow) {
    100          
2544 121         149 $d1 -= ($dow1-$dow);
2545             } elsif ($dow1 < $dow) {
2546 15         23 $d1 -= 7-($dow-$dow1);
2547             }
2548              
2549             # Find out the number of occurrenced of $dow
2550 164         425 my $doy1 = $dmb->day_of_year([$y,12,$d1]);
2551 164         296 my $n = ($doy1 - $d0)/7 + 1;
2552              
2553             # Get the list of @w
2554 164         301 @args = (1,1,$n,53);
2555              
2556             } elsif ($type eq 'dow_of_month') {
2557 826         1360 my($y,$m,$dow) = @args;
2558              
2559             # Get the 1st occurrence of $dow in the month
2560 826         1022 my $d0 = 1;
2561 826         2804 my $dow0 = $dmb->day_of_week([$y,$m,$d0]);
2562 826 100       2149 if ($dow > $dow0) {
    100          
2563 185         331 $d0 += ($dow-$dow0);
2564             } elsif ($dow < $dow0) {
2565 504         797 $d0 += 7-($dow0-$dow);
2566             }
2567              
2568             # Get the last occurrence of $dow
2569 826         1752 my $d1 = $dmb->days_in_month($y,$m);
2570 826         2017 my $dow1 = $dmb->day_of_week([$y,$m,$d1]);
2571 826 100       1841 if ($dow1 > $dow) {
    100          
2572 526         741 $d1 -= ($dow1-$dow);
2573             } elsif ($dow1 < $dow) {
2574 180         296 $d1 -= 7-($dow-$dow1);
2575             }
2576              
2577             # Find out the number of occurrenced of $dow
2578 826         1154 my $n = ($d1 - $d0)/7 + 1;
2579              
2580             # Get the list of @w
2581 826         1728 @args = (1,1,$n,5);
2582              
2583             } elsif ($type eq 'day_of_year') {
2584 171         225 my($y) = @args;
2585 171         419 my $diy = $dmb->days_in_year($y);
2586 171         330 @args = (1,1,$diy,366);
2587              
2588             } elsif ($type eq 'day_of_month') {
2589 2810         4552 my($y,$m) = @args;
2590 2810         6818 my $dim = $dmb->days_in_month($y,$m);
2591 2810         5194 @args = (1,1,$dim,31);
2592              
2593             } elsif ($type eq 'day_of_week') {
2594 726         1379 @args = (0,1,7,7);
2595             }
2596              
2597 19788         28541 my($err,@vals) = $self->__rtime_values($val,@args);
2598 19788 50       28926 if ($err) {
2599 0         0 $$self{'err'} = "[dates] $err [$type]";
2600 0         0 return (1);
2601             }
2602 19788         35348 return(0,@vals);
2603             }
2604              
2605             # This returns the raw values for a list.
2606             #
2607             # If $allowneg is 0, only positive numbers are allowed, and they must be
2608             # in the range [$min,$absmax]. If $allowneg is 1, positive numbers in the
2609             # range [$min,$absmax] and negative numbers in the range [-$absmax,-$min]
2610             # are allowed. An error occurs if a value falls outside the range.
2611             #
2612             # Only values in the range of [$min,$max] are actually kept. This allows
2613             # a recurrence for day_of_month to be 1-31 and not fail for a month that
2614             # has fewer than 31 days. Any value outside the [$min,$max] are silently
2615             # discarded.
2616             #
2617             # Returns:
2618             # ($err,@vals)
2619             #
2620             sub __rtime_values {
2621 19788     19788   27282 my($self,$vals,$allowneg,$min,$max,$absmax) = @_;
2622 19788         20175 my(@ret);
2623              
2624 19788         26283 foreach my $val (@$vals) {
2625              
2626 20337 100       26084 if (ref($val)) {
2627 24         42 my($val1,$val2) = @$val;
2628              
2629 24 50       52 if ($allowneg) {
2630 24 0 33     135 return ('Value outside range')
      33        
      0        
      33        
      33        
2631             if ( ($val1 >= 0 && ($val1 < $min || $val1 > $absmax) ) ||
2632             ($val2 >= 0 && ($val2 < $min || $val2 > $absmax) ) );
2633 24 50 0     140 return ('Negative value outside range')
      33        
      33        
      33        
      33        
2634             if ( ($val1 <= 0 && ($val1 < -$absmax || $val1 > -$min) ) ||
2635             ($val2 <= 0 && ($val2 < -$absmax || $val2 > -$min) ) );
2636              
2637             } else {
2638 0 0 0     0 return ('Value outside range')
      0        
      0        
2639             if ( ($val1 < $min || $val1 > $absmax) ||
2640             ($val2 < $min || $val2 > $absmax) );
2641              
2642             }
2643              
2644 24 50 33     161 return ('Range values reversed')
      33        
      33        
      33        
      33        
2645             if ( ($val1 <= 0 && $val2 <= 0 && $val1 > $val2) ||
2646             ($val1 >= 0 && $val2 >= 0 && $val1 > $val2) );
2647              
2648             # Use $max instead of $absmax when converting negative numbers to
2649             # positive ones.
2650              
2651 24 50       43 $val1 = $max + $val1 + 1 if ($val1 < 0); # day -10
2652 24 50       47 $val2 = $max + $val2 + 1 if ($val2 < 0);
2653              
2654 24 50       42 $val1 = $min if ($val1 < $min); # day -31 in a 30 day month
2655 24 50       43 $val2 = $max if ($val2 > $max);
2656              
2657 24 100       42 next if ($val1 > $val2);
2658              
2659 20         49 push(@ret,$val1..$val2);
2660              
2661             } else {
2662              
2663 20313 100       25756 if ($allowneg) {
2664 4193 50 33     14737 return ('Value outside range')
      66        
2665             if ($val >= 0 && ($val < $min || $val > $absmax));
2666 4193 50 33     7924 return ('Negative value outside range')
      66        
2667             if ($val <= 0 && ($val < -$absmax || $val > -$min));
2668             } else {
2669 16120 50 33     40047 return ('Value outside range')
2670             if ($val < $min || $val > $absmax);
2671             }
2672              
2673             # Use $max instead of $absmax when converting negative numbers to
2674             # positive ones.
2675              
2676 20313         20739 my $ret;
2677 20313 100       25035 if ($val < 0 ) {
2678 401         507 $ret = $max + $val + 1;
2679             } else {
2680 19912         20956 $ret = $val;
2681             }
2682              
2683 20313 100 100     42624 next if ($ret > $max || $ret < $min);
2684 19925         28399 push(@ret,$ret);
2685             }
2686             }
2687              
2688 19788         37764 return ('',@ret);
2689             }
2690              
2691             # This takes a list of dates (each a listref of [y,m,d,h,mn,s]) and replaces
2692             # the Nth field with all of the possible values passed in, creating a new
2693             # list with all the dates.
2694             #
2695             sub _field_add_values {
2696 11952     11952   17860 my($self,$datesref,$n,@val) = @_;
2697              
2698 11952         14666 my @dates = @$datesref;
2699 11952         12263 my @tmp;
2700              
2701 11952         14593 foreach my $date (@dates) {
2702 12397         17600 my @d = @$date;
2703 12397         13847 foreach my $val (@val) {
2704 12465         15702 $d[$n] = $val;
2705 12465         28922 push(@tmp,[@d]);
2706             }
2707             }
2708              
2709 11952         24408 @$datesref = @tmp;
2710             }
2711              
2712             1;
2713             # Local Variables:
2714             # mode: cperl
2715             # indent-tabs-mode: nil
2716             # cperl-indent-level: 3
2717             # cperl-continued-statement-offset: 2
2718             # cperl-continued-brace-offset: 0
2719             # cperl-brace-offset: 0
2720             # cperl-brace-imaginary-offset: 0
2721             # cperl-label-offset: 0
2722             # End: