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   1251 use Date::Manip::Obj;
  168         363  
  168         8085  
15             @ISA = ('Date::Manip::Obj');
16              
17             require 5.010000;
18 168     168   976 use warnings;
  168         350  
  168         5768  
19 168     168   1095 use strict;
  168         398  
  168         4144  
20 168     168   898 use integer;
  168         389  
  168         5925  
21 168     168   4821 use utf8;
  168         375  
  168         922  
22 168     168   4294 use IO::File;
  168         415  
  168         27362  
23             #use re 'debug';
24              
25 168     168   1195 use Date::Manip::Base;
  168         363  
  168         3911  
26 168     168   972 use Date::Manip::TZ;
  168         414  
  168         2299668  
27              
28             our $VERSION;
29             $VERSION='6.91';
30 168     168   2531 END { undef $VERSION; }
31              
32             ########################################################################
33             # BASE METHODS
34             ########################################################################
35              
36             sub is_recur {
37 1     1 1 112 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   2934 my($self) = @_;
45 1718         3798 my $dmt = $$self{'tz'};
46 1718         2742 my $dmb = $$dmt{'base'};
47              
48 1718         2815 $$self{'err'} = '';
49              
50 1718         2949 $$self{'data'}{'freq'} = ''; # The frequency
51 1718         3353 $$self{'data'}{'flags'} = []; # Modifiers
52 1718         3709 $$self{'data'}{'base'} = undef; # The specified base date
53 1718         2562 $$self{'data'}{'BASE'} = undef; # The actual base date
54 1718         3381 $$self{'data'}{'start'} = undef; # Start and end date
55 1718         3170 $$self{'data'}{'end'} = undef;
56 1718         2532 $$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         3206 $$self{'data'}{'interval'} = []; # (Y, M, ...)
61 1718         3452 $$self{'data'}{'rtime'} = []; # ( [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
62             # [ VAL_OR_RANGE, VAL_OR_RANGE, ... ],
63             # ... )
64 1718         2881 $$self{'data'}{'slow'} = 0; # 1 if a range of the form 2--2 is
65             # included.
66 1718         2671 $$self{'data'}{'ev_per_d'} = 0; # The number of events per interval date.
67 1718         4362 $$self{'data'}{'delta'} = undef; # The offset based on the interval.
68 1718         2672 $$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         6342 $$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         6262 $$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         3103 $$self{'data'}{'curr'} = undef; # Iterator pointer
84 1718         2640 $$self{'data'}{'first'} = undef; # N : the first date in a range
85 1718         2562 $$self{'data'}{'last'} = undef; # N : the last date in a range
86              
87             # Get the default start/end dates
88              
89 1718         5011 my $range = $dmb->_config('recurrange');
90              
91 1718 50       4124 if ($range eq 'none') {
    0          
    0          
    0          
    0          
    0          
92 1718         2645 $$self{'data'}{'start'} = undef;
93 1718         3149 $$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   3098 my($self,$keep) = @_;
153              
154 1603 100       3336 if (! $keep) {
155 1097         2727 $$self{'data'}{'base'} = undef;
156 1097         1938 $$self{'data'}{'BASE'} = undef;
157 1097         12515 $$self{'data'}{'idate'} = {};
158 1097         8710 $$self{'data'}{'dates'} = {};
159             }
160 1603         2776 $$self{'data'}{'curr'} = undef;
161 1603         2729 $$self{'data'}{'first'} = undef;
162 1603         3232 $$self{'data'}{'last'} = undef;
163             }
164              
165             sub _init_args {
166 2     2   6 my($self) = @_;
167              
168 2         4 my @args = @{ $$self{'args'} };
  2         6  
169 2         7 $self->parse(@args);
170             }
171              
172             ########################################################################
173             # METHODS
174             ########################################################################
175              
176             sub parse {
177 487     487 1 377461 my($self,$string,@args) = @_;
178 487         1522 $self->_init();
179              
180             # Test if $string = FREQ
181              
182 487         1425 my $err = $self->frequency($string);
183 487 100       1084 if (! $err) {
184 364         619 $string = '';
185             }
186              
187             # Test if $string = "FREQ*..." and FREQ contains an '*'.
188              
189 487 100       1153 if ($err) {
190 123         553 $self->err(1);
191              
192 123         846 $string =~ s/\s*\*\s*/\*/g;
193              
194 123 50       592 if ($string =~ /^([^*]*\*[^*]*)\*/) {
195             # Everything up to the 2nd '*'
196 123         373 my $freq = $1;
197 123         344 $err = $self->frequency($freq);
198 123 50       315 if (! $err) {
199 123         1974 $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       1225 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       977 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         1180 my @string = split(/\*/,$string);
231              
232 487 100       1106 if (@string) {
233 123         248 my $tmp = shift(@string);
234 123 100       441 $err = $self->modifiers($tmp) if ($tmp);
235 123 50       293 return 1 if ($err);
236             }
237              
238 487 100       1089 if (@args) {
239 266         493 my $tmp = $args[0];
240 266 100 66     940 if ($tmp && ! ref($tmp)) {
241 207         591 $err = $self->modifiers($tmp);
242 207 100       552 shift(@args) if (! $err);
243             }
244             }
245              
246             # Handle BASE
247              
248 487 100       1075 if (@string) {
249 25         72 my $tmp = shift(@string);
250 25 100 66     169 $err = $self->basedate($tmp) if (defined($tmp) && $tmp);
251 25 50       82 return 1 if ($err);
252             }
253 487 100       997 if (@args) {
254 265         413 my $tmp = shift(@args);
255 265 100 66     1018 $err = $self->basedate($tmp) if (defined($tmp) && $tmp);
256 265 50       586 return 1 if ($err);
257             }
258              
259             # Handle START, END, UNMOD
260              
261 487 100       1022 if (@string) {
262 24         75 my($start) = shift(@string);
263 24         76 my($end) = shift(@string);
264 24         59 my($unmod) = shift(@string);
265              
266 24 50 33     212 $err = $self->start($start,$unmod) if (defined($start) && $start);
267 24 50       78 return 1 if ($err);
268              
269 24 50 33     285 $err = $self->end($end) if (defined($end) && $end);
270 24 50       137 return 1 if ($err);
271             }
272 487 100       1019 if (@args) {
273 265         553 my($start) = shift(@args);
274 265         496 my($end) = shift(@args);
275 265         408 my($unmod) = shift(@args);
276              
277 265 100 66     1173 $err = $self->start($start,$unmod) if (defined($start) && $start);
278 265 50       669 return 1 if ($err);
279              
280 265 100 66     1287 $err = $self->end($end) if (defined($end) && $end);
281 265 50       704 return 1 if ($err);
282             }
283              
284             # Remaining arguments are invalid.
285              
286 487 50       1114 if (@string) {
287 0         0 $$self{'err'} = "[parse] String contains invalid elements";
288 0         0 return 1;
289             }
290 487 50       1015 if (@args) {
291 0         0 $$self{'err'} = "[parse] Unknown arguments";
292 0         0 return 1;
293             }
294              
295 487         1340 return 0;
296             }
297              
298             sub frequency {
299 942     942 1 365700 my($self,$string) = @_;
300 942 50       2084 return $$self{'data'}{'freq'} if (! defined $string);
301              
302 942         2337 $self->_init();
303 942         1518 my (@int,@rtime);
304              
305             PARSE: {
306              
307             # Standard frequency notation
308              
309 942         1336 my $stdrx = $self->_rx('std');
  942         2374  
310 942 100       9523 if ($string =~ $stdrx) {
311 782         7701 my($l,$r) = @+{qw(l r)};
312              
313 782 50       2813 if (defined($l)) {
314 782         1886 $l =~ s/^\s*:/0:/;
315 782         1590 $l =~ s/:\s*$/:0/;
316 782         1176 $l =~ s/::/:0:/g;
317              
318 782         2471 @int = split(/:/,$l);
319             }
320              
321 782 50       1594 if (defined($r)) {
322 782         1908 $r =~ s/^\s*:/0:/;
323 782         2234 $r =~ s/:\s*$/:0/;
324 782         1421 $r =~ s/::/:0:/g;
325              
326 782         2142 @rtime = split(/:/,$r);
327             }
328              
329 782         1763 last PARSE;
330             }
331              
332             # Other frequency strings
333              
334             # Strip out some words to ignore
335              
336 160         448 my $ignrx = $self->_rx('ignore');
337 160         1292 $string =~ s/$ignrx/ /g;
338              
339 160         412 my $eachrx = $self->_rx('each');
340 160         314 my $each = 0;
341 160 100       1188 if ($string =~ s/$eachrx/ /g) {
342 28         53 $each = 1;
343             }
344              
345 160         1058 $string =~ s/\s*$//;
346              
347 160 50       448 if (! $string) {
348 0         0 $$self{'err'} = "[frequency] Invalid frequency string";
349 0         0 return 1;
350             }
351              
352 160         500 my $err = $self->_parse_lang($string);
353 160 100       459 if ($err) {
354 128         257 $$self{'err'} = "[frequency] Invalid frequency string";
355 128         320 return 1;
356             }
357 32         77 return 0;
358             }
359              
360             # If the interval consists only of zeros, the last entry is changed
361             # to 1.
362              
363 782 100       1829 if (@int) {
364 552         1107 for my $i (@int) {
365 1078         2003 $i += 0;
366             }
367              
368             TEST_INT: {
369 552         774 for my $i (@int) {
  552         974  
370 787 100       1730 last TEST_INT if ($i);
371             }
372 75         154 $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     4534 while (@int &&
      100        
      100        
382             ($#int == 1 || $#int == 2) &&
383             ($int[$#int] == 0)) {
384 101         192 pop(@int);
385 101         564 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         2339 my @ftype = ('y','m','w','d','h','mn','s');
405 782         1912 my @vtype = ('' ,'' ,'' ,'' ,'' ,'' ,'');
406              
407 782         2037 my ($y,$m,$w,$d,$h,$mn,$s) = (@int,@rtime);
408              
409 782 100       1767 if (@rtime == 7) {
410 230         401 $vtype[0] = 'y';
411             }
412              
413 782 100       1766 if (@rtime >= 6) {
414 547 100       1136 if ($m) {
415 371         669 $vtype[1] = 'moy';
416             } else {
417 176         338 $vtype[1] = 'zero';
418             }
419             }
420              
421 782 100       1649 if (@rtime >= 5) {
422 685 100       1354 if ($w) {
423 329 100       652 if ($m) {
424 226         448 $vtype[2] = 'wom';
425             } else {
426 103         181 $vtype[2] = 'woy';
427             }
428             } else {
429 356         601 $vtype[2] = 'zero';
430             }
431             }
432              
433 782 100       1727 if (@rtime >= 4) {
434 727 100       1374 if ($d) {
435 528 100       1241 if ($w) {
    100          
436 226         378 $vtype[3] = 'dow';
437             } elsif ($m) {
438 247         448 $vtype[3] = 'dom';
439             } else {
440 55         115 $vtype[3] = 'doy';
441             }
442             } else {
443 199         351 $vtype[3] = 'zero';
444             }
445             }
446              
447 782 100       1590 if (@rtime >= 3) {
448 766         1109 $vtype[4] = 'time';
449             }
450 782 100       1569 if (@rtime >= 2) {
451 771         1148 $vtype[5] = 'time';
452             }
453 782 100       1556 if (@rtime) {
454 771         1103 $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         1821 my $rfieldrx = $self->_rx('rfield');
466 782         1549 my $rrangerx = $self->_rx('rrange');
467              
468 782         1319 my $i = -1;
469 782         1566 foreach my $f (@int,@rtime) {
470 4772         6053 $i++;
471 4772         6585 my $vtype = $vtype[$i];
472 4772         6017 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       8130 next if (! $vtype);
480              
481 3795 100 100     17890 if ($f && $f !~ $rfieldrx) {
482 1         2 $$self{'err'} = "[frequency] Invalid rtime string";
483 1         7 return 1;
484             }
485              
486 3794         8116 my @rfield = split(/,/,$f);
487 3794         4742 my @val;
488              
489 3794         5225 foreach my $vals (@rfield) {
490 3858 100       10154 if ($vals =~ $rrangerx) {
491 73         321 my ($num1,$num2) = ($1+0,$2+0);
492              
493 73         231 my $err = $self->_frequency_values($num1,$type,$vtype);
494 73 100       180 return $err if ($err);
495              
496 72         175 $err = $self->_frequency_values($num2,$type,$vtype);
497 72 50       204 return $err if ($err);
498              
499 72 100 100     331 if ( ($num1 > 0 && $num2 > 0) ||
      66        
      100        
500             ($num1 < 0 && $num2 < 0) ) {
501 66 100       154 if ($num1 > $num2) {
502 2         4 $$self{'err'} = "[frequency] Invalid rtime range string";
503 2         10 return 1;
504             }
505 64         232 push(@val,$num1..$num2);
506             } else {
507 6         20 push(@val,[$num1,$num2]);
508             }
509              
510             } else {
511 3785         6160 $vals += 0;
512              
513 3785         6861 my $err = $self->_frequency_values($vals,$type,$vtype);
514 3785 100       7215 return $err if ($err);
515              
516 3609         6601 push(@val,$vals);
517             }
518             }
519              
520 3615         8671 $f = [ @val ];
521             }
522              
523             # Store it
524              
525 602         1599 $$self{'data'}{'interval'} = [ @int ];
526 602         1492 $$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         1517 my $freq = join(':',@int);
532 602         895 my $slow = 0;
533 602         822 my $n = 1;
534 602 100       1284 if (@rtime) {
535 591         1008 $freq .= '*';
536 591         846 my (@tmp);
537              
538 591         934 foreach my $rtime (@rtime) {
539 3418         3996 my @t2;
540 3418         4742 foreach my $tmp (@$rtime) {
541 3694 100       5373 if (ref($tmp)) {
542 6         15 my($a,$b) = @$tmp;
543 6         21 push(@t2,"$a-$b");
544 6         16 $slow = 1;
545             } else {
546 3688         5745 push(@t2,$tmp);
547             }
548             }
549 3418         5577 my $tmp = join(',',@t2);
550 3418         5001 push(@tmp,$tmp);
551 3418         4182 my $nn = @t2;
552 3418         5524 $n *= $nn;
553             }
554 591         1798 $freq .= join(':',@tmp);
555             }
556 602         1212 $$self{'data'}{'freq'} = $freq;
557 602         945 $$self{'data'}{'slow'} = $slow;
558 602 100       1445 $$self{'data'}{'ev_per_d'} = $n if (! $slow);
559              
560 602 100       1205 if (@int) {
561 436         773 $$self{'data'}{'noint'} = 0;
562              
563 436         989 while (@int < 7) {
564 2256         3869 push(@int,0);
565             }
566 436         1736 my $delta = $self->new_delta();
567 436         2273 $delta->set('delta',[@int]);
568 436         1211 $$self{'data'}{'delta'} = $delta;
569              
570             } else {
571 166         300 $$self{'data'}{'noint'} = 1;
572             }
573              
574 602         2517 return 0;
575             }
576              
577             sub _frequency_values {
578 3930     3930   6819 my($self,$num,$type,$vtype) = @_;
579 3930         4823 my $err;
580              
581 3930 100       10876 if ($type eq 'y') {
    100          
    100          
    100          
    100          
582 248 50       523 if ($vtype eq 'y') {
583 248 100 100     942 if ($num < 0 || $num > 9999) {
584 16         33 $$self{'err'} = "[frequency] Year must be in the range 1-9999";
585 16         36 return 1;
586             }
587             }
588              
589             } elsif ($type eq 'm') {
590 572 100       1264 if ($vtype eq 'moy') {
591 404 100 100     1568 if ($num < 1 || $num > 12) {
592 34         61 $$self{'err'} = "[frequency] Month of year must be 1-12";
593 34         69 return 1;
594             }
595             }
596              
597             } elsif ($type eq 'w') {
598 670 100       1962 if ($vtype eq 'woy') {
    100          
599 103 100 66     638 if ($num == 0 || $num > 53 || $num < -53) {
      100        
600 22         44 $$self{'err'} = "[frequency] Week of year must be 1-53 or -1 to -53";
601 22         44 return 1;
602             }
603              
604             } elsif ($vtype eq 'wom') {
605 235 100 66     1300 if ($num == 0 || $num > 5 || $num < -5) {
      100        
606 31         59 $$self{'err'} = "[frequency] Week of month must be 1-5 or -1 to -5";
607 31         66 return 1;
608             }
609              
610             }
611              
612             } elsif ($type eq 'd') {
613 635 100       1927 if ($vtype eq 'dow') {
    100          
    100          
614 190 100 100     827 if ($num < 1 || $num > 7) {
615 36         63 $$self{'err'} = "[frequency] Day of week must be 1-7";
616 36         74 return 1;
617             }
618              
619             } elsif ($vtype eq 'dom') {
620 245 100 66     1363 if ($num == 0 || $num > 31 || $num < -31) {
      100        
621 20         39 $$self{'err'} = "[frequency] Day of month must be 1-31 or -1 to -31";
622 20         42 return 1;
623             }
624              
625             } elsif ($vtype eq 'doy') {
626 55 100 66     355 if ($num == 0 || $num > 366 || $num < -366) {
      100        
627 14         29 $$self{'err'} = "[frequency] Day of year must be 1-366 or -1 to -366";
628 14         30 return 1;
629             }
630             }
631              
632             } elsif ($type eq 'h') {
633 614 50       1283 if ($vtype eq 'time') {
634 614 100 66     2159 if ($num < 0 || $num > 23) {
635 1         3 $$self{'err'} = "[frequency] Hour must be 0-23";
636 1         3 return 1;
637             }
638             }
639              
640             } else {
641 1191 50       2360 if ($vtype eq 'time') {
642 1191 100 66     3993 if ($num < 0 || $num > 59) {
643 3         6 $$self{'err'} = "[frequency] Minute/second must be 0-59";
644 3         7 return 1;
645             }
646             }
647             }
648              
649 3753         6476 return 0;
650             }
651              
652             sub _parse_lang {
653 160     160   349 my($self,$string) = @_;
654 160         281 my $dmt = $$self{'tz'};
655 160         267 my $dmb = $$dmt{'base'};
656              
657             # Test the regular expression
658              
659 160         454 my $rx = $self->_rx('every');
660              
661 160 100       2875 return 1 if ($string !~ $rx);
662             my($month,$week,$day,$last,$nth,$day_name,$day_abb,$mon_name,$mon_abb,$n,$y) =
663 32         705 @+{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         143 my $dow;
668 32 100 66     128 if (defined($day_name) || defined($day_abb)) {
669 16 50       57 if (defined($day_name)) {
670 16         66 $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     120 if (defined($mon_name) || defined($mon_abb)) {
678 8 50       22 if (defined($mon_name)) {
679 8         39 $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       75 if (defined($nth)) {
686 14         88 $nth = $$dmb{'data'}{'wordmatch'}{'nth'}{lc($nth)};
687             }
688              
689             # Get the frequencies
690              
691 32         52 my($freq);
692 32 100       97 if (defined($dow)) {
    50          
693 16 100       46 if (defined($mmm)) {
694 8 100       28 if (defined($last)) {
    100          
695             # last DoW in MMM [YY]
696 2         8 $freq = "1*$mmm:-1:$dow:0:0:0";
697              
698             } elsif (defined($nth)) {
699             # Nth DoW in MMM [YY]
700 4         23 $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       29 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         19 $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       40 if (defined($month)) {
724 8 100       29 if (defined($nth)) {
    100          
725             # Nth day of every month [YY]
726 4         31 $freq = "0:1*0:$nth:0:0:0";
727              
728             } elsif (defined($last)) {
729             # last day of every month [YY]
730 2         8 $freq = "0:1*0:-1:0:0:0";
731              
732             } else {
733             # every day of every month [YY]
734 2         4 $freq = "0:0:0:1*0:0:0";
735             }
736              
737             } else {
738 8 100       20 if (defined($nth)) {
    100          
739             # every Nth day [YY]
740 2         8 $freq = "0:0:0:$nth*0:0:0";
741              
742             } elsif (defined($n)) {
743             # every N days [YY]
744 4         14 $freq = "0:0:0:$n*0:0:0";
745              
746             } else {
747             # every day [YY]
748 2         5 $freq = "0:0:0:1*0:0:0";
749             }
750             }
751             }
752              
753             # Get the range (if YY is included)
754              
755 32 100       77 if (defined($y)) {
756 18         81 $y = $dmt->_fix_year($y);
757 18         61 my $start = "${y}010100:00:00";
758 18         33 my $end = "${y}123123:59:59";
759              
760 18         127 return $self->parse($freq,undef,$start,$end);
761             }
762              
763 14         55 return $self->frequency($freq)
764             }
765              
766             sub _date {
767 679     679   1342 my($self,$op,$date_or_string) = @_;
768              
769             # Make sure the argument is a date
770              
771 679 50       1825 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         1940 my $date = $self->new_date();
780 679         1878 my $err = $date->parse($date_or_string);
781 679 50       1530 if ($err) {
782 0         0 $$self{'err'} = "[$op] Invalid date string";
783 0         0 return 1;
784             }
785 679         1700 $$self{'data'}{$op} = $date;
786             }
787              
788 679         1486 return 0;
789             }
790              
791             sub start {
792 1019     1019 1 2512 my($self,$start,$unmod) = @_;
793 1019 100       4324 return $$self{'data'}{'start'} if (! defined $start);
794              
795 253         723 $self->_init_dates(1);
796 253         490 $$self{'data'}{'unmod_range'} = $unmod;
797 253         661 $self->_date('start',$start);
798             }
799              
800             sub end {
801 337     337 1 1214 my($self,$end) = @_;
802 337 100       1074 return $$self{'data'}{'end'} if (! defined $end);
803              
804 253         687 $self->_init_dates(1);
805 253         634 $self->_date('end',$end);
806             }
807              
808             sub basedate {
809 173     173 1 2051 my($self,$base) = @_;
810 173 50       369 return ($$self{'data'}{'base'},$$self{'data'}{'BASE'}) if (! defined $base);
811              
812 173         483 $self->_init_dates();
813 173         458 $self->_date('base',$base);
814             }
815              
816             sub modifiers {
817 309     309 1 811 my($self,@flags) = @_;
818 309 50       707 return @{ $$self{'data'}{'flags'} } if (! @flags);
  0         0  
819              
820 309         557 my $dmt = $$self{'tz'};
821 309         607 my $dmb = $$dmt{'base'};
822 309 50       736 if (@flags == 1) {
823 309         896 @flags = split(/,/,lc($flags[0]));
824             }
825              
826             # Add these flags to the list
827              
828 309 50 33     1274 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         640 foreach my $flag (@flags) {
837 322 100       1526 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         432 $$self{'err'} = "[modifiers] Invalid modifier: $flag";
839 151         397 return 1;
840             }
841              
842 158         451 $$self{'data'}{'flags'} = [ @flags ];
843 158         501 $self->_init_dates();
844              
845 158         317 return 0;
846             }
847              
848             sub nth {
849 2097     2097 1 7310 my($self,$n) = @_;
850 2097 100       4075 $n = 0 if (! $n);
851             return ($$self{'data'}{'dates'}{$n},0)
852 2097 100       6370 if (exists $$self{'data'}{'dates'}{$n});
853              
854 86         207 my ($err) = $self->_error();
855 86 50       213 return (undef,$err) if ($err);
856              
857             return ($$self{'data'}{'dates'}{$n},0)
858 86 100       223 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       201 if ($$self{'data'}{'noint'}) {
863 4         9 return (undef,0);
864             }
865              
866 80 100       179 if ($$self{'data'}{'slow'}) {
867 2         5 my $nn = 0;
868 2         3 while (1) {
869 4         9 $self->_nth_interval($nn);
870             return ($$self{'data'}{'dates'}{$n},0)
871 4 100       28 if (exists $$self{'data'}{'dates'}{$n});
872 2 50       7 if ($n >= 0) {
873 2         5 $nn++;
874             } else {
875 0         0 $nn--;
876             }
877             }
878              
879             } else {
880 78         109 my $nn;
881 78 100       155 if ($n >= 0) {
882 74         140 $nn = int($n/$$self{'data'}{'ev_per_d'});
883             } else {
884 4         9 $nn = int(($n+1)/$$self{'data'}{'ev_per_d'}) -1;
885             }
886 78         202 $self->_nth_interval($nn);
887 78         219 return ($$self{'data'}{'dates'}{$n},0);
888             }
889             }
890              
891             sub next {
892 8     8 1 1048 my($self) = @_;
893              
894 8         19 my ($err) = $self->_error();
895 8 50       26 return (undef,$err) if ($err);
896              
897             # If curr is not set, we have to get it.
898              
899 8 100       24 if (! defined $$self{'data'}{'curr'}) {
900              
901             CURR:
902 5         7 while (1) {
903              
904             # If no interval then
905             # return base date
906              
907 5 100       28 if ($$self{'data'}{'noint'}) {
908 1         4 $$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     30 if (defined $$self{'data'}{'start'} &&
916             defined $$self{'data'}{'end'}) {
917              
918 2         17 my $n = $self->_locate_n('first');
919 2 100 66     13 return (undef,'Not found') if ($$self{'err'} || ! defined($n));
920 1         3 $$self{'data'}{'curr'} = $n-1;
921              
922             } else {
923 2         4 $$self{'data'}{'curr'} = -1;
924             }
925 3         7 last CURR;
926             }
927             }
928              
929             # With curr set, find the next defined one
930              
931 7         10 while (1) {
932 9         14 $$self{'data'}{'curr'}++;
933 9 100       16 if ($$self{'data'}{'noint'}) {
934             return (undef,0)
935 3 100       11 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       25 return ($d,0) if (defined $d);
940             }
941             }
942              
943             sub prev {
944 11     11 1 1381 my($self) = @_;
945              
946 11         23 my ($err) = $self->_error();
947 11 50       27 return (undef,$err) if ($err);
948              
949             # If curr is not set, we have to get it.
950              
951 11 100       27 if (! defined $$self{'data'}{'curr'}) {
952              
953             CURR:
954 5         10 while (1) {
955              
956             # If no interval then
957             # return last one
958              
959 5 100       12 if ($$self{'data'}{'noint'}) {
960 1         2 my @n = sort { $a <=> $b } keys %{ $$self{'data'}{'dates'} };
  1         5  
  1         6  
961 1         6 $$self{'data'}{'curr'} = pop(@n) + 1;
962 1         2 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         8 my $n = $self->_locate_n('last');
972 2 100 66     18 return (undef,'Not found') if ($$self{'err'} || ! defined($n));
973 1         3 $$self{'data'}{'curr'} = $n+1;
974              
975             } else {
976 2         4 $$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       25 if ($$self{'data'}{'noint'}) {
987             return (undef,0)
988 6 100       20 if (! exists $$self{'data'}{'dates'}{$$self{'data'}{'curr'}});
989             }
990 9         27 my ($d,$e) = $self->nth($$self{'data'}{'curr'});
991 9 50       30 return (undef,$e) if ($e);
992 9 100       32 return ($d,0) if (defined $d);
993             }
994             }
995              
996             sub dates {
997 1181     1181 1 3818 my($self,$start2,$end2,$unmod) = @_;
998 1181         3888 $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         1778 my $tmp_limits = 0;
1004 1181 100 100     3742 $tmp_limits = 1 if ($start2 || $end2);
1005 1181 100       2434 $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         1611 my $range_required;
1011 1181 100 100     3765 if (defined($start2) && defined($end2)) {
1012 735         1169 $range_required = 0;
1013             } else {
1014 446         715 $range_required = 1;
1015             }
1016              
1017 1181         1614 my($err);
1018 1181         3016 ($err,$start2,$end2) = $self->_error($range_required,$start2,$end2);
1019 1181 100       2618 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         1943 my ($old_start, $old_end, $old_first, $old_last, $old_unmod);
1025              
1026 1174 100       2282 if ($tmp_limits) {
1027 737         1331 $old_start = $$self{'data'}{'start'};
1028 737         1665 $old_end = $$self{'data'}{'end'};
1029 737         1153 $old_first = $$self{'data'}{'first'};
1030 737         1170 $old_last = $$self{'data'}{'last'};
1031 737         1190 $old_unmod = $$self{'data'}{'unmod_range'};
1032              
1033 737         1253 $$self{'data'}{'start'} = $start2;
1034 737         1136 $$self{'data'}{'end'} = $end2;
1035 737         1190 $$self{'data'}{'first'} = undef;
1036 737         1152 $$self{'data'}{'last'} = undef;
1037 737         1175 $$self{'data'}{'unmod_range'} = $unmod;
1038             }
1039              
1040             # Get all of the dates
1041              
1042 1174         1901 my($end,$first,$last,@dates);
1043              
1044 1174         3101 $first = $self->_locate_n('first');
1045 1174 100       3250 return () if ($$self{'err'});
1046 1173         3005 $last = $self->_locate_n('last');
1047 1173 50       3159 return () if ($$self{'err'});
1048              
1049 1173 100 66     3953 if (defined($first) && defined($last)) {
1050 1068         2720 for (my $n = $first; $n <= $last; $n++) {
1051 2050         4354 my($date,$err) = $self->nth($n);
1052 2050 100       6490 push(@dates,$date) if (defined $date);
1053             }
1054             }
1055              
1056             # Restore the original date range values.
1057              
1058 1173 100       2446 if ($tmp_limits) {
1059 737         1405 $$self{'data'}{'start'} = $old_start;
1060 737         1303 $$self{'data'}{'end'} = $old_end;
1061 737         1146 $$self{'data'}{'first'} = $old_first;
1062 737         1201 $$self{'data'}{'last'} = $old_last;
1063 737         1257 $$self{'data'}{'unmod_range'} = $old_unmod;
1064             }
1065              
1066 1173         7693 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   2616 my($self,$range_required,$start2,$end2) = @_;
1078              
1079 1286 50       2767 return ('Invalid recurrence') if ($self->err());
1080              
1081             # All dates entered must be valid.
1082              
1083 1286         2339 my($start,$end);
1084 1286 100       3238 if (defined $start2) {
    100          
1085 736 100       1964 if (ref($start2) eq 'Date::Manip::Date') {
    50          
1086 54         90 $start = $start2;
1087             } elsif (! ref($start2)) {
1088 682         1708 $start = $self->new_date();
1089 682         2116 $start->parse($start2);
1090             } else {
1091 0         0 return ('Invalid start argument');
1092             }
1093 736 50       2293 return ('Start invalid') if ($start->err());
1094             } elsif (defined $$self{'data'}{'start'}) {
1095 369         722 $start = $$self{'data'}{'start'};
1096 369 50       916 return ('Start invalid') if ($start->err());
1097             }
1098              
1099 1286 100       3485 if (defined $end2) {
    100          
1100 736 100       2093 if (ref($end2) eq 'Date::Manip::Date') {
    50          
1101 54         73 $end = $end2;
1102             } elsif (! ref($end2)) {
1103 682         1900 $end = $self->new_date();
1104 682         1807 $end->parse($end2);
1105             } else {
1106 0         0 return ('Invalid end argument');
1107             }
1108 736 50       2333 return ('End invalid') if ($end->err());
1109             } elsif (defined $$self{'data'}{'end'}) {
1110 369         627 $end = $$self{'data'}{'end'};
1111 369 50       899 return ('End invalid') if ($end->err());
1112             }
1113              
1114 1286 100       3502 if (defined $$self{'data'}{'base'}) {
1115 227         409 my $base = $$self{'data'}{'base'};
1116 227 50       466 return ('Base invalid') if ($base->err());
1117             }
1118              
1119             # *Y:M:W:D:H:MN:S is complete.
1120              
1121 1286 100       3158 if ($$self{'data'}{'noint'}) {
1122 148 100       397 if ($$self{'data'}{'noint'} == 1) {
1123 137         312 my @dates = $self->_apply_rtime_mods();
1124 137         340 $$self{'data'}{'noint'} = 2;
1125              
1126 137         218 my $n = 0;
1127 137         255 foreach my $date (@dates) {
1128 230 50       471 next if (! defined $date);
1129 230         625 $$self{'data'}{'dates'}{$n++} = $date;
1130             }
1131              
1132 137 50       323 return (0,$start,$end) if ($n == 0);
1133              
1134 137 100 66     438 if (defined $start && defined $end) {
1135 5         11 my ($first,$last);
1136 5         23 for (my $i=0; $i<$n; $i++) {
1137 7         19 my $date = $$self{'data'}{'dates'}{$i};
1138 7 100 66     27 if ($start->cmp($date) <= 0 &&
1139             $end->cmp($date) >= 0) {
1140 4         20 $first = $i;
1141 4         14 last;
1142             }
1143             }
1144 5         28 for (my $i=$n-1; $i>=0; $i--) {
1145 8         24 my $date = $$self{'data'}{'dates'}{$i};
1146 8 100 100     25 if ($start->cmp($date) <= 0 &&
1147             $end->cmp($date) >= 0) {
1148 4         11 $last = $i;
1149 4         13 last;
1150             }
1151             }
1152              
1153 5         25 $$self{'data'}{'first'} = $first;
1154 5         14 $$self{'data'}{'last'} = $last;
1155             } else {
1156 132         233 $$self{'data'}{'first'} = 0;
1157 132         290 $$self{'data'}{'last'} = $n-1;
1158             }
1159             }
1160 148         422 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     3925 if ($start && $end) {
    100          
1167 1100 50       3088 return ('Range invalid') if ($start->cmp($end) == 1);
1168             } elsif ($range_required) {
1169 7         16 return ('Incomplete recurrence');
1170             }
1171              
1172             # Check that the base date is available.
1173              
1174 1131         3670 $self->_actual_base($start);
1175              
1176 1131 50       2875 if (defined $$self{'data'}{'BASE'}) {
1177 1131         2027 my $base = $$self{'data'}{'BASE'};
1178 1131 50       3336 return ('Base invalid') if ($base->err());
1179 1131         3464 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   2216 my($self,$start2) = @_;
1191              
1192             # Is the actual base date already defined?
1193              
1194 1131 100       2922 return if (defined $$self{'data'}{'BASE'});
1195              
1196             # Use the specified base date or start date.
1197              
1198 1011         1616 my $base = undef;
1199 1011 100       2661 if (defined $$self{'data'}{'base'}) {
    50          
    0          
1200 171         300 $base = $$self{'data'}{'base'};
1201             } elsif (defined $start2) {
1202 840         1335 $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         1594 my $dmt = $$self{'tz'};
1212 1011         1482 my $dmb = $$dmt{'base'};
1213 1011         3256 $dmt->_update_now(); # Update NOW
1214 1011         1459 my @int = @{ $$self{'data'}{'interval'} };
  1011         3004  
1215 1011         1715 my @rtime = @{ $$self{'data'}{'rtime'} };
  1011         3369  
1216 1011         2372 my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime);
1217 1011         2402 my ($y,$m,$d,$h,$mn,$s) = $base->value();
1218 1011         2951 my $BASE = $self->new_date();
1219 1011         1797 my $n = @int;
1220              
1221 1011 50       3282 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         2938 $BASE->set('date',[$y,1,1,0,0,0]);
1228              
1229             } elsif ($n == 2) {
1230             # Y:M*W:D:H:MN:S
1231 78         334 $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         72 my($ymd) = $dmb->week_of_year($yy,$w);
1237 19         128 $BASE->set('date',[@$ymd,0,0,0]);
1238              
1239             } elsif ($n == 4) {
1240             # Y:M:W:D*H:MN:S
1241 31         146 $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         32 $BASE->set('date',[$y,$m,$d,$h,$mn,$s]);
1254             }
1255              
1256 1011         3726 $$self{'data'}{'BASE'} = $BASE;
1257             }
1258              
1259             sub _rx {
1260 2986     2986   5093 my($self,$rx) = @_;
1261 2986         4504 my $dmt = $$self{'tz'};
1262 2986         4302 my $dmb = $$dmt{'base'};
1263              
1264             return $$dmb{'data'}{'rx'}{'recur'}{$rx}
1265 2986 100       9103 if (exists $$dmb{'data'}{'rx'}{'recur'}{$rx});
1266              
1267 122 100 66     935 if ($rx eq 'std') {
    100 66        
    100          
    100          
    50          
1268              
1269 28         62 my $l = '[0-9]*';
1270 28         65 my $r = '[-,0-9]*';
1271 28         781 my $stdrx = "(?$l:$l:$l:$l:$l:$l:$l)(?)|" .
1272             "(?$l:$l:$l:$l:$l:$l)\\*(?$r)|" .
1273             "(?$l:$l:$l:$l:$l)\\*(?$r:$r)|" .
1274             "(?$l:$l:$l:$l)\\*(?$r:$r:$r)|" .
1275             "(?$l:$l:$l)\\*(?$r:$r:$r:$r)|" .
1276             "(?$l:$l)\\*(?$r:$r:$r:$r:$r)|" .
1277             "(?$l)\\*(?$r:$r:$r:$r:$r:$r)|" .
1278             "(?)\\*(?$r:$r:$r:$r:$r:$r:$r)";
1279 28         3437 $$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         71 my $num = '[+-]?\d+';
1286 28         121 my $range = "$num\-$num";
1287 28         287 my $val = "(?:$range|$num)";
1288 28         103 my $vals = "$val(?:,$val)*";
1289              
1290 28         1209 $$dmb{'data'}{'rx'}{'recur'}{'rfield'} = qr/^($vals)$/;
1291 28         521 $$dmb{'data'}{'rx'}{'recur'}{'rnum'} = qr/^($num)$/;
1292 28         713 $$dmb{'data'}{'rx'}{'recur'}{'rrange'} = qr/^($num)\-($num)$/;
1293              
1294             } elsif ($rx eq 'each') {
1295              
1296 22         93 my $each = $$dmb{'data'}{'rx'}{'each'};
1297              
1298 22         622 my $eachrx = qr/(?:^|\s+)(?:$each)(\s+|$)/i;
1299 22         121 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $eachrx;
1300              
1301             } elsif ($rx eq 'ignore') {
1302              
1303 22         78 my $of = $$dmb{'data'}{'rx'}{'of'};
1304 22         84 my $on = $$dmb{'data'}{'rx'}{'on'};
1305              
1306 22         733 my $ignrx = qr/(?:^|\s+)(?:$on|$of)(\s+|$)/i;
1307 22         115 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $ignrx;
1308              
1309             } elsif ($rx eq 'every') {
1310              
1311 22         84 my $month = $$dmb{'data'}{'rx'}{'fields'}[2];
1312 22         66 my $week = $$dmb{'data'}{'rx'}{'fields'}[3];
1313 22         64 my $day = $$dmb{'data'}{'rx'}{'fields'}[4];
1314              
1315 22         60 my $last = $$dmb{'data'}{'rx'}{'last'};
1316 22         64 my $nth = $$dmb{'data'}{'rx'}{'nth'}[0];
1317 22         63 my $nth_wom = $$dmb{'data'}{'rx'}{'nth_wom'}[0];
1318 22         74 my $nth_dom = $$dmb{'data'}{'rx'}{'nth_dom'}[0];
1319              
1320 22         67 my $day_abb = $$dmb{'data'}{'rx'}{'day_abb'}[0];
1321 22         68 my $day_name = $$dmb{'data'}{'rx'}{'day_name'}[0];
1322 22         61 my $mon_abb = $$dmb{'data'}{'rx'}{'month_abb'}[0];
1323 22         69 my $mon_name = $$dmb{'data'}{'rx'}{'month_name'}[0];
1324              
1325 22         48 my $beg = '(?:^|\s+)';
1326 22         47 my $end = '(?:\s*$)';
1327              
1328 22         95 $month = "$beg(?$month)"; # months
1329 22         77 $week = "$beg(?$week)"; # weeks
1330 22         69 $day = "$beg(?$day)"; # days
1331              
1332 22         61 $last = "$beg(?$last)"; # last
1333 22         122 $nth = "$beg(?$nth)"; # 1st,2nd,...
1334 22         80 $nth_wom = "$beg(?$nth_wom)"; # 1st - 5th
1335 22         88 $nth_dom = "$beg(?$nth_dom)"; # 1st - 31st
1336 22         59 my $n = "$beg(?\\d+)"; # 1,2,...
1337              
1338 22         99 my $dow = "$beg(?:(?$day_name)|(?$day_abb))"; # Sun|Sunday
1339 22         101 my $mmm = "$beg(?:(?$mon_name)|(?$mon_abb))"; # Jan|January
1340              
1341 22         71 my $y = "(?:$beg(?:(?\\d\\d\\d\\d)|(?\\d\\d)))?";
1342              
1343 22         670 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         38602 $freqrx = qr/^(?:$freqrx)\s*$/i;
1372 22         726 $$dmb{'data'}{'rx'}{'recur'}{$rx} = $freqrx;
1373             }
1374              
1375 122         628 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   7961 my($self,$date) = @_;
1393 4050         6369 my $dmt = $$self{'tz'};
1394 4050         6234 my $dmb = $$dmt{'base'};
1395 4050         5543 my @int = @{ $$self{'data'}{'interval'} };
  4050         8996  
1396 4050         6091 my @rtime = @{ $$self{'data'}{'rtime'} };
  4050         9263  
1397 4050         5995 my $n = @int;
1398              
1399 4050         8506 my ($yf,$mf,$wf,$df,$hf,$mnf,$sf) = (@int,@rtime);
1400 4050         8676 my $m_empty = $self->_field_empty($mf);
1401 4050         7527 my $w_empty = $self->_field_empty($wf);
1402 4050         7573 my $d_empty = $self->_field_empty($df);
1403 4050         7481 my ($err,$y,$m,$d,$h,$mn,$s,@y,@m,@w,@d,@h,@mn,@s,@doy,@woy,@dow,@n);
1404 4050 100       13561 ($y,$m,$d,$h,$mn,$s) = $date->value() if (defined $date);
1405 4050         6912 my(@date);
1406              
1407 4050 100       8503 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       6104 if (@int == 0) {
1414 137         296 ($err,@y) = $self->_rtime_values('y',$yf);
1415 137 50       350 return () if ($err);
1416             } else {
1417 3144         5440 @y = ($y);
1418             }
1419              
1420 3281 100 100     17358 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       4776 $mf = [1] if ($m_empty);
1434 2480 100       4559 $df = [1] if ($d_empty);
1435              
1436 2480         5356 ($err,@m) = $self->_rtime_values('m',$mf);
1437 2480 50       4982 return () if ($err);
1438              
1439 2480         3936 foreach my $y (@y) {
1440 2496         3649 foreach my $m (@m) {
1441 2549         4836 ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
1442 2549 50       4903 return () if ($err);
1443 2549         3899 foreach my $d (@d) {
1444 2429         7849 push(@date,[$y,$m,$d,0,0,0]);
1445             }
1446             }
1447             }
1448              
1449             } elsif ($m_empty) {
1450              
1451 328 100       769 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         285 foreach my $y (@y) {
1458 171         399 ($err,@doy) = $self->_rtime_values('day_of_year',$df,$y);
1459 171 50       362 return () if ($err);
1460 171         358 foreach my $doy (@doy) {
1461 137         180 my($yy,$mm,$dd) = @{ $dmb->day_of_year($y,$doy) };
  137         368  
1462 137         468 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         110 foreach my $y (@y) {
1473 49         140 ($err,@woy) = $self->_rtime_values('week_of_year',$wf,$y);
1474 49 50       130 return () if ($err);
1475 49         113 foreach my $woy (@woy) {
1476 51         72 my ($yy,$mm,$dd) = @{ $dmb->week_of_year($y,$woy) };
  51         162  
1477 51         179 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         299 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1488 128 50       295 return () if ($err);
1489 128         250 foreach my $y (@y) {
1490 164         260 foreach my $dow (@dow) {
1491 164         334 ($err,@n) = $self->_rtime_values('dow_of_year',$wf,$y,$dow);
1492 164 50       368 return () if ($err);
1493 164         314 foreach my $n (@n) {
1494 82         246 my $ymd = $dmb->nth_day_of_week($y,$n,$dow);
1495 82         199 my($yy,$mm,$dd) = @$ymd;
1496 82         310 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         1203 ($err,@m) = $self->_rtime_values('m',$mf);
1512 473 50       1204 return () if ($err);
1513              
1514 473 100       975 if ($d_empty) {
1515 76         248 @dow = ($dmb->_config('firstday'));
1516             } else {
1517 397         866 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1518 397 50       1025 return () if ($err);
1519             }
1520              
1521 473         918 foreach my $y (@y) {
1522 477         840 foreach my $m (@m) {
1523 639         1010 foreach my $dow (@dow) {
1524 639         1330 ($err,@n) = $self->_rtime_values('dow_of_month',
1525             $wf,$y,$m,$dow);
1526 639 50       1436 return () if ($err);
1527 639         1141 foreach my $n (@n) {
1528 629         1889 my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
1529 629         1270 my($yy,$mm,$dd) = @$ymd;
1530 629         2357 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       934 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       608 $df = [1] if ($d_empty);
1551              
1552 261         608 ($err,@d) = $self->_rtime_values('day_of_month',$df,$y,$m);
1553 261 50       588 return () if ($err);
1554 261         479 foreach my $d (@d) {
1555 271         814 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       407 if ($d_empty) {
1566 51         155 @dow = ($dmb->_config('firstday'));
1567             } else {
1568 136         367 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1569 136 50       383 return () if ($err);
1570             }
1571              
1572 187         341 foreach my $dow (@dow) {
1573 187         410 ($err,@n) = $self->_rtime_values('dow_of_month',
1574             $wf,$y,$m,$dow);
1575 187 50       476 return () if ($err);
1576 187         328 foreach my $n (@n) {
1577 237         610 my $ymd = $dmb->nth_day_of_week($y,$n,$dow,$m);
1578 237         455 my($yy,$mm,$dd) = @$ymd;
1579 237         786 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         293 my $fdow = $dmb->_config('firstday');
1600 100 100       230 if ($d_empty) {
1601 35         77 @dow = ($fdow);
1602             } else {
1603 65         154 ($err,@dow) = $self->_rtime_values('day_of_week',$df);
1604 65 50       159 return () if ($err);
1605             }
1606              
1607 100         165 my($mm,$dd);
1608 100         363 my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]);
1609 100         173 ($yy,$mm,$dd) = @{ $dmb->week_of_year($yy,$ww) };
  100         223  
1610              
1611 100         207 foreach my $dow (@dow) {
1612 112 50       250 $dow += 7 if ($dow < $fdow);
1613 112         501 my($yyy,$mmm,$ddd) = @{ $dmb->calc_date_days([$yy,$mm,$dd],$dow-$fdow) };
  112         377  
1614 112         374 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         344 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         87 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         132 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       8233 if ($n <= 4 ) {
1656 3962         7896 ($err,@h) = $self->_rtime_values('h',$hf);
1657 3962 50       7436 return () if ($err);
1658 3962         9508 $self->_field_add_values(\@date,3,@h);
1659             }
1660              
1661             # Do minutes
1662 4050 100       8498 if ($n <= 5) {
1663 3995         7687 ($err,@mn) = $self->_rtime_values('mn',$mnf);
1664 3995 50       7829 return () if ($err);
1665 3995         7983 $self->_field_add_values(\@date,4,@mn);
1666             }
1667              
1668             # Do seconds
1669 4050 100       8247 if ($n <= 6) {
1670 3995         7298 ($err,@s) = $self->_rtime_values('s',$sf);
1671 3995 50       7927 return () if ($err);
1672 3995         7873 $self->_field_add_values(\@date,5,@s);
1673             }
1674              
1675             # Sort the dates... just to be sure.
1676              
1677 4050 100       12540 @date = sort { $dmb->cmp($a,$b) } @date if (@date);
  507         1336  
1678              
1679             #
1680             # Apply modifiers
1681             #
1682              
1683 4050         5945 my @flags = @{ $$self{'data'}{'flags'} };
  4050         9181  
1684 4050 100       8042 if (@flags) {
1685 2156         6604 my $obj = $self->new_date();
1686              
1687 2156         3336 my @keep;
1688 2156         3933 foreach my $date (@date) {
1689 2192         4931 my ($y,$m,$d,$h,$mn,$s) = @$date;
1690              
1691 2192         3028 my $keep = 1;
1692              
1693             MODIFIER:
1694 2192         3440 foreach my $flag (@flags) {
1695 2343         3363 my(@wd,$today);
1696              
1697 2343 100 100     23964 if ($flag =~ /^([pn])([dt])([1-7])$/) {
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
1698 56         176 my($forw,$today,$dow) = ($1,$2,$3);
1699 56 100       130 $forw = ($forw eq 'p' ? 0 : 1);
1700 56 100       111 $today = ($today eq 'd' ? 0 : 1);
1701             ($y,$m,$d,$h,$mn,$s) =
1702 56         74 @{ $obj->__next_prev([$y,$m,$d,$h,$mn,$s],$forw,$dow,$today) };
  56         202  
1703              
1704             } elsif ($flag =~ /^([fb])([dw])(\d+)$/) {
1705 427         2571 my($prev,$business,$n) = ($1,$2,$3);
1706 427 100       1064 $prev = ($prev eq 'b' ? 1 : 0);
1707 427 100       860 $business = ($business eq 'w' ? 1 : 0);
1708              
1709 427 100       869 if ($business) {
1710             ($y,$m,$d,$h,$mn,$s) =
1711 18         32 @{ $obj->__nextprev_business_day($prev,$n,0,[$y,$m,$d,$h,$mn,$s]) };
  18         102  
1712             } else {
1713 409         597 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],$n,$prev) };
  409         1584  
1714             }
1715              
1716             } elsif ($flag eq 'ibd' ||
1717             $flag eq 'nbd') {
1718 243         954 my $bd = $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0);
1719              
1720 243 100 100     1369 if ( ($flag eq 'ibd' && ! $bd) ||
      100        
      100        
1721             ($flag eq 'nbd' && $bd) ) {
1722 113         179 $keep = 0;
1723 113         253 last MODIFIER;
1724             }
1725              
1726             } elsif ($flag =~ /^([in])w([1-7])$/) {
1727 99         331 my($is,$dow) = ($1,$2);
1728 99 50       219 $is = ($is eq 'i' ? 1 : 0);
1729 99         368 my $currdow = $dmb->day_of_week([$y,$m,$d]); # Current dow
1730 99 100 66     539 if ( ($is && $dow != $currdow) ||
      33        
      66        
1731             (! $is && $dow == $currdow) ) {
1732 85         122 $keep = 0;
1733 85         207 last MODIFIER;
1734             }
1735              
1736             } elsif ($flag =~ /^wd([1-7])$/) {
1737 9         29 my $dow = $1; # Dow wanted
1738 9         37 my $currdow = $dmb->day_of_week([$y,$m,$d]); # Current dow
1739 9 100       45 if ($dow != $currdow) {
1740 7         39 my($yy,$ww) = $dmb->week_of_year([$y,$m,$d]); # What week is this
1741 7         19 my $tmp = $dmb->week_of_year($yy,$ww); # First day of week
1742 7         15 ($y,$m,$d) = @$tmp;
1743 7         16 $currdow = $dmb->_config('firstday');
1744 7 50       21 if ($dow > $currdow) {
    0          
1745 7         24 $tmp = $dmb->calc_date_days([$y,$m,$d],$dow-$currdow);
1746 7         26 ($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       714 if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1755             ($y,$m,$d,$h,$mn,$s) =
1756 78         142 @{ $obj->__nextprev_business_day(0,0,0,[$y,$m,$d,$h,$mn,$s]) };
  78         380  
1757             }
1758              
1759             } elsif ($flag eq 'pwd') {
1760 10 100       54 if (! $obj->__is_business_day([$y,$m,$d,$h,$mn,$s],0)) {
1761             ($y,$m,$d,$h,$mn,$s) =
1762 5         18 @{ $obj->__nextprev_business_day(1,1,0,[$y,$m,$d,$h,$mn,$s]) };
  5         22  
1763             }
1764              
1765             } elsif ($flag eq 'easter') {
1766 21         86 ($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     2557 if ($flag eq 'cwd' || $flag eq 'dwd') {
    100          
    50          
1775 608 50       1416 if ($dmb->_config('tomorrowfirst')) {
1776 608         2961 @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         61 @wd = ([$y,$m,$d,$h,$mn,$s],+1, [$y,$m,$d,$h,$mn,$s],-1);
1783 9         25 $today = 0;
1784              
1785             } elsif ($flag eq 'cwp') {
1786 9         82 @wd = ([$y,$m,$d,$h,$mn,$s],-1, [$y,$m,$d,$h,$mn,$s],+1);
1787 9         22 $today = 0;
1788             }
1789              
1790 626         1218 while (1) {
1791 739         1282 my(@d,$off);
1792              
1793             # Test in the first direction
1794              
1795 739         1073 @d = @{ $wd[0] };
  739         2098  
1796 739         1280 $off = $wd[1];
1797 739         1009 @d = @{ $dmb->calc_date_days(\@d,$off) };
  739         2221  
1798              
1799 739 100       2464 if ($obj->__is_business_day(\@d,0)) {
1800 396         1015 ($y,$m,$d,$h,$mn,$s) = @d;
1801 396         1564 last;
1802             }
1803              
1804 343         1198 $wd[0] = [@d];
1805              
1806             # Test in the other direction
1807              
1808 343         611 @d = @{ $wd[2] };
  343         924  
1809 343         645 $off = $wd[3];
1810 343         545 @d = @{ $dmb->calc_date_days(\@d,$off) };
  343         944  
1811              
1812 343 100       1196 if ($obj->__is_business_day(\@d,0)) {
1813 230         580 ($y,$m,$d,$h,$mn,$s) = @d;
1814 230         881 last;
1815             }
1816              
1817 113         448 $wd[2] = [@d];
1818             }
1819              
1820             }
1821             }
1822              
1823 2192 100       4724 if ($keep) {
1824 1994         5895 push(@keep,[$y,$m,$d,$h,$mn,$s]);
1825             }
1826             }
1827 2156         11131 @date = @keep;
1828             }
1829              
1830             #
1831             # Convert the dates to objects.
1832             #
1833              
1834 4050         6082 my(@ret);
1835              
1836 4050         6483 foreach my $date (@date) {
1837 4039         9168 my @d = @$date;
1838              
1839 4039         11285 my $obj = $self->new_date();
1840 4039         13558 $obj->set('date',\@d);
1841 4039 100       12736 if ($obj->err()) {
1842 1         8 push(@ret,undef);
1843             } else {
1844 4038         9735 push(@ret,$obj);
1845             }
1846             }
1847              
1848 4050         19638 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   13744 my($self,$n) = @_;
1856 7768 100       18874 return if (exists $$self{'data'}{'idate'}{$n});
1857 3913         6310 my $base = $$self{'data'}{'BASE'};
1858 3913         5131 my $date;
1859              
1860             # Get the interval date.
1861              
1862 3913 100       7366 if ($n == 0) {
1863 999         1459 $date = $base;
1864              
1865             } else {
1866 2914         9412 my @delta = $$self{'data'}{'delta'}->value;
1867 2914         5347 my $absn = abs($n);
1868 2914         5587 @delta = map { $absn*$_ } @delta;
  20398         31116  
1869 2914         8319 my $delta = $self->new_delta;
1870 2914         11150 $delta->set('delta',[@delta]);
1871 2914 100       13262 $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       10499 if ($$self{'data'}{'slow'}) {
1878              
1879 24 100       70 if ($n > 0) {
    100          
1880 14         60 $self->_nth_interval($n-1);
1881             } elsif ($n < 0) {
1882 5         21 $self->_nth_interval($n+1);
1883             }
1884             }
1885              
1886             # Get the list of events associated with this interval date.
1887              
1888 3913         9936 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         6393 my($n0,$n1);
1896 3913 100       9258 if ($$self{'data'}{'slow'}) {
1897              
1898 24 100       129 if (! @date) {
    100          
    100          
1899 4         10 $n0 = undef;
1900 4         11 $n1 = undef;
1901              
1902             } elsif ($n == 0) {
1903 4         9 $n0 = 0;
1904 4         12 $n1 = $#date;
1905              
1906             } elsif ($n > 0) {
1907 11         105 foreach (my $i = $n-1; $i >= 0; $i--) {
1908 14 100       51 next if (! defined $$self{'data'}{'idate'}{$i}[2]);
1909 10         21 $n0 = $$self{'data'}{'idate'}{$i}[2] + 1;
1910 10         15 last;
1911             }
1912 11 100       23 $n0 = 0 if (! defined $n0);
1913 11         20 $n1 = $n0 + $#date;
1914              
1915             } else {
1916 5         23 foreach (my $i = $n+1; $i <= 0; $i++) {
1917 5 100       33 next if (! defined $$self{'data'}{'idate'}{$i}[1]);
1918 4         11 $n1 = $$self{'data'}{'idate'}{$i}[1] - 1;
1919 4         7 last;
1920             }
1921 5 100       12 $n1 = -1 if (! defined $n1);
1922 5         11 $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         6475 $n0 = $n * $$self{'data'}{'ev_per_d'};
1936 3889         6959 $n1 = $n0 + $$self{'data'}{'ev_per_d'} - 1;
1937             }
1938              
1939             # Store the dates.
1940              
1941 3913         9349 for (my $i=0; $i<=$#date; $i++) {
1942 3809         14590 $$self{'data'}{'dates'}{$n0+$i} = $date[$i];
1943             }
1944              
1945             # Store the idate.
1946              
1947 3913 100       8074 if ($$self{'data'}{'slow'}) {
1948 24         84 $$self{'data'}{'idate'}{$n} = [$date,$n0,$n1];
1949             } else {
1950 3889         9737 $$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   4431 my($self,$op) = @_;
1959              
1960 2351 100       6656 return $$self{'data'}{$op} if (defined $$self{'data'}{$op});
1961              
1962 1152         2019 my $start = $$self{'data'}{'start'};
1963 1152         1921 my $end = $$self{'data'}{'end'};
1964 1152         1958 my $unmod = $$self{'data'}{'unmod_range'};
1965 1152         1791 my $dmt = $$self{'tz'};
1966 1152         1767 my $dmb = $$dmt{'base'};
1967 1152         3131 my $maxatt = $dmb->_config('maxrecurattempts');
1968              
1969 1152 100       3041 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         8 my($i,$first,$last);
1974              
1975             # Find the first date in the interval
1976              
1977 3         6 $i = 0;
1978 3         5 while (1) {
1979 7 100       21 last if (! exists $$self{'data'}{'dates'}{$i});
1980 5         11 my $date = $$self{'data'}{'dates'}{$i};
1981 5 100       16 if ($date->cmp($start) == -1) {
    50          
1982             # date < start : move to the next one
1983 4         7 $i++;
1984 4         9 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         4 $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         2 $i = $first;
1999 1         2 $last = $i;
2000 1         2 while (1) {
2001 4 50       12 last if (! exists $$self{'data'}{'dates'}{$i});
2002 4         8 my $date = $$self{'data'}{'dates'}{$i};
2003 4 100       10 if ($date->cmp($end) == 1) {
2004             # date > end : we're done
2005 1         3 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         8 $$self{'data'}{'first'} = $first;
2016 3         9 $$self{'data'}{'last'} = $last;
2017 3         10 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         1988 my($first_int,$last_int,$first,$last);
2043              
2044 1149 100       2524 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         12 $first_int = 0;
2054 4 50       11 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         9 my $n = 0;
2075 4         5 while (1) {
2076 9 50       23 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         27 $self->_nth_interval($first_int);
2082 9         25 my $ptr = $$self{'data'}{'idate'}{$first_int}[2];
2083 9 100       23 if (defined $ptr) {
2084 8         15 my $date = $$self{'data'}{'dates'}{$ptr};
2085 8 50       19 if (defined($date)) {
2086 8         12 $n = 0;
2087 8 100       23 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       13 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         9 my $n = 0;
2123 4         6 while (1) {
2124 11 50       28 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         37 my $ptr = $$self{'data'}{'idate'}{$first_int}[2];
2131 11 100       21 if (defined $ptr) {
2132 10         18 my $date = $$self{'data'}{'dates'}{$ptr};
2133 10 50       18 if (defined($date)) {
2134 10         16 $n = 0;
2135 10 100       28 last if ($date->cmp($start) >= 0);
2136             } else {
2137 0         0 $n++;
2138             }
2139             } else {
2140 1         3 $n++;
2141             }
2142 7         15 $first_int++;
2143             }
2144              
2145 4         26 foreach my $i ($$self{'data'}{'idate'}{$first_int}[1] ..
2146             $$self{'data'}{'idate'}{$first_int}[2]) {
2147 4         11 my $date = $$self{'data'}{'dates'}{$i};
2148 4 50 33     19 if (defined $date && $date->cmp($start) >= 0) {
2149 4         9 $first = $i;
2150 4         11 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         5 $last_int = $first_int;
2159              
2160 4 50       11 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         9 while (1) {
2192 14 50       28 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         37 $self->_nth_interval($last_int);
2198 14         29 my $ptr = $$self{'data'}{'idate'}{$last_int}[1];
2199 14 100       29 if (defined $ptr) {
2200 12         22 my $date = $$self{'data'}{'dates'}{$ptr};
2201 12 50       23 if (defined($date)) {
2202 12         19 $n = 0;
2203 12 100       57 last if ($date->cmp($end) > 0);
2204             } else {
2205 0         0 $n++;
2206             }
2207             } else {
2208 2         3 $n++;
2209             }
2210 10         21 $last_int++;
2211             }
2212 4         19 $last_int--;
2213              
2214 4         16 $last = undef;
2215 4         6 my $i = $first;
2216 4         7 while (1) {
2217 17 50       41 last if (! exists $$self{'data'}{'dates'}{$i});
2218 17         30 my $date = $$self{'data'}{'dates'}{$i};
2219 17 50       31 next if (! defined $date);
2220 17 100       38 last if ($date->cmp($end) > 0);
2221 13         29 $last = $i;
2222 13         21 $i++;
2223             }
2224             }
2225              
2226 4 50 33     20 return undef if (! defined $last ||
2227             $last < $first);
2228 4         10 $$self{'data'}{'first'} = $first;
2229 4         12 $$self{'data'}{'last'} = $last;
2230 4         11 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         1958 my $base = $$self{'data'}{'BASE'};
2245 1145         1906 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       4481 my $len = ($delta ? $delta->printf('%sys') : 0);
2248              
2249 1145 100       2731 my $targ = ($op eq 'first' ? $start : $end);
2250 1145         3514 my $diff = $base->calc($targ);
2251 1145         3525 my $tot = $diff->printf('%sys');
2252 1145 50       3896 my $nn = ($len ? int($tot/$len) : 1);
2253 1145         2722 my $ev = $$self{'data'}{'ev_per_d'};
2254              
2255             # Move backwards until we're completely before start
2256              
2257 1145         1772 $first_int = $nn;
2258 1145 100       2403 if ($unmod) {
2259 739         1095 my $n = 0;
2260 739         1039 while (1) {
2261 1492 50       3129 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         4199 $self->_nth_interval($first_int);
2267 1492         3026 my $date = $$self{'data'}{'idate'}{$first_int};
2268 1492 50       2881 if (defined($date)) {
2269 1492         1989 $n = 0;
2270 1492 100       4086 last if ($date->cmp($start) < 0);
2271             } else {
2272 0         0 $n++;
2273             }
2274 753         1467 $first_int--;
2275             }
2276              
2277             } else {
2278 406         699 my $n = 0;
2279             LOOP:
2280 406         676 while (1) {
2281 885 100       2059 if ($n > $maxatt) {
2282 1         9 $$self{'err'} =
2283             "[_locate_n] Unable to find an interval in $maxatt attempts";
2284 1         21 return;
2285             }
2286 884         2588 $self->_nth_interval($first_int);
2287 884         3085 for (my $i=($first_int+1)*$ev - 1; $i >= $first_int*$ev; $i--) {
2288 1012 100       2495 if (exists $$self{'data'}{'dates'}{$i}) {
2289 816         1449 my $date = $$self{'data'}{'dates'}{$i};
2290 816 50       1893 if (defined($date)) {
2291 816         1237 $n = 0;
2292 816 100       2158 last LOOP if ($date->cmp($start) < 0);
2293             } else {
2294 0         0 $n++;
2295             }
2296             } else {
2297 196         420 $n++;
2298             }
2299             }
2300 479         796 $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       2881 if ($unmod) {
2308 739         1242 my $n = 0;
2309 739         1109 while (1) {
2310 1478 50       3045 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         3830 $self->_nth_interval($first_int);
2316 1478         2690 my $date = $$self{'data'}{'idate'}{$first_int};
2317 1478 50       2641 if (defined($date)) {
2318 1478         1993 $n = 0;
2319 1478 100       3178 last if ($date->cmp($start) >= 0);
2320             } else {
2321 0         0 $n++;
2322             }
2323 739         1470 $first_int++;
2324             }
2325              
2326             } else {
2327 405         778 my $n = 0;
2328             LOOP:
2329 405         700 while (1) {
2330 839 50       1852 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         2267 $self->_nth_interval($first_int);
2336 839         2442 for (my $i=($first_int+1)*$ev - 1; $i >= $first_int*$ev; $i--) {
2337 963 100       2089 if (exists $$self{'data'}{'dates'}{$i}) {
2338 872         1440 my $date = $$self{'data'}{'dates'}{$i};
2339 872 50       1595 if (defined($date)) {
2340 872         1185 $n = 0;
2341 872 100       1892 last LOOP if ($date->cmp($start) >= 0);
2342             } else {
2343 0         0 $n++;
2344             }
2345             } else {
2346 91         199 $n++;
2347             }
2348             }
2349 434         723 $first_int++;
2350             }
2351             }
2352 1144         2056 $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         1976 $last_int = $first_int;
2358              
2359 1144 100       2271 if ($unmod) {
2360 739         1168 my $n = 0;
2361 739         1064 while (1) {
2362 1478 50       2834 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         3670 $self->_nth_interval($last_int);
2368 1478         3166 my $date = $$self{'data'}{'idate'}{$last_int};
2369 1478 50       2734 if (defined($date)) {
2370 1478         2043 $n = 0;
2371 1478 100       3476 last if ($date->cmp($end) > 0);
2372             } else {
2373 0         0 $n++;
2374             }
2375 739         1346 $last_int++;
2376             }
2377 739         1541 $last_int--;
2378              
2379             } else {
2380 405         718 my $n = 0;
2381             LOOP:
2382 405         603 while (1) {
2383 1462 50       2886 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         3859 $self->_nth_interval($last_int);
2389 1462         4492 for (my $i=($last_int+1)*$ev - 1; $i >= $last_int*$ev; $i--) {
2390 1701 100       4176 next if (! exists $$self{'data'}{'dates'}{$i});
2391 1544         2605 my $date = $$self{'data'}{'dates'}{$i};
2392 1544 50       2772 if (defined($date)) {
2393 1544         2127 $n = 0;
2394 1544 100       3898 last LOOP if ($date->cmp($end) >= 0);
2395             } else {
2396 0         0 $n++;
2397             }
2398             }
2399 1057         1668 $last_int++;
2400             }
2401             }
2402              
2403 1144         2598 $last = ($last_int+1)*$ev - 1;
2404              
2405             # Now get the actual first/last dates
2406              
2407 1144 100       2534 if ($unmod) {
2408 739         1046 while (1) {
2409             last if (exists $$self{'data'}{'dates'}{$first} &&
2410 739 100 66     3474 defined $$self{'data'}{'dates'}{$first});
2411 112         201 $first++;
2412 112 50       1039 return undef if ($first > $last);
2413             }
2414              
2415 627         1007 while (1) {
2416             last if (exists $$self{'data'}{'dates'}{$last} &&
2417 627 50 33     2545 defined $$self{'data'}{'dates'}{$last});
2418 0         0 $last--;
2419             }
2420              
2421             } else {
2422 405         638 while (1) {
2423             last if (exists $$self{'data'}{'dates'}{$first} &&
2424             defined $$self{'data'}{'dates'}{$first} &&
2425 407 100 33     2989 $$self{'data'}{'dates'}{$first}->cmp($start) >= 0);
      66        
2426 2         11 $first++;
2427 2 50       19 return undef if ($first > $last);
2428             }
2429              
2430 405         857 while (1) {
2431             last if (exists $$self{'data'}{'dates'}{$last} &&
2432             defined $$self{'data'}{'dates'}{$last} &&
2433 954 100 66     5120 $$self{'data'}{'dates'}{$last}->cmp($end) <= 0);
      100        
2434 549         1074 $last--;
2435             }
2436             }
2437              
2438 1032 100 66     4653 return undef if (! defined $last ||
2439             $last < $first);
2440 934         1852 $$self{'data'}{'first'} = $first;
2441 934         1669 $$self{'data'}{'last'} = $last;
2442 934         9684 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   43 my($self,$y) = @_;
2450              
2451 21         41 my($c) = $y/100;
2452 21         34 my($g) = $y % 19;
2453 21         37 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         42 my($j) = ($y + $y/4 + $i + 2 - $c + $c/4) % 7;
2457 21         35 my($l) = $i-$j;
2458 21         34 my($m) = 3 + ($l+40)/44;
2459 21         46 my($d) = $l + 28 - 31*($m/4);
2460 21         61 return ($m,$d);
2461             }
2462              
2463             # This returns 1 if a field is empty.
2464             #
2465             sub _field_empty {
2466 12150     12150   18276 my($self,$val) = @_;
2467              
2468 12150 100       20235 if (ref($val)) {
2469 10839         17262 my @tmp = @$val;
2470 10839 100 100     54188 return 1 if ($#tmp == -1 ||
      100        
      66        
2471             ($#tmp == 0 && ! ref($tmp[0]) && ! $tmp[0]));
2472 7289         14307 return 0;
2473              
2474             } else {
2475 1311         2215 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   35714 my($self,$type,$val,@args) = @_;
2500 19788         28398 my $dmt = $$self{'tz'};
2501 19788         26588 my $dmb = $$dmt{'base'};
2502              
2503 19788 100       58433 if ($type eq 'h') {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
2504 3962         7073 @args = (0,0,23,23);
2505              
2506             } elsif ($type eq 'mn') {
2507 3995         6657 @args = (0,0,59,59);
2508              
2509             } elsif ($type eq 's') {
2510 3995         6553 @args = (0,0,59,59);
2511              
2512             } elsif ($type eq 'y') {
2513 137         463 my $curry = $dmt->_now('y',1);
2514 137         279 foreach my $y (@$val) {
2515 213 100 66     776 $y = $curry if (! ref($y) && $y==0);
2516             }
2517              
2518 137         312 @args = (0,1,9999,9999);
2519              
2520             } elsif ($type eq 'm') {
2521 2953         5218 @args = (0,1,12,12);
2522              
2523             } elsif ($type eq 'week_of_year') {
2524 49         81 my($y) = @args;
2525 49         170 my $wiy = $dmb->weeks_in_year($y);
2526 49         120 @args = (1,1,$wiy,53);
2527              
2528             } elsif ($type eq 'dow_of_year') {
2529 164         342 my($y,$dow) = @args;
2530              
2531             # Get the 1st occurrence of $dow
2532 164         233 my $d0 = 1;
2533 164         621 my $dow0 = $dmb->day_of_week([$y,1,$d0]);
2534 164 100       546 if ($dow > $dow0) {
    100          
2535 15         43 $d0 += ($dow-$dow0);
2536             } elsif ($dow < $dow0) {
2537 119         201 $d0 += 7-($dow0-$dow);
2538             }
2539              
2540             # Get the last occurrence of $dow
2541 164         230 my $d1 = 31;
2542 164         407 my $dow1 = $dmb->day_of_week([$y,12,$d1]);
2543 164 100       456 if ($dow1 > $dow) {
    100          
2544 121         192 $d1 -= ($dow1-$dow);
2545             } elsif ($dow1 < $dow) {
2546 15         33 $d1 -= 7-($dow-$dow1);
2547             }
2548              
2549             # Find out the number of occurrenced of $dow
2550 164         468 my $doy1 = $dmb->day_of_year([$y,12,$d1]);
2551 164         326 my $n = ($doy1 - $d0)/7 + 1;
2552              
2553             # Get the list of @w
2554 164         351 @args = (1,1,$n,53);
2555              
2556             } elsif ($type eq 'dow_of_month') {
2557 826         1725 my($y,$m,$dow) = @args;
2558              
2559             # Get the 1st occurrence of $dow in the month
2560 826         1135 my $d0 = 1;
2561 826         2984 my $dow0 = $dmb->day_of_week([$y,$m,$d0]);
2562 826 100       2860 if ($dow > $dow0) {
    100          
2563 185         442 $d0 += ($dow-$dow0);
2564             } elsif ($dow < $dow0) {
2565 504         934 $d0 += 7-($dow0-$dow);
2566             }
2567              
2568             # Get the last occurrence of $dow
2569 826         1985 my $d1 = $dmb->days_in_month($y,$m);
2570 826         2369 my $dow1 = $dmb->day_of_week([$y,$m,$d1]);
2571 826 100       2284 if ($dow1 > $dow) {
    100          
2572 526         869 $d1 -= ($dow1-$dow);
2573             } elsif ($dow1 < $dow) {
2574 180         394 $d1 -= 7-($dow-$dow1);
2575             }
2576              
2577             # Find out the number of occurrenced of $dow
2578 826         1352 my $n = ($d1 - $d0)/7 + 1;
2579              
2580             # Get the list of @w
2581 826         1888 @args = (1,1,$n,5);
2582              
2583             } elsif ($type eq 'day_of_year') {
2584 171         281 my($y) = @args;
2585 171         489 my $diy = $dmb->days_in_year($y);
2586 171         416 @args = (1,1,$diy,366);
2587              
2588             } elsif ($type eq 'day_of_month') {
2589 2810         4938 my($y,$m) = @args;
2590 2810         7788 my $dim = $dmb->days_in_month($y,$m);
2591 2810         6018 @args = (1,1,$dim,31);
2592              
2593             } elsif ($type eq 'day_of_week') {
2594 726         1371 @args = (0,1,7,7);
2595             }
2596              
2597 19788         34493 my($err,@vals) = $self->__rtime_values($val,@args);
2598 19788 50       35401 if ($err) {
2599 0         0 $$self{'err'} = "[dates] $err [$type]";
2600 0         0 return (1);
2601             }
2602 19788         42208 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   33042 my($self,$vals,$allowneg,$min,$max,$absmax) = @_;
2622 19788         24814 my(@ret);
2623              
2624 19788         31624 foreach my $val (@$vals) {
2625              
2626 20337 100       31608 if (ref($val)) {
2627 24         41 my($val1,$val2) = @$val;
2628              
2629 24 50       46 if ($allowneg) {
2630 24 0 33     179 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     162 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     140 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       51 $val1 = $max + $val1 + 1 if ($val1 < 0); # day -10
2652 24 50       51 $val2 = $max + $val2 + 1 if ($val2 < 0);
2653              
2654 24 50       45 $val1 = $min if ($val1 < $min); # day -31 in a 30 day month
2655 24 50       48 $val2 = $max if ($val2 > $max);
2656              
2657 24 100       50 next if ($val1 > $val2);
2658              
2659 20         97 push(@ret,$val1..$val2);
2660              
2661             } else {
2662              
2663 20313 100       29815 if ($allowneg) {
2664 4193 50 33     17153 return ('Value outside range')
      66        
2665             if ($val >= 0 && ($val < $min || $val > $absmax));
2666 4193 50 33     9243 return ('Negative value outside range')
      66        
2667             if ($val <= 0 && ($val < -$absmax || $val > -$min));
2668             } else {
2669 16120 50 33     47892 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         25508 my $ret;
2677 20313 100       29543 if ($val < 0 ) {
2678 401         580 $ret = $max + $val + 1;
2679             } else {
2680 19912         25307 $ret = $val;
2681             }
2682              
2683 20313 100 100     51936 next if ($ret > $max || $ret < $min);
2684 19925         34799 push(@ret,$ret);
2685             }
2686             }
2687              
2688 19788         44489 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   21423 my($self,$datesref,$n,@val) = @_;
2697              
2698 11952         17489 my @dates = @$datesref;
2699 11952         14376 my @tmp;
2700              
2701 11952         17322 foreach my $date (@dates) {
2702 12397         20941 my @d = @$date;
2703 12397         16896 foreach my $val (@val) {
2704 12465         18132 $d[$n] = $val;
2705 12465         34243 push(@tmp,[@d]);
2706             }
2707             }
2708              
2709 11952         28544 @$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: